home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / sampler / 04 / diverse / anyprog.pas next >
Encoding:
Pascal/Delphi Source File  |  1988-10-19  |  4.7 KB  |  210 lines
  1. { ANYPROG.PAS }
  2. {
  3. Description:  Program that demonstrates the ability of Turbo 4.0 to run
  4.               a child process and return. This two-level demonstration
  5.               shows how the DOS FORMAT command can be used in conjunction
  6.               with batch files and a Turbo Pascal program to format a disk
  7.               in Drive B: without any of the usual user input or screen
  8.               messages from FORMAT.
  9.  
  10. Author:       Jay van Santen
  11. Application:  IBM PC and compatibles; Turbo Pascal 4.0
  12.  
  13. }
  14.  
  15. {Copyright 1988 Jay van Santen All Rights Reserved}
  16.  
  17. {$M 16384,0,0}
  18. program ANYPROG;
  19.  
  20. {
  21. In a parent process of normal size and no pointer variables, to free
  22. memory for the child process, set memory directive $M as follows:
  23.  
  24.  STACKsize to 16384 (default), HEAPmin to 0, HEAPmax to 0.
  25. }
  26.  
  27. uses
  28.  Dos, Crt;
  29.  
  30.  
  31. const
  32.  NONE                =     0;
  33.  FILEexists          =     0;
  34.  SOMECRITICALerror   =   255;
  35.  FIRST               =   '1';
  36.  
  37. type
  38.  STRING80    =   STRING [80];
  39.  STRING11    =   STRING [11];
  40.  ERRORfiles  =   TEXT;
  41.  
  42. var
  43.  PROCEED         :   BOOLEAN;
  44.  ROUTINE         :   CHAR;
  45.  ERRORcode       :   INTEGER;
  46.  ERRORinfo       :   STRING80;
  47.  ERRORfile       :   ERRORfiles;
  48.  
  49. const
  50.  ERRORprog   :   STRING80    =   'A:ERRMSGE.DAT';
  51.  
  52.  
  53. procedure  BeginProg;
  54. begin
  55.  clrscr;
  56.  writeln ('BEGINNING Parent Process "ANYPROG.PAS".');
  57.  writeln;
  58.  writeln ('This program calls a child process to format a disk.');
  59.  writeln ('  COMMAND.COM must be in root or current directory.');
  60.  write   ('  FORMAT.COM (or FORMAT.EXE) must be in the current directory');
  61.  writeln (' or path.');
  62.  writeln;
  63.  writeln ('  Keep program disk in Drive A:, put blank disk in Drive B:')
  64. end;
  65.  
  66.  
  67. procedure  UserResp
  68.     (var    PROCEED :  BOOLEAN);
  69.  
  70. var
  71.  KEYin   :  CHAR;
  72.  
  73. begin
  74.  writeln;
  75.  write ('If you want to proceed, type Y. Otherwise, type N: ');
  76.  repeat
  77.   KEYin  :=  readkey
  78.  until  KEYin  in  ['Y', 'y', 'N', 'n'];
  79.  write (KEYin);
  80.  writeln;
  81.  
  82.  case  KEYin of
  83.   'Y', 'y':   PROCEED  :=  TRUE;
  84.   'N', 'n':   PROCEED  :=  FALSE;
  85.  end
  86. end;
  87.  
  88.  
  89. procedure  UserDirection
  90.     (var    KEYin   :   CHAR);
  91.  
  92. begin
  93.  writeln;
  94.  writeln ('Process 1 is the most straightforward.');
  95.  writeln ('Process 2 provides much better error-trapping (try some out!)');
  96.  write ('CHOOSE child process 1 or 2: ');
  97.  repeat
  98.   KEYin := ReadKey
  99.  until  KEYin  in ['1', '2'];
  100.  write (KEYin);
  101.  writeln
  102. end;
  103.  
  104.  
  105. procedure  UserInform;
  106. begin
  107.  writeln;
  108.  writeln ('BEGINNING Child Process: (note the lack of messages)')
  109. end;
  110.  
  111.  
  112. procedure  ReportError
  113.     (ERRORcode  :   INTEGER);
  114.  
  115. var
  116.  ERRORinfo   :   STRING80;
  117.  
  118. begin
  119.  case  ERRORcode  of
  120.     2:  ERRORinfo := 'FILE NOT FOUND -- COMMAND.COM or child process.';
  121.     5:  ERRORinfo := 'ACCESS DENIED -- child process is write only.';
  122.     8:  ERRORinfo := 'INSUFFICIENT MEMORY to run child process.';
  123.    10:  ERRORinfo := 'INVALID ENVIRONMENT -- improper SET path variables.';
  124.    11:  ERRORinfo := 'INVALID FORMAT.';
  125.   152:  ERRORinfo := 'DRIVE NOT READY -- where child process located.';
  126.   162:  ERRORinfo := 'HARDWARE FAILURE -- drive door probably not closed.';
  127.   255:  ERRORinfo := 'CHILD PROCESS RAN but halted on critical error.';
  128.   else  ERRORinfo := 'ERROR in accessing child process to run.'
  129.  end;
  130.  
  131.  gotoXY  (1, 25);
  132.  writeln (ERRORinfo);
  133.  writeln ('PROGRAM ENDING.  Fix error and run again.')
  134. end;
  135.  
  136.  
  137. procedure  EndProgA;
  138. begin
  139.  writeln;
  140.  writeln('ENDING Child Process. Format complete, parent process takes');
  141.  writeln(' control, and itself ends.')
  142. end;
  143.  
  144.  
  145. procedure  EndProgB;
  146. begin
  147.  writeln;
  148.  writeln  ('By your choice, the program now ends.')
  149. end;
  150.  
  151.  
  152. procedure  InitDiskA
  153.     (var    ERRORcode  :  INTEGER);
  154.  
  155. begin
  156.  exec ( '\COMMAND.COM', '/C FORMAT B: <A:FMTINFO.BAT >NUL');
  157.  ERRORcode   :=  DosError
  158. end;
  159.  
  160.  
  161. procedure  InitDiskB
  162.     (var    ERRORcode  :   INTEGER);
  163.  
  164. var
  165.  TEMP    :   INTEGER;
  166.  
  167. begin
  168.  {$I-}
  169.  exec ('\COMMAND.COM', '/C  A:BATCH.BAT >NUL');
  170.  {$I+}
  171.  ERRORcode   :=  IOResult;
  172.  if (ERRORcode = NONE) AND (DosError <> NONE) then
  173.   ERRORcode :=  DosError;
  174.  
  175.  if  ERRORcode  =  NONE  then
  176.   begin
  177.    assign (ERRORfile, ERRORprog);
  178.    {$I-}
  179.    reset  (ERRORfile);
  180.    {$I+}
  181.    TEMP    :=  IOResult;
  182.    if  TEMP  =  FILEexists  then
  183.     begin
  184.      ERRORcode   :=  SOMECRITICALerror;
  185.      close (ERRORfile);
  186.      erase (ERRORfile)
  187.     end
  188.   end
  189. end;
  190.  
  191. begin { Main program }
  192.  
  193.  CheckBreak := FALSE;    { Prevent CTL-BREAK from terminating program }
  194.  BeginProg;
  195.  UserResp (PROCEED);
  196.  if PROCEED then
  197.   begin
  198.    UserDirection (ROUTINE);
  199.    UserInform;
  200.    if  ROUTINE = FIRST
  201.     then  InitDiskA (ERRORcode)
  202.     else  InitDiskB (ERRORcode);
  203.    if  ERRORcode  <>  NONE
  204.     then  ReportError (ERRORcode)
  205.     else  EndProgA
  206.   end
  207.   else  EndProgB
  208. end.
  209. 
  210.