{

Based on code from http://pda.delphimaster.net/?id=1245251049&n=5

}

unit ConsoleRedirect;

interface

uses
  Classes, Windows, Messages, SyncObjs;

type
  TConsoleRedirector = class(TThread)
  private
   { Private declarations }
    FErrorCode: Integer;
    FCmdPath: string;
    FSendCmd: AnsiString;
    FOutput: AnsiString;
    FLocker: TCriticalSection;
    FAborted: boolean;

    si: TStartupInfo;
    pi: TProcessInformation;

    procedure OutputLines(const AText: AnsiString);
    procedure ExecuteCommand(Cmd: string);
  protected
    procedure Execute; override;
  public
    Queue: TStringList;
    function CurrentQueueItemName: string;

    constructor Create(); reintroduce; overload;
    destructor Destroy; override;
    procedure SendBuff(const AText: AnsiString);

    property Terminated;
    property Locker: TCriticalSection read FLocker write FLocker;
    property SendCmd: AnsiString read FSendCmd write FSendCmd;
    property Output: AnsiString read FOutput write FOutput;

    property Aborted: boolean read FAborted;

    procedure Run(Cmd: string);
    procedure SuspendProcess();
    procedure ResumeProcess();
    procedure Abort();

    function ErrorCode(): integer;
  end;

implementation

uses
  SysUtils, utils, tlhelp32;

const
  CRLF = #13#10;

function OpenThread(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwThreadId: DWORD): THandle; stdcall; external 'kernel32.dll';

const
  THREAD_TERMINATE = $0001;
  THREAD_SUSPEND_RESUME = $0002;
  THREAD_GET_CONTEXT = $0008;
  THREAD_SET_CONTEXT = $0010;
  THREAD_SET_INFORMATION = $0020;
  THREAD_QUERY_INFORMATION = $0040;
  THREAD_SET_THREAD_TOKEN = $0080;
  THREAD_IMPERSONATE = $0100;
  THREAD_DIRECT_IMPERSONATION = $0200;

procedure SetSuspendState(PID: DWORD; Resume: Boolean);
var
  hSnap, hThread: THandle;
  te32: THREADENTRY32;
begin
  hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
  te32.dwSize := SizeOf(te32);
  if Thread32First(hSnap, te32) then
    repeat
      if te32.th32OwnerProcessID = PID then begin
        hThread := OpenThread(THREAD_SUSPEND_RESUME, False, te32.th32ThreadID);
        if Resume then
          ResumeThread(hThread)
        else
          SuspendThread(hThread);
        CloseHandle(hThread);
      end;
    until not Thread32Next(hSnap, te32);
  CloseHandle(hSnap);
end;

{ TConsoleRedirector }

constructor TConsoleRedirector.Create;
begin
  inherited Create(True);
  FLocker := TCriticalSection.Create;
  Queue := TStringList.Create;

  FillChar(si, SizeOf(TStartupInfo), 0);
  FillChar(pi, SizeOf(TProcessInformation), 0);
end;

function TConsoleRedirector.CurrentQueueItemName: string;
begin
  if Queue.Count > 0 then
    Result := Queue.Names[0]
  else
    Result := '';
end;

destructor TConsoleRedirector.Destroy;
begin
  FLocker.Free;
  Queue.Free;
  inherited Destroy;
end;

function TConsoleRedirector.ErrorCode: integer;
begin
  Result:=FErrorCode;
end;

procedure TConsoleRedirector.Execute;
begin
  FAborted := False;
  while Queue.Count > 0 do
  begin
    FOutput := '';
    ExecuteCommand(Queue.ValueFromIndex[0]);
    if Queue.Count > 0 then
      Queue.Delete(0);
  end;
  Terminate;
  Free; // wtf...
end;

procedure TConsoleRedirector.ExecuteCommand(Cmd: string);
const
  BufSize = 512;
var
  Buf: array[0..BufSize - 1] of AnsiChar;
  sInternalBuff: AnsiString;
  sa: SECURITY_ATTRIBUTES;
  hNewStdIn, hNewStdOut, hReadStdOut, hWriteStdIn: THandle;
  bread, avail, cExitCode: Cardinal;
  ta: SECURITY_ATTRIBUTES;
begin
  FCmdPath := Cmd;
  FErrorCode := 0;

  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    sa.nLength := SizeOf(SECURITY_ATTRIBUTES);
    sa.bInheritHandle := True;
    sa.lpSecurityDescriptor := nil;
  end else
  begin
    sa.lpSecurityDescriptor := nil;
  end;

 // Проинициализируем переменные.
  hNewStdIn := 0;
  hNewStdOut := 0;
  hReadStdOut := 0;
  hWriteStdIn := 0;

  try
   // Создаем первый анонимный пайп.
    if not CreatePipe(hNewStdIn, hWriteStdIn, @sa, 0) then
    begin
      FErrorCode := 1;
      Exit;
    end;

    SetHandleInformation(hWriteStdIn, HANDLE_FLAG_INHERIT, 0);

   // Создаем второй анонимный пайп.
    if not CreatePipe(hReadStdOut, hNewStdOut, @sa, 0) then
    begin
      FErrorCode := 1;
      Exit;
    end;

    SetHandleInformation(hReadStdOut, HANDLE_FLAG_INHERIT, 0);

