1{ 2 ***************************************************************************** 3 This file is part of LazUtils. 4 5 See the file COPYING.modifiedLGPL.txt, included in this distribution, 6 for details about the license. 7 ***************************************************************************** 8 9 Initial Revision : Tue Dec 06 09:00:00 CET 2005 10} 11 12unit UTF8Process; 13 14{$mode objfpc}{$H+} 15 16interface 17 18uses 19 Classes, SysUtils, Process, 20 FileUtil, LazFileUtils, LazUTF8, LazUtilsStrConsts; 21 22 {$IF DEFINED(MSWINDOWS) AND NOT DECLARED(poDetached)} // we need to work around the poNoConsole->poDetached change 23 // more info: issue #32055, #35991; FPC r45228, https://forum.lazarus.freepascal.org/index.php/topic,49631.0 24 {$DEFINE UseTProcessW} 25 {$ENDIF} 26 27{ TProcessUTF8 } 28 29{$IFDEF UseTProcessW} 30{$Optimization -ORDERFIELDS } 31const 32 SNoCommandLine = 'Cannot execute empty command-line'; 33 SErrCannotExecute = 'Failed to execute %s : %d'; 34type 35 TProcessUTF8 = class(TProcess) 36 protected 37 procedure SetProcessHandle(aProcessHandle : THandle); 38 procedure SetThreadHandle(aThreadHandle : THandle); 39 procedure SetProcessID(aProcessID : Integer); 40 public 41 procedure Execute; override; 42 procedure ParseCmdLine(const CmdLine: string; ReadBackslash: boolean = false); 43 end; 44 45{$ELSE} 46 47type 48 TProcessUTF8 = class(TProcess) 49 public 50 procedure ParseCmdLine(const CmdLine: string; ReadBackslash: boolean = false); 51 end; 52{$ENDIF} 53 54procedure RunCmdFromPath(ProgramFilename, CmdLineParameters: string); 55function FindFilenameOfCmd(ProgramFilename: string): string; 56 57function GetSystemThreadCount: integer; // guess number of cores 58 59procedure Register; 60 61implementation 62 63{$IF defined(windows)} 64uses Windows 65 {$IFDEF UseTProcessW} 66 ,pipes 67 {$ENDIF} 68; 69{$ELSEIF defined(freebsd) or defined(darwin)} 70uses ctypes, sysctl; 71{$ELSEIF defined(linux)} 72{$linklib c} 73uses ctypes; 74{$ENDIF} 75 76{$IFDEF Linux} 77const _SC_NPROCESSORS_ONLN = 83; 78function sysconf(i: cint): clong; cdecl; external name 'sysconf'; 79{$ENDIF} 80 81function GetSystemThreadCount: integer; 82// returns a good default for the number of threads on this system 83{$IF defined(windows)} 84//returns total number of processors available to system including logical hyperthreaded processors 85var 86 SystemInfo: SYSTEM_INFO; 87 {$IFnDEF WinCE} 88 i: Integer; 89 ProcessAffinityMask, SystemAffinityMask: DWORD_PTR; 90 Mask: DWORD; 91 {$ENDIF} 92begin 93 {$IFnDEF WinCE} 94 if GetProcessAffinityMask(GetCurrentProcess, ProcessAffinityMask{%H-}, SystemAffinityMask{%H-}) 95 then begin 96 Result := 0; 97 for i := 0 to 31 do begin 98 Mask := DWord(1) shl i; 99 if (ProcessAffinityMask and Mask)<>0 then 100 inc(Result); 101 end; 102 exit; 103 end; 104 {$ENDIF} 105 //can't get the affinity mask so we just report the total number of processors 106 GetSystemInfo(SystemInfo{%H-}); 107 Result := SystemInfo.dwNumberOfProcessors; 108end; 109{$ELSEIF defined(UNTESTEDsolaris)} 110 begin 111 t = sysconf(_SC_NPROC_ONLN); 112 end; 113{$ELSEIF defined(freebsd) or defined(darwin)} 114var 115 mib: array[0..1] of cint; 116 len: cint; 117 t: cint; 118begin 119 mib[0] := CTL_HW; 120 mib[1] := HW_NCPU; 121 len := sizeof(t); 122 {$if FPC_FULLVERSION >= 30101} 123 fpsysctl(@mib, 2, @t, @len, Nil, 0); 124 {$else} 125 fpsysctl(pchar(@mib), 2, @t, @len, Nil, 0); 126 {$endif} 127 Result:=t; 128end; 129{$ELSEIF defined(linux)} 130 begin 131 Result:=sysconf(_SC_NPROCESSORS_ONLN); 132 end; 133 134{$ELSE} 135 begin 136 Result:=1; 137 end; 138{$ENDIF} 139 140function FindFilenameOfCmd(ProgramFilename: string): string; 141begin 142 Result:=TrimFilename(ProgramFilename); 143 if not FilenameIsAbsolute(Result) then begin 144 if Pos(PathDelim,Result)>0 then begin 145 // with sub directory => relative to current directory 146 Result:=CleanAndExpandFilename(Result); 147 end else begin 148 // search in PATH 149 Result:=FindDefaultExecutablePath(Result); 150 end; 151 end; 152 if (Result<>'') and not FileExistsUTF8(Result) then 153 Result:=''; 154end; 155 156// Runs a short command which should point to an executable in 157// the environment PATH 158// For example: ProgramFilename=ls CmdLineParameters=-l /home 159// Will locate and execute the file /bin/ls 160// If the command isn't found, an exception will be raised 161procedure RunCmdFromPath(ProgramFilename, CmdLineParameters: string); 162var 163 OldProgramFilename: String; 164 BrowserProcess: TProcessUTF8; 165begin 166 OldProgramFilename:=ProgramFilename; 167 ProgramFilename:=FindFilenameOfCmd(ProgramFilename); 168 169 if ProgramFilename='' then 170 raise EFOpenError.Create(Format(lrsProgramFileNotFound, [OldProgramFilename])); 171 if not FileIsExecutable(ProgramFilename) then 172 raise EFOpenError.Create(Format(lrsCanNotExecute, [ProgramFilename])); 173 174 // run 175 BrowserProcess := TProcessUTF8.Create(nil); 176 try 177 BrowserProcess.InheritHandles:=false; 178 // Encloses the executable with "" if its name has spaces 179 if Pos(' ',ProgramFilename)>0 then 180 ProgramFilename:='"'+ProgramFilename+'"'; 181 182 {$Push} 183 {$WARN SYMBOL_DEPRECATED OFF} 184 BrowserProcess.CommandLine := ProgramFilename; 185 if CmdLineParameters<>'' then 186 BrowserProcess.CommandLine := BrowserProcess.CommandLine + ' ' + CmdLineParameters; 187 {$Pop} 188 BrowserProcess.Execute; 189 finally 190 BrowserProcess.Free; 191 end; 192end; 193 194procedure Register; 195begin 196 RegisterComponents('System',[TProcessUTF8]); 197end; 198 199{$IFDEF UseTProcessW} 200Const 201 PriorityConstants : Array [TProcessPriority] of Cardinal = 202 (HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS, 203 NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS 204 {$if (FPC_FULLVERSION >= 30200) and not defined(WinCE)} 205 ,BELOW_NORMAL_PRIORITY_CLASS,ABOVE_NORMAL_PRIORITY_CLASS 206 {$endif} 207 ); 208 209function WStrAsUniquePWideChar(var s: UnicodeString): PWideChar; inline; 210begin 211 UniqueString(s); 212 if s<>'' then 213 Result:=PWideChar(s) 214 else 215 Result:=nil; 216end; 217 218Function GetStartupFlags (P : TProcessUTF8): Cardinal; 219 220begin 221 Result:=0; 222 if poUsePipes in P.Options then 223 Result:=Result or Startf_UseStdHandles; 224 if suoUseShowWindow in P.StartupOptions then 225 Result:=Result or startf_USESHOWWINDOW; 226 if suoUSESIZE in P.StartupOptions then 227 Result:=Result or startf_usesize; 228 if suoUsePosition in P.StartupOptions then 229 Result:=Result or startf_USEPOSITION; 230 if suoUSECOUNTCHARS in P.Startupoptions then 231 Result:=Result or startf_usecountchars; 232 if suoUsefIllAttribute in P.StartupOptions then 233 Result:=Result or startf_USEFILLATTRIBUTE; 234end; 235 236Function GetCreationFlags(P : TProcessUTF8) : Cardinal; 237 238begin 239 Result:=CREATE_UNICODE_ENVIRONMENT; 240 {$IF DECLARED(poDetached)} 241 if poNoConsole in P.Options then 242 Result:=Result or CREATE_NO_WINDOW; 243 if poDetached in P.Options then 244 Result:=Result or Detached_Process; 245 {$ELSE} 246 if poNoConsole in P.Options then 247 Result:=Result or Detached_Process; 248 {$ENDIF} 249 if poNewConsole in P.Options then 250 Result:=Result or Create_new_console; 251 if poNewProcessGroup in P.Options then 252 Result:=Result or CREATE_NEW_PROCESS_GROUP; 253 If poRunSuspended in P.Options Then 254 Result:=Result or Create_Suspended; 255 if poDebugProcess in P.Options Then 256 Result:=Result or DEBUG_PROCESS; 257 if poDebugOnlyThisProcess in P.Options Then 258 Result:=Result or DEBUG_ONLY_THIS_PROCESS; 259 if poDefaultErrorMode in P.Options Then 260 Result:=Result or CREATE_DEFAULT_ERROR_MODE; 261 result:=result or PriorityConstants[P.Priority]; 262end; 263 264Function MaybeQuote(Const S : String) : String; 265 266begin 267 If (Pos(' ',S)<>0) then 268 Result:='"'+S+'"' 269 else 270 Result:=S; 271end; 272 273Function MaybeQuoteIfNotQuoted(Const S : String) : String; 274 275begin 276 If (Pos(' ',S)<>0) and (pos('"',S)=0) then 277 Result:='"'+S+'"' 278 else 279 Result:=S; 280end; 281 282Function StringsToWChars(List : TStrings): pointer; 283 284var 285 EnvBlock: UnicodeString; 286 I: Integer; 287 288begin 289 EnvBlock := ''; 290 For I:=0 to List.Count-1 do 291 EnvBlock := EnvBlock + UTF8Decode(List[i]) + #0; 292 EnvBlock := EnvBlock + #0; 293 GetMem(Result, Length(EnvBlock)*2); 294 CopyMemory(Result, @EnvBlock[1], Length(EnvBlock)*2); 295end; 296 297Procedure InitProcessAttributes(Out PA : TSecurityAttributes); 298 299begin 300 FillChar(PA{%H-},SizeOf(PA),0); 301 PA.nLength := SizeOf(PA); 302end; 303 304Procedure InitThreadAttributes(Out TA : TSecurityAttributes); 305 306begin 307 FillChar(TA{%H-},SizeOf(TA),0); 308 TA.nLength := SizeOf(TA); 309end; 310 311Procedure InitStartupInfo(P : TProcessUTF8; Out SI : STARTUPINFOW); 312 313Const 314 SWC : Array [TShowWindowOptions] of Cardinal = 315 (0,SW_HIDE,SW_Maximize,SW_Minimize,SW_Restore,SW_Show, 316 SW_ShowDefault,SW_ShowMaximized,SW_ShowMinimized, 317 SW_showMinNOActive,SW_ShowNA,SW_ShowNoActivate,SW_ShowNormal); 318 319begin 320 FillChar(SI{%H-},SizeOf(SI),0); 321 SI.dwFlags:=GetStartupFlags(P); 322 if P.ShowWindow<>swoNone then 323 SI.dwFlags:=SI.dwFlags or Startf_UseShowWindow 324 else 325 SI.dwFlags:=SI.dwFlags and not Startf_UseShowWindow; 326 SI.wShowWindow:=SWC[P.ShowWindow]; 327 if (poUsePipes in P.Options) then 328 begin 329 SI.dwFlags:=SI.dwFlags or Startf_UseStdHandles; 330 end; 331 if P.FillAttribute<>0 then 332 begin 333 SI.dwFlags:=SI.dwFlags or Startf_UseFillAttribute; 334 SI.dwFillAttribute:=P.FillAttribute; 335 end; 336 SI.dwXCountChars:=P.WindowColumns; 337 SI.dwYCountChars:=P.WindowRows; 338 SI.dwYsize:=P.WindowHeight; 339 SI.dwXsize:=P.WindowWidth; 340 SI.dwy:=P.WindowTop; 341 SI.dwX:=P.WindowLeft; 342end; 343 344{ The handles that are to be passed to the child process must be 345 inheritable. On the other hand, only non-inheritable handles 346 allow the sending of EOF when the write-end is closed. This 347 function is used to duplicate the child process's ends of the 348 handles into inheritable ones, leaving the parent-side handles 349 non-inheritable. 350} 351function DuplicateHandleFP(var handle: THandle): Boolean; 352 353var 354 oldHandle: THandle; 355begin 356 oldHandle := handle; 357 Result := DuplicateHandle 358 ( GetCurrentProcess(), 359 oldHandle, 360 GetCurrentProcess(), 361 @handle, 362 0, 363 true, 364 DUPLICATE_SAME_ACCESS 365 ); 366 if Result then 367 Result := CloseHandle(oldHandle); 368end; 369 370 371Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfoW; CE : Boolean; APipeBufferSize : Cardinal); 372 373begin 374 CreatePipeHandles(SI.hStdInput,HI, APipeBufferSize); 375 DuplicateHandleFP(SI.hStdInput); 376 CreatePipeHandles(HO,Si.hStdOutput, APipeBufferSize); 377 DuplicateHandleFP( Si.hStdOutput); 378 if CE then begin 379 CreatePipeHandles(HE,SI.hStdError, APipeBufferSize); 380 DuplicateHandleFP( SI.hStdError); 381 end 382 else 383 begin 384 SI.hStdError:=SI.hStdOutput; 385 HE:=HO; 386 end; 387end; 388 389{ TProcessUTF8 } 390 391type 392 PHandle = ^THandle; 393 394procedure TProcessUTF8.SetProcessHandle(aProcessHandle: THandle); 395var 396 P: PHandle; 397begin 398 P := @Self.ProcessHandle; 399 P^ := aProcessHandle; 400 if aProcessHandle<>ProcessHandle then 401 raise Exception.Create('TProcessUTF8.SetProcessHandle failed'); 402end; 403 404procedure TProcessUTF8.SetThreadHandle(aThreadHandle: THandle); 405var 406 P: PHandle; 407begin 408 P := @Self.ThreadHandle; 409 P^ := aThreadHandle; 410 if aThreadHandle<>ThreadHandle then 411 raise Exception.Create('TProcessUTF8.SetThreadHandle failed'); 412end; 413 414procedure TProcessUTF8.SetProcessID(aProcessID: Integer); 415var 416 P: PInteger; 417begin 418 P := @Self.ProcessID; 419 P^ := aProcessID; 420 if aProcessID<>ProcessID then 421 raise Exception.Create('TProcessUTF8.SetProcessID failed'); 422end; 423 424procedure TProcessUTF8.Execute; 425Var 426 i : Integer; 427 WName,WDir,WCommandLine : UnicodeString; 428 PWName,PWDir,PWCommandLine : PWideChar; 429 FEnv: pointer; 430 FCreationFlags : Cardinal; 431 FProcessAttributes : TSecurityAttributes; 432 FThreadAttributes : TSecurityAttributes; 433 FProcessInformation : TProcessInformation; 434 FStartupInfo : STARTUPINFOW; 435 HI,HO,HE : THandle; 436 Cmd : String; 437 438begin 439 WName:=''; 440 WCommandLine:=''; 441 WDir:=''; 442 443 if (ApplicationName{%H-}='') and (CommandLine{%H-}='') and (Executable='') then 444 Raise EProcess.Create(SNoCommandline); 445 if (ApplicationName{%H-}<>'') then 446 begin 447 WName:=UTF8Decode(ApplicationName{%H-}); 448 WCommandLine:=UTF8Decode(CommandLine{%H-}); 449 end 450 else If (CommandLine{%H-}<>'') then 451 WCommandLine:=UTF8Decode(CommandLine{%H-}) 452 else if (Executable<>'') then 453 begin 454 Cmd:=MaybeQuoteIfNotQuoted(Executable); 455 For I:=0 to Parameters.Count-1 do 456 Cmd:=Cmd+' '+MaybeQuoteIfNotQuoted(Parameters[i]); 457 WCommandLine:=UTF8Decode(Cmd); 458 end; 459 If CurrentDirectory<>'' then 460 WDir:=UTF8Decode(CurrentDirectory); 461 if Environment.Count<>0 then 462 FEnv:=StringsToWChars(Environment) 463 else 464 FEnv:=Nil; 465 Try 466 FCreationFlags:=GetCreationFlags(Self); 467 InitProcessAttributes(FProcessAttributes); 468 InitThreadAttributes(FThreadAttributes); 469 InitStartupInfo(Self,FStartupInfo); 470 If poUsePipes in Options then 471 CreatePipes(HI{%H-},HO{%H-},HE{%H-},FStartupInfo,Not(poStdErrToOutPut in Options), PipeBufferSize); 472 Try 473 // Beware: CreateProcess can alter the strings 474 // Beware: nil is not the same as a pointer to a #0 475 PWName:=WStrAsUniquePWideChar(WName); 476 PWCommandLine:=WStrAsUniquePWideChar(WCommandLine); 477 PWDir:=WStrAsUniquePWideChar(WDir); 478 479 If Not CreateProcessW (PWName,PWCommandLine,@FProcessAttributes,@FThreadAttributes, 480 InheritHandles,FCreationFlags,FEnv,PWDir,FStartupInfo, 481 fProcessInformation{%H-}) then 482 Raise EProcess.CreateFmt(SErrCannotExecute,[CommandLine{%H-},GetLastError]); 483 SetProcessHandle(FProcessInformation.hProcess); 484 SetThreadHandle(FProcessInformation.hThread); 485 SetProcessID(FProcessINformation.dwProcessID); 486 Finally 487 if POUsePipes in Options then 488 begin 489 FileClose(FStartupInfo.hStdInput); 490 FileClose(FStartupInfo.hStdOutput); 491 if Not (poStdErrToOutPut in Options) then 492 FileClose(FStartupInfo.hStdError); 493 CreateStreams(HI,HO,HE); 494 end; 495 end; 496 FRunning:=True; 497 Finally 498 If FEnv<>Nil then 499 FreeMem(FEnv); 500 end; 501 if not (csDesigning in ComponentState) and // This would hang the IDE ! 502 (poWaitOnExit in Options) and 503 not (poRunSuspended in Options) then 504 WaitOnExit; 505end; 506{$ENDIF} 507 508procedure TProcessUTF8.ParseCmdLine(const CmdLine: string; ReadBackslash: boolean); 509var 510 List: TStringList; 511begin 512 List:=TStringList.Create; 513 try 514 SplitCmdLineParams(CmdLine, List, ReadBackslash); 515 if List.Count>0 then begin 516 Executable:=List[0]; 517 List.Delete(0); 518 end else begin 519 Executable:=''; 520 end; 521 Parameters.Assign(List); 522 finally 523 List.Free; 524 end; 525end; 526 527end. 528