unit dprocess;
interface
uses
windows,
classes,
sysutils;
type
TProcessOption = (poRunSuspended,poWaitOnExit,
poUsePipes,poStderrToOutPut,
poNoConsole,poNewConsole,
poDefaultErrorMode,poNewProcessGroup,
poDebugProcess,poDebugOnlyThisProcess);
TShowWindowOptions = (swoNone,swoHIDE,swoMaximize,swoMinimize,swoRestore,swoShow,
swoShowDefault,swoShowMaximized,swoShowMinimized,
swoshowMinNOActive,swoShowNA,swoShowNoActivate,swoShowNormal);
TStartupOption = (suoUseShowWindow,suoUseSize,suoUsePosition,
suoUseCountChars,suoUseFillAttribute);
TProcessPriority = (ppHigh,ppIdle,ppNormal,ppRealTime);
TProcessOptions = set of TProcessOption;
TStartupOptions = set of TStartupOption;
type
{ TInputPipeStream }
TInputPipeStream = Class(THandleStream)
end;
{ TProcess }
TProcess = Class (TComponent)
Private
FProcessOptions : TProcessOptions;
FStartupOptions : TStartupOptions;
FProcessID : Integer;
FProcessHandle : Thandle;
FThreadHandle : Thandle;
FFillAttribute : Cardinal;
FApplicationName : string;
FCommandLine : String;
FCurrentDirectory : String;
FEnvironment : Tstrings;
FExecutable : String;
FParameters : TStrings;
FShowWindow : TShowWindowOptions;
FProcessPriority : TProcessPriority;
FPipeBufferSize : cardinal;
Procedure FreeStreams;
Function GetExitStatus : Integer;
Function GetRunning : Boolean;
procedure SetParameters(const AValue: TStrings);
Procedure SetShowWindow (Value : TShowWindowOptions);
procedure SetProcessOptions(const Value: TProcessOptions);
function PeekExitStatus: Boolean;
Protected
FRunning : Boolean;
FExitCode : Cardinal;
FOutputStream : TInputPipeStream;
FStderrStream : TInputPipeStream;
procedure CloseProcessHandles; virtual;
Procedure CreateStreams(InHandle,OutHandle,ErrHandle : Longint);virtual;
procedure FreeStream(var AStream: THandleStream);
Public
Constructor Create (AOwner : TComponent);override;
Destructor Destroy; override;
Procedure Execute; virtual;
procedure CloseOutput; virtual;
procedure CloseStderr; virtual;
Function Resume : Integer; virtual;
Function Suspend : Integer; virtual;
Function Terminate (AExitCode : Integer): Boolean; virtual;
Function WaitOnExit : Boolean;
Property Handle : THandle Read FProcessHandle;
Property ProcessHandle : THandle Read FProcessHandle;
Property ThreadHandle : THandle Read FThreadHandle;
Property Output : TInputPipeStream Read FOutputStream;
Property ExitStatus : Integer Read GetExitStatus;
Published
property PipeBufferSize : cardinal read FPipeBufferSize write FPipeBufferSize default 1024;
Property Executable : String Read FExecutable Write FExecutable;
Property Parameters : TStrings Read FParameters Write SetParameters;
Property CurrentDirectory : String Read FCurrentDirectory Write FCurrentDirectory;
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 FillAttribute : Cardinal read FFillAttribute Write FFillAttribute;
end;
EProcess = Class(Exception);
function RunCommandIndir(const curdir: string; const exename: string; const commands: array of string; out outputstring: ansistring; out exitstatus:integer; Options : TProcessOptions = []):integer; overload; //L505
function RunCommand(const exename: string; const commands: array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean; overload;// L505
implementation
Resourcestring
SNoCommandLine = 'Cannot execute empty command-line';
SErrCannotExecute = 'Failed to execute %s : %d';
Const
PriorityConstants : Array [TProcessPriority] of Cardinal =
(HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS,
NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS);
piNonInheritablePipe : TSecurityAttributes = (
nlength:SizeOF(TSecurityAttributes);
lpSecurityDescriptor:Nil;
Binherithandle:False);
PipeBufSize = 1024;
type
PSecurityAttributes = ^TSecurityAttributes;
TSecurityAttributes = record
nLength : DWORD;
lpSecurityDescriptor : Pointer;
bInheritHandle : BOOL;
end;
Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = PipeBufSize) : Boolean;
begin
Result := CreatePipe(Inhandle,OutHandle,@piNonInheritablePipe,APipeBufferSize);
end;
procedure PipeClose(const FHandle: THandle);
begin
FileClose(FHandle);
end;
procedure TProcess.CloseProcessHandles;
begin
if (FProcessHandle<>0) then
CloseHandle(FProcessHandle);
if (FThreadHandle<>0) then
CloseHandle(FThreadHandle);
end;
Function TProcess.PeekExitStatus : Boolean;
begin
GetExitCodeProcess(ProcessHandle,FExitCode);
Result:=(FExitCode<>Still_Active);
end;
function GetStartupFlags (P : TProcess): Cardinal;
begin
With P do
begin
Result:=0;
if poUsePipes in FProcessOptions then
Result:=Result or Startf_UseStdHandles;
if suoUseShowWindow in FStartupOptions then
Result:=Result or startf_USESHOWWINDOW;
if suoUSESIZE in FStartupOptions then
Result:=Result or startf_usesize;
if suoUsePosition in FStartupOptions then
Result:=Result or startf_USEPOSITION;
if suoUSECOUNTCHARS in FStartupoptions then
Result:=Result or startf_usecountchars;
if suoUsefIllAttribute in FStartupOptions then
Result:=Result or startf_USEFILLATTRIBUTE;
end;
end;
function GetCreationFlags(P : TProcess) : Cardinal;
begin
With P do
begin
Result:=0;
if poNoConsole in FProcessOptions then
Result:=Result or Detached_Process;
if poNewConsole in FProcessOptions then
Result:=Result or Create_new_console;
if poNewProcessGroup in FProcessOptions then
Result:=Result or CREATE_NEW_PROCESS_GROUP;
If poRunSuspended in FProcessOptions Then
Result:=Result or Create_Suspended;
if poDebugProcess in FProcessOptions Then
Result:=Result or DEBUG_PROCESS;
if poDebugOnlyThisProcess in FProcessOptions Then
Result:=Result or DEBUG_ONLY_THIS_PROCESS;
if poDefaultErrorMode in FProcessOptions Then
Result:=Result or CREATE_DEFAULT_ERROR_MODE;
result:=result or PriorityConstants[FProcessPriority];
end;
end;
function StringsToPChars(List : TStrings): pointer;
var
EnvBlock, item: string;
I: Integer;
memsize: integer;
begin
EnvBlock := '';
For I:=0 to List.Count-1 do begin
item := List[i];
EnvBlock := EnvBlock + item + #0;
end;
EnvBlock := EnvBlock + #0;
memsize := Length(EnvBlock);
GetMem(Result, memsize);
CopyMemory(Result, @EnvBlock[1], memsize);
end;
procedure InitProcessAttributes(P : TProcess; Var PA : TSecurityAttributes);
begin
FillChar(PA,SizeOf(PA),0);
PA.nLength := SizeOf(PA);
end;
procedure InitThreadAttributes(P : TProcess; Var TA : TSecurityAttributes);
begin
FillChar(TA,SizeOf(TA),0);
TA.nLength := SizeOf(TA);
end;
procedure InitStartupInfo(P : TProcess; Var SI : STARTUPINFOW);
Const
SWC : Array [TShowWindowOptions] of Cardinal =
(0,SW_HIDE,SW_Maximize,SW_Minimize,SW_Restore,SW_Show,
SW_ShowDefault,SW_ShowMaximized,SW_ShowMinimized,
SW_showMinNOActive,SW_ShowNA,SW_ShowNoActivate,SW_ShowNormal);
begin
FillChar(SI,SizeOf(SI),0);
With SI do
begin
dwFlags:=GetStartupFlags(P);
if P.FShowWindow<>swoNone then
dwFlags:=dwFlags or Startf_UseShowWindow
else
dwFlags:=dwFlags and not Startf_UseShowWindow;
wShowWindow:=SWC[P.FShowWindow];
if (poUsePipes in P.Options) then
begin
dwFlags:=dwFlags or Startf_UseStdHandles;
end;
if P.FillAttribute<>0 then
begin
dwFlags:=dwFlags or Startf_UseFillAttribute;
dwFillAttribute:=P.FillAttribute;
end;
end;
end;
function DuplicateHandleFP(var handle: THandle): Boolean;
var
oldHandle: THandle;
begin
oldHandle := handle;
Result := DuplicateHandle
( GetCurrentProcess(),
oldHandle,
GetCurrentProcess(),
@handle,
0,
true,
DUPLICATE_SAME_ACCESS
);
if Result then
Result := CloseHandle(oldHandle);
end;
procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfoW; CE : Boolean; APipeBufferSize : Cardinal);
begin
CreatePipeHandles(SI.hStdInput,HI, APipeBufferSize);
DuplicateHandleFP(SI.hStdInput);
CreatePipeHandles(HO,Si.hStdOutput, APipeBufferSize);
DuplicateHandleFP(Si.hStdOutput);
if CE then begin
CreatePipeHandles(HE,SI.hStdError, APipeBufferSize);
DuplicateHandleFP( SI.hStdError);
end
else
begin
SI.hStdError:=SI.hStdOutput;
HE:=HO;
end;
end;
Function MaybeQuoteIfNotQuoted(Const S : String) : String;
begin
If (Pos(' ',S)<>0) and (pos('"',S)=0) then
Result:='"'+S+'"'
else
Result:=S;
end;
Procedure TProcess.Execute;
Var
i : Integer;
PCommandLine : PChar;
FCreationFlags : Cardinal;
FProcessAttributes : TSecurityAttributes;
FThreadAttributes : TSecurityAttributes;
FProcessInformation : TProcessInformation;
FStartupInfo : STARTUPINFOW;
HI,HO,HE : THandle;
Cmd : String;
begin
PCommandLine:= nil;
if (FApplicationName='') and (FCommandLine='') and (FExecutable='') then
Raise EProcess.Create(SNoCommandline);
if (FApplicationName<>'') then
begin
PCommandLine:=PChar(FCommandLine);
end
else If (FCommandLine<>'') then
PCommandLine:=PChar(FCommandLine)
else if (Fexecutable<>'') then
begin
Cmd:=MaybeQuoteIfNotQuoted(Executable);
For I:=0 to Parameters.Count-1 do
Cmd:=Cmd+' '+MaybeQuoteIfNotQuoted(Parameters[i]);
PCommandLine:=PChar(Cmd);
end;
FCreationFlags:=GetCreationFlags(Self);
InitProcessAttributes(Self,FProcessAttributes);
InitThreadAttributes(Self,FThreadAttributes);
InitStartupInfo(Self,FStartUpInfo);
If poUsePipes in FProcessOptions then begin
CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions), FPipeBufferSize);
end;
Try
If Not CreateProcess(nil,
PCommandLine,
@FProcessAttributes,
@FThreadAttributes,
True,
FCreationFlags,
nil,
nil,
FStartupInfo,
fProcessInformation) then
Raise EProcess.CreateFmt(SErrCannotExecute,[FCommandLine,GetLastError]);
FProcessHandle:=FProcessInformation.hProcess;
FThreadHandle:=FProcessInformation.hThread;
FProcessID:=FProcessINformation.dwProcessID;
Finally
if POUsePipes in FProcessOptions then
begin
FileClose(FStartupInfo.hStdInput);
FileClose(FStartupInfo.hStdOutput);
if Not (poStdErrToOutPut in FProcessOptions) then
FileClose(FStartupInfo.hStdError);
CreateStreams(HI,HO,HE);
end;
end;
FRunning:=True;
if not (csDesigning in ComponentState) and
(poWaitOnExit in FProcessOptions) and
not (poRunSuspended in FProcessOptions) then
WaitOnExit;
end;
Function TProcess.WaitOnExit : Boolean;
Var
R : DWord;
begin
R:=WaitForSingleObject (FProcessHandle,Infinite);
Result:=(R<>Wait_Failed);
If Result then
GetExitStatus;
FRunning:=False;
end;
Function TProcess.Suspend : Longint;
begin
Result:=SuspendThread(ThreadHandle);
end;
Function TProcess.Resume : LongInt;
begin
Result:=ResumeThread(ThreadHandle);
end;
Function TProcess.Terminate(AExitCode : Integer) : Boolean;
begin
Result:=False;
If ExitStatus=Still_active then
Result:=TerminateProcess(Handle,AexitCode);
end;
Procedure TProcess.SetShowWindow (Value : TShowWindowOptions);
begin
FShowWindow:=Value;
end;
Constructor TProcess.Create(AOwner : TComponent);
begin
Inherited;
FProcessPriority:=ppNormal;
FShowWindow:=swoNone;
FPipeBufferSize := 1024;
FEnvironment:=TStringList.Create;
FParameters:=TStringList.Create;
end;
Destructor TProcess.Destroy;
begin
FParameters.Free;
FEnvironment.Free;
FreeStreams;
CloseProcessHandles;
Inherited Destroy;
end;
Procedure TProcess.FreeStreams;
begin
If FStderrStream<>FOutputStream then
FreeStream(THandleStream(FStderrStream));
FreeStream(THandleStream(FOutputStream));
end;
Function TProcess.GetExitStatus: Integer;
begin
GetRunning;
Result:=FExitCode;
end;
function TProcess.GetRunning : Boolean;
begin
IF FRunning then
FRunning:=Not PeekExitStatus;
Result:=FRunning;
end;
procedure TProcess.CreateStreams(InHandle,OutHandle,ErrHandle : Longint);
begin
FreeStreams;
FOutputStream:=TInputPipeStream.Create (OutHandle);
if Not (poStderrToOutput in FProcessOptions) then
FStderrStream:=TInputPipeStream.Create(ErrHandle);
end;
procedure TProcess.FreeStream(var AStream: THandleStream);
begin
if AStream = nil then exit;
FreeAndNil(AStream);
end;
procedure TProcess.CloseOutput;
begin
FreeStream(THandleStream(FOutputStream));
end;
procedure TProcess.CloseStderr;
begin
FreeStream(THandleStream(FStderrStream));
end;
procedure TProcess.SetParameters(const AValue: TStrings);
begin
FParameters.Assign(AValue);
end;
procedure TProcess.SetProcessOptions(const Value: TProcessOptions);
begin
FProcessOptions := Value;
If poNewConsole in FProcessOptions then
Exclude(FProcessOptions,poNoConsole);
if poRunSuspended in FProcessOptions then
Exclude(FProcessOptions,poWaitOnExit);
end;
Const
READ_BYTES = 65536; // not too small to avoid fragmentation when reading large files.
function internalRuncommand(p:TProcess;out outputstring: ansistring;
out exitstatus:integer):integer;
var
numbytes,bytesread : integer;
begin
result:=0;
bytesread:=0;
try
p.Options := p.Options + [poUsePipes];
p.Execute;
while p.Running do
begin
Setlength(outputstring, READ_BYTES);
NumBytes := p.Output.Read(outputstring[1+bytesread], 255);
if NumBytes > 0 then
Inc(BytesRead, NumBytes);
end;
exitstatus:= p.exitstatus;
finally
p.free;
end;
end;
Const
ForbiddenOptions = [poRunSuspended,poWaitOnExit];
function RunCommandIndir(const curdir: string; const exename: string; const commands:array of string; out outputstring: ansistring;out exitstatus:integer; Options : TProcessOptions = []):integer;
Var
p : TProcess;
i : integer;
begin
p:=TProcess.create(nil);
if Options<>[] then
P.Options:=Options - ForbiddenOptions;
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]);
result:=internalruncommand(p,outputstring,exitstatus);
end;
function RunCommand(const exename:string; const commands:array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean;
Var
p : TProcess;
i,
exitstatus : integer;
begin
p:=TProcess.create(nil);
if Options<>[] then
P.Options:=Options - ForbiddenOptions;
p.Executable:=exename;
if high(commands)>=0 then
for i:=low(commands) to high(commands) do
p.Parameters.add(commands[i]);
result:=internalruncommand(p,outputstring,exitstatus)=0;
if exitstatus<>0 then result:=false;
end;
end.
)