//    si.dwFlags := 0;
    si.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
    si.wShowWindow := SW_HIDE;
    //if Pos('>', cmd) = 0 then
    si.hStdOutput := hNewStdOut;
    si.hStdError := hNewStdOut;
    si.hStdInput := hNewStdIn;

    ta.nLength := SizeOf(SECURITY_ATTRIBUTES);
    ta.bInheritHandle := True;
    ta.lpSecurityDescriptor := nil;

   // Пытаемся запустить процесс.
    if not CreateProcess(nil, PChar(FCmdPath), nil, @ta, True,
      CREATE_NEW_CONSOLE, {@Env}nil, nil, si, pi) then
    begin
      FErrorCode := 2;
      Terminate;
      Exit;
    end;

    CloseHandle(pi.hThread);

    FillChar(Buf, SizeOf(Buf), 0);

    while not Terminated do
    begin
      Sleep(100);
      GetExitCodeProcess(pi.hProcess, cExitCode);

      if cExitCode <> STILL_ACTIVE then
      begin
        FErrorCode := 3;
        Break;
      end;

      PeekNamedPipe(hReadStdOut, @Buf, BufSize, @bread, @avail, nil);

     // Данные есть, считываем.
      while bread <> 0 do
      begin
        FillChar(Buf, BufSize, 0);
        if avail > BufSize then
        begin
          while bread >= bufsize do
          begin
            ReadFile(hReadStdOut, Buf, BufSize, bread, nil);
            sInternalBuff := sInternalBuff + Buf;
            FillChar(Buf, BufSize, 0);
          end;
        end
        else
        begin
          ReadFile(hReadStdOut, Buf, BufSize, bread, nil);
          sInternalBuff := sInternalBuff + Buf;
        end;

        PeekNamedPipe(hReadStdOut, @Buf, BufSize, @bread, @avail, nil);
      end;

      FLocker.Enter;
      try
        if sInternalBuff <> '' then
        begin
         // Запишем данные из внутреннего буффера во внешний.
          OutputLines(sInternalBuff);
          sInternalBuff := '';
        end;

       // Записываем данные ввода, если они есть, посимвольно.
        sInternalBuff := FSendCmd;
        while Length(sInternalBuff) > 0 do
        begin
          WriteFile(hWriteStdIn, sInternalBuff[1], 1, bread, nil);
          Delete(sInternalBuff, 1, 1);
        end;

        sInternalBuff := '';
        FSendCmd := '';
      finally
        FLocker.Leave;
      end;
    end;
  finally
    if hNewStdIn <> 0 then
      CloseHandle(hNewStdIn);
    if hNewStdOut <> 0 then
      CloseHandle(hNewStdOut);
    if hReadStdOut <> 0 then
      CloseHandle(hReadStdOut);
    if hWriteStdIn <> 0 then
      CloseHandle(hWriteStdIn);

   // Остановим процесс.
    if pi.hProcess <> 0 then
    begin
      TerminateProcess(pi.hProcess, 0);
    end;

//   if pi.hThread <> 0 then
//     CloseHandle(pi.hThread);
    if pi.hProcess <> 0 then
      CloseHandle(pi.hProcess);

    FillChar(si, SizeOf(TStartupInfo), 0);
    FillChar(pi, SizeOf(TProcessInformation), 0);
  end;
end;

procedure TConsoleRedirector.OutputLines(const AText: AnsiString);
var
  sText: AnsiString;
begin
  sText := AText;
  sText := AnsiString(StringReplace(string(sText), #13#13#10, #13, [rfReplaceAll]));
  FOutput := FOutput + sText;
end;

procedure TConsoleRedirector.SendBuff(const AText: AnsiString);
begin
  FLocker.Enter;
  try
    FSendCmd := FSendCmd + AText + CRLF;
  finally
    FLocker.Leave;
  end;
end;

procedure TConsoleRedirector.Run(Cmd: string);
begin
  Queue.Add(Cmd);
  Resume;
end;

procedure TConsoleRedirector.Abort;
begin
  FAborted := True;
  Queue.Clear();
  Terminate();
end;

procedure TConsoleRedirector.SuspendProcess;
begin
  SetSuspendState(pi.dwProcessId, False);
end;

procedure TConsoleRedirector.ResumeProcess;
begin
  SetSuspendState(pi.dwProcessId, True);
end;

end.

