1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 1999-2008 by the Free Pascal development team 4 5 See the file COPYING.FPC, included in this distribution, 6 for details about the copyright. 7 8 This program is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 12 **********************************************************************} 13 14Uses 15 Windows; 16 17 18Resourcestring 19 SNoCommandLine = 'Cannot execute empty command-line'; 20 SErrCannotExecute = 'Failed to execute %s : %d'; 21{ SErrNoSuchProgram = 'Executable not found: "%s"'; 22 SErrNoTerminalProgram = 'Could not detect X-Terminal program'; 23} 24 25Const 26 PriorityConstants : Array [TProcessPriority] of Cardinal = 27 (HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS, 28 NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS, 29 BELOW_NORMAL_PRIORITY_CLASS,ABOVE_NORMAL_PRIORITY_CLASS); 30 31procedure TProcessnamemacro.CloseProcessHandles; 32begin 33 if (FProcessHandle<>0) then 34 CloseHandle(FProcessHandle); 35 if (FThreadHandle<>0) then 36 CloseHandle(FThreadHandle); 37end; 38 39Function TProcessnamemacro.PeekExitStatus : Boolean; 40begin 41 Result:=GetExitCodeProcess(ProcessHandle,FExitCode) and (FExitCode<>Still_Active); 42end; 43 44Function GetStartupFlags (P : TProcessnamemacro): Cardinal; 45 46begin 47 Result:=0; 48 if poUsePipes in P.Options then 49 Result:=Result or Startf_UseStdHandles; 50 if suoUseShowWindow in P.StartupOptions then 51 Result:=Result or startf_USESHOWWINDOW; 52 if suoUSESIZE in P.StartupOptions then 53 Result:=Result or startf_usesize; 54 if suoUsePosition in P.StartupOptions then 55 Result:=Result or startf_USEPOSITION; 56 if suoUSECOUNTCHARS in P.Startupoptions then 57 Result:=Result or startf_usecountchars; 58 if suoUsefIllAttribute in P.StartupOptions then 59 Result:=Result or startf_USEFILLATTRIBUTE; 60end; 61 62Function GetCreationFlags(P : TProcessnamemacro) : Cardinal; 63 64begin 65 Result:=CREATE_UNICODE_ENVIRONMENT; 66 if poNoConsole in P.Options then 67 Result:=Result or CREATE_NO_WINDOW; 68 if poNewConsole in P.Options then 69 Result:=Result or Create_new_console; 70 if poNewProcessGroup in P.Options then 71 Result:=Result or CREATE_NEW_PROCESS_GROUP; 72 If poRunSuspended in P.Options Then 73 Result:=Result or Create_Suspended; 74 if poDebugProcess in P.Options Then 75 Result:=Result or DEBUG_PROCESS; 76 if poDebugOnlyThisProcess in P.Options Then 77 Result:=Result or DEBUG_ONLY_THIS_PROCESS; 78 if poDefaultErrorMode in P.Options Then 79 Result:=Result or CREATE_DEFAULT_ERROR_MODE; 80 if poDetached in P.Options Then 81 Result:=Result or DETACHED_PROCESS; 82 83 result:=result or PriorityConstants[P.FProcessPriority]; 84end; 85 86function WStrAsUniquePWideChar(var s: UnicodeString): PWideChar; 87begin 88 UniqueString(s); 89 if s<>'' then 90 Result:=PWideChar(s) 91 else 92 Result:=nil; 93end; 94 95Function StringsToWChars(List : TProcessStrings): pointer; 96 97var 98 EnvBlock: UnicodeString; 99 I: Integer; 100 101begin 102 EnvBlock := ''; 103 For I:=0 to List.Count-1 do 104 EnvBlock := EnvBlock + List[i] + #0; 105 EnvBlock := EnvBlock + #0; 106 GetMem(Result, Length(EnvBlock)*2); 107 CopyMemory(Result, @EnvBlock[1], Length(EnvBlock)*2); 108end; 109 110Procedure InitProcessAttributes(P : TProcessnamemacro; Var PA : TSecurityAttributes); 111 112begin 113 FillChar(PA,SizeOf(PA),0); 114 PA.nLength := SizeOf(PA); 115end; 116 117Procedure InitThreadAttributes(P : TProcessnamemacro; Var TA : TSecurityAttributes); 118 119begin 120 FillChar(TA,SizeOf(TA),0); 121 TA.nLength := SizeOf(TA); 122end; 123 124Procedure InitStartupInfo(P : TProcessnamemacro; Var SI : STARTUPINFOW); 125 126Const 127 SWC : Array [TShowWindowOptions] of Cardinal = 128 (0,SW_HIDE,SW_Maximize,SW_Minimize,SW_Restore,SW_Show, 129 SW_ShowDefault,SW_ShowMaximized,SW_ShowMinimized, 130 SW_showMinNOActive,SW_ShowNA,SW_ShowNoActivate,SW_ShowNormal); 131 132begin 133 FillChar(SI,SizeOf(SI),0); 134 SI.cb:=SizeOf(SI); 135 SI.dwFlags:=GetStartupFlags(P); 136 if P.FShowWindow<>swoNone then 137 SI.dwFlags:=SI.dwFlags or Startf_UseShowWindow 138 else 139 SI.dwFlags:=SI.dwFlags and not Startf_UseShowWindow; 140 SI.wShowWindow:=SWC[P.FShowWindow]; 141 if (poUsePipes in P.Options) then 142 begin 143 SI.dwFlags:=SI.dwFlags or Startf_UseStdHandles; 144 end; 145 if P.FillAttribute<>0 then 146 begin 147 SI.dwFlags:=SI.dwFlags or Startf_UseFillAttribute; 148 SI.dwFillAttribute:=P.FillAttribute; 149 end; 150 SI.dwXCountChars:=P.WindowColumns; 151 SI.dwYCountChars:=P.WindowRows; 152 SI.dwYsize:=P.WindowHeight; 153 SI.dwXsize:=P.WindowWidth; 154 SI.dwy:=P.WindowTop; 155 SI.dwX:=P.WindowLeft; 156end; 157 158{ The handles that are to be passed to the child process must be 159 inheritable. On the other hand, only non-inheritable handles 160 allow the sending of EOF when the write-end is closed. This 161 function is used to duplicate the child process's ends of the 162 handles into inheritable ones, leaving the parent-side handles 163 non-inheritable. 164} 165function DuplicateHandleFP(var handle: THandle): Boolean; 166 167var 168 oldHandle: THandle; 169begin 170 oldHandle := handle; 171 Result := DuplicateHandle 172 ( GetCurrentProcess(), 173 oldHandle, 174 GetCurrentProcess(), 175 @handle, 176 0, 177 true, 178 DUPLICATE_SAME_ACCESS 179 ); 180 if Result then 181 Result := CloseHandle(oldHandle); 182end; 183 184 185Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfoW; CI, CE : Boolean; APipeBufferSize : Cardinal); 186 187begin 188 if CI then 189 begin 190 CreatePipeHandles(SI.hStdInput,HI, APipeBufferSize); 191 DuplicateHandleFP(SI.hStdInput); 192 end 193 else 194 begin 195 SI.hStdInput:=StdInputHandle; 196 end; 197 CreatePipeHandles(HO,Si.hStdOutput, APipeBufferSize); 198 DuplicateHandleFP( Si.hStdOutput); 199 if CE then begin 200 CreatePipeHandles(HE,SI.hStdError, APipeBufferSize); 201 DuplicateHandleFP( SI.hStdError); 202 end 203 else 204 begin 205 SI.hStdError:=SI.hStdOutput; 206 HE:=HO; 207 end; 208end; 209 210{Function MaybeQuote(Const S : String) : String; 211 212begin 213 If (Pos(' ',S)<>0) then 214 Result:='"'+S+'"' 215 else 216 Result:=S; 217end; 218} 219Function MaybeQuoteIfNotQuoted(Const S : TProcessString) : TProcessString; 220 221begin 222 If (Pos(' ',S)<>0) and (pos('"',S)=0) then 223 Result:='"'+S+'"' 224 else 225 Result:=S; 226end; 227 228 229Procedure TProcessnamemacro.Execute; 230Var 231 i : Integer; 232 WName,WDir,WCommandLine : UnicodeString; 233 PWName,PWDir,PWCommandLine : PWideChar; 234 FEnv: pointer; 235 FCreationFlags : Cardinal; 236 FProcessAttributes : TSecurityAttributes; 237 FThreadAttributes : TSecurityAttributes; 238 FProcessInformation : TProcessInformation; 239 FStartupInfo : STARTUPINFOW; 240 HI,HO,HE : THandle; 241 Cmd : TProcessString; 242 243 begin 244 WName:=''; 245 WCommandLine:=''; 246 WDir:=''; 247 if (FApplicationName='') and (FCommandLine='') and (FExecutable='') then 248 Raise EProcess.Create(SNoCommandline); 249 if (FApplicationName<>'') then 250 begin 251 WName:=FApplicationName; 252 WCommandLine:=FCommandLine; 253 end 254 else If (FCommandLine<>'') then 255 WCommandLine:=FCommandLine 256 else if (FExecutable<>'') then 257 begin 258 Cmd:=MaybeQuoteIfNotQuoted(Executable); 259 For I:=0 to Parameters.Count-1 do 260 Cmd:=Cmd+' '+MaybeQuoteIfNotQuoted(Parameters[i]); 261 WCommandLine:=Cmd; 262 end; 263 If FCurrentDirectory<>'' then 264 WDir:=FCurrentDirectory; 265 if FEnvironment.Count<>0 then 266 FEnv:=StringsToWChars(FEnvironment) 267 else 268 FEnv:=Nil; 269 Try 270 FCreationFlags:=GetCreationFlags(Self); 271 InitProcessAttributes(Self,FProcessAttributes); 272 InitThreadAttributes(Self,FThreadAttributes); 273 InitStartupInfo(Self,FStartUpInfo); 274 If poUsePipes in Options then 275 CreatePipes(HI,HO,HE,FStartupInfo,Not(poPassInput in Options), Not(poStdErrToOutPut in Options), FPipeBufferSize); 276 Try 277 // Beware: CreateProcess can alter the strings 278 // Beware: nil is not the same as a pointer to a #0 279 PWName:=WStrAsUniquePWideChar(WName); 280 PWCommandLine:=WStrAsUniquePWideChar(WCommandLine); 281 PWDir:=WStrAsUniquePWideChar(WDir); 282 If Not CreateProcessW (PWName,PWCommandLine,@FProcessAttributes,@FThreadAttributes, 283 FInheritHandles,FCreationFlags,FEnv,PWDir,FStartupInfo, 284 fProcessInformation) then 285 Raise EProcess.CreateFmt(SErrCannotExecute,[FCommandLine,GetLastError]); 286 FProcessHandle:=FProcessInformation.hProcess; 287 FThreadHandle:=FProcessInformation.hThread; 288 FThreadId:=FProcessInformation.dwThreadId; 289 FProcessID:=FProcessINformation.dwProcessID; 290 Finally 291 if POUsePipes in Options then 292 begin 293 if not (poPassInput in Options) then 294 FileClose(FStartupInfo.hStdInput); 295 FileClose(FStartupInfo.hStdOutput); 296 if Not (poStdErrToOutPut in Options) then 297 FileClose(FStartupInfo.hStdError); 298 CreateStreams(HI,HO,HE); 299 end; 300 end; 301 FRunning:=True; 302 Finally 303 If FEnv<>Nil then 304 FreeMem(FEnv); 305 end; 306 if not (csDesigning in ComponentState) and // This would hang the IDE ! 307 (poWaitOnExit in Options) and 308 not (poRunSuspended in Options) then 309 WaitOnExit; 310end; 311 312Function TProcessnamemacro.WaitOnExit : Boolean; 313Var 314 R : DWord; 315begin 316 R:=WaitForSingleObject (FProcessHandle,Infinite); 317 Result:=(R<>Wait_Failed); 318 If Result then 319 GetExitStatus; 320 FRunning:=False; 321end; 322 323Function TProcessnamemacro.WaitOnExit(Timeout : DWord) : Boolean; 324Var 325 R : DWord; 326begin 327 R:=WaitForSingleObject (FProcessHandle,Timeout); 328 Result:=R=0; 329 If Result then 330 begin 331 GetExitStatus; 332 FRunning:=False; 333 end; 334end; 335 336Function TProcessnamemacro.Suspend : Longint; 337 338begin 339 Result:=SuspendThread(ThreadHandle); 340end; 341 342Function TProcessnamemacro.Resume : LongInt; 343 344begin 345 Result:=ResumeThread(ThreadHandle); 346end; 347 348Function TProcessnamemacro.Terminate(AExitCode : Integer) : Boolean; 349 350begin 351 Result:=False; 352 If ExitStatus=Still_active then 353 Result:=TerminateProcess(Handle,AexitCode); 354end; 355 356Procedure TProcessnamemacro.SetShowWindow (Value : TShowWindowOptions); 357 358begin 359 FShowWindow:=Value; 360end; 361