mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2026-01-16 22:11:28 +01:00
389 lines
8.6 KiB
ObjectPascal
389 lines
8.6 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal Integrated Development Environment
|
|
Copyright (c) 1998 by Berczi Gabor
|
|
|
|
Unit to redirect output and error to files
|
|
|
|
Adapted from code donated to public domain by Schwartz Gabriel. 20/03/1993.
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
Unit FPRedir;
|
|
Interface
|
|
|
|
{$R-}
|
|
{$ifndef linux}
|
|
{$S-}
|
|
{$endif}
|
|
|
|
{$ifdef TP}
|
|
{$define implemented}
|
|
{$endif TP}
|
|
{$ifdef Go32v2}
|
|
{$define implemented}
|
|
{$endif}
|
|
{$ifdef linux}
|
|
{$define implemented}
|
|
{$endif}
|
|
|
|
{ be sure msdos is not set for FPC compiler }
|
|
{$ifdef FPC}
|
|
{$UnDef MsDos}
|
|
{$endif FPC}
|
|
|
|
|
|
Var
|
|
IOStatus : Integer;
|
|
RedirError : Integer;
|
|
ExecuteResult : Word;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
function ExecuteRedir (Const ProgName, ComLine, RedirStdOut, RedirStdErr : String) : boolean;
|
|
|
|
function ChangeRedir(Const Redir : String; AppendToFile : Boolean) : Boolean;
|
|
procedure RestoreRedir;
|
|
|
|
function ChangeErrorRedir(Const Redir : String; AppendToFile : Boolean) : Boolean;
|
|
procedure RestoreErrorRedir;
|
|
|
|
|
|
Implementation
|
|
|
|
Uses
|
|
{$ifdef go32v2}
|
|
go32,
|
|
{$endif go32v2}
|
|
{$ifdef linux}
|
|
linux,
|
|
{$endif linux}
|
|
dos;
|
|
|
|
{*****************************************************************************
|
|
Dos
|
|
*****************************************************************************}
|
|
|
|
{$ifdef implemented}
|
|
|
|
{$ifdef TP}
|
|
|
|
const
|
|
UnusedHandle = -1;
|
|
StdInputHandle = 0;
|
|
StdOutputHandle = 1;
|
|
StdErrorHandle = 2;
|
|
|
|
Type
|
|
PtrRec = packed record
|
|
Ofs, Seg : Word;
|
|
end;
|
|
|
|
PHandles = ^THandles;
|
|
THandles = Array [Byte] of Byte;
|
|
|
|
PWord = ^Word;
|
|
|
|
Var
|
|
PrefSeg : Word;
|
|
MinBlockSize : Word;
|
|
MyBlockSize : Word;
|
|
Handles : PHandles;
|
|
OldHandle,OldErrorHandle : Byte;
|
|
{$endif TP}
|
|
|
|
Var
|
|
F,FE : File;
|
|
RedirChanged : Boolean;
|
|
RedirErrorChanged : Boolean;
|
|
TempH, TempErrorH : longint;
|
|
|
|
{ For linux the following functions exist
|
|
Function Dup(oldfile:longint;var newfile:longint):Boolean;
|
|
Function Dup2(oldfile,newfile:longint):Boolean; }
|
|
{$ifdef go32v2}
|
|
|
|
function dup(fh : longint;var nh : longint) : boolean;
|
|
var
|
|
Regs : Registers;
|
|
|
|
begin
|
|
Regs.ah:=$45;
|
|
Regs.bx:=fh;
|
|
MsDos (Regs);
|
|
Dup:=true;
|
|
If (Regs.Flags and fCarry)=0 then
|
|
nh:=Regs.Ax
|
|
else
|
|
Dup:=false;
|
|
end;
|
|
|
|
function dup2(fh,nh : longint) : boolean;
|
|
var
|
|
Regs : Registers;
|
|
|
|
begin
|
|
Dup2:=true;
|
|
If fh=nh then
|
|
exit;
|
|
Regs.ah:=$46;
|
|
Regs.bx:=fh;
|
|
Regs.cx:=nh;
|
|
MsDos (Regs);
|
|
If (Regs.Flags and fCarry)<>0 then
|
|
Dup2:=false;
|
|
end;
|
|
|
|
{$endif def go32v2}
|
|
|
|
{$I-}
|
|
function FileExist(const FileName : PathStr) : Boolean;
|
|
var
|
|
f : file;
|
|
Attr : word;
|
|
begin
|
|
Assign(f, FileName);
|
|
GetFAttr(f, Attr);
|
|
FileExist := DosError = 0;
|
|
end;
|
|
|
|
|
|
{............................................................................}
|
|
|
|
function ChangeRedir(Const Redir : String; AppendToFile : Boolean) : Boolean;
|
|
begin
|
|
ChangeRedir:=False;
|
|
If Redir = '' then Exit;
|
|
Assign (F, Redir);
|
|
If AppendToFile and FileExist(Redir) then
|
|
Begin
|
|
Reset(F,1);
|
|
Seek(F,FileSize(F));
|
|
End else Rewrite (F);
|
|
|
|
RedirError:=IOResult;
|
|
IOStatus:=RedirError;
|
|
If IOStatus <> 0 then Exit;
|
|
{$ifndef FPC}
|
|
Handles:=Ptr (prefseg, PWord (Ptr (prefseg, $34))^);
|
|
OldHandle:=Handles^[1];
|
|
Handles^[1]:=Handles^[FileRec (F).Handle];
|
|
ChangeRedir:=True;
|
|
{$else}
|
|
if dup(StdOutputHandle,TempH) and
|
|
dup2(FileRec(F).Handle,StdOutputHandle) then
|
|
ChangeRedir:=True;
|
|
{$endif def FPC}
|
|
RedirChanged:=True;
|
|
end;
|
|
|
|
function ChangeErrorRedir(Const Redir : String; AppendToFile : Boolean) : Boolean;
|
|
begin
|
|
ChangeErrorRedir:=False;
|
|
If Redir = '' then Exit;
|
|
Assign (FE, Redir);
|
|
If AppendToFile and FileExist(Redir) then
|
|
Begin
|
|
Reset(FE,1);
|
|
Seek(FE,FileSize(FE));
|
|
End
|
|
else
|
|
Rewrite (FE);
|
|
|
|
RedirError:=IOResult;
|
|
IOStatus:=RedirError;
|
|
If IOStatus <> 0 then Exit;
|
|
{$ifndef FPC}
|
|
Handles:=Ptr (prefseg, PWord (Ptr (prefseg, $34))^);
|
|
OldErrorHandle:=Handles^[2];
|
|
Handles^[2]:=Handles^[FileRec (FE).Handle];
|
|
ChangeErrorRedir:=True;
|
|
{$else}
|
|
if dup(StdErrorHandle,TempErrorH) and
|
|
dup2(FileRec(FE).Handle,StdErrorHandle) then
|
|
ChangeErrorRedir:=True;
|
|
{$endif}
|
|
RedirErrorChanged:=True;
|
|
end;
|
|
|
|
|
|
{$IfDef MsDos}
|
|
{Set HeapEnd Pointer to Current Used Heapsize}
|
|
Procedure SmallHeap;assembler;
|
|
asm
|
|
mov bx,word ptr HeapPtr
|
|
shr bx,4
|
|
inc bx
|
|
add bx,word ptr HeapPtr+2
|
|
mov ax,PrefixSeg
|
|
sub bx,ax
|
|
mov es,ax
|
|
mov ah,4ah
|
|
int 21h
|
|
end;
|
|
|
|
|
|
|
|
{Set HeapEnd Pointer to Full Heapsize}
|
|
Procedure FullHeap;assembler;
|
|
asm
|
|
mov bx,word ptr HeapEnd
|
|
shr bx,4
|
|
inc bx
|
|
add bx,word ptr HeapEnd+2
|
|
mov ax,PrefixSeg
|
|
sub bx,ax
|
|
mov es,ax
|
|
mov ah,4ah
|
|
int 21h
|
|
end;
|
|
|
|
{$EndIf MsDos}
|
|
|
|
|
|
procedure RestoreRedir;
|
|
|
|
begin
|
|
If not RedirChanged then Exit;
|
|
{$ifndef FPC}
|
|
Handles^[1]:=OldHandle;
|
|
OldHandle:=StdOutputHandle;
|
|
{$else}
|
|
dup2(TempH,StdOutputHandle);
|
|
{$endif}
|
|
Close (F);
|
|
RedirChanged:=false;
|
|
end;
|
|
|
|
{............................................................................}
|
|
|
|
procedure RestoreErrorRedir;
|
|
|
|
begin
|
|
If not RedirErrorChanged then Exit;
|
|
{$ifndef FPC}
|
|
Handles^[2]:=OldErrorHandle;
|
|
OldErrorHandle:=StdErrorHandle;
|
|
{$else}
|
|
dup2(TempErrorH,StdErrorHandle);
|
|
{$endif}
|
|
Close (FE);
|
|
RedirErrorChanged:=false;
|
|
end;
|
|
|
|
{............................................................................}
|
|
|
|
procedure DosExecute(ProgName, ComLine : String);
|
|
|
|
Begin
|
|
{$IfDef MsDos}
|
|
SmallHeap;
|
|
{$EndIf MsDos}
|
|
SwapVectors;
|
|
{ Must use shell() for linux for the wildcard expansion (PFV) }
|
|
{$ifdef linux}
|
|
Shell(Progname+' '+Comline);
|
|
{$else}
|
|
Dos.Exec (ProgName, ComLine);
|
|
{$endif}
|
|
IOStatus:=DosError;
|
|
ExecuteResult:=DosExitCode;
|
|
SwapVectors;
|
|
{$IfDef MsDos}
|
|
Fullheap;
|
|
{$EndIf MsDos}
|
|
End;
|
|
|
|
{............................................................................}
|
|
|
|
function ExecuteRedir (Const ProgName, ComLine, RedirStdOut, RedirStdErr : String) : boolean;
|
|
Begin
|
|
RedirError:=0;
|
|
ExecuteResult:=0;
|
|
IOStatus:=0;
|
|
if RedirStdOut<>'' then
|
|
ChangeRedir(RedirStdOut,false);
|
|
if RedirStdErr<>'stderr' then
|
|
RedirErrorChanged:=ChangeErrorRedir(RedirStdErr,false);
|
|
DosExecute(ProgName,ComLine);
|
|
RestoreRedir;
|
|
RestoreErrorRedir;
|
|
ExecuteRedir:=(IOStatus=0) and (RedirError=0) and (ExecuteResult=0);
|
|
End;
|
|
|
|
|
|
{$else not implemented}
|
|
|
|
|
|
{*****************************************************************************
|
|
Linux
|
|
*****************************************************************************}
|
|
|
|
|
|
function ExecuteRedir (Const ProgName, ComLine, RedirStdOut, RedirStdErr : String) : boolean;
|
|
begin
|
|
ExecuteRedir:=false;
|
|
end;
|
|
|
|
function ChangeRedir(Const Redir : String; AppendToFile : Boolean) : Boolean;
|
|
begin
|
|
ChangeRedir:=false;
|
|
end;
|
|
|
|
procedure RestoreRedir;
|
|
begin
|
|
end;
|
|
|
|
function ChangeErrorRedir(Const Redir : String; AppendToFile : Boolean) : Boolean;
|
|
begin
|
|
ChangeErrorRedir:=false;
|
|
end;
|
|
|
|
procedure RestoreErrorRedir;
|
|
begin
|
|
end;
|
|
|
|
procedure InitRedir;
|
|
begin
|
|
end;
|
|
|
|
{$endif not implemented}
|
|
|
|
|
|
{*****************************************************************************
|
|
Initialize
|
|
*****************************************************************************}
|
|
|
|
End.
|
|
{
|
|
$Log$
|
|
Revision 1.10 1999-02-22 12:46:58 peter
|
|
* small fixes for linux and grep
|
|
|
|
Revision 1.9 1999/02/22 11:12:33 pierre
|
|
* dup and dup2 work for go32v2
|
|
+ also should work for linux (after linux.pp patch)
|
|
|
|
Revision 1.8 1999/02/22 02:15:18 peter
|
|
+ default extension for save in the editor
|
|
+ Separate Text to Find for the grep dialog
|
|
* fixed redir crash with tp7
|
|
|
|
Revision 1.7 1999/02/20 15:18:32 peter
|
|
+ ctrl-c capture with confirm dialog
|
|
+ ascii table in the tools menu
|
|
+ heapviewer
|
|
* empty file fixed
|
|
* fixed callback routines in fpdebug to have far for tp7
|
|
|
|
Revision 1.6 1999/02/05 13:51:43 peter
|
|
* unit name of FPSwitches -> FPSwitch which is easier to use
|
|
* some fixes for tp7 compiling
|
|
|
|
}
|