Category : Pascal Source Code
Archive   : TSPA3370.ZIP
Filename : TSUNTG.TST

{$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,
26-Jul-93 *)

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, [email protected]');
{$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}
{$IFDEF VER70}
writeln ('TP version 7.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 *)

(* 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 *)

(* Test if a drive is a ram disk *)
procedure TEST20;
const drive = 'B';
var status : boolean;
begin
status := ISRAMFN (drive);
writeln ('Drive ', drive, ' is a ramdrive is ', status);
end; (* test20 *)

(* 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;
TEST10;
TEST11;
TEST12;
TEST13;
TEST14;
TEST15;
TEST16;
}
TEST16;
TEST17;
TEST18;
TEST19;
{}
write ('Press <-'' '); readln;
end. (* tsuntg.tst *)