Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TSPA3260.ZIP/TSUNTG.TST

Text File | 1992-11-08 | 9.4 KB | 366 lines

{$M 16384,0,655360}

(* This is a test program for the TSUNTG.TPU unit
   Updated 26-Nov-89, 6-Dec-89, 14-Jun-90, 22-Jul-90, 1-Aug-90,
           8-Aug-90, 27-Oct-91, 13-Jun-92, 19-Oct-92, 8-Nov-92 *)

uses Dos,
     TSUNTB,  (* to have access to number base conversion *)
     TSUNTH,  (* to have access to keyboad type *)
     TSUNTG;

procedure LOGO;
begin
  writeln;
  writeln ('TSUNTG unit test by Prof. Timo Salmi');
  writeln ('University of Vaasa, Finland, [e-mail]');
{$IFDEF VER40}
  writeln ('TP version 4.0');
{$ENDIF}
{$IFDEF VER50}
  writeln ('TP version 5.0');
{$ENDIF}
{$IFDEF VER55}
  writeln ('TP version 5.5');
{$ENDIF}
{$IFDEF VER60}
  writeln ('TP version 6.0');
{$ENDIF}
  writeln;
end;

(* Number of diskette drives *)
procedure TEST1;
begin
  writeln ('Number of diskette drives on this system is ', DRIVESFN);
end; (* test1 *)

(* Number of disk devices *)
procedure TEST2;
begin
{$IFDEF VER50}
  if swap(DosVersion) < $0300 then
    begin writeln ('Not MsDos 3.+'); exit; end;
{$ENDIF}
  writeln ('Number of disks on this system is ', DSKCNTFN);
end;  (* test2 *)

(* Number of diskette drives *)
procedure TEST3;
begin
  writeln ('The first diskette drive is ', FDRIVEFN);
end; (* test3 *)

(* Is a media present in the drive *)
procedure TEST4;
const drive = 'B';
begin
  If INDRIVFN (drive) then
    writeln ('Disk present in drive ', drive)
  else
    writeln ('Disk not present in drive ', drive);
end;  (* test4 *)

(* Cursor location test *)
procedure TEST5;
var x , y : byte;
begin
  GOATXY (10, 20);
  write ('▓The block is at 10,20 .');
  x := WHEREXFN - 1; y := WHEREYFN;
  write (' and the point at ', x:0, ',', y:0);
end;  (* test5 *)

(* Reverse the colors of an area *)
procedure TEST6;
begin
  REVAREA (2, 2, 79, 24);
  GOATXY (1, 22);
end;  (* test6 *)

(* Redirection of writes *)
procedure TEST7;
begin
  writeln ('If you get runtime error 160, first test for printer readiness');
  writeln ('TSUNTC has the relevant routines');
  writeln;
  USEPRN;
  writeln ('This goes to the printer');
  writeln ('As does this');
  USECON;
  write   ('This goes on the screen');
end;  (* test7 *)

(* Test of the timed inkey function *)
procedure TEST8;
var key : char;
    timeout : boolean;
