mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-07-23 02:36:16 +02:00
147 lines
3.9 KiB
PHP
147 lines
3.9 KiB
PHP
uses windows;
|
|
|
|
Function TProcess.GetRunning : Boolean;
|
|
|
|
begin
|
|
IF FRunning then
|
|
Frunning:=GetExitStatus=Still_Active;
|
|
Result:=FRunning;
|
|
end;
|
|
|
|
Procedure TProcess.Execute;
|
|
|
|
Var PName,PDir : PChar;
|
|
FStartupInfo : TStartupInfo;
|
|
FProcessAttributes,
|
|
FTHreadAttributes : TSecurityAttributes;
|
|
FProcessInformation : TProcessInformation;
|
|
status : longbool;
|
|
|
|
begin
|
|
FillChar(FProcessAttributes,SizeOf(FProcessAttributes),#0);
|
|
FillChar(FThreadAttributes,SizeOf(FThreadAttributes),#0);
|
|
FillChar(FStartupInfo,SizeOf(FStartupInfo),#0);
|
|
if poNoConsole in FCReateOptions then
|
|
FCreationFlags:=FCreationFlags or Detached_Process;
|
|
If poRunSuspended in FCreateOptions Then
|
|
FCreationFlags:=FCreationFlags or Create_Suspended;
|
|
If poUsePipes in FCreateOptions then
|
|
begin
|
|
FreeStreams;
|
|
CreatePipeStreams (FChildInputSTream,FParentOutPutStream);
|
|
CreatePipeStreams (FParentInputStream,FChildOutPutStream);
|
|
if poStdErrToOutPut in FCreateOptions then
|
|
CreatePipeStreams (FParentErrorStream,FChildErrorStream)
|
|
else
|
|
begin
|
|
FChildErrorStream:=FChildOutPutStream;
|
|
FParentErrorStream:=FParentInputStream;
|
|
end;
|
|
end;
|
|
With FStartupInfo do
|
|
begin
|
|
if poUsePipes in FCreateOptions then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UseStdHandles;
|
|
hStdInput:=FChildInputStream.Handle;
|
|
hStdOutput:=FChildOutPutStream.Handle;
|
|
hStdError:=FChildErrorStream.Handle;
|
|
end;
|
|
If (FFillAttribute<>-1) then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UseFillAttribute;
|
|
dwFillAttribute:=FFIllAttribute;
|
|
end;
|
|
If FShowWindow then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UseShowWindow;
|
|
// ?? dwXCountChars:=Value;
|
|
end;
|
|
if FWindowWidth<>-1 then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UseCountChars;
|
|
dwXCountChars:=FWindowWidth;
|
|
end;
|
|
if FWindowRows<>-1 then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UseCountChars;
|
|
dwYCountChars:=FWindowRows;
|
|
end;
|
|
if FWindowHeight<>-1 then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UsePosition;
|
|
dwYsize:=FWindowHeight;
|
|
end;
|
|
If FWindowWidth<>-1 then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UsePosition;
|
|
dwxsize:=FWindowWidth;
|
|
end;
|
|
IF FWindowLeft<>-1 then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UseSize;
|
|
dwx:=FWindowLeft;
|
|
end;
|
|
If FWindowTop<>-1 then
|
|
begin
|
|
dwFlags:=dwFlags or Startf_UseSize;
|
|
dwy:=FWindowTop;
|
|
end;
|
|
end;
|
|
Writeln ('About to start');
|
|
If FApplicationName<>'' then PName:=Pchar(FApplicationName) else PName:=Nil;
|
|
If FCurrentDirectory<>'' then PName:=Pchar(FCurrentDirectory) else PDir:=Nil;
|
|
Status:=CreateProcess (Pname,PChar(FCommandLine),@FProcessAttributes,@FThreadAttributes,
|
|
FInheritHandles,FCreationFlags,FEnvironment,PDir,@FStartupInfo,
|
|
@fProcessInformation);
|
|
Writeln ('Created ',Status);
|
|
FTHreadHandle:=fProcessInformation.hthread;
|
|
Writeln ('ThreadHandle :',FThreadHandle);
|
|
FHandle:=fProcessInformation.hProcess;
|
|
Writeln ('Process Handle :',FHandle);
|
|
FPID:=fProcessInformation.dwProcessID;
|
|
Writeln ('Process Handle :',FPID);
|
|
FRunning:=True;
|
|
if (poWaitOnExit in FCreateOptions) and
|
|
not (poRunSuspended in FCreateOptions) then
|
|
WaitOnExit;
|
|
end;
|
|
|
|
Function TProcess.WaitOnExit : Dword;
|
|
|
|
begin
|
|
Result:=WaitForSingleObject (FHandle,Infinite);
|
|
If Result<>Wait_Failed 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;
|
|
{
|
|
$Log$
|
|
Revision 1.3 2000-07-25 11:27:35 jonas
|
|
* fixed missing comment openers for log section
|
|
|
|
Revision 1.2 2000/07/13 11:33:07 michael
|
|
+ removed logs
|
|
|
|
}
|