home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TSPA3260.ZIP / TSUNTENV.TST < prev    next >
Encoding:
Text File  |  1993-01-23  |  2.9 KB  |  120 lines
  1. {$M 16384,0,0}
  2. {$R+}
  3.  
  4. program tsuntenvTest;
  5.  
  6. uses Dos,
  7.      TSUNTENV,
  8.      TSUNTE;     (* To include the routine getting the command line *)
  9.  
  10. procedure LOGO;
  11. begin
  12.   writeln;
  13.   writeln ('TSUNTENV unit test by Prof. Timo Salmi, 23-Jan-93');
  14.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  15. {$IFDEF VER40}
  16.   writeln ('TP version 4.0');
  17. {$ENDIF}
  18. {$IFDEF VER50}
  19.   writeln ('TP version 5.0');
  20. {$ENDIF}
  21. {$IFDEF VER55}
  22.   writeln ('TP version 5.5');
  23. {$ENDIF}
  24. {$IFDEF VER60}
  25.   writeln ('TP version 6.0');
  26. {$ENDIF}
  27. {$IFDEF VER70}
  28.   writeln ('TP version 7.0');
  29. {$ENDIF}
  30.   writeln;
  31. end;  (* logo *)
  32.  
  33. function HEXFN (decimal : word) : string;
  34. const hexDigit : array [0..15] of char = '0123456789ABCDEF';
  35. begin
  36.   hexfn := hexDigit[(decimal shr 12)]
  37.         + hexDigit[(decimal shr 8) and $0F]
  38.         + hexDigit[(decimal shr 4) and $0F]
  39.         + hexDigit[(decimal and $0F)];
  40. end;  (* hexfn *)
  41.  
  42. (* Demonstrate some information about the parent environment *)
  43. procedure TEST1;
  44. var envsize : word;
  45.     envuse  : word;
  46.     envaddr : string;
  47. begin
  48.   envsize := ENVSIZFN;
  49.   writeln ('The environment size is ', envsize:5, ' bytes');
  50.   envuse := ENVUSEFN;
  51.   writeln ('The environment use  is ', envuse:5, ' bytes');
  52.   envaddr := '$' + HEXFN(ENVADDFN);
  53.   writeln ('The environment segment address is ', envaddr);
  54.   SHOWENV;
  55. end;  (* test1 *)
  56.  
  57. procedure TEST2;
  58. var status : byte;
  59.     newset : string;
  60. begin
  61.   newset := copy (CMDLNFN, 2, 255);           (* From TSUNTE *)
  62.   if newset <> '' then
  63.     begin
  64.       SETENV (newset, status);
  65.       case status of
  66.         0 : writeln ('No errors detected');
  67.         1 : writeln ('Syntax error (Usage: variable=value)', #7);
  68.         2 : writeln ('Out of environment space', #7);
  69.         3 : writeln ('Missed the variable or the environment', #7);
  70.       end;
  71.     end
  72.   else
  73.     writeln ('Usage: TSUNTENV.EXE name=value');
  74. end;  (* test2 *)
  75.  
  76. (* Test setting the invironment variable for the duration of shelling
  77.    to MsDos *)
  78. procedure TEST3;
  79. var comspec : string;
  80.     error   : integer;
  81. begin
  82.   {}
  83.   comspec := GetEnv ('comspec');
  84.   SETENVSH ('TEST_LONG_ENVIRONMENT', 'testing_the_environment');
  85.   SETENVSH ('PROMPT', '$p$g[SHELLED] ');
  86.   {}
  87.   writeln ('Type EXIT to return to TSUNTENV');
  88.   writeln ('Write SET to see the current environment variable values');
  89.   swapvectors;
  90.   Exec (comspec, '');   {execute the DOS shell}
  91.   swapvectors;
  92.   {}
  93.   error := DosError;
  94.   if error <> 0 then
  95.     begin
  96.       writeln ('Cannot run MsDos shell');
  97.       if error = 8 then
  98.          writeln ('Out of memory')
  99.        else
  100.          writeln ('Command processor ', comspec, ' not found');
  101.       halt;
  102.     end;
  103.   {}
  104.   writeln ('Back from shell');
  105.   writeln ('Write SET to see the current environment variable values');
  106. end;  (* test3 *)
  107.  
  108. (* Main program *)
  109. begin
  110.   LOGO;
  111.   {
  112.   TEST3;
  113.   TEST1;
  114.   }
  115.   TEST2;
  116.   TEST1;
  117.   {}
  118.   { write ('Press <-'' '); readln; }
  119. end.  (* tsuntenv.tst *)
  120.