begin
  repeat
    key := INKEYFN (3.0, timeout);
    if not timeout then write (key)
      else begin writeln; writeln ('Timeout',#7); end;
  until key = #27;
end;  (* test8 *)

(* Try warmboot *)
procedure TEST9;
var ch : char;
begin
  write ('Press Y if you really want to test a warm reboot, any other key to cancel ');
  repeat
    if KEYPREFN then
      begin
        ch := READKEFN;
        case ch of
          #3       : exit;
          #27      : exit;
          #0       : begin
                       if KEYPREFN then
                         begin
                           ch := READKEFN;
                           exit;
                         end;
                     end;
          'Y', 'y' : WARMBOOT;
          #0..#255 : exit;
          else     ;
        end; {case}
      end; {if}
  until false;
end;  (* test9 *)

(* Test whether a media is a fixed disk *)
procedure TEST10;
var drive : string;
begin
  write ('Enter drive letter? '); readln (drive);
  case Length (drive) of
    0  : drive := '0';
    else drive := UpCase(drive[1]);
  end;
  if FIXEDFN (drive[1]) then
     writeln ('Media ', drive , ' is a fixed disk')
   else
     writeln ('Media ', drive , ' is not a fixed disk');
end;  (* test10 *)

(* Detect special keys, and normal keyboard scancodes. Note that depending
   on the keyboard some of the tests below can be mutually exclusive.
   CTLFN excludes detecting RTCTRLFN, LFCTRLFN, and SYSRQFN. ALTFN excludes
   FLATLFN. *)
procedure TEST11;
var ch : char;
begin
  writeln ('Esc to exit');
  repeat
    if LFSHFTFN then write ('LfShift ');
    if RTSHFTFN then write ('RtShift ');
    {}
    if ISENHAFN then
       begin
         if LFCTRLFN then write ('LfCtrl ');
         if RTCTRLFN then write ('RtCtrl ');
       end
     else
       if CTRLFN then write ('Ctrl ');
    {}
    if ISENHAFN then
       if LFALTFN  then write ('LfAlt ')
         else                               (* Notice the else else trick *)
      else
         if ALTFN    then write ('Alt ');
    {}
    if RTALTFN  then write ('RtAlt ');
    if SYSRQFN  then write ('SysRq ');
    if KEYPREFN then
      begin
        ch := READKEFN;
        case ch of
          #0  : begin
                  write (byte(ch), ' ');    (* ord(ch) is ok, too *)
                  ch := READKEFN;           (* byte(ch) is an just an *)
                  write (byte(ch), ' ');    (* example of typecasting *)
                end;
          #27 : exit;
          else write (byte(ch), ' ');
        end; {case}
      end; {if}
  until false;
end;  (* test11 *)

(* Test reading enhanced keyboard keys. Notice the trick to get the
   low and the high parts of a Turbo Pascal word *)
procedure TEST12;
var scancode : word;
    key      : array [1..2] of byte absolute scancode;
begin
  repeat
    scancode := RDENKEFN;
    {}
    {... show the first part of the scancode ...}
    write (key[1], ' ');
    {}
    {... enhanced keys have also a second part in the scancode ...}
    case key[1] of
      0, 224 : write (key[2], ' ');
    end;
  until (key[1] = 27)                 (* escape with esc *)
         or (scancode = 0);           (* not an enhanced keyboard *)
end;  (* test12 *)

(* Test whether ANSI.SYS or a comparable driver has been loaded *)
procedure TEST13;
begin
  if ISANSIFN then
    writeln ('ANSI.SYS or a comparable screen driver has been installed')
  else
    begin
      writeln;
      writeln ('ANSI.SYS or a comparable screen driver has not been installed');
    end;
end;  (* test13 *)

(* Display the ascii value and the scancode of the key pressed *)
procedure TEST14;
var scanCode : byte;
    charCode : byte;
    s        : string;
begin
  writeln ('Press Esc to end this folly');
  writeln;
  repeat
    GETSCAN (scanCode, charCode);
    case charCode of
      0..31, 129..255 : begin
                          Str(charCode, s);
                          s := 'asc(' + s + ')';
                        end;
      else s := chr(charCode)
    end; {case}
    writeln (s, ' scancode = ', scancode:3);
  until scancode = 1;
end;  (* test14 *)

(* Display the ascii value and the scancode of the key pressed for
   the enhanced keyboard with GETESCAN. To test the presence of an
   enhanced keyboard use ISENHAFN from the TSUNTH unit *)
procedure TEST15;
var scanCode : byte;
    charCode : byte;
    s        : string;
begin
  writeln ('Press Esc to end this folly');
  writeln;
  repeat
    GETESCAN (scanCode, charCode);
    case charCode of
      0..31, 129..255 : begin
                          Str(charCode, s);
                          s := 'asc(' + s + ')';
                        end;
      else s := chr(charCode)
    end; {case}
    writeln (s, ' scancode = ', scancode:3);
  until scancode = 1;
end;  (* test15 *)

(* Test the disk status *)
procedure TEST16;
const drive = 'A';
var status : integer;
begin
  status := FLOPSTFN (drive);
  if status = -1 then
    begin
      writeln ('Invalid drive, must be A or B');
      exit;
    end; {if}
  writeln ('Disk status for ', drive, ': $', BHEXFN(status));
  case status of
    $00 : writeln ('Disk present');
    $02 : writeln ('Address mark not found (Disk unformatted)');
    $40 : writeln ('Seek failure (Disk not present?)');
    $80 : writeln ('Disk timed out (Disk not present in drive)');
  end;
end;  (* test16 *)

(* Test whether a drive is a substituted drive *)
procedure TEST17;
const drive = 'R';
var isubst : boolean;
begin
  if (100*Lo(DosVersion) + Hi(DosVersion)) < 310 then
    begin
      writeln ('The MsDos version must be at least 3.1');
      exit;
    end;
  isubst := ISUBSTFN (drive);
  writeln ('Drive ', drive, ' is a substituted drive is ', isubst);
end;  (* test17 *)

(* What kind of a disk is in the drive *)
procedure TEST18;
const drive = 'B';
var mediaID : byte;
begin
  mediaID := MEDIAFN (drive);
  write ('Media currently in drive ', drive, ': is ');
  case mediaID of
    $00 : writeln ('Error');
    $F0 : writeln ('Floppy of 1.44Mb');
    $F8 : writeln ('Fixed disk');
    $F9 : writeln ('Floppy of 1.2Mb');
    $FA : writeln ('Floppy of 720Kb');
    $FD : writeln ('Floppy of 360Kb');
    $FF : writeln ('Floppy of 320Kb');
    else  writeln ('something else');
  end; {case}
end;  (* test18 *)

(* Get the currently active floppy drive on one drive systems *)
procedure TEST19;
var active : char;
begin
  active := ACTDRVFN;
  write ('The currently active floppy drive is ');
  case active of
    '0' : writeln ('Error ');
    'A' : writeln ('A:');
    'B' : writeln ('B:');
    '2' : writeln ('not relevant (Two or more drives)');
  end;
end;  (* test19 *)

(* Main program
   If you just want a particular test, comment the others away, just as
   I have done.
   If you want pauses, put readln where appropriate *)
begin
  LOGO;
  {
  TEST1;
  TEST2;
  TEST3;
  TEST4;
  TEST5;
  TEST6;
  TEST7;
  TEST8;
  TEST9;
  TEST10;
  TEST11;
  TEST12;
  TEST13;
  TEST14;
  TEST15;
  TEST16;
  }
  TEST16;
  TEST17;
  TEST18;
  TEST19;
  {}
  write ('Press <-'' '); readln;
end.  (* tsuntg.tst *)