* adapted for 1.1 unix

ide/fpredir.pas

@@ -1,7 +1,7 @@
 {
     $Id$
-    This file is part of the Free Pascal Integrated Development Environment
-    Copyright (c) 1998 by Berczi Gabor
+    This file is part of the Free Pascal Test Suite
+    Copyright (c) 1999-2000 by Pierre Muller
 
     Unit to redirect output and error to files
 
@@ -15,13 +15,15 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
-Unit FPRedir;
+Unit Redir;
 Interface
 
 {$R-}
+{$ifndef Linux}
 {$ifndef Unix}
   {$S-}
 {$endif}
+{$endif}
 
 {$ifdef TP}
 {$define implemented}
@@ -29,10 +31,16 @@ Interface
 {$ifdef Go32v2}
 {$define implemented}
 {$endif}
+{$ifdef OS2}
+{$define shell_implemented}
+{$endif}
 {$ifdef Win32}
 {$define implemented}
 {$endif}
-{$ifdef Unix}
+{$ifdef linux}
+{$define implemented}
+{$endif}
+{$ifdef BSD}
 {$define implemented}
 {$endif}
 
@@ -66,9 +74,10 @@ procedure DisableRedirError;
 procedure EnableRedirError;
 procedure RedirDisableAll;
 procedure RedirEnableAll;
-{$ifdef win32}
-procedure Win32ShowMouse;
-{$endif win32}
+
+{ unused in UNIX }
+const
+  UseComSpec : boolean = true;
 
 Implementation
 
@@ -79,15 +88,28 @@ Uses
 {$ifdef win32}
   windows,
 {$endif win32}
-{$ifdef Unix}
-  {$ifdef VER1_0}
+{$ifdef unix}
+  {$ifdef ver1_0}
     linux,
   {$else}
+    baseunix,
     unix,
   {$endif}
-{$endif Unix}
+{$endif unix}
   dos;
 
+Const
+{$ifdef UNIX}
+  DirSep='/';
+  listsep = [';',':'];
+  exeext = '';
+{$else UNIX}
+  DirSep='\';
+  listsep = [';'];
+  exeext = '.exe';
+{$endif UNIX}
+
+
 var
   FIN,FOUT,FERR     : ^File;
   RedirChangedOut,
@@ -95,6 +117,25 @@ var
   RedirChangedError : Boolean;
   InRedirDisabled,OutRedirDisabled,ErrorRedirDisabled : Boolean;
 
+
+{*****************************************************************************
+                                     Helpers
+*****************************************************************************}
+
+function FixPath(const s:string):string;
+var
+  i : longint;
+begin
+  { Fix separator }
+  for i:=1 to length(s) do
+   if s[i] in ['/','\'] then
+    fixpath[i]:=DirSep
+   else
+    fixpath[i]:=s[i];
+  fixpath[0]:=s[0];
+end;
+
+
 {*****************************************************************************
                                      Dos
 *****************************************************************************}
@@ -132,34 +173,33 @@ Var
 var
   TempHOut, TempHIn,TempHError : longint;
 
-{ For Unix the following functions exist
-Function  Dup(oldfile:longint;var newfile:longint):Boolean;
-Function  Dup2(oldfile,newfile:longint):Boolean;
-Function  fdClose(fd:longint):boolean;
+{
+For linux the following functions exist
+Function  fpdup(oldfile:longint;var newfile:longint):Boolean;
+Function  fpdup2(oldfile,newfile:longint):Boolean;
+Function  fpClose(fd:longint):boolean;
 }
 {$ifdef go32v2}
 
 function dup(fh : longint;var nh : longint) : boolean;
-  var
-    Regs : Registers;
-
+var
+  Regs : Registers;
 begin
     Regs.ah:=$45;
     Regs.bx:=fh;
     MsDos (Regs);
-    Dup:=true;
+    dup:=true;
     If (Regs.Flags and fCarry)=0 then
       nh:=Regs.Ax
     else
-      Dup:=false;
+      fpdup:=false;
 end;
 
 function dup2(fh,nh : longint) : boolean;
-  var
-    Regs : Registers;
-
+var
+  Regs : Registers;
 begin
-    Dup2:=true;
+    dup2:=true;
     If fh=nh then
       exit;
     Regs.ah:=$46;
@@ -167,39 +207,60 @@ begin
     Regs.cx:=nh;
     MsDos (Regs);
     If (Regs.Flags and fCarry)<>0 then
-      Dup2:=false;
+      dup2:=false;
 end;
 
-Function FdClose (Handle : Longint) : boolean;
+{$ifndef ver1_0}
+function fpdup(fh:longint):longint;
+var
+  fn : longint;
+begin
+  if not dup(fh,fpdup) then
+   fpdup:=-1;
+end;
+
+function fpdup2(fh:longint):longint;
+var
+  fn : longint;
+begin
+  if not dup2(fh,fpdup2) then
+   fpdup2:=-1;
+end;
+{$endif ver1_0}
+
+
+Function {$ifdef ver1_0}fdclose{$else}fpclose{$endif}( (Handle : Longint) : boolean;
 var Regs: registers;
 begin
   Regs.Eax := $3e00;
   Regs.Ebx := Handle;
   MsDos(Regs);
-  FdClose:=(Regs.Flags and fCarry)=0;
+  {$ifdef ver1_0}fdclose{$else}fpclose{$endif}(:=(Regs.Flags and fCarry)=0;
 end;
 
 {$endif def go32v2}
 
 {$ifdef win32}
-procedure Win32ShowMouse;
+Function {$ifdef ver1_0}fdclose{$else}fpclose{$endif}( (Handle : Longint) : boolean;
 begin
-  ExecuteRedir(GetEnv('COMSPEC'),'/C rem echo This dummy call gets the mouse to become visible'
-    ,'','nul','');
+  { Do we need this ?? }
+  {$ifdef ver1_0}fdclose{$else}fpclose{$endif}(:=true;
 end;
+{$endif}
 
-Function FdClose (Handle : Longint) : boolean;
+{$ifdef os2}
+Function {$ifdef ver1_0}fdclose{$else}fpclose{$endif}( (Handle : Longint) : boolean;
 begin
   { Do we need this ?? }
-  FdClose:=true;
+  {$ifdef ver1_0}fdclose{$else}fpclose{$endif}(:=true;
 end;
 {$endif}
 
 {$ifdef TP}
-Function FdClose (Handle : Longint) : boolean;
+Function {$ifdef ver1_0}fdclose{$else}fpclose{$endif}( (Handle : Longint) : boolean;
 begin
   { if executed as under GO32 this hangs the DOS-prompt }
-  FdClose:=true;
+  {$ifdef ver1_0}fdclose{$else}fpclose{$endif}(:=true;
 end;
 
 {$endif}
@@ -215,6 +276,58 @@ begin
   FileExist := DosError = 0;
 end;
 
+function CompleteDir(const Path: string): string;
+begin
+  { keep c: untouched PM }
+  if (Path<>'') and (Path[Length(Path)]<>DirSep) and
+     (Path[Length(Path)]<>':') then
+   CompleteDir:=Path+DirSep
+  else
+   CompleteDir:=Path;
+end;
+
+
+function LocateExeFile(var FileName:string): boolean;
+var
+  dir,s,d,n,e : string;
+  i : longint;
+begin
+  LocateExeFile:=False;
+  if FileExist(FileName) then
+    begin
+      LocateExeFile:=true;
+      Exit;
+    end;
+
+  Fsplit(Filename,d,n,e);
+
+  if (e='') and FileExist(FileName+exeext) then
+    begin
+      FileName:=FileName+exeext;
+      LocateExeFile:=true;
+      Exit;
+    end;
+
+  S:=GetEnv('PATH');
+  While Length(S)>0 do
+    begin
+      i:=1;
+      While (i<=Length(S)) and not (S[i] in ListSep) do
+        Inc(i);
+      Dir:=CompleteDir(Copy(S,1,i-1));
+      if i<Length(S) then
+        Delete(S,1,i)
+      else
+        S:='';
+      if FileExist(Dir+FileName) then
+        Begin
+           FileName:=Dir+FileName;
+           LocateExeFile:=true;
+           Exit;
+        End;
+   end;
+end;
+
 
 {............................................................................}
 
@@ -242,8 +355,15 @@ function ChangeRedirOut(Const Redir : String; AppendToFile : Boolean) : Boolean;
 {$ifdef win32}
     if SetStdHandle(Std_Output_Handle,FileRec(FOUT^).Handle) then
 {$else not win32}
-    if dup(StdOutputHandle,TempHOut) and
-       dup2(FileRec(FOUT^).Handle,StdOutputHandle) then
+    {$ifdef ver1_0}
+    dup(StdOutputHandle,TempHOut);
+    dup2(FileRec(FOUT^).Handle,StdOutputHandle);
+    {$else}
+    TempHOut:=fpdup(StdOutputHandle);
+    fpdup2(FileRec(FOUT^).Handle,StdOutputHandle);
+    {$endif}
+    if (TempHOut<>UnusedHandle) and
+       (StdOutputHandle<>UnusedHandle) then
 {$endif not win32}
       begin
          ChangeRedirOut:=True;
@@ -273,8 +393,15 @@ function ChangeRedirIn(Const Redir : String) : Boolean;
 {$ifdef win32}
     if SetStdHandle(Std_Input_Handle,FileRec(FIN^).Handle) then
 {$else not win32}
-    if dup(StdInputHandle,TempHIn) and
-       dup2(FileRec(FIN^).Handle,StdInputHandle) then
+    {$ifdef ver1_0}
+    dup(StdInputHandle,TempHIn);
+    dup2(FileRec(FIn^).Handle,StdInputHandle);
+    {$else}
+    TempHIn:=fpdup(StdInputHandle);
+    fpdup2(FileRec(FIn^).Handle,StdInputHandle);
+    {$endif}
+    if (TempHIn<>UnusedHandle) and
+       (StdInputHandle<>UnusedHandle) then
 {$endif not win32}
       begin
          ChangeRedirIn:=True;
@@ -308,8 +435,15 @@ function ChangeRedirError(Const Redir : String; AppendToFile : Boolean) : Boolea
 {$ifdef win32}
     if SetStdHandle(Std_Error_Handle,FileRec(FERR^).Handle) then
 {$else not win32}
-    if dup(StdErrorHandle,TempHError) and
-       dup2(FileRec(FERR^).Handle,StdErrorHandle) then
+    {$ifdef ver1_0}
+    dup(StdErrorHandle,TempHError);
+    dup2(FileRec(FERR^).Handle,StdErrorHandle);
+    {$else}
+    TempHError:=fpdup(StdErrorHandle);
+    fpdup2(FileRec(FERR^).Handle,StdErrorHandle);
+    {$endif}
+    if (TempHError<>UnusedHandle) and
+       (StdErrorHandle<>UnusedHandle) then
 {$endif not win32}
       begin
          ChangeRedirError:=True;
@@ -365,11 +499,11 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Output_Handle,StdOutputHandle);
 {$else not win32}
-    dup2(TempHOut,StdOutputHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(TempHOut,StdOutputHandle);
 {$endif not win32}
 {$endif FPC}
     Close (FOUT^);
-    fdClose(TempHOut);
+    {$ifdef ver1_0}fdclose{$else}fpclose{$endif}(TempHOut);
     RedirChangedOut:=false;
   end;
 
@@ -386,11 +520,11 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Input_Handle,StdInputHandle);
 {$else not win32}
-    dup2(TempHIn,StdInputHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(TempHIn,StdInputHandle);
 {$endif not win32}
 {$endif}
     Close (FIn^);
-    fdClose(TempHIn);
+    {$ifdef ver1_0}fdclose{$else}fpclose{$endif}(TempHIn);
     RedirChangedIn:=false;
   end;
 
@@ -407,7 +541,7 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Input_Handle,StdInputHandle);
 {$else not win32}
-    dup2(TempHIn,StdInputHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(TempHIn,StdInputHandle);
 {$endif not win32}
 {$endif}
     InRedirDisabled:=True;
@@ -427,7 +561,7 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Input_Handle,FileRec(FIn^).Handle);
 {$else not win32}
-    dup2(FileRec(FIn^).Handle,StdInputHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(FileRec(FIn^).Handle,StdInputHandle);
 {$endif not win32}
 {$endif}
     InRedirDisabled:=False;
@@ -446,7 +580,7 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Output_Handle,StdOutputHandle);
 {$else not win32}
-    dup2(TempHOut,StdOutputHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(TempHOut,StdOutputHandle);
 {$endif not win32}
 {$endif}
     OutRedirDisabled:=True;
@@ -466,7 +600,7 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Output_Handle,FileRec(FOut^).Handle);
 {$else not win32}
-    dup2(FileRec(FOut^).Handle,StdOutputHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(FileRec(FOut^).Handle,StdOutputHandle);
 {$endif not win32}
 {$endif}
     OutRedirDisabled:=False;
@@ -485,11 +619,11 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Error_Handle,StdErrorHandle);
 {$else not win32}
-    dup2(TempHError,StdErrorHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(TempHError,StdErrorHandle);
 {$endif not win32}
 {$endif}
     Close (FERR^);
-    fdClose(TempHError);
+    {$ifdef ver1_0}fdclose{$else}fpclose{$endif}(TempHError);
     RedirChangedError:=false;
   end;
 
@@ -506,7 +640,7 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Error_Handle,StdErrorHandle);
 {$else not win32}
-    dup2(TempHError,StdErrorHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(TempHError,StdErrorHandle);
 {$endif not win32}
 {$endif}
     ErrorRedirDisabled:=True;
@@ -526,7 +660,7 @@ end;
 {$ifdef win32}
     SetStdHandle(Std_Error_Handle,FileRec(FErr^).Handle);
 {$else not win32}
-    dup2(FileRec(FERR^).Handle,StdErrorHandle);
+    {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(FileRec(FERR^).Handle,StdErrorHandle);
 {$endif not win32}
 {$endif}
     ErrorRedirDisabled:=False;
@@ -593,10 +727,92 @@ end;
                                  Fake
 *****************************************************************************}
 
+{$IFDEF SHELL_IMPLEMENTED}
+{$I-}
+function FileExist(const FileName : PathStr) : Boolean;
+var
+  f : file;
+  Attr : word;
+begin
+  Assign(f, FileName);
+  GetFAttr(f, Attr);
+  FileExist := DosError = 0;
+end;
+
+function CompleteDir(const Path: string): string;
+begin
+  { keep c: untouched PM }
+  if (Path<>'') and (Path[Length(Path)]<>DirSep) and
+     (Path[Length(Path)]<>':') then
+   CompleteDir:=Path+DirSep
+  else
+   CompleteDir:=Path;
+end;
+
+
+function LocateExeFile(var FileName:string): boolean;
+var
+  dir,s,d,n,e : string;
+  i : longint;
+begin
+  LocateExeFile:=False;
+  if FileExist(FileName) then
+    begin
+      LocateExeFile:=true;
+      Exit;
+    end;
+
+  Fsplit(Filename,d,n,e);
+
+  if (e='') and FileExist(FileName+exeext) then
+    begin
+      FileName:=FileName+exeext;
+      LocateExeFile:=true;
+      Exit;
+    end;
+
+  S:=GetEnv('PATH');
+  While Length(S)>0 do
+    begin
+      i:=1;
+      While (i<=Length(S)) and not (S[i] in ListSep) do
+        Inc(i);
+      Dir:=CompleteDir(Copy(S,1,i-1));
+      if i<Length(S) then
+        Delete(S,1,i)
+      else
+        S:='';
+      if FileExist(Dir+FileName) then
+        Begin
+           FileName:=Dir+FileName;
+           LocateExeFile:=true;
+           Exit;
+        End;
+   end;
+end;
+
+function ExecuteRedir (Const ProgName, ComLine, RedirStdIn, RedirStdOut, RedirStdErr: String): boolean;
+var
+ CmdLine2: string;
+begin
+ CmdLine2 := ComLine;
+ if RedirStdIn <> '' then CmdLine2 := CmdLine2 + ' < ' + RedirStdIn;
+ if RedirStdOut <> '' then CmdLine2 := CmdLine2 + ' > ' + RedirStdOut;
+ if RedirStdErr <> '' then
+ begin
+  if RedirStdErr = RedirStdOut
+          then CmdLine2 := CmdLine2 + ' 2>&1'
+                              else CmdLine2 := CmdLine2 + ' 2> ' + RedirStdErr;
+ end;
+ DosExecute (ProgName, CmdLine2);
+ ExecuteRedir := true;
+end;
+{$ELSE SHELL_IMPLEMENTED}
 function ExecuteRedir (Const ProgName, ComLine, RedirStdIn, RedirStdOut, RedirStdErr : String) : boolean;
 begin
   ExecuteRedir:=false;
 end;
+{$ENDIF SHELL_IMPLEMENTED}
 
 function  ChangeRedirOut(Const Redir : String; AppendToFile : Boolean) : Boolean;
 begin
@@ -691,54 +907,91 @@ end;
 {$EndIf MsDos}
     SwapVectors;
     { Must use shell() for linux for the wildcard expansion (PFV) }
-{$ifdef Unix}
+{$ifdef UNIX}
     IOStatus:=0;
-    ExecuteResult:=Shell(Progname+' '+Comline);
+    ExecuteResult:=Shell(FixPath(Progname)+' '+Comline);
+  {$ifdef ver1_0}
     { Signal that causes the stop of the shell }
     IOStatus:=ExecuteResult and $7F;
     { Exit Code seems to be in the second byte,
       is this also true for BSD ??
       $80 bit is a CoreFlag apparently }
     ExecuteResult:=(ExecuteResult and $ff00) shr 8;
+  {$else}
+    if ExecuteResult<0 then
+      begin
+        IOStatus:=(-ExecuteResult) and $7f;
+        ExecuteResult:=((-ExecuteResult) and $ff00) shr 8;
+      end;
+  {$endif}
 {$else}
-{$ifdef win32}
+  {$ifdef win32}
     StoreInherit:=ExecInheritsHandles;
     ExecInheritsHandles:=true;
-{$endif win32}
+  {$endif win32}
     DosError:=0;
-    Dos.Exec (ProgName, ComLine);
-{$ifdef win32}
+    If UseComSpec then
+      Dos.Exec (Getenv('COMSPEC'),'/C '+FixPath(progname)+' '+Comline)
+    else
+      begin
+        if LocateExeFile(progname) then
+          Dos.Exec(ProgName,Comline)
+        else
+          DosError:=2;
+      end;
+  {$ifdef win32}
     ExecInheritsHandles:=StoreInherit;
-{$endif win32}
+  {$endif win32}
     IOStatus:=DosError;
     ExecuteResult:=DosExitCode;
 {$endif}
     SwapVectors;
+{$ifdef CPU86}
+    { reset the FPU }
+    {$asmmode att}
+    asm
+      fninit
+    end;
+{$endif CPU86}
 {$IfDef MsDos}
   Fullheap;
 {$EndIf MsDos}
-  End;
+End;
 
 {*****************************************************************************
                                   Initialize
 *****************************************************************************}
 
-var oldexit : pointer;
+initialization
+  New(FIn); New(FOut); New(FErr);
 
-procedure RedirExit; {$ifndef FPC}far;{$endif}
-begin
-  exitproc:=oldexit;
+finalization
   Dispose(FIn); Dispose(FOut); Dispose(FErr);
-end;
-
-Begin
-  oldexit:=exitproc;
-  exitproc:=@RedirExit;
-  New(FIn); New(FOut); New(FErr);
 End.
 {
   $Log$
-  Revision 1.2  2002-09-07 15:40:44  peter
+  Revision 1.3  2003-09-25 16:49:08  peter
+    * adapted for 1.1 unix
+
+  Revision 1.13  2003/06/05 20:03:22  peter
+    * Shell return adapted for 1.1
+
+  Revision 1.12  2003/01/12 19:46:50  hajny
+    + newer functions made available under OS/2
+
+  Revision 1.11  2002/12/05 16:03:04  pierre
+   + UseComSpec boolean added to be able to not use ComSpec
+
+  Revision 1.10  2002/09/07 15:40:56  peter
     * old logs removed and tabs fixed
 
+  Revision 1.9  2002/06/03 19:07:55  pierre
+   * fix compilation failure
+
+  Revision 1.8  2002/06/01 19:08:52  marco
+   * Renamefest
+
+  Revision 1.7  2002/02/24 20:07:23  hajny
+    * dummy implementation for OS/2
+
 }