unit Utils.ConsoleRedirector;

interface

uses
  Windows;

type

  TConsoleRedirector = class;

  TConsoleFinishedEvent = procedure(Sender: TConsoleRedirector) of object;

  TConsoleTextEvent = procedure(Sender: TConsoleRedirector; Text: string) of object;

  TConsoleRedirector = class
  private
    FWorkingThread: THandle; // thread to receive the output of the child process
    FStopEvent: THandle; // event to notify the redir thread to exit
    FWorkingThreadId: Cardinal; // id of the redir thread
    FWaitTime: Cardinal;
    FOnStdoutText: TConsoleTextEvent;
    FOnStderrText: TConsoleTextEvent;
    FOnFinished: TConsoleFinishedEvent; // wait time to check the status of the child process
    FStdInWritePipe: THandle; // write end of child's stdin pipe
    FStdOutReadPipe: THandle; // read end of child's stdout pipe
    FChildProcess: THandle;
  protected
    function LaunchChild(CommandLine: string; StdOutHandle, StdInHandle, StdErrHandle: THandle): Boolean;
    function RedirectStdout: Integer;
    procedure DestroyHandle(var Handle: THandle);
    procedure DoStdOutEvent(Text: AnsiString); virtual;
    procedure DoStdErrorEvent(Text: AnsiString); virtual;
    procedure DoFinishedEvent; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    function Open(CommandLine: string): Boolean;
    procedure Close; virtual;
    function Write(Text: AnsiString): Boolean;
    property WaitTime: Cardinal read FWaitTime write FWaitTime;
    property OnStdoutText: TConsoleTextEvent read FOnStdoutText write FOnStdoutText;
    property OnStderrText: TConsoleTextEvent read FOnStderrText write FOnStderrText;
    property OnFinished: TConsoleFinishedEvent read FOnFinished write FOnFinished;
  end;

implementation

uses
  SysUtils,
  Math;

{ TConsoleRedirector }

procedure TConsoleRedirector.Close;
begin
  if FWorkingThread <> 0 then
  begin
    // this function might be called from redir thread
    if GetCurrentThreadId <> FWorkingThreadId then
    begin
      SetEvent(FStopEvent);
      if WaitForSingleObject(FWorkingThread, 5000) = WAIT_TIMEOUT then
      begin
        DoStdErrorEvent('The redir thread is dead');
        TerminateThread(FWorkingThread, Cardinal(-2));
      end;
    end;
    DestroyHandle(FWorkingThread);
  end;

  DestroyHandle(FStopEvent);
  DestroyHandle(FChildProcess);
  DestroyHandle(FStdInWritePipe);
  DestroyHandle(FStdOutReadPipe);
  FWorkingThreadId := 0;
end;

constructor TConsoleRedirector.Create;
begin
  inherited Create;
  FStdInWritePipe := 0;
  FStdOutReadPipe := 0;
  FChildProcess := 0;
  FWorkingThread := 0;
  FStopEvent := 0;
  FWorkingThreadId := 0;
  FWaitTime := 100;
end;

destructor TConsoleRedirector.Destroy;
begin
  Close;
  inherited Destroy;
end;

procedure TConsoleRedirector.DestroyHandle(var Handle: THandle);
begin
  if Handle <> 0 then
  begin
    CloseHandle(Handle);
    Handle := 0;
  end;
end;

function TConsoleRedirector.LaunchChild(CommandLine: string; StdOutHandle, StdInHandle, StdErrHandle: THandle): Boolean;
var
  vPI: PROCESS_INFORMATION;
  vSI: STARTUPINFO;
