{ This file is part of the Free Component Library (FCL) Copyright (c) 1999-2000 by the Free Pascal development team 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. **********************************************************************} Type {$ifdef processunicodestring} TProcessString = Unicodestring; TprocessChar = UnicodeChar; { TProcessStrings } TProcessStrings = Class(TPersistent) private name : array of unicodestring; function getcount: Integer; function getname( index: integer): Unicodestring; public procedure AssignTo(Dest: TPersistent); override; procedure add(const s : Unicodestring); procedure Clear; procedure Delete(i:integer); property Names[ index:integer]:Unicodestring read getname; default; property Count : Integer read getcount; end; TProcessStringList = TProcessStrings; {$else} TprocessChar = {Ansi}Char; TProcessString = {Ansi}String; TProcessStrings = TStrings; TProcessStringList = TStringList; {$endif} { TProcess } TProcessnamemacro = Class (TComponent) Private FOnRunCommandEvent: TOnRunCommandEvent; FProcessOptions : TProcessOptions; FRunCommandSleepTime: Integer; FStartupOptions : TStartupOptions; FFillAttribute : Cardinal; FApplicationName : TProcessString; FConsoleTitle : TProcessString; FCommandLine : TProcessString; FCurrentDirectory : TProcessString; FDesktop : String; FEnvironment : TProcessStrings; FExecutable : TProcessString; FParameters : TProcessStrings; FShowWindow : TShowWindowOptions; FInherithandles : Boolean; {$ifdef UNIX} FForkEvent : TProcessForkEvent; {$endif UNIX} FProcessPriority : TProcessPriority; dwXCountchars, dwXSize, dwYsize, dwx, dwYcountChars, dwy : Cardinal; FXTermProgram: String; FPipeBufferSize : cardinal; Procedure FreeStreams; Function GetExitStatus : Integer; Function GetExitCode : Integer; Function GetRunning : Boolean; Function GetWindowRect : TRect; procedure SetCommandLine(const AValue: TProcessString); deprecated; procedure SetParameters(const AValue: TProcessStrings); Procedure SetWindowRect (Value : TRect); Procedure SetShowWindow (Value : TShowWindowOptions); Procedure SetWindowColumns (Value : Cardinal); Procedure SetWindowHeight (Value : Cardinal); Procedure SetWindowLeft (Value : Cardinal); Procedure SetWindowRows (Value : Cardinal); Procedure SetWindowTop (Value : Cardinal); Procedure SetWindowWidth (Value : Cardinal); procedure SetApplicationName(const Value: TProcessString); procedure SetProcessOptions(const Value: TProcessOptions); procedure SetActive(const Value: Boolean); procedure SetEnvironment(const Value: TProcessStrings); Procedure ConvertCommandLine; function PeekExitStatus: Boolean; Procedure IntOnIdleSleep(Sender,Context : TObject;Status:TRunCommandEventCode;const Message:String); Protected FRunning : Boolean; FExitCode : Cardinal; FInputStream : TOutputPipeStream; FOutputStream : TInputPipeStream; FStderrStream : TInputPipeStream; FProcessID : Integer; FThreadID : Integer; FProcessHandle : Thandle; FThreadHandle : Thandle; procedure CloseProcessHandles; virtual; Procedure CreateStreams(InHandle,OutHandle,ErrHandle : Longint);virtual; procedure FreeStream(var AStream: THandleStream); procedure Loaded; override; Public Constructor Create (AOwner : TComponent);override; Destructor Destroy; override; Procedure Execute; virtual; procedure CloseInput; virtual; procedure CloseOutput; virtual; procedure CloseStderr; virtual; Function Resume : Integer; virtual; Function Suspend : Integer; virtual; Function Terminate (AExitCode : Integer): Boolean; virtual; Function WaitOnExit : Boolean; Function WaitOnExit(Timeout : DWord) : Boolean; function ReadInputStream(p:TInputPipeStream;var BytesRead:integer;var DataLength:integer;var Data:string;MaxLoops:integer=10):boolean; virtual; function ReadInputStream(p:TInputPipeStream;data:TStream;MaxLoops:integer=10):boolean; virtual; function RunCommandLoop(out outputstring:string;out stderrstring:string; out anexitstatus:integer):integer; virtual; Property WindowRect : Trect Read GetWindowRect Write SetWindowRect; Property Handle : THandle Read FProcessHandle; Property ProcessHandle : THandle Read FProcessHandle; Property ThreadHandle : THandle Read FThreadHandle; Property ProcessID : Integer Read FProcessID; Property ThreadID : Integer Read FThreadID; Property Input : TOutputPipeStream Read FInputStream; Property Output : TInputPipeStream Read FOutputStream; Property Stderr : TinputPipeStream Read FStderrStream; Property ExitStatus : Integer Read GetExitStatus; Property ExitCode : Integer Read GetExitCode; Property InheritHandles : Boolean Read FInheritHandles Write FInheritHandles; Property OnRunCommandEvent : TOnRunCommandEvent Read FOnRunCommandEvent Write FOnRunCommandEvent; Property RunCommandSleepTime : Integer read FRunCommandSleepTime write FRunCommandSleepTime; {$ifdef UNIX} property OnForkEvent : TProcessForkEvent Read FForkEvent Write FForkEvent; {$endif UNIX} Published property PipeBufferSize : cardinal read FPipeBufferSize write FPipeBufferSize default 1024; Property Active : Boolean Read GetRunning Write SetActive; Property ApplicationName : TProcessString Read FApplicationName Write SetApplicationName; deprecated; Property CommandLine : TProcessString Read FCommandLine Write SetCommandLine ; deprecated; Property Executable : TProcessString Read FExecutable Write FExecutable; Property Parameters : TProcessStrings Read FParameters Write SetParameters; Property ConsoleTitle : TProcessString Read FConsoleTitle Write FConsoleTitle; Property CurrentDirectory : TProcessString Read FCurrentDirectory Write FCurrentDirectory; Property Desktop : String Read FDesktop Write FDesktop; Property Environment : TProcessStrings Read FEnvironment Write SetEnvironment; Property Options : TProcessOptions Read FProcessOptions Write SetProcessOptions; Property Priority : TProcessPriority Read FProcessPriority Write FProcessPriority; Property StartupOptions : TStartupOptions Read FStartupOptions Write FStartupOptions; Property Running : Boolean Read GetRunning; Property ShowWindow : TShowWindowOptions Read FShowWindow Write SetShowWindow; Property WindowColumns : Cardinal Read dwXCountChars Write SetWindowColumns; Property WindowHeight : Cardinal Read dwYSize Write SetWindowHeight; Property WindowLeft : Cardinal Read dwX Write SetWindowLeft; Property WindowRows : Cardinal Read dwYCountChars Write SetWindowRows; Property WindowTop : Cardinal Read dwY Write SetWindowTop ; Property WindowWidth : Cardinal Read dwXSize Write SetWindowWidth; Property FillAttribute : Cardinal read FFillAttribute Write FFillAttribute; Property XTermProgram : String Read FXTermProgram Write FXTermProgram; end; TProcessClass = Class of TProcessnamemacro; Procedure CommandToList(S : TProcessString; List : TProcessStrings); {$ifdef unix} Var TryTerminals : Array of string; XTermProgram : String; Function DetectXTerm : String; {$endif unix} function RunCommandIndir(const curdir:TProcessString;const exename:TProcessString;const commands:array of TProcessString;out outputstring:string; out exitstatus:integer; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone):integer; function RunCommandIndir(const curdir:TProcessString;const exename:TProcessString;const commands:array of TProcessString;out outputstring:string; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone):boolean; function RunCommand(const exename:TProcessString;const commands:array of TProcessString;out outputstring:string; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone):boolean; function RunCommandInDir(const curdir,cmdline:TProcessString;out outputstring:string):boolean; deprecated; function RunCommand(const cmdline:TProcessString;out outputstring:string):boolean; deprecated; // Allows override of the class instantiated for RunCommand*. var DefaultTProcess : TProcessClass = TProcessnamemacro; implementation {$i process.inc} Procedure CommandToList(S : TProcessString; List : TProcessStrings); Function GetNextWord : TProcessString; Const WhiteSpace = [' ',#9,#10,#13]; Literals = ['"','''']; Var Wstart,wend : Integer; InLiteral : Boolean; LastLiteral : TProcessChar; begin WStart:=1; While (WStart<=Length(S)) and charinset(S[WStart],WhiteSpace) do Inc(WStart); WEnd:=WStart; InLiteral:=False; LastLiteral:=#0; While (Wend<=Length(S)) and (Not charinset(S[Wend],WhiteSpace) or InLiteral) do begin if charinset(S[Wend],Literals) then If InLiteral then InLiteral:=Not (S[Wend]=LastLiteral) else begin InLiteral:=True; LastLiteral:=S[Wend]; end; inc(wend); end; Result:=Copy(S,WStart,WEnd-WStart); if (Length(Result) > 0) and (Result[1] = Result[Length(Result)]) // if 1st char = last char and.. and (Result[1] in Literals) then // it's one of the literals, then Result:=Copy(Result, 2, Length(Result) - 2); //delete the 2 (but not others in it) While (WEnd<=Length(S)) and (S[Wend] in WhiteSpace) do inc(Wend); Delete(S,1,WEnd-1); end; Var W : TProcessString; begin While Length(S)>0 do begin W:=GetNextWord; If (W<>'') then List.Add(W); end; end; Constructor TProcessnamemacro.Create (AOwner : TComponent); begin Inherited; FProcessPriority:=ppNormal; FShowWindow:=swoNone; FInheritHandles:=True; {$ifdef UNIX} FForkEvent:=nil; {$endif UNIX} FPipeBufferSize := 1024; FEnvironment:=TProcessStringList.Create; FParameters:=TProcessStringList.Create; FRunCommandSleepTime:=100; FOnRunCommandEvent:=@IntOnIdleSleep; end; Destructor TProcessnamemacro.Destroy; begin FParameters.Free; FEnvironment.Free; FreeStreams; CloseProcessHandles; Inherited Destroy; end; Procedure TProcessnamemacro.FreeStreams; begin If FStderrStream<>FOutputStream then FreeStream(THandleStream(FStderrStream)); FreeStream(THandleStream(FOutputStream)); FreeStream(THandleStream(FInputStream)); end; Function TProcessnamemacro.GetExitStatus : Integer; begin GetRunning; Result:=FExitCode; end; {$IFNDEF OS_HASEXITCODE} Function TProcessnamemacro.GetExitCode : Integer; begin if Not Running then Result:=GetExitStatus else Result:=0 end; {$ENDIF} Function TProcessnamemacro.GetRunning : Boolean; begin IF FRunning then FRunning:=Not PeekExitStatus; Result:=FRunning; end; Procedure TProcessnamemacro.CreateStreams(InHandle,OutHandle,ErrHandle : Longint); begin FreeStreams; FInputStream:=TOutputPipeStream.Create (InHandle); FOutputStream:=TInputPipeStream.Create (OutHandle); if Not (poStderrToOutput in FProcessOptions) then FStderrStream:=TInputPipeStream.Create(ErrHandle); end; procedure TProcessnamemacro.FreeStream(var AStream: THandleStream); begin if AStream = nil then exit; FreeAndNil(AStream); end; procedure TProcessnamemacro.Loaded; begin inherited Loaded; If (csDesigning in ComponentState) and (FCommandLine<>'') then ConvertCommandLine; end; procedure TProcessnamemacro.CloseInput; begin FreeStream(THandleStream(FInputStream)); end; procedure TProcessnamemacro.CloseOutput; begin FreeStream(THandleStream(FOutputStream)); end; procedure TProcessnamemacro.CloseStderr; begin FreeStream(THandleStream(FStderrStream)); end; Procedure TProcessnamemacro.SetWindowColumns (Value : Cardinal); begin if Value<>0 then Include(FStartupOptions,suoUseCountChars); dwXCountChars:=Value; end; Procedure TProcessnamemacro.SetWindowHeight (Value : Cardinal); begin if Value<>0 then include(FStartupOptions,suoUsePosition); dwYSize:=Value; end; Procedure TProcessnamemacro.SetWindowLeft (Value : Cardinal); begin if Value<>0 then Include(FStartupOptions,suoUseSize); dwx:=Value; end; Procedure TProcessnamemacro.SetWindowTop (Value : Cardinal); begin if Value<>0 then Include(FStartupOptions,suoUsePosition); dwy:=Value; end; Procedure TProcessnamemacro.SetWindowWidth (Value : Cardinal); begin If (Value<>0) then Include(FStartupOptions,suoUseSize); dwXSize:=Value; end; Function TProcessnamemacro.GetWindowRect : TRect; begin With Result do begin Left:=dwx; Right:=dwx+dwxSize; Top:=dwy; Bottom:=dwy+dwysize; end; end; procedure TProcessnamemacro.SetCommandLine(const AValue: TProcessString); begin if FCommandLine=AValue then exit; FCommandLine:=AValue; If Not (csLoading in ComponentState) then ConvertCommandLine; end; procedure TProcessnamemacro.SetParameters(const AValue: TProcessStrings); begin FParameters.Assign(AValue); end; Procedure TProcessnamemacro.SetWindowRect (Value : Trect); begin Include(FStartupOptions,suoUseSize); Include(FStartupOptions,suoUsePosition); With Value do begin dwx:=Left; dwxSize:=Right-Left; dwy:=Top; dwySize:=Bottom-top; end; end; Procedure TProcessnamemacro.SetWindowRows (Value : Cardinal); begin if Value<>0 then Include(FStartupOptions,suoUseCountChars); dwYCountChars:=Value; end; procedure TProcessnamemacro.SetApplicationName(const Value: TProcessString); begin FApplicationName := Value; If (csDesigning in ComponentState) and (FCommandLine='') then FCommandLine:=Value; end; procedure TProcessnamemacro.SetProcessOptions(const Value: TProcessOptions); begin FProcessOptions := Value; If poNewConsole in FProcessOptions then Exclude(FProcessOptions,poNoConsole); if poRunSuspended in FProcessOptions then Exclude(FProcessOptions,poWaitOnExit); end; procedure TProcessnamemacro.SetActive(const Value: Boolean); begin if (Value<>GetRunning) then If Value then Execute else Terminate(0); end; procedure TProcessnamemacro.SetEnvironment(const Value: TProcessStrings); begin FEnvironment.Assign(Value); end; procedure TProcessnamemacro.ConvertCommandLine; begin FParameters.Clear; CommandToList(FCommandLine,FParameters); If FParameters.Count>0 then begin Executable:=FParameters[0]; FParameters.Delete(0); end; end; Const READ_BYTES = 65536; // not too small to avoid fragmentation when reading large files. function TProcessnamemacro.ReadInputStream(p:TInputPipeStream;var BytesRead:integer;var DataLength:integer;var data:string;MaxLoops:integer=10):boolean; var Available, NumBytes: integer; begin Available:=P.NumBytesAvailable; result:=Available>0; if not result then exit; while (available > 0) and (MaxLoops>0) do begin if (BytesRead + available > DataLength) then begin DataLength:=BytesRead + max(READ_BYTES,available); Setlength(Data,DataLength); end; NumBytes := p.Read(data[1+BytesRead], Available); if NumBytes > 0 then Inc(BytesRead, NumBytes); Available:=P.NumBytesAvailable; dec(MaxLoops); end; end; function TProcessnamemacro.ReadInputStream(p:TInputPipeStream;data:TStream;MaxLoops:integer=10):boolean; const BufSize = 4096; var Buffer: array[0..BufSize - 1] of byte; ReadBytes: integer; Available : integer; begin Available:=P.NumBytesAvailable; result:=Available>0; if not result then Exit; while (available > 0) and (MaxLoops>0) do begin ReadBytes := Output.Read({%H-}Buffer, min(BufSize,Available)); data.Write(Buffer, ReadBytes); Available:=P.NumBytesAvailable; dec(MaxLoops); end; end; procedure TProcessnamemacro.IntOnIdleSleep(Sender,Context : TObject;status:TRunCommandEventCode;const message:string); begin if status=RunCommandIdle then sleep(FRunCommandSleepTime); end; // helperfunction that does the bulk of the work. // We need to also collect stderr output in order to avoid // lock out if the stderr pipe is full. function TProcessnamemacro.RunCommandLoop(out outputstring:string; out stderrstring:string; out anexitstatus:integer):integer; var bytesread : integer; outputlength, stderrlength : integer; stderrbytesread : integer; gotoutput,gotoutputstderr : boolean; begin result:=-1; try Options := Options + [poUsePipes]; bytesread:=0; outputlength:=0; stderrbytesread:=0; stderrlength:=0; Execute; while Running do begin // Only call ReadFromStream if Data from corresponding stream // is already available, otherwise, on linux, the read call // is blocking, and thus it is not possible to be sure to handle // big data amounts bboth on output and stderr pipes. PM. gotoutput:=ReadInputStream(output,BytesRead,OutputLength,OutputString,1); // The check for assigned(P.stderr) is mainly here so that // if we use poStderrToOutput in p.Options, we do not access invalid memory. gotoutputstderr:=false; if assigned(stderr) then gotoutputstderr:=ReadInputStream(StdErr,StdErrBytesRead,StdErrLength,StdErrString,1); if (porunidle in options) and not gotoutput and not gotoutputstderr and Assigned(FOnRunCommandEvent) Then FOnRunCommandEvent(self,Nil,RunCommandIdle,''); end; // Get left output after end of execution ReadInputStream(output,BytesRead,OutputLength,OutputString,250); setlength(outputstring,BytesRead); if assigned(stderr) then ReadInputStream(StdErr,StdErrBytesRead,StdErrLength,StdErrString,250); setlength(stderrstring,StderrBytesRead); anexitstatus:=exitstatus; result:=0; // we came to here, document that. if Assigned(FOnRunCommandEvent) then // allow external apps to react to that and finish GUI FOnRunCommandEvent(self,Nil,RunCommandFinished,''); except on e : Exception do begin result:=1; setlength(outputstring,BytesRead); setlength(stderrstring,StderrBytesRead); if Assigned(FOnRunCommandEvent) then FOnRunCommandEvent(self,Nil,RunCommandException,e.Message); end; end; end; { Functions without StderrString } Const ForbiddenOptions = [poRunSuspended,poWaitOnExit]; function RunCommandIndir(const curdir:TProcessString;const exename:TProcessString;const commands:array of TProcessString;out outputstring:string;out exitstatus:integer; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone):integer; Var p : TProcessnamemacro; i : integer; ErrorString : String; begin p:=DefaultTProcess.create(nil); if Options<>[] then P.Options:=Options - ForbiddenOptions; P.ShowWindow:=SwOptions; p.Executable:=exename; if curdir<>'' then p.CurrentDirectory:=curdir; if high(commands)>=0 then for i:=low(commands) to high(commands) do p.Parameters.add(commands[i]); try result:=p.RunCommandLoop(outputstring,errorstring,exitstatus); finally p.free; end; end; function RunCommandInDir(const curdir,cmdline:TProcessString;out outputstring:string):boolean; deprecated; Var p : TProcessnamemacro; exitstatus : integer; ErrorString : String; begin p:=DefaultTProcess.create(nil); p.setcommandline(cmdline); if curdir<>'' then p.CurrentDirectory:=curdir; try result:=p.RunCommandLoop(outputstring,errorstring,exitstatus)=0; finally p.free; end; if exitstatus<>0 then result:=false; end; function RunCommandIndir(const curdir:TProcessString;const exename:TProcessString;const commands:array of TProcessString;out outputstring:string; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone):boolean; Var p : TProcessnamemacro; i, exitstatus : integer; ErrorString : String; begin p:=DefaultTProcess.create(nil); if Options<>[] then P.Options:=Options - ForbiddenOptions; P.ShowWindow:=SwOptions; p.Executable:=exename; if curdir<>'' then p.CurrentDirectory:=curdir; if high(commands)>=0 then for i:=low(commands) to high(commands) do p.Parameters.add(commands[i]); try result:=p.RunCommandLoop(outputstring,errorstring,exitstatus)=0; finally p.free; end; if exitstatus<>0 then result:=false; end; function RunCommand(const cmdline:TProcessString;out outputstring:String):boolean; deprecated; Var p : TProcessnamemacro; exitstatus : integer; ErrorString : String; begin p:=DefaultTProcess.create(nil); p.setcommandline(cmdline); try result:=p.RunCommandLoop(outputstring,errorstring,exitstatus)=0; finally p.free; end; if exitstatus<>0 then result:=false; end; function RunCommand(const exename:TProcessString;const commands:array of TProcessString;out outputstring:string; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone):boolean; Var p : TProcessnamemacro; i, exitstatus : integer; ErrorString : String; begin p:=DefaultTProcess.create(nil); if Options<>[] then P.Options:=Options - ForbiddenOptions; P.ShowWindow:=SwOptions; p.Executable:=exename; if high(commands)>=0 then for i:=low(commands) to high(commands) do p.Parameters.add(commands[i]); try result:=p.RunCommandLoop(outputstring,errorstring,exitstatus)=0; finally p.free; end; if exitstatus<>0 then result:=false; end; {$ifdef processunicodestring} // dummy subset of tstrings. { TProcessStrings } function TProcessStrings.getname( index: integer): Unicodestring; begin if indexlen-1) and (len<>1) then begin for j:=i+1 to len-1 do name[j-1]:=name[j]; setlength(name,len-1) end else setlength(name,len-1) end; {$endif} end.