home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / TSPA3340.ZIP / TSUNTL.TST < prev    next >
Text File  |  1993-02-24  |  3KB  |  115 lines
  1. {$R+}
  2.  
  3. program tsuntzTest;
  4.  
  5. uses TSUNTL,
  6.      TSUNTE,
  7.      TSUNTG
  8.      {$IFDEF VER40}
  9.      ,TSUNT45
  10.      {$ELSE}
  11.      ,Dos
  12.      {$ENDIF}
  13.      ;
  14.  
  15. procedure LOGO;
  16. begin
  17.   writeln;
  18.   writeln ('TSUNTL unit test by Prof. Timo Salmi, 24-Feb-93');
  19.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  20. {$IFDEF VER40}
  21.   writeln ('TP version 4.0');
  22. {$ENDIF}
  23. {$IFDEF VER50}
  24.   writeln ('TP version 5.0');
  25. {$ENDIF}
  26. {$IFDEF VER55}
  27.   writeln ('TP version 5.5');
  28. {$ENDIF}
  29. {$IFDEF VER60}
  30.   writeln ('TP version 6.0');
  31. {$ENDIF}
  32. {$IFDEF VER70}
  33.   writeln ('TP version 7.0');
  34. {$ENDIF}
  35.   writeln;
  36. end;  (* logo *)
  37.  
  38. (* Test scrolling a window up and down *)
  39. procedure TEST1;
  40. var i, j : byte;
  41. begin
  42.   for i := 0 to 23 do
  43.     begin
  44.       case (i mod 2) of
  45.         0 : for j := 1 to 79 do write (j mod 10);
  46.       end;
  47.       writeln
  48.     end;
  49.   write ('Press any key');
  50.   {}
  51.   for i := 1 to 4 do
  52.     begin
  53.       repeat until KEYPREFN;              { from TSUNTG }
  54.       CLB;                                { from TSUNTE }
  55.       SCROLLUP (1, 0, 3, 20, 18, 39);
  56.     end;
  57.   for i := 1 to 6 do
  58.     begin
  59.       repeat until KEYPREFN;
  60.       CLB;
  61.       SCROLLDN (1, 0, 3, 20, 20, 39);
  62.     end;
  63. end;  (* test1 *)
  64.  
  65. (* Test if an EGA or better is available *)
  66. procedure TEST2;
  67. begin
  68.   if ISEGAFN then
  69.     writeln ('EGA or better detected')
  70.   else
  71.     writeln ('No EGA or better');
  72. end;  (* test2 *)
  73.  
  74. {$IFNDEF VER40}  (* Not Turbo Pascal 4.0 *)
  75. (* Set a disk volume label *)
  76. procedure TEST3;
  77. const drive = 'R';                     { I have ramdisk on R: }
  78.       newLabel : string = 'ramdisk';
  79. var s        : string11;
  80.     ok       : boolean;
  81.     i        : byte;
  82.     nonblank : boolean;
  83. begin
  84.   {... the new label must contain something ...}
  85.   if newLabel = '' then exit;
  86.   nonblank := false;
  87.   for i := 1 to Length(newLabel) do
  88.     if (newLabel[i] <> ' ') then nonblank := true;
  89.   if not nonblank then exit;
  90.   {}
  91.   s :=  LABELFN (drive);  { from TSUNTE }
  92.   writeln ('Label on ', drive, ': is ', s);
  93.   SETLABEL (drive, newlabel, ok);
  94.   {}
  95.   if ok then
  96.     writeln ('Success in setting the label on drive ', drive, ':')
  97.   else
  98.     writeln ('Error in setting the label on drive ', drive, ':');
  99.   {}
  100.   s := LABELFN (drive);
  101.   writeln ('Label on ', drive, ': is ', s);
  102. end;  (* test3 *)
  103. {$ENDIF}  (* Not Turbo Pascal 4.0 *)
  104.  
  105. (* Main program *)
  106. begin
  107.   LOGO;
  108.   TEST2;
  109.   {}
  110.   {... if you want the rest of the tests, just include them ...}
  111.   {}
  112.   write ('Press <-'' '); readln;
  113.   {}
  114. end.  (* tsuntl.tst *)
  115.