begin
  // Set up the start up info struct.
  ZeroMemory(@vSI, SizeOf(vSI));
  vSI.cb := SizeOf(vSI);
  vSI.hStdOutput := StdOutHandle;
  vSI.hStdInput := StdInHandle;
  vSI.hStdError := StdErrHandle;
  vSI.wShowWindow := SW_HIDE;
  vSI.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;

  // Note that dwFlags must include STARTF_USESHOWWINDOW if we
  // use the wShowWindow flags. This also assumes that the
  // CreateProcess() call will use CREATE_NEW_CONSOLE.

  // Launch the child process.
  if not CreateProcess(nil, PChar(CommandLine), nil, nil, True, CREATE_NEW_CONSOLE, nil, nil, vSI, vPI) then
    Result := False
  else
  begin
    FChildProcess := vPI.hProcess;
    // Close any unuseful handles
    CloseHandle(vPI.hThread);
    Result := True;
  end;
end;

// thread to receive output of the child process
function OutputThread(lpvThreadParam: Pointer): Cardinal; stdcall;
var
  vWaitHandles: array [0 .. 1] of THandle;
  vRedirector: TConsoleRedirector;
  vWaitResult: Cardinal;
  vRedirectResult: Integer;
begin
  vRedirector := TConsoleRedirector(lpvThreadParam);
  vWaitHandles[0] := vRedirector.FChildProcess;
  vWaitHandles[1] := vRedirector.FStopEvent;

  // redirect stdout till there's no more data.
  vRedirectResult := vRedirector.RedirectStdout;
  while vRedirectResult > 0 do
  begin
    // check if the child process has terminated.
    vWaitResult := WaitForMultipleObjects(2, @vWaitHandles, False, vRedirector.FWaitTime);
    case vWaitResult of
      WAIT_OBJECT_0: // the child process ended
      begin
        vRedirectResult := vRedirector.RedirectStdout;
        if vRedirectResult > 0 then
          vRedirectResult := 0;
        Break;
      end;
      WAIT_OBJECT_0 + 1: // m_hEvtStop was signalled
      begin
        vRedirectResult := 1; // cancelled
        Break;
      end;
    end;

    // Next redirect:
    vRedirectResult := vRedirector.RedirectStdout;
  end;

  // close handles
  vRedirector.Close;
  Result := vRedirectResult;
end;

function TConsoleRedirector.Open(CommandLine: string): Boolean;
var
  vStdOutReadPipe: THandle; // parent stdout read handle
  vStdOutWritePipe, vStdErrWritePipe: THandle; // child stdout write handle
  vStdInWritePipe: THandle; // parent stdin write handle
  vStdInReadPipe: THandle; // child stdin read handle
  vSA: SECURITY_ATTRIBUTES;
begin
  Close;
  Result := False;
  vStdOutReadPipe := 0;
  vStdOutWritePipe := 0;
  vStdErrWritePipe := 0;
  vStdInWritePipe := 0;
  vStdInReadPipe := 0;

  // Set up the security attributes struct.
  vSA.nLength := SizeOf(SECURITY_ATTRIBUTES);
  vSA.lpSecurityDescriptor := nil;
  vSA.bInheritHandle := True;

  try
    // Create a child stdout pipe.
    if not CreatePipe(vStdOutReadPipe, vStdOutWritePipe, @vSA, 0) then
      RaiseLastOSError;

    // Create a duplicate of the stdout write handle for the std
    // error write handle. This is necessary in case the child
    // application closes one of its std output handles.
    if not DuplicateHandle(GetCurrentProcess, vStdOutWritePipe, GetCurrentProcess, @vStdErrWritePipe, 0, True, DUPLICATE_SAME_ACCESS) then
      RaiseLastOSError;

    // Create a child stdin pipe.
    if not CreatePipe(vStdInReadPipe, vStdInWritePipe, @vSA, 0) then
      RaiseLastOSError;

    // Create new stdout read handle and the stdin write handle.
    // Set the inheritance properties to FALSE. Otherwise, the child
    // inherits the these handles; resulting in non-closeable
    // handles to the pipes being created.
    if not DuplicateHandle(GetCurrentProcess, vStdOutReadPipe, GetCurrentProcess, @FStdOutReadPipe, 0, False {make it uninheritable}, DUPLICATE_SAME_ACCESS) then
      RaiseLastOSError;

    if not DuplicateHandle(GetCurrentProcess, vStdInWritePipe, GetCurrentProcess, @FStdInWritePipe, 0, False {make it uninheritable}, DUPLICATE_SAME_ACCESS) then
      RaiseLastOSError;

    // Close inheritable copies of the handles we do not want to
    // be inherited.
    DestroyHandle(vStdOutReadPipe);
    DestroyHandle(vStdInWritePipe);

    // launch the child process
    if not LaunchChild(CommandLine, vStdOutWritePipe, vStdInReadPipe, vStdErrWritePipe) then
      RaiseLastOSError;

    // Child is launched. Close the parents copy of those pipe
    // handles that only the child should have open.
    // Make sure that no handles to the write end of the stdout pipe
    // are maintained in this process or else the pipe will not
    // close when the child process exits and ReadFile will hang.
    DestroyHandle(vStdOutWritePipe);
    DestroyHandle(vStdInReadPipe);
    DestroyHandle(vStdErrWritePipe);

    // Launch a thread to receive output from the child process.
    FStopEvent := CreateEvent(nil, True, False, nil);
    FWorkingThread := Windows.CreateThread(nil, 0, @OutputThread, self, 0, FWorkingThreadId);
    if FWorkingThread = 0 then
      RaiseLastOSError;

    Result := True;
  except
    on E: Exception do
    begin
      DestroyHandle(vStdOutReadPipe);
      DestroyHandle(vStdOutWritePipe);
      DestroyHandle(vStdErrWritePipe);
      DestroyHandle(vStdInWritePipe);
      DestroyHandle(vStdInReadPipe);
      Close;
      DoStdErrorEvent(AnsiString(E.Message));
      //DONE: raise;
    end;
  end;
