home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / t / tcsel003.zip / DUALOPT.PAS < prev    next >
Pascal/Delphi Source File  |  1992-10-16  |  5KB  |  135 lines
  1. unit dualopt;
  2.  
  3. { This unit is designed to demonstrate directing all screen output to a file }
  4. { in addition to the normal display.  This means that any write or writeln   }
  5. { will display normally on the screen and also be recorded in a text file.   }
  6. { The file name for the output can be supplied by a command line parameter   }
  7. { in the format -  dual=c:\test\output.dat OR you can provide an environment }
  8. { variable named dual that supplies the file name or it will default to the  }
  9. { current directory and output.dat.                                          }
  10.  
  11. interface
  12.  
  13. uses
  14.   globals,  { contains the function exist, which tests for the existence of  }
  15.             { a file.  It also defines the type str80 as string[80]          }
  16.   dos,
  17.   tpstring; { from TPro. Needed for StUpCase function in procedure initialise}
  18.  
  19. const 
  20.   DualOn   : boolean = false;
  21.   DualOK   : boolean = false;
  22.   fname    : str80   = 'output.dat';  { The default file name for the output }
  23.   
  24. type
  25.   DriverFunc = function(var f: TextRec): integer;
  26.  
  27. var
  28.   OldExitProc    : pointer;                  { For saving old exit procedure }
  29.   OldInOutOutput,                            { The old output InOut function }
  30.   OldFlushOutput : DriverFunc;               { The old output Flush function }
  31.   dualf          : text;
  32.  
  33. procedure  dual(status: boolean);
  34.  
  35. {===========================================================================}
  36. implementation
  37.  
  38. var
  39.   cmdline : string;
  40.   
  41. procedure DualWrite(var f: TextRec);
  42.   { Writes the output from stdout to a file }
  43.   var
  44.     x : word;
  45.   begin
  46.     for x := 0 to pred(f.BufPos) do
  47.       write(dualf, f.BufPtr^[x]);
  48.   end;  { DualWrite }
  49.  
  50. {$F+}
  51. function InOutOutput(var f: TextRec): integer;
  52.   begin
  53.     DualWrite(f);                                        { Write to the file }
  54.     InOutOutput := OldInOutOutput(f);                { Call the old function }
  55.   end; { InOutOutput }
  56.  
  57. function FlushOutput(var f: TextRec): integer;
  58.   begin
  59.     DualWrite(f);                                        { Write to the file }
  60.     FlushOutput := OldFlushOutput(f);                { Call the old function }
  61.   end; { FlushOutput }
  62.  
  63. procedure DualExitProc;
  64.   begin
  65.     close(dualf);
  66.     ExitProc := OldExitProc;                { Restore the old exit procedure }
  67.     with TextRec(output) do begin
  68.       InOutFunc := @OldInOutOutput;          { Restore the old output record }
  69.       FlushFunc := @OldFlushOutput;           { Restore the old flush record }
  70.     end; { with }
  71.   end; { DualExitProc }
  72.  
  73. {$F-,I-}
  74. procedure dual(status: boolean);
  75.   var
  76.     ErrorCode : integer;
  77.   begin
  78.     if status then begin
  79.       assign(dualf,fname);
  80.       if Exist(fname) then { open for writing }
  81.         append(dualf)
  82.       else { start new file }
  83.         rewrite(dualf);
  84.       ErrorCode := IOResult;   
  85.       if ErrorCode <> 0 then 
  86.         halt(ErrorCode);
  87.       with TextRec(output) do begin
  88.         { This is where the old output functions are rerouted }
  89.         OldInOutOutput := DriverFunc(InOutFunc);
  90.         OldFlushOutput := DriverFunc(FlushFunc);
  91.         InOutFunc := @InOutOutput;
  92.         FlushFunc := @FlushOutput;
  93.       end; { with }
  94.       OldExitProc := ExitProc;            { Save the current exit procedure }
  95.       ExitProc    := @DualExitProc;            { Install new exit procedure }
  96.       DualOn      := true;
  97.     end { if status }  
  98.     else { switch dual output off } begin  
  99.       if DualOn then begin
  100.         close(dualf);  if IOResult = 0 then;                   { dummy call }
  101.         ExitProc := OldExitProc;           { Restore the old exit procedure }
  102.         OldExitProc := nil;
  103.         with TextRec(output) do begin
  104.           InOutFunc := @OldInOutOutput;     { Restore the old output record }
  105.           FlushFunc := @OldFlushOutput;      { Restore the old flush record }
  106.         end; { with }
  107.       end; { if DualOn }
  108.     end; { else }
  109.   end; { dual }
  110. {$I+}  
  111.  
  112.  
  113. procedure Initialise;
  114.   { Determines if a file name for the output has been provided. }
  115.   begin
  116.     if GetEnv('DUAL') <> '' then
  117.       fname := GetEnv('DUAL')
  118.     else begin
  119.       if ParamCount <> 0 then begin
  120.         cmdline := string(ptr(PrefixSeg,$80)^);
  121.         cmdline := StUpCase(cmdline);
  122.         if pos('DUAL=',cmdline) <> 0 then begin
  123.           fname := copy(cmdline,pos('DUAL=',cmdline)+5,80);
  124.           if pos(' ',fname) <> 0 then
  125.             fname := copy(fname,1,pos(' ',fname)-1);
  126.         end; { if pos('Dual... }
  127.       end;  { if ParamCount... }
  128.     end; { else }
  129.   end; { Initialise }
  130.   
  131. begin
  132.   Initialise;
  133. end.  
  134.  
  135.