Thread Process //Pascal class
A thread class to open processes on windows and retrieve its output (input isn't supported but it's easy to add).
unit Process; interface uses SysUtils, Windows, Classes, TLHelp32; const INITIALIZATION_TIMEOUT = 10000; type TStringArray = array of string; TProcessArray = array of Cardinal; TExceptionEvent = procedure(Sender: TObject; Exception: Exception) of object; EProcessError = class(Exception); TProcessThread = class(TThread) private FException: Exception; FWatching, FStarted, FSuspended: Boolean; FDirectory, FPath, FCommandLine, FEnvironment: PChar; FData: string; FOnProcessTerminated, FOnDataAvailable: TNotifyEvent; InputRead, InputWrite, OutputRead, OutputWrite: THandle; FMainProcess: PROCESS_INFORMATION; FOnException: TExceptionEvent; FOnProcessStarted: TNotifyEvent; function GetPriority: TThreadPriority; procedure SetPriority(const Value: TThreadPriority); procedure FreeResources; protected procedure CallDataAvailable; virtual; procedure CallProcessTerminated; virtual; procedure CallProcessOpened; virtual; procedure CallException; virtual; procedure Execute; override; public constructor Create(Path, CommandLine, Directory: string; Environment: TStrings = nil; Watch: Boolean = True); destructor Destroy; override; function IsProcessAlive: Boolean; procedure Resume; procedure Suspend; property OnDataAvailable: TNotifyEvent read FOnDataAvailable write FOnDataAvailable; property OnProcessTerminated: TNotifyEvent read FOnProcessTerminated write FOnProcessTerminated; property OnProcessStarted: TNotifyEvent read FOnProcessStarted write FOnProcessStarted; property OnException: TExceptionEvent read FOnException write FOnException; property Data: string read FData; property Process: PROCESS_INFORMATION read FMainProcess; property Priority: TThreadPriority read GetPriority write SetPriority; end; TProcessLineThread = class; TOnNewLineEvent = procedure(ProcessLine: TProcessLineThread; const Line: string) of object; TProcessLineThread = class(TProcessThread) private FCurrentLine: string; FOnNewLine: TOnNewLineEvent; procedure DataAvailable(Sender: TObject); procedure Finished(Sender: TObject); public constructor Create(Path, CommandLine, Directory: string; Environment: TStrings = nil); property OnNewLine: TOnNewLineEvent read FOnNewLine write FOnNewLine; end; function KillProcess(const Process: Cardinal): Boolean; function GetChildrenProcesses(const Process: Cardinal; const IncludeParent: Boolean = True): TProcessArray; implementation const Priorities: array [TThreadPriority] of Integer = (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL, THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL); function GetChildrenProcesses(const Process: Cardinal; const IncludeParent: Boolean): TProcessArray; var Snapshot: Cardinal; ProcessList: PROCESSENTRY32; Current: Integer; begin Current := 0; SetLength(Result, 1); Result[0] := Process; repeat ProcessList.dwSize := SizeOf(PROCESSENTRY32); Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (Snapshot = INVALID_HANDLE_VALUE) or not Process32First(Snapshot, ProcessList) then Continue; repeat if ProcessList.th32ParentProcessID = Result[Current] then begin SetLength(Result, Length(Result) + 1); Result[Length(Result) - 1] := ProcessList.th32ProcessID; end; until Process32Next(Snapshot, ProcessList) = False; Inc(Current); until Current >= Length(Result); if not IncludeParent then Result := Copy(Result, 2, Length(Result)); end; function KillProcess(const Process: Cardinal): Boolean; var Handle: Cardinal; List: TProcessArray; I: Integer; begin Result := True; List := GetChildrenProcesses(Process); for I := Length(List) - 1 downto 0 do if Result then begin Handle := OpenProcess(PROCESS_TERMINATE, false, List[I]); Result := (Handle <> 0) and TerminateProcess(Handle, 0) and CloseHandle(Handle); end; end; { TProcessThread } procedure TProcessThread.CallDataAvailable; begin if Assigned(FOnDataAvailable) then FOnDataAvailable(Self); end; procedure TProcessThread.Resume; var SuspendCount: Integer; begin if FStarted then begin FStarted := True; SuspendCount := ResumeThread(FMainProcess.hThread); CheckThreadError(SuspendCount >= 0); if SuspendCount = 1 then FSuspended := False; end; inherited Resume; end; function TProcessThread.GetPriority: TThreadPriority; begin if FStarted then begin CheckThreadError(GetThreadPriority(FMainProcess.hThread) <> THREAD_PRIORITY_ERROR_RETURN); end; Result := inherited Priority; end; function TProcessThread.IsProcessAlive: Boolean; var Status: Cardinal; begin GetExitCodeProcess(FMainProcess.hProcess, Status); Result := Status = STILL_ACTIVE; end; procedure TProcessThread.SetPriority(const Value: TThreadPriority); begin if FStarted then CheckThreadError(SetThreadPriority(FMainProcess.hThread, Priorities[Value])); inherited Priority := Value; end; procedure TProcessThread.Suspend; var OldSuspend: Boolean; begin if FStarted then begin OldSuspend := FSuspended; try FSuspended := True; CheckThreadError(Integer(SuspendThread(FMainProcess.hThread)) >= 0); except FSuspended := OldSuspend; raise; end; end; inherited Suspend; end; procedure TProcessThread.CallException; begin if Assigned(FOnException) then FOnException(Self, FException); end; procedure TProcessThread.CallProcessOpened; begin if Assigned(FOnProcessStarted) then FOnProcessStarted(Self); end; procedure TProcessThread.CallProcessTerminated; begin if Assigned(FOnProcessTerminated) then FOnProcessTerminated(Self); end; constructor TProcessThread.Create(Path, CommandLine, Directory: string; Environment: TStrings; Watch: Boolean); var Len, I: Integer; begin inherited Create(True); if (Length(CommandLine) > 0) and (Length(Path) > 0) then CommandLine := ' ' + CommandLine; if Length(Path) > 0 then begin GetMem(FPath, Length(Path) + 1); StrCopy(FPath, PChar(Path)); end; if Length(CommandLine) > 0 then begin GetMem(FCommandLine, Length(CommandLine) + 1); StrCopy(FCommandLine, PChar(CommandLine)); end; if Length(Directory) > 0 then begin GetMem(FDirectory, Length(Directory) + 1); StrCopy(FDirectory, PChar(Directory)); end; FWatching := Watch; if Assigned(Environment) then begin GetMem(FEnvironment, 1); Len := 1; for I := 0 to Environment.Count - 1 do begin Inc(Len, Length(Environment[I]) + 1); ReallocMem(FEnvironment, Len); SetEnvironmentVariable(PChar(Environment.Names[I]), PChar(Environment.ValueFromIndex[I])); StrCopy(FEnvironment + Len - Length(Environment[I]) - 2, PChar(Environment[I])); end; (FEnvironment + Len - 1)^ := #0; FreeMem(FEnvironment); FEnvironment := nil; end; end; destructor TProcessThread.Destroy; begin FreeMem(FPath); FreeMem(FCommandLine); FreeMem(FDirectory); FreeResources; if Assigned(FEnvironment) then FreeMem(FEnvironment); inherited; end; procedure TProcessThread.Execute; const MAX_BUFFER = 512 * 1024; var MaxBytes, Available, BytesRead: Cardinal; Buffer: array[0..MAX_BUFFER] of Char; function Read: Boolean; begin Result := True; FillChar(Buffer, MAX_BUFFER, #0); PeekNamedPipe(OutputRead, @Buffer, MAX_BUFFER, @BytesRead, @Available, nil); if BytesRead < MAX_BUFFER then begin MaxBytes := BytesRead; end else MaxBytes := MAX_BUFFER; if MaxBytes > 0 then if ReadFile(OutputRead, Buffer, MaxBytes, BytesRead, nil) then begin if BytesRead > 0 then begin FData := StrPas(Buffer); Synchronize(CallDataAvailable); end; end else Result := False; end; var Startup: STARTUPINFO; SecurityDescriptor: SECURITY_DESCRIPTOR; SecurityAttributes: SECURITY_ATTRIBUTES; begin try ZeroMemory(@Startup, SizeOf(STARTUPINFO)); Startup.cb := SizeOf(STARTUPINFO); ZeroMemory(@SecurityDescriptor, SizeOf(SECURITY_DESCRIPTOR)); ZeroMemory(@SecurityAttributes, SizeOf(SECURITY_ATTRIBUTES)); InputRead := 0; InputWrite := 0; OutputRead := 0; OutputWrite := 0; if Win32Platform = VER_PLATFORM_WIN32_NT then begin InitializeSecurityDescriptor(@SecurityDescriptor, SECURITY_DESCRIPTOR_REVISION); SetSecurityDescriptorDacl(@SecurityDescriptor, True, nil, False); SecurityAttributes.lpSecurityDescriptor := @SecurityDescriptor; end else SecurityAttributes.lpSecurityDescriptor := nil; SecurityAttributes.nLength := SizeOf(SECURITY_ATTRIBUTES); SecurityAttributes.bInheritHandle := True; if not CreatePipe(OutputRead, OutputWrite, @SecurityAttributes, 0) or not CreatePipe(InputRead, InputWrite, @SecurityAttributes, 0) then raise EProcessError.Create('Error while opening pipes'); SetHandleInformation(OutputRead, HANDLE_FLAG_INHERIT, 0); SetHandleInformation(InputWrite, HANDLE_FLAG_INHERIT, 0); GetStartupInfo(Startup); Startup.dwFlags := STARTF_USESHOWWINDOW OR STARTF_USESTDHANDLES; Startup.hStdOutput := OutputWrite; Startup.hStdError := OutputWrite; Startup.hStdInput := InputRead; FlushFileBuffers(OutputWrite); FlushFileBuffers(OutputRead); FlushFileBuffers(InputRead); FlushFileBuffers(InputWrite); Startup.wShowWindow := SW_HIDE; if not CreateProcess(FPath, FCommandLine, nil, nil, True, CREATE_NEW_CONSOLE OR NORMAL_PRIORITY_CLASS, FEnvironment, FDirectory, Startup, FMainProcess) then raise EProcessError.Create('Error while starting Process: ' + SysErrorMessage(GetLastError) + ':' + FPath + ':' + FCommandLine + ':' + FDirectory); WaitForInputIdle(FMainProcess.hProcess, INITIALIZATION_TIMEOUT); FStarted := True; SetPriority(GetPriority); Synchronize(CallProcessOpened); if not FWatching then Exit; repeat if not Read then Break; until not IsProcessAlive or Terminated; Read; if not IsProcessAlive then Synchronize(CallProcessTerminated); except on E: Exception do begin FException := E; Synchronize(CallException); end; end; end; procedure TProcessThread.FreeResources; begin KillProcess(FMainProcess.dwProcessId); if OutputRead <> 0 then begin CloseHandle(OutputRead); OutputRead := 0; end; if OutputWrite <> 0 then begin CloseHandle(OutputWrite); OutputWrite := 0; end; if InputWrite <> 0 then begin CloseHandle(InputWrite); InputWrite := 0; end; if InputRead <> 0 then begin CloseHandle(InputRead); InputRead := 0; end; end; { TProcessLineThread } constructor TProcessLineThread.Create(Path, CommandLine, Directory: string; Environment: TStrings); begin inherited Create(Path, CommandLine, Directory, Environment); OnDataAvailable := DataAvailable; OnTerminate := Finished; end; procedure TProcessLineThread.DataAvailable(Sender: TObject); var I, L: Integer; begin I := 0; L := Length(Data); while I < L do begin Inc(I); if Data[I] in [#13, #10] then begin if (I < L) and (Data[I+1] in [#13, #10]) then Inc(I); if Assigned(FOnNewLine) then FOnNewLine(Self, FCurrentLine); FCurrentLine := ''; end else FCurrentLine := FCurrentLine + Data[I]; end; end; procedure TProcessLineThread.Finished(Sender: TObject); begin if (FCurrentLine <> '') and Assigned(FOnNewLine) then FOnNewLine(Self, FCurrentLine); end; end.