end;

// redirect the child process's stdout:
// return: 1: no more data, 0: child terminated, -1: os error
function TConsoleRedirector.RedirectStdout: Integer;
const
  cBufferSize = 255;
var
  vBytesAvailable, vBytesRead, vErrorCode: Cardinal;
  vBuffer: array [0 .. cBufferSize] of AnsiChar;
begin
  // Проверяем количество доступных байт в пайпе:
  while PeekNamedPipe(FStdOutReadPipe, nil, 0, nil, @vBytesAvailable, nil) do
  begin
    // Если чтение успешно, но байт больше нет, то программа завершилась, выходим:
    if vBytesAvailable = 0 then
    begin
      Result := 1; // not data available
      Exit;
    end;

    vBytesRead := 0;
    if not ReadFile(FStdOutReadPipe, vBuffer, Min(cBufferSize, vBytesAvailable), vBytesRead, nil) or (vBytesRead = 0) then
      Break; // error, the child might ended

    vBuffer[vBytesRead] := #0;
    OemToAnsi(vBuffer, vBuffer);
    DoStdOutEvent(vBuffer);
  end;

  // pipe has been ended or pipe closing in progress:
  vErrorCode := GetLastError;
  if (vErrorCode = ERROR_BROKEN_PIPE) or (vErrorCode = ERROR_NO_DATA) then
  begin
    DoFinishedEvent;
    Result := 0; // child process ended
    Exit;
  end;

  DoStdErrorEvent('Read stdout pipe error' + #13#10);
  Result := -1; // os error
end;

function TConsoleRedirector.Write(Text: AnsiString): Boolean;
var
  vBytesWritten: Cardinal;
begin
  if FStdInWritePipe <> 0 then
    if Text <> '' then
      Result := WriteFile(FStdInWritePipe, Text[1], Length(Text), vBytesWritten, nil)
    else
      Result := True
  else
    Result := False;
end;

procedure TConsoleRedirector.DoFinishedEvent;
begin
  if Assigned(FOnFinished) then
    FOnFinished(self);
end;

procedure TConsoleRedirector.DoStdErrorEvent(Text: AnsiString);
begin
  if Assigned(FOnStderrText) then
    FOnStderrText(self, string(Text));
end;

procedure TConsoleRedirector.DoStdOutEvent(Text: AnsiString);
begin
  if Assigned(FOnStdoutText) then
    FOnStdoutText(self, string(Text));
end;

end.