ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/TSPA2540.ZIP/TSUNTG.TST

Text File | 1991-10-27 | 5.8 KB | 231 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 *)

uses Dos, TSUNTH, TSUNTG;

procedure LOGO;
begin
  writeln;
  writeln ('TSUNTG unit test by Prof. Timo Salmi');
  writeln ('University of Vaasa, Finland, [e-mail]');
  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 *)

(* 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;
  TEST13;
  {
  TEST1;
  TEST2;
  TEST3;
  TEST4;
  TEST5;
  TEST6;
  TEST7;
  TEST8;
  TEST9;
  TEST10;
  TEST11;
  TEST12;
  }
end.  (* tsuntg.tst *)