[Back to REDIRECT SWAG index]  [Back to Main SWAG index]  [Original]

Unit dualout;

{ This Unit is designed to demonstrate directing all screen output to a File }
{ in addition to the normal display.  This means that any Write or Writeln   }
{ will display normally on the screen and also be Recorded in a Text File.   }
{ The File name For the output can be supplied by a command line parameter   }
{ in the Format -  dual=c:\test\output.dat or you can provide an environment }
{ Variable named dual that supplies the File name or it will default to the  }
{ current directory and output.dat.                                          }

Interface

Uses
  globals,  { contains the Function exist, which tests For the existence of  }
            { a File.  It also defines the Type str80 as String[80]          }
  Dos,
  tpString; { from TPro. Needed For StUpCase Function in Procedure initialise}

Const 
  DualOn   : Boolean = False;
  DualOK   : Boolean = False;
  fname    : str80   = 'output.dat';  { The default File name For the output }
  
Type
  DriverFunc = Function(Var f: TextRec): Integer;

Var
  OldExitProc    : Pointer;                  { For saving old Exit Procedure }
  OldInOutOutput,                            { The old output InOut Function }
  OldFlushOutput : DriverFunc;               { The old output Flush Function }
  dualf          : Text;

Procedure  dual(status: Boolean);

{===========================================================================}
Implementation

Var
  cmdline : String;
  
Procedure DualWrite(Var f: TextRec);
  { Writes the output from stdout to a File }
  Var
    x : Word;
  begin
    For x := 0 to pred(f.BufPos) do
      Write(dualf, f.BufPtr^[x]);
  end;  { DualWrite }

{$F+}
Function InOutOutput(Var f: TextRec): Integer;
  begin
    DualWrite(f);                                        { Write to the File }
    InOutOutput := OldInOutOutput(f);                { Call the old Function }
  end; { InOutOutput }

Function FlushOutput(Var f: TextRec): Integer;
  begin
    DualWrite(f);                                        { Write to the File }
    FlushOutput := OldFlushOutput(f);                { Call the old Function }
  end; { FlushOutput }

Procedure DualExitProc;
  begin
    close(dualf);
    ExitProc := OldExitProc;                { Restore the old Exit Procedure }
    With TextRec(output) do begin
      InOutFunc := @OldInOutOutput;          { Restore the old output Record }
      FlushFunc := @OldFlushOutput;           { Restore the old flush Record }
    end; { With }
  end; { DualExitProc }

{$F-,I-}
Procedure dual(status: Boolean);
  Var
    ErrorCode : Integer;
  begin
    if status then begin
      assign(dualf,fname);
      if Exist(fname) then { open For writing }
        append(dualf)
      else { start new File }
        reWrite(dualf);
      ErrorCode := Ioresult;   
      if ErrorCode <> 0 then 
        halt(ErrorCode);
      With TextRec(output) do begin
        { This is where the old output Functions are rerouted }
        OldInOutOutput := DriverFunc(InOutFunc);
        OldFlushOutput := DriverFunc(FlushFunc);
        InOutFunc := @InOutOutput;
        FlushFunc := @FlushOutput;
      end; { With }
      OldExitProc := ExitProc;            { Save the current Exit Procedure }
      ExitProc    := @DualExitProc;            { Install new Exit Procedure }
      DualOn      := True;
    end { if status }  
    else { switch dual output off } begin  
      if DualOn then begin
        close(dualf);  if Ioresult = 0 then;                   { dummy call }
        ExitProc := OldExitProc;           { Restore the old Exit Procedure }
        OldExitProc := nil;
        With TextRec(output) do begin
          InOutFunc := @OldInOutOutput;     { Restore the old output Record }
          FlushFunc := @OldFlushOutput;      { Restore the old flush Record }
        end; { With }
      end; { if DualOn }
    end; { else }
  end; { dual }
{$I+}  


Procedure Initialise;
  { Determines if a File name For the output has been provided. }
  begin
    if GetEnv('DUAL') <> '' then
      fname := GetEnv('DUAL')
    else begin
      if ParamCount <> 0 then begin
        cmdline := String(ptr(PrefixSeg,$80)^);
        cmdline := StUpCase(cmdline);
        if pos('DUAL=',cmdline) <> 0 then begin
          fname := copy(cmdline,pos('DUAL=',cmdline)+5,80);
          if pos(' ',fname) <> 0 then
            fname := copy(fname,1,pos(' ',fname)-1);
        end; { if pos('Dual... }
      end;  { if ParamCount... }
    end; { else }
  end; { Initialise }
  
begin
  Initialise;
end.  

[Back to REDIRECT SWAG index]  [Back to Main SWAG index]  [Original]