home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
t
/
tspa3150.zip
/
TSUNTD.TST
< prev
next >
Wrap
Text File
|
1991-01-05
|
6KB
|
246 lines
{$R+} (* Index range check on *)
(* This is a test program for the TSUNTD.TPU unit
2-Aug-89, Updated 25-Sep-89, 13-Jun-90, 15-Jul-90, 5-Jan-91 *)
uses TSUNTB,
TSUNTD;
const loop = 200; (* If you do want to make it quickly, change this to 1 *)
var time : real; (* For timing the tests *)
procedure LOGO;
begin
writeln;
writeln ('TSUNTD unit test by Prof. Timo Salmi');
writeln ('University of Vaasa, Finland, ts@chyde.uwasa.fi');
writeln;
end;
(* Dosdelay function, no Ctr unit needed *)
procedure TEST1;
begin
time := TIMERFN;
DOSDELAY (1000);
time := TIMERFN - time;
writeln ('DOSDELAY(1000)');
writeln ('Elapsed ', time:0:2);
writeln;
end; (* test1 *)
(* Justify a string right *)
procedure TEST2;
var sj1, sj2 : string;
i : word;
begin
writeln ('....:....1....:....2....:....3....:....4....:....5....');
sj1 := 'TSUNTD';
time := TIMERFN;
for i := 1 to loop do sj2 := TRIMRGFN (sj1, 20);
time := TIMERFN - time;
writeln (sj1); writeln (sj2);
writeln ('Elapsed ', time:0:2);
end; (* test2 *)
procedure TEST3;
var sj1, sj2 : string;
i : word;
begin
writeln ('....:....1....:....2....:....3....:....4....:....5....');
sj1 := 'TSUNTD';
time := TIMERFN;
for i := 1 to loop do sj2 := TRIMRGFN (sj1, 4);
time := TIMERFN - time;
writeln (sj1); writeln (sj2);
writeln ('Elapsed ', time:0:2);
end; (* test3 *)
(* Justify a string left *)
procedure TEST4;
var sj1, sj2 : string;
i : word;
begin
writeln ('....:....1....:....2....:....3....:....4....:....5....');
sj1 := ' TSUNTD';
time := TIMERFN;
for i := 1 to loop do sj2 := TRIMLFFN (sj1, 20);
time := TIMERFN - time;
writeln (sj1); writeln (sj2);
writeln ('Elapsed ', time:0:2);
end; (* test4 *)
procedure TEST5;
var sj1, sj2 : string;
i : word;
begin
writeln ('....:....1....:....2....:....3....:....4....:....5....');
sj1 := ' TSUNTD';
time := TIMERFN;
for i := 1 to loop do sj2 := TRIMLFFN (sj1, 4);
time := TIMERFN - time;
writeln (sj1); writeln (sj2);
writeln ('Elapsed ', time:0:2);
end; (* test5 *)
(* Lead a string *)
procedure TEST6;
var sj1, sj2 : string;
i : word;
begin
writeln ('....:....1....:....2....:....3....:....4....:....5....');
sj1 := 'TSUNTD';
time := TIMERFN;
for i := 1 to loop do sj2 := LEADFN (sj1, 20, '.');
time := TIMERFN - time;
writeln (sj1); writeln (sj2);
writeln ('Elapsed ', time:0:2);
end; (* test6 *)
(* Trail a string *)
procedure TEST7;
var sj1, sj2 : string;
i : word;
begin
writeln ('....:....1....:....2....:....3....:....4....:....5....');
sj1 := 'TSUNTD';
time := TIMERFN;
for i := 1 to loop do sj2 := TRAILFN (sj1, 20, '.');
time := TIMERFN - time;
writeln (sj1); writeln (sj2);
writeln ('Elapsed ', time:0:2);
end; (* test7 *)
(* Extract all substrings from a string *)
procedure TEST8;
{$IFNDEF VER40}
const separators : string = ' ' + ',' + #9;
{$ENDIF}
var sj : string;
partPtr : parseVectorPtrType;
n : integer;
ok : boolean;
i : byte;
{$IFDEF VER40} var separators : string; {$ENDIF}
begin
{$IFDEF VER40} separators := ' ' + ',' + #9; {$ENDIF}
New (partPtr);
sj := 'TSUNTD unit test by Prof. Timo Salmi';
PARSE (sj, parse_parts_max, separators,
n, partPtr, ok);
if not ok then halt; {or whatever you want do in case of an error}
for i := 1 to n do writeln (partPtr^[i]);
Dispose (partPtr); partPtr := nil;
end; (* test8 *)
(* Alternative method: Extract all substrings from a string *)
procedure TEST9;
var sj : string;
n : integer;
i : byte;
var separators : string;
begin
separators := ' ' + ',' + #9;
sj := 'TSUNTD unit test by Prof. Timo Salmi';
n := STRCNTFN (sj, separators);
for i := 1 to n do writeln (SPARTFN(sj, separators, i));
end; (* test9 *)
(* How does it sound *)
procedure TEST10;
begin
AUDIO (300, 300); DOSDELAY(20); AUDIO (300, 300); AUDIO (400, 600);
end; (* test10 *)
(* Printer status retort *)
procedure TEST11;
begin
if PRTONLFN then
writeln ('Printer ready')
else
writeln ('Printer not ready');
end; (* test11 *)
(* Printer status retort, the second method *)
procedure TEST12;
begin
if LPTONLFN then
writeln ('Second test: Printer ready')
else
writeln ('Second test: Printer not ready');
end; (* test12 *)
(* Print screen *)
procedure TEST13;
begin
if LPTONLFN then
PRTSCR
else
writeln ('Can''t print the screen: Printer not ready');
end; (* test13 *)
(* Convert to lower case *)
procedure TEST14;
var str : string;
i,p : byte;
begin
str := 'Lets See if This Works: ABC XYZ 123 890 fred *?';
writeln (str);
p := Length(str);
i := 1;
while i <= p do begin
write (LOWCASFN(str[i]));
Flush (output);
Inc(i);
end;
writeln;
end; (* test14 *)
(* The current default number of printer retrys before I/O error *)
procedure TEST15;
begin
writeln ('Printer default retrys = ', GETPRTFN, ' times');
Flush (output);
end; (* test15 *)
(* Number of substrings in a string *)
procedure TEST16;
var s, s1 : string;
n, i : integer;
time : real;
begin
repeat
write ('Give a string (exit to end): '); readln (s);
writeln ('Number of substrings = ', n);
for i := 1 to n do
writeln (PARSERFN (s, i));
until s = 'exit';
end; (* test16 *)
(* Main program *)
begin
{}
LOGO;
TEST11;
TEST12;
TEST13;
{... Comment the halt away if you want the rest of the tests ...}
halt;
{}
TEST10;
TEST1;
TEST2;
TEST3;
TEST4;
write ('Press «═╝ '); readln;
TEST5;
TEST6;
TEST7;
write ('Press «═╝ '); readln;
TEST8;
write ('Press «═╝ '); readln;
TEST9;
TEST14;
TEST15;
end. (* tsuntd.tst *)