unit ConsoleRedirect;

interface

uses
 Classes, Windows, SyncObjs;

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

   procedure OutputLines(const AText: AnsiString);
   //procedure InprocessDuplicateHandle(Source: THandle; var Destination: THandle);
 protected
   procedure Execute; override;
 public
   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;
 end;

implementation

uses
 SysUtils;

const
 CRLF = #13#10;

{ TConsoleRedirector }

constructor TConsoleRedirector.Create;
var
 pch: PChar;
begin
 inherited Create(True);

 FLocker := TCriticalSection.Create;

 // Извлечем путь к системному каталогу.
 GetMem(pch, MAX_PATH);
 try
   GetSystemDirectory(pch, MAX_PATH);
   FCmdPath := pch;
   UniqueString(FCmdPath);
 finally
   FreeMem(pch);
 end;

 FCmdPath := IncludeTrailingPathDelimiter(FCmdPath) + 'cmd.exe';
 //OutputDebugString(PChar(FCmdPath));
end;

destructor TConsoleRedirector.Destroy;
begin
 FLocker.Free;

 inherited Destroy;
end;

procedure TConsoleRedirector.Execute;
const
 BufSize = 512;
var
 Buf: array[0..BufSize - 1] of AnsiChar;
 sInternalBuff: AnsiString;
 si: TStartupInfo;
 sa: SECURITY_ATTRIBUTES;
 pi: TProcessInformation;
 hNewStdIn, hNewStdOut, hReadStdOut, hWriteStdIn: THandle;
 bread, avail, cExitCode: Cardinal;
begin
 //FreeOnTerminate := True;
 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;
 FillChar(si, SizeOf(TStartupInfo), 0);
 FillChar(pi, SizeOf(TProcessInformation), 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 := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
   si.wShowWindow := SW_HIDE;
   si.hStdOutput := hNewStdOut;
   si.hStdError := hNewStdOut;
   si.hStdInput := hNewStdIn;

   // Пытаемся запустить процесс.
   if not CreateProcess(PChar(FCmdPath), nil, nil, nil, True,
     CREATE_NEW_CONSOLE, nil, nil, si, pi) then
   begin
     //MessageBox(0, PChar('error CreateProcess #' + IntToStr(GetLastError)), nil, MB_OK);
     FErrorCode := 2;
     Exit;
   end;

   CloseHandle(pi.hThread);

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

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

     if cExitCode <> STILL_ACTIVE then
     begin
       FErrorCode := 3;
       //MessageBox(0, PChar('exit #' + IntToStr(cExitCode)), nil, MB_OK);
       Exit;
     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);
 end;
end;

{
procedure TConsoleRedirector.InprocessDuplicateHandle(Source: THandle;
 var Destination: THandle);
var
 CurrentProcess: THandle;
begin
 CurrentProcess := GetCurrentProcess;
 DuplicateHandle(
   CurrentProcess,
   Source,
   CurrentProcess,
   @Destination,
   0, False, DUPLICATE_SAME_ACCESS);
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;

end.

var hReadPipe: THandle = 0;
   hWritePipe: THandle = 0;
   hProc: THandle = 0;
   buf: array [0..1023] of char;

// test console output redirecting
procedure TForm1.Button2Click(Sender: TObject);
var si: TStartupInfo;
   pi: TProcessInformation;
   sa: TSecurityAttributes;
   dir: string;
   bytesread: cardinal;
   h: thandle;
   space: integer;
begin
 FillChar(sa, SizeOf(sa), 0);
 sa.nLength := SizeOf(sa);
 sa.lpSecurityDescriptor := nil;
 sa.bInheritHandle := True;
 if not CreatePipe(hReadPipe, hWritePipe, @sa, 0) then
   Error(LastErrMsg);

 FillChar(si, SizeOf(si), 0);
 FillChar(pi, SizeOf(pi), 0);
 si.cb := SizeOf(si);
 si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
 si.wShowWindow := SW_HIDE;
 si.hStdOutput := hWritePipe;
 si.hStdError := hWritePipe;
 // определяем рабочую директорию, если в батнике относительные пути - ненадежно!! не учитывает пробелы в пути
 space := Pos(' ',edit4.Text);
 if space = 0 then space := Length(edit4.Text)+1;
 dir := ExtractFilePath(Copy(edit4.Text,1,space-1));
 if dir = '' then dir := ExtractFilePath(Application.ExeName);

 if not CreateProcess(nil,PChar(edit4.Text),@sa,nil,True,0,nil,PChar(dir),si,pi)
   then Error(LastErrMsg)
   else memo2.Lines.Add('>process launched');
 hProc := pi.hProcess;

 CloseHandle(pi.hThread);
 timer1.Enabled := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var bytesread, cExitcode: cardinal;
begin
 if (hProc = 0) or (hWritePipe = 0) or (hReadPipe = 0) then Exit;

 if (not GetExitCodeProcess(hProc, cExitcode)) or (cExitcode <> STILL_ACTIVE)
   then begin CloseHandle(hProc); hProc := 0; end;

 repeat
   PeekNamedPipe(hReadPipe, nil, 0, nil, @bytesread, nil);
   if bytesread = 0 then
   begin
     if hProc = 0 then CloseHandle(hReadPipe);
     Break;
   end;
   FillChar(buf, SizeOf(buf), 0);
   if not ReadFile(hReadPipe, buf, 1024, bytesread, nil) then
     begin Timer1.Enabled := False; Error(LastErrMsg); end;
   OemToAnsi(buf,buf);
   if bytesread > 0 then
     memo2.Text:=memo2.Text+(pchar(@buf));
   sendmessage(memo2.Handle, WM_VSCROLL, SB_BOTTOM, 0);
 until bytesread = 0;

 if hProc = 0 then
   memo2.Lines.Add('>process exited');
end;