mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-02 02:36:12 +02:00
396 lines
11 KiB
PHP
396 lines
11 KiB
PHP
{
|
|
This file is part of the Free Component Library (FCL)
|
|
Copyright (c) 1999-2008 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.
|
|
|
|
**********************************************************************}
|
|
|
|
{$IFDEF FPC_DOTTEDUNITS}
|
|
Uses
|
|
WinApi.Windows;
|
|
{$ELSE}
|
|
Uses
|
|
Windows;
|
|
{$ENDIF}
|
|
|
|
const
|
|
SNoCommandLine = 'Cannot execute empty command-line';
|
|
SErrCannotExecute = 'Failed to execute %s : %d';
|
|
{ SErrNoSuchProgram = 'Executable not found: "%s"';
|
|
SErrNoTerminalProgram = 'Could not detect X-Terminal program';
|
|
}
|
|
|
|
Const
|
|
PriorityConstants : Array [TProcessPriority] of Cardinal =
|
|
(HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS,
|
|
NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS,
|
|
BELOW_NORMAL_PRIORITY_CLASS,ABOVE_NORMAL_PRIORITY_CLASS);
|
|
|
|
procedure TProcess.CloseProcessHandles;
|
|
begin
|
|
if (FProcessHandle<>0) then
|
|
CloseHandle(FProcessHandle);
|
|
if (FThreadHandle<>0) then
|
|
CloseHandle(FThreadHandle);
|
|
end;
|
|
|
|
Function TProcess.PeekExitStatus : Boolean;
|
|
begin
|
|
Result:=GetExitCodeProcess(ProcessHandle,FExitCode) and (FExitCode<>Still_Active);
|
|
// wait up to 10ms extra till process really done to get rest of input bug #39821
|
|
if not Result Then
|
|
WaitForSingleObject(FProcessHandle,10);
|
|
end;
|
|
|
|
Function GetStartupFlags (P : TProcess; AllDescriptorsDefault: Boolean): Cardinal;
|
|
|
|
begin
|
|
if AllDescriptorsDefault then
|
|
Result:= 0
|
|
else
|
|
Result:= Startf_UseStdHandles;
|
|
if suoUseShowWindow in P.StartupOptions then
|
|
Result:=Result or startf_USESHOWWINDOW;
|
|
if suoUSESIZE in P.StartupOptions then
|
|
Result:=Result or startf_usesize;
|
|
if suoUsePosition in P.StartupOptions then
|
|
Result:=Result or startf_USEPOSITION;
|
|
if suoUSECOUNTCHARS in P.Startupoptions then
|
|
Result:=Result or startf_usecountchars;
|
|
if suoUsefIllAttribute in P.StartupOptions then
|
|
Result:=Result or startf_USEFILLATTRIBUTE;
|
|
end;
|
|
|
|
Function GetCreationFlags(P : TProcess) : Cardinal;
|
|
|
|
begin
|
|
Result:=CREATE_UNICODE_ENVIRONMENT;
|
|
if poNoConsole in P.Options then
|
|
Result:=Result or CREATE_NO_WINDOW;
|
|
if poNewConsole in P.Options then
|
|
Result:=Result or Create_new_console;
|
|
if poNewProcessGroup in P.Options then
|
|
Result:=Result or CREATE_NEW_PROCESS_GROUP;
|
|
If poRunSuspended in P.Options Then
|
|
Result:=Result or Create_Suspended;
|
|
if poDebugProcess in P.Options Then
|
|
Result:=Result or DEBUG_PROCESS;
|
|
if poDebugOnlyThisProcess in P.Options Then
|
|
Result:=Result or DEBUG_ONLY_THIS_PROCESS;
|
|
if poDefaultErrorMode in P.Options Then
|
|
Result:=Result or CREATE_DEFAULT_ERROR_MODE;
|
|
if poDetached in P.Options Then
|
|
Result:=Result or DETACHED_PROCESS;
|
|
|
|
result:=result or PriorityConstants[P.FProcessPriority];
|
|
end;
|
|
|
|
function WStrAsUniquePWideChar(var s: UnicodeString): PWideChar;
|
|
begin
|
|
UniqueString(s);
|
|
if s<>'' then
|
|
Result:=PWideChar(s)
|
|
else
|
|
Result:=nil;
|
|
end;
|
|
|
|
Function StringsToWChars(List : TProcessStrings): pointer;
|
|
|
|
var
|
|
EnvBlock: UnicodeString;
|
|
I: Integer;
|
|
|
|
begin
|
|
EnvBlock := '';
|
|
For I:=0 to List.Count-1 do
|
|
EnvBlock := EnvBlock + List[i] + #0;
|
|
EnvBlock := EnvBlock + #0;
|
|
GetMem(Result, Length(EnvBlock)*2);
|
|
CopyMemory(Result, @EnvBlock[1], Length(EnvBlock)*2);
|
|
end;
|
|
|
|
Procedure InitProcessAttributes(P : TProcess; Out PA : TSecurityAttributes);
|
|
|
|
begin
|
|
FillChar(PA,SizeOf(PA),0);
|
|
PA.nLength := SizeOf(PA);
|
|
end;
|
|
|
|
Procedure InitThreadAttributes(P : TProcess; Out TA : TSecurityAttributes);
|
|
|
|
begin
|
|
FillChar(TA,SizeOf(TA),0);
|
|
TA.nLength := SizeOf(TA);
|
|
end;
|
|
|
|
Procedure InitStartupInfo(P : TProcess; AllDescriptorsDefault: Boolean; Out 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);
|
|
SI.cb:=SizeOf(SI);
|
|
SI.dwFlags:=GetStartupFlags(P, AllDescriptorsDefault);
|
|
if P.FShowWindow<>swoNone then
|
|
SI.dwFlags:=SI.dwFlags or Startf_UseShowWindow
|
|
else
|
|
SI.dwFlags:=SI.dwFlags and not Startf_UseShowWindow;
|
|
SI.wShowWindow:=SWC[P.FShowWindow];
|
|
if P.FillAttribute<>0 then
|
|
begin
|
|
SI.dwFlags:=SI.dwFlags or Startf_UseFillAttribute;
|
|
SI.dwFillAttribute:=P.FillAttribute;
|
|
end;
|
|
SI.dwXCountChars:=P.WindowColumns;
|
|
SI.dwYCountChars:=P.WindowRows;
|
|
SI.dwYsize:=P.WindowHeight;
|
|
SI.dwXsize:=P.WindowWidth;
|
|
SI.dwy:=P.WindowTop;
|
|
SI.dwX:=P.WindowLeft;
|
|
end;
|
|
|
|
Function MaybeQuoteIfNotQuoted(Const S : TProcessString) : TProcessString;
|
|
|
|
begin
|
|
If (Pos(' ',S)<>0) and (pos('"',S)=0) then
|
|
Result:='"'+S+'"'
|
|
else
|
|
Result:=S;
|
|
end;
|
|
|
|
|
|
Procedure TProcess.SysExecute;
|
|
Var
|
|
i : Integer;
|
|
WName,WDir,WCommandLine : UnicodeString;
|
|
PWName,PWDir,PWCommandLine : PWideChar;
|
|
FEnv: pointer;
|
|
FCreationFlags : Cardinal;
|
|
FProcessAttributes : TSecurityAttributes;
|
|
FThreadAttributes : TSecurityAttributes;
|
|
FProcessInformation : TProcessInformation;
|
|
FStartupInfo : STARTUPINFOW;
|
|
Cmd : TProcessString;
|
|
AllDescriptorsDefault: Boolean;
|
|
|
|
begin
|
|
fProcessInformation:=default(TProcessInformation);
|
|
AllDescriptorsDefault :=
|
|
(FDescriptors[phtInput].IOType = iotDefault) and
|
|
(FDescriptors[phtOutput].IOType = iotDefault) and
|
|
(FDescriptors[phtError].IOType = iotDefault) and
|
|
not (poStdErrToOutput in Options);
|
|
FDescriptors[phtInput].PrepareHandles;
|
|
FDescriptors[phtOutput].PrepareHandles;
|
|
if not (poStdErrToOutput in Options) then
|
|
FDescriptors[phtError].PrepareHandles;
|
|
WName:='';
|
|
WCommandLine:='';
|
|
WDir:='';
|
|
if (FApplicationName='') and (FCommandLine='') and (FExecutable='') then
|
|
Raise EProcess.Create(SNoCommandline);
|
|
if (FApplicationName<>'') then
|
|
begin
|
|
WName:=FApplicationName;
|
|
WCommandLine:=FCommandLine;
|
|
end
|
|
else If (FCommandLine<>'') then
|
|
WCommandLine:=FCommandLine
|
|
else if (FExecutable<>'') then
|
|
begin
|
|
Cmd:=MaybeQuoteIfNotQuoted(Executable);
|
|
For I:=0 to Parameters.Count-1 do
|
|
Cmd:=Cmd+' '+MaybeQuoteIfNotQuoted(Parameters[i]);
|
|
WCommandLine:=Cmd;
|
|
end;
|
|
If FCurrentDirectory<>'' then
|
|
WDir:=FCurrentDirectory;
|
|
if FEnvironment.Count<>0 then
|
|
FEnv:=StringsToWChars(FEnvironment)
|
|
else
|
|
FEnv:=Nil;
|
|
Try
|
|
FCreationFlags:=GetCreationFlags(Self);
|
|
InitProcessAttributes(Self,FProcessAttributes);
|
|
InitThreadAttributes(Self,FThreadAttributes);
|
|
InitStartupInfo(Self,AllDescriptorsDefault,FStartUpInfo);
|
|
if not AllDescriptorsDefault then
|
|
begin
|
|
FStartupInfo.hStdInput:=FDescriptors[phtInput].ResolveProcessHandle;
|
|
FStartupInfo.hStdOutput:=FDescriptors[phtOutput].ResolveProcessHandle;
|
|
if Not(poStdErrToOutPut in Options) then
|
|
FStartupInfo.hStdError:=FDescriptors[phtError].ResolveProcessHandle
|
|
else
|
|
FStartupInfo.hStdError:=FStartupInfo.hStdOutput;
|
|
end;
|
|
Try
|
|
// Beware: CreateProcess can alter the strings
|
|
// Beware: nil is not the same as a pointer to a #0
|
|
PWName:=WStrAsUniquePWideChar(WName);
|
|
PWCommandLine:=WStrAsUniquePWideChar(WCommandLine);
|
|
PWDir:=WStrAsUniquePWideChar(WDir);
|
|
If Not CreateProcessW (PWName,PWCommandLine,@FProcessAttributes,@FThreadAttributes,
|
|
FInheritHandles,FCreationFlags,FEnv,PWDir,FStartupInfo,
|
|
fProcessInformation) then
|
|
Raise EProcess.CreateFmt(SErrCannotExecute,[FCommandLine,GetLastError]);
|
|
FProcessHandle:=FProcessInformation.hProcess;
|
|
FThreadHandle:=FProcessInformation.hThread;
|
|
FThreadId:=FProcessInformation.dwThreadId;
|
|
FProcessID:=FProcessINformation.dwProcessID;
|
|
Finally
|
|
FDescriptors[phtInput].CloseTheirHandle;
|
|
FDescriptors[phtOutput].CloseTheirHandle;
|
|
if Not(poStdErrToOutPut in Options) then
|
|
FDescriptors[phtError].CloseTheirHandle;
|
|
end;
|
|
FRunning:=True;
|
|
Finally
|
|
If FEnv<>Nil then
|
|
FreeMem(FEnv);
|
|
end;
|
|
if not (csDesigning in ComponentState) and // This would hang the IDE !
|
|
(poWaitOnExit in Options) and
|
|
not (poRunSuspended in Options) 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.WaitOnExit(Timeout : DWord) : Boolean;
|
|
Var
|
|
R : DWord;
|
|
begin
|
|
R:=WaitForSingleObject (FProcessHandle,Timeout);
|
|
Result:=R=0;
|
|
If Result then
|
|
begin
|
|
GetExitStatus;
|
|
FRunning:=False;
|
|
end;
|
|
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;
|
|
|
|
Function TIODescriptor.SysCreateFileNameHandle(const aFileName: string) : THandle;
|
|
|
|
const
|
|
ModeNames : Array[Boolean] of String = ('Reading','Writing');
|
|
|
|
var
|
|
Sec: SECURITY_ATTRIBUTES;
|
|
|
|
begin
|
|
if (aFileName='') then
|
|
Raise EProcess.Create('No filename set');
|
|
Sec:=Default(SECURITY_ATTRIBUTES);
|
|
sec.nLength := SizeOf(Sec);
|
|
sec.bInheritHandle := True;
|
|
case ProcessHandleType of
|
|
phtInput: Result:=CreateFileW(PWideChar(WideString(aFileName)), GENERIC_READ,
|
|
FILE_SHARE_READ, @sec, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
|
|
phtOutput,
|
|
phtError:
|
|
begin
|
|
Result:=CreateFileW(PWideChar(WideString(aFileName)), GENERIC_WRITE,
|
|
FILE_SHARE_READ, @sec, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
|
|
if not(Result=INVALID_HANDLE_VALUE) then
|
|
FileSeek(Result, 0, 2);
|
|
end;
|
|
end;
|
|
if (Result=INVALID_HANDLE_VALUE) then
|
|
Raise EProcess.CreateFmt('Could not open file "%s" for %s',[aFileName,ModeNames[ProcessHandleType<>phtInput]]);
|
|
end;
|
|
|
|
|
|
|
|
function TIODescriptor.SysPrepareCreatedHandleForProcess(aHandle: THandle): THandle;
|
|
|
|
var
|
|
oldHandle: THandle;
|
|
Res : Boolean;
|
|
|
|
begin
|
|
if (IOType in [iotDefault,iotFile]) or ((IOType=iotHandle) and FCustomHandleIsInheritable) then
|
|
begin
|
|
Result:=aHandle;
|
|
exit;
|
|
end;
|
|
oldHandle := ahandle;
|
|
ahandle:=THandle(INVALID_HANDLE_VALUE);
|
|
Res := DuplicateHandle
|
|
( GetCurrentProcess(),
|
|
oldHandle,
|
|
GetCurrentProcess(),
|
|
@aHandle,
|
|
0,
|
|
true,
|
|
DUPLICATE_SAME_ACCESS
|
|
);
|
|
if Res then begin
|
|
// Either AutoCloseCustomHandle or set in OnGetHandle
|
|
if (IOType=iotHandle) and not FCloseHandleOnExecute then
|
|
FCloseHandleOnExecute:=True // the original CustomHandle is kept open / Set True for the duplicate handle
|
|
else
|
|
Res:=CloseHandle(oldHandle);
|
|
end;
|
|
if not Res then
|
|
begin
|
|
FileClose(aHandle);
|
|
Raise EProcess.CreateFmt('Could not make handle %d inheritable',[aHandle]);
|
|
end;
|
|
Result:=aHandle;
|
|
end;
|
|
|
|
function TIODescriptor.SysNullFileName: string;
|
|
begin
|
|
result:='NULL';
|
|
end;
|
|
|
|
function TIODescriptor.SysIsTypeSupported(AValue: TIOType): Boolean;
|
|
begin
|
|
Result:=True;
|
|
end;
|