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.