home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / redirect.swg / 0002_DUALOUT.PAS.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  4.5 KB  |  135 lines
  1. Unit dualout;
  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.