fpc/fcl/win32/process.inc
2000-07-25 11:27:34 +00:00

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
}