home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
TCSEL002
/
DUALOPT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-10-16
|
5KB
|
135 lines
unit dualopt;
{ 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.