lasarus_compotents/ConsoleEmulator/data/consoleemulator.pas

{}{
FlushFileBuffers перед tryread (хэндл у нас остался), попробовать с named pipe

PeekNamedPipe(FHandles[ehStdOut], nil, 0, nil, @ToRead, nil);
// если ничего не прочитано и процесс завершился, закрываем трубу
if ToRead = 0 then
begin
if FProcessId = 0 then CloseAndZeroHandle(FHandles[ehStdOut]);
end
else
//

piped command : Launch( [ 'cmd /c dir', 'gzip -9', 'gzip --decompress' ] )
with checking status & exit codes

}

{*******************************************************************************
Эмулятор консоли для запуска консольных приложений
с перенаправлением ввода/вывода.

© Fr0sT, fr0st.brutal@gmail.com

Возможности:
* Как визуальный, так и невизуальный (без Forms) вариант. Для
использования визуального варианта надо объявить дефайн ConEm_VCL
* Запуск любых консольных программ, batch файлов и т.д.
* Получение вывода
* Передача переменных окружения
* Ввод команд после запуска программы
* Запись данных в STDIN запущенной программы
* Отслеживание таймаута неактивности
* Стандартизованный вывод сообщений об ошибках (должна быть поддержка в
запускаемых программах/скриптах)
* Запись выводимых данных в лог файл
* Неблокирующие операции чтения-записи

*******************************************************************************}
unit ConsoleEmulator;
{$mode delphi}
{$codepage UTF8}
interface
uses Classes, Windows, SysUtils, Messages, StrUtils
     {$IFDEF ConEm_VCL}
     , ExtCtrls, Forms, Graphics, Controls, StdCtrls
     {$ENDIF}
     {Utils};
{$REGION 'Notes'}
{========= IMPORTANT NOTES ON PIPES =========

SCHEME OF CONSOLE EMULATOR
Usual console app:
STDIN =====> [APP] =====> STDOUT
=====> STDERR

Console app launched with console emulator:
CONS_EM.InputStream =====> [APP] =====> CONS_EM.OuputStream
CONS_EM.DataInput() CONS_EM.OnDataOutput()

DELAYED OUTPUT / PIPE BUFFERING
If you encounter delays in launched command's output, that's the case.
Windows buffers pipe output to internal memory and writes data when the
buffer fills. Compilator-specific IO libs may have their own buffering as
well. Alas, there's nothing we can do with it.

WAIT FOR INPUT / PIPE EOF
Console apps that read input from STDIN continue reading until they encounter
EOF (IOW, ReadFile returns -1). This happens only when the input channel
closes. You can control this manually with CloseInput method or automatically
by setting AutoCloseInput parameter in Launch() method to True. In this case
STDIN will be closed when InputStream reaches its end. There's no means to
reopen input channel after closing, that's why InputStream setting is available
only in Launch().
=============================================}
{$ENDREGION}
type
  THandles = (ehStdIn, // STDIN pipe handle
              ehStdOut, // STDOUT pipe handle
              ehProcess); // Process handle for checking state
  TConsEmulState = (cesWaiting, cesRunning, cesFinished, cesTerminated, cesTerminatedByTimeout);
  TIODir = (ioInput, ioOutput);
  // Class which implements command line execution
  TConsoleEmulator = class
  strict private
    FHWnd: HWND; // owns timer for reading data and tracking timeout
    FInputBuf, FOutputBuf: TBytes;
    FProcExitCode: Cardinal;
    FTimeout: Cardinal; // [sec]
    FHandles: array[THandles] of THandle;
    FProcessId: THandle;
    FState: TConsEmulState;
    FLaunchTick, FLastActiveTick: Cardinal;
    FCmdLine: string;
    FInputStm, FOutputStm: TStream;
    FAutoCloseInput: Boolean;
    const
      BufSize = 16*1024;
      EventIDs: array[TIODir] of UINT_PTR = (100, 101);
      TimerIntervals: array[TIODir] of UINT = (500, 300);
    function WndProc(wnd: HWND; msg: UINT; wPar: WPARAM; lPar: LPARAM): LRESULT;
    procedure SetState(NewState: TConsEmulState);
    procedure ClearHandles;
    procedure SetTimer(IODir: TIODir; Enabled: Boolean);
    procedure TryWrite;
    procedure TryRead;
  public
    OnDataOutput : procedure(Sender: TConsoleEmulator; Data: PByte; DataLen: Integer) of object;
    OnStateChange : procedure(Sender: TConsoleEmulator; State: TConsEmulState; ExitCode: Cardinal) of object;
    OnIOError : procedure(Sender: TConsoleEmulator; IODirection: TIODir; ErrCode: Cardinal) of object;
    constructor Create(ProcTimeout: Cardinal); reintroduce;
    destructor Destroy; override;
    procedure Launch(CmdLine: string; CurrDir: string = ''; EnvVars: string = ''; InputStm: TStream = nil; AutoCloseInput: Boolean = False);
    procedure Terminate(ByTimeout: Boolean = False);
    function DataInput(const Data; DataLen: Integer): Integer;
    procedure SendCmd(const Cmd: string);
    procedure CloseInput;
    property State: TConsEmulState read FState;
    property ExitCode: Cardinal read FProcExitCode;
    property CmdLine: string read FCmdLine;
    property OutputStm: TStream read FOutputStm write FOutputStm;
    property InputStm: TStream read FInputStm;
  end;
  {$IFDEF ConEm_VCL}
  // Console form with logging of output, command input, status labels and so on
  TfrmConsole = class(TCustomForm)
  private
    // components
    mConsole: TMemo;
    eCommand: TEdit;
    lblState, lblEmulCallback: TLabel;
    // fields
    FMemoLineCompl, FThisLineCompl: Boolean;
    FConsEmul: TConsoleEmulator;
    FLogFile: TFileStream;
    FExitCode: Cardinal;
    FErrorMsg: string;
    // property g/setters
    function GetLogFileName: string;
    // events
    procedure btnSendCmdClick(Sender: TObject);
    procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure btnAbortClick(Sender: TObject);
    // event handers
    procedure ConsEmulOnDataOutput(Sender: TConsoleEmulator; Data: PByte; DataLen: Integer);
    procedure ConsEmulOnStateChange(Sender: TConsoleEmulator; State: TConsEmulState; ExitCode: Cardinal);
  public
    OnProcessFinished: procedure(Sender: TfrmConsole; State: TConsEmulState) of object;
    property ExitCode: Cardinal read FExitCode;
    property ErrorMsg: string read FErrorMsg;
    property LogFileName: string read GetLogFileName;
    constructor Create(AOwner: TComponent; ATimeout: Cardinal); reintroduce;
    destructor Destroy; override;
    procedure Log(Msg: string);
    function Launch(const CmdLine: string; LogFN: string = ''; CurrDir: string = ''; EnvVars: string = ''): Boolean;
    function IsRunning: Boolean;
  end;
  {$ENDIF}
const
  ErrSignName = 'ConEm_Err'; // имя переменной окружения, содержащей сигнатуру ошибки
  ErrSign = '*ERROR*'; // сигнатура ошибки. Если запускаемая программа выводит сообщение
                              // с этой сигнатурой, это сообщение будет распознано эмулятором
                              // и занесено в поле ErrorMsg
function Execute(CmdLine: string; CurrDir: string; EnvVars: string;
                 InputStm: TStream; OutputStm: TStream; Timeout: Cardinal): DWORD;
implementation
uses TlHelp32;
const // localizable
  S_AlreadyLaunched = 'Launch: процесс уже запущен!';
  S_NotLaunched = 'SendCmd: Процесс не запущен!';
  {$IFDEF ConEm_VCL}
  S_FormCaption = 'Эмулятор консоли';
  S_BtnSendCaption = 'Отправить';
  S_BtnAbortCaption = 'Прервать';
  S_ConsEmulStateLabels: array[TConsEmulState] of string =
    ('ожидает', 'запущен', 'завершён', 'остановлен', 'остановлен по таймауту');
  S_LblStatePatt = 'Состояние: %s Командная строка: %s';
  S_ProcessStatePatt = '<=== %s Процесс %s%s ===>';
  S_ExitCodePatt = ' (Код %d%s)';
  S_ErrMsgPatt = ', сообщение "%s"';
  S_ErrLaunching = '! Ошибка запуска "%s": %s';
  {$ENDIF}
// Функция завершает процесс вместе со всеми дочерними
function KillProcessTree(ProcId: DWORD): Integer;
var Snapshot: Cardinal;
    PrEntry: PROCESSENTRY32;
    hProc: Cardinal;
begin
  // получаем слепок
  Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if Snapshot = INVALID_HANDLE_VALUE then
    begin Result := GetLastError; Exit; end;
  // получаем первый процесс
  PrEntry.dwSize := SizeOf(PrEntry);
  if not Process32First(Snapshot, PrEntry) then
    begin Result := GetLastError; CloseHandle(Snapshot); Exit; end;
  // убиваем все процессы, порождённые текущим
  repeat
    if PrEntry.th32ParentProcessID = ProcId then
      KillProcessTree(PrEntry.th32ProcessID);
  until not Process32Next(Snapshot, PrEntry);
  CloseHandle(Snapshot);
  // и завершаем исходный процесс
  hProc := OpenProcess(PROCESS_TERMINATE, False, ProcId);
  if hProc <> 0 then TerminateProcess(hProc, High(DWORD)-1);
  Result := GetLastError;
  CloseHandle(hProc);
end;
// Execute console application or script
// CmdLine - command to execute
// CurrDir [opt] - current dir for command
// EnvVars [opt] - custom environment variables, "v1=val1;v2=val2;..."
// InputStm [opt] - stream to write to STDIN
// OutputStm [opt] - stream to read from STDOUT

// ? очень странно. если неблок на вывод - ООООчень долго. чтение по мелким кусочкам.
// но если блок и без внутреннего цикла - также чтение по мелким кусочкам
function Execute(CmdLine: string; CurrDir: string; EnvVars: string;
                 InputStm: TStream; OutputStm: TStream; Timeout: Cardinal): DWORD;
const
  BufSize = 16*1024;
  MaxLoopTime = 100; // [ms] максимальное время
var // общие для всех процедур переменные
  ProcessId: THandle;
  InputBuf, OutputBuf: TBytes;
  Handles: array[THandles] of THandle;
  LastActiveTick: Cardinal;
procedure Launch(CmdLine: string; CurrDir: string; EnvVars: string);
var
  si: TStartupInfo;
  pi: TProcessInformation;
  sa: TSecurityAttributes;
  pOldEnv, tmp: PChar;
  OldEnvLen, NewEnvLen, err: Integer;
  hStdOut, hStdIn: THandle;
  mode: DWORD;
  IntCmdLine: string;
begin
  ZeroMem(si, SizeOf(si));
  ZeroMem(pi, SizeOf(pi));

  try
    // TSecurityAttributes для процесса и труб
    ZeroMem(sa, SizeOf(sa));
    sa.nLength := SizeOf(sa);
    sa.lpSecurityDescriptor := nil;
    sa.bInheritHandle := True;
    // create pipes
    mode := PIPE_READMODE_BYTE or PIPE_NOWAIT;
    // STDOUT
    if not CreatePipe(Handles[ehStdOut], hStdOut, @sa, 1) then
      Error('CreatePipe: '+LastErrMsg);
    // Ensure the read handle to the pipe for STDOUT is not inherited (from MSDN example)
    SetHandleInformation(Handles[ehStdOut], HANDLE_FLAG_INHERIT, 0);
    // Set non-blocking R/W mode for the pipe (!)
// SetNamedPipeHandleState(Handles[ehStdOut], mode, nil, nil);
    // STDIN
    if not CreatePipe(hStdIn, Handles[ehStdIn], @sa, 1) then
      Error('CreatePipe: '+LastErrMsg);
    // Ensure the write handle to the pipe for STDIN is not inherited (from MSDN example)
    SetHandleInformation(Handles[ehStdIn], HANDLE_FLAG_INHERIT, 0);
    // Set non-blocking R/W mode for the pipe (!)
    SetNamedPipeHandleState(Handles[ehStdIn], mode, nil, nil);

    // заполняем структуры для создания процесса
    si.cb := SizeOf(si);
    si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
    si.wShowWindow := SW_HIDE;
    si.hStdInput := hStdIn;
    si.hStdOutput := hStdOut;
    si.hStdError := hStdOut;
    if CurrDir = '' then CurrDir := GetCurrentDir;

    // Конструируем новое окружение из переданной в параметре строки, сразу добавляя
    // и сигнатуру сообщения об ошибке. Соответственно EnvVars у нас всегда непуст,
    // и проверки if (EnvVars <> '') можно убрать
    EnvVars := ErrSignName + '=' + ErrSign + ';' + EnvVars;
    if EnvVars[Length(EnvVars)] <> ';' then EnvVars := EnvVars + ';';
    EnvVars := StringReplace(EnvVars, ';', #0, [rfReplaceAll]);
    NewEnvLen := Length(EnvVars);

    // Получаем старые переменные окружения, определяем их длину
    // (НЕ включая завершающий второй ноль, чтобы обработать случай пустой строки)
    pOldEnv := GetEnvironmentStrings;
    if pOldEnv <> nil then
    begin
      tmp := pOldEnv;
      while not ( (tmp^ = #0) and (CharNext(tmp)^ = #0) ) do Inc(tmp, StrLen(tmp)+1);
      OldEnvLen := tmp - pOldEnv;
    end
    else
      OldEnvLen := 0;

    // Собираем новый список переменных окружения, в конец вручную добавляем второй ноль
    SetLength(EnvVars, NewEnvLen + OldEnvLen + 1);
    Move(pOldEnv^, EnvVars[NewEnvLen + 1], OldEnvLen*SizeOf(Char));
    EnvVars[Length(EnvVars)] := #0;
    FreeEnvironmentStrings(pOldEnv);

    IntCmdLine := CmdLine; // обеспечиваем изменяемость комстроки - особенности CreateProcessW
    UniqueString(IntCmdLine);
    if not CreateProcess(nil, PChar(IntCmdLine), @sa, nil, True,
                         CREATE_NEW_CONSOLE{$IFDEF UNICODE} or CREATE_UNICODE_ENVIRONMENT{$ENDIF},
                         PChar(EnvVars), PChar(CurrDir), si, pi) then
    begin
      err := GetLastError;
      Error('CreateProcess: '+SysErrorMessage(err)+' ['+IntToStr(err)+'], "'+IntCmdLine+'"');
    end;
    ProcessId := pi.dwProcessId;
    Handles[ehProcess] := pi.hProcess;
  finally
    // освобождаем хэндлы потока и уже унаследованных концов труб
    CloseAndZeroHandle(hStdIn);
    CloseAndZeroHandle(hStdOut);
    CloseAndZeroHandle(pi.hThread);
  end;
end;

procedure TryWrite(InputStm: TStream);
var
  InputPtr: PByte;
  ToWrite: Integer;
  bytes, StartTick: Cardinal;
  res: Boolean;
begin
  if Handles[ehStdIn] <> 0 then
  begin
    // copy input data from stream to buffer
    ToWrite := InputStm.Read(InputBuf[0], Length(InputBuf));
    if ToWrite <= 0 then // nothing to write
    begin
      CloseAndZeroHandle(Handles[ehStdIn]);
      Exit;
    end;
    InputPtr := @InputBuf[0];
    StartTick := GetTickCount;
    // write data in a loop
    repeat
      res := WriteFile(Handles[ehStdIn], InputPtr^, ToWrite, bytes, nil);
      if not res then
        case GetLastError of
          ERROR_NO_DATA, // here: pipe closed
          ERROR_BROKEN_PIPE: // pipe closed on the other end
            CloseAndZeroHandle(Handles[ehStdIn]);
          else // other error - report & close
          begin
            CloseAndZeroHandle(Handles[ehStdIn]);
            Error('TryWrite: '+LastErrMsg);
          end;
        end; // case
      if bytes = 0 then Break;

      // if something was read, regardless the error, process it
      LastActiveTick := GetTickCount;
      Inc(InputPtr, bytes);
      Dec(ToWrite, bytes);

      if not res then Break; // if WriteFile failed, break
      // control loop execution time
      if TicksSince(StartTick) > MaxLoopTime then Break;
    until False;
    // ToWrite is amount of data unwritten so rewind the stream (hoping it supports that!)
    if ToWrite > 0 then
      InputStm.Seek(-ToWrite, soCurrent);
  end; // if
end;

procedure TryRead(OutputStm: TStream);
var
  bytes, StartTick: Cardinal;
  res: Boolean;
begin
//WriteLnToFile('console.log', FormatDateTime('hh:mm:ss.zzz', now)+ ' << TryRead');
  // read data from pipe in a loop
  if Handles[ehStdOut] <> 0 then
  begin
    StartTick := GetTickCount;
    repeat
      // read data, on error close the {}handle and break the loop
      res := ReadFile(Handles[ehStdOut], OutputBuf[0], Length(OutputBuf), bytes, nil);
      if not res then
        case GetLastError of
          ERROR_NO_DATA: // here: pipe is currently empty, that's OK
            ;
          ERROR_BROKEN_PIPE: // pipe closed on the other end
            CloseAndZeroHandle(Handles[ehStdOut]);
          else // other error - report & close
          begin
            CloseAndZeroHandle(Handles[ehStdOut]);
            Error('TryRead: '+LastErrMsg);
          end;
        end; // case
      if bytes = 0 then Break;
//WriteLnToFile('console.log', FormatDateTime('hh:mm:ss.zzz', now)+ ' read '+itos(bytes));

      // if something was read, regardless the error, process it
      LastActiveTick := GetTickCount;
      OutputStm.Write(OutputBuf[0], bytes);

      if not res then Break; // if ReadFile failed, break
      // control loop execution time
      if TicksSince(StartTick) > MaxLoopTime then Break;
    until False;
  end; // if
//WriteLnToFile('console.log', FormatDateTime('hh:mm:ss.zzz', now)+ ' TryRead >>');
end;

var h: THandles;
begin
  Result := 0;

  Launch(CmdLine, CurrDir, EnvVars);

  LastActiveTick := GetTickCount;
  if InputStm <> nil then
    SetLength(InputBuf, BufSize);
  SetLength(OutputBuf, BufSize);

  // основной цикл
  Sleep(200);
  repeat
    if InputStm <> nil then
      TryWrite(InputStm);
    TryRead(OutputStm);

    if (not GetExitCodeProcess(Handles[ehProcess], Result)) or (Result <> STILL_ACTIVE) then
      Break
    // если нет - проверяем, не истёк ли таймаут неактивности
    else if Timeout <> 0 then
      if TicksSince(LastActiveTick) >= Timeout*MSecsPerSec then
      begin
        KillProcessTree(ProcessId);
        Result := 1;
      end;

     Sleep(200);
  until False;

  for h := Low(THandles) to High(THandles) do
    CloseAndZeroHandle(Handles[h]);
end;

{$REGION 'TConsoleEmulator'}

constructor TConsoleEmulator.Create(ProcTimeout: Cardinal);
begin
  inherited Create;
  FHWnd := AllocateMsgWnd(WndProc);
  if FHWnd = 0 then
    Error('AllocateMsgWnd: '+LastErrMsg);
  SetTimer(ioOutput, True);
  SetLength(FOutputBuf, BufSize);

  FTimeout := ProcTimeout;
  FState := cesWaiting;
end;

destructor TConsoleEmulator.Destroy;
begin
  Terminate;
  DestroyWindow(FHWnd);
  inherited;
end;

// Меняем состояние и вызываем обработчик этого события, если он присвоен
procedure TConsoleEmulator.SetState(NewState: TConsEmulState);
begin
  if FState = NewState then Exit;
  FState := NewState;
  if Assigned(OnStateChange) then
    OnStateChange(Self, FState, FProcExitCode);
  // если процесс так или иначе завершился - отключаем таймеры, меняем состояние на ожидающее
  if FState in [cesFinished, cesTerminated, cesTerminatedByTimeout] then
  begin
    SetTimer(ioInput, False);
    SetTimer(ioOutput, False);
    SetState(cesWaiting);
  end;
end;

procedure TConsoleEmulator.SetTimer(IODir: TIODir; Enabled: Boolean);
begin
  if not Enabled then
    KillTimer(FHWnd, EventIDs[IODir])
  else
    if Windows.SetTimer(FHWnd, EventIDs[IODir], TimerIntervals[IODir], nil) = 0 then
      Error('SetTimer: '+LastErrMsg);
end;

// закрываем и обнуляем все хэндлы, за исключением Id процесса (Id просто обнуляем - это не хэндл)
procedure TConsoleEmulator.ClearHandles;
var h: THandles;
begin
  for h := Low(THandles) to High(THandles) do
    CloseAndZeroHandle(FHandles[h]);
  FProcessId := 0;
end;

// завершаем процесс и обнуляем все хэндлы
procedure TConsoleEmulator.Terminate(ByTimeout: Boolean);
begin
  if FProcessId <> 0 then
  begin
    // if the input pipe is open, try closing it, child process will probably flush its STDOUT
    if ByTimeout then
      if FHandles[ehStdIn] <> 0 then
      begin
        CloseInput;
        Sleep(100); // wait some time to flush
        TryRead; // read the data
      end;
    KillProcessTree(FProcessId);
    FProcExitCode := 0;
    if ByTimeout
      then SetState(cesTerminatedByTimeout)
      else SetState(cesTerminated);
  end;
  ClearHandles;
end;

// Execute console application or script
// CmdLine - command to execute
// CurrDir [opt] - current dir for command
// EnvVars [opt] - custom environment variables, "v1=val1;v2=val2;..."
// InputStm [opt] - stream to write to STDIN
// AutoCloseInput [opt] - close STDIN pipe when InputStm reaches the end. See Notes#WAIT FOR INPUT
procedure TConsoleEmulator.Launch(CmdLine: string; CurrDir: string; EnvVars: string;
                                  InputStm: TStream; AutoCloseInput: Boolean);
var si: TStartupInfo;
    pi: TProcessInformation;
    sa: TSecurityAttributes;
    pOldEnv, tmp: PChar;
    OldEnvLen, NewEnvLen, err: Integer;
    hStdOut, hStdIn: THandle;
    mode: DWORD;
begin
  if FState = cesRunning then Error(S_AlreadyLaunched);
  FProcExitCode := 0;

  // обнуляем все переменные, чтобы в finally их все скопом закрыть
  ClearHandles;
  hStdOut := 0; hStdIn := 0;
  ZeroMem(si, SizeOf(si));
  ZeroMem(pi, SizeOf(pi));

  try try
    // TSecurityAttributes для процесса и труб
    ZeroMem(sa, SizeOf(sa));
    sa.nLength := SizeOf(sa);
    sa.lpSecurityDescriptor := nil;
    sa.bInheritHandle := True;
    // create pipes
    mode := PIPE_READMODE_BYTE or PIPE_NOWAIT;
    // STDOUT
    if not CreatePipe(FHandles[ehStdOut], hStdOut, @sa, 1) then
      Error('CreatePipe: '+LastErrMsg);
    // Ensure the read handle to the pipe for STDOUT is not inherited (from MSDN example)
    SetHandleInformation(FHandles[ehStdOut], HANDLE_FLAG_INHERIT, 0);
    // Set non-blocking R/W mode for the pipe (!)
    SetNamedPipeHandleState(FHandles[ehStdOut], mode, nil, nil);
    // STDIN
    if not CreatePipe(hStdIn, FHandles[ehStdIn], @sa, 1) then
      Error('CreatePipe: '+LastErrMsg);
    // Ensure the write handle to the pipe for STDIN is not inherited (from MSDN example)
    SetHandleInformation(FHandles[ehStdIn], HANDLE_FLAG_INHERIT, 0);
    // Set non-blocking R/W mode for the pipe (!)
    SetNamedPipeHandleState(FHandles[ehStdIn], mode, nil, nil);

    // заполняем структуры для создания процесса
    si.cb := SizeOf(si);
    si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
    si.wShowWindow := SW_HIDE;
    si.hStdInput := hStdIn;
    si.hStdOutput := hStdOut;
    si.hStdError := hStdOut;
    if CurrDir = '' then CurrDir := GetCurrentDir;

    // Конструируем новое окружение из переданной в параметре строки, сразу добавляя
    // и сигнатуру сообщения об ошибке. Соответственно EnvVars у нас всегда непуст,
    // и проверки if (EnvVars <> '') можно убрать
    EnvVars := ErrSignName + '=' + ErrSign + ';' + EnvVars;
    if EnvVars[Length(EnvVars)] <> ';' then EnvVars := EnvVars + ';';
    EnvVars := StringReplace(EnvVars, ';', #0, [rfReplaceAll]);
    NewEnvLen := Length(EnvVars);

    // Получаем старые переменные окружения, определяем их длину
    // (НЕ включая завершающий второй ноль, чтобы обработать случай пустой строки)
    pOldEnv := GetEnvironmentStrings;
    if pOldEnv <> nil then
    begin
      tmp := pOldEnv;
      while not ( (tmp^ = #0) and (CharNext(tmp)^ = #0) ) do Inc(tmp, StrLen(tmp)+1);
      OldEnvLen := tmp - pOldEnv;
    end
    else
      OldEnvLen := 0;

    // Собираем новый список переменных окружения, в конец вручную добавляем второй ноль
    SetLength(EnvVars, NewEnvLen + OldEnvLen + 1);
    Move(pOldEnv^, EnvVars[NewEnvLen + 1], OldEnvLen*SizeOf(Char));
    EnvVars[Length(EnvVars)] := #0;
    FreeEnvironmentStrings(pOldEnv);

    FCmdLine := CmdLine; // обеспечиваем изменяемость комстроки - особенности CreateProcessW
    UniqueString(FCmdLine);
    if not CreateProcess(nil, PChar(FCmdLine), @sa, nil, True,
                         CREATE_NEW_CONSOLE{$IFDEF UNICODE} or CREATE_UNICODE_ENVIRONMENT{$ENDIF},
                         PChar(EnvVars), PChar(CurrDir), si, pi) then
    begin
      err := GetLastError;
      Error('CreateProcess: '+SysErrorMessage(err)+' ['+IntToStr(err)+'], "'+CmdLine+'"');
    end;
    FProcessId := pi.dwProcessId;
    FHandles[ehProcess] := pi.hProcess;

    // присваиваем различные внутренние поля, запускаем таймеры и меняем состояние
    FLaunchTick := GetTickCount; FLastActiveTick := GetTickCount;

    SetTimer(ioOutput, True);
    // set input stream and activate input timer
    FInputStm := InputStm;
    fAutoCloseInput := AutoCloseInput;
    if FInputStm <> nil then
    begin
      SetTimer(ioInput, True);
      SetLength(FInputBuf, BufSize);
    end
    else
      SetLength(FInputBuf, 0);

    SetState(cesRunning);
  except
    on E: Exception do
    begin
      Terminate;
      raise;
    end;
  end;
  finally
    // освобождаем хэндлы потока и уже унаследованных концов труб
    CloseAndZeroHandle(hStdIn);
    CloseAndZeroHandle(hStdOut);
    CloseAndZeroHandle(pi.hThread);
  end;
end;

procedure TConsoleEmulator.CloseInput;
begin
  CloseAndZeroHandle(FHandles[ehStdIn]);
end;

procedure TConsoleEmulator.TryRead;
var
  bytes, StartTick: Cardinal;
  res: Boolean;
begin
  // read data from pipe in a loop
  if FHandles[ehStdOut] <> 0 then
  begin
    StartTick := GetTickCount;
    repeat
      // read data, on error close the {}handle and break the loop
      res := ReadFile(FHandles[ehStdOut], FOutputBuf[0], Length(FOutputBuf), bytes, nil);
      if not res then
        case GetLastError of
          ERROR_NO_DATA: // here: pipe is currently empty, that's OK
            ;
          ERROR_BROKEN_PIPE: // pipe closed on the other end
            CloseAndZeroHandle(FHandles[ehStdOut]);
          else // other error - report & close
          begin
            if Assigned(OnIOError) then
              OnIOError(Self, ioOutput, GetLastError);
            CloseAndZeroHandle(FHandles[ehStdOut]);
          end;
        end; // case
      if bytes = 0 then Break;

      // if something was read, regardless the error, process it
      FLastActiveTick := GetTickCount;
      if Assigned(OnDataOutput) then OnDataOutput(Self, @FOutputBuf[0], bytes);
      if Assigned(FOutputStm) then FOutputStm.Write(FOutputBuf[0], bytes);
//debug(timetostr(now)+' '+'read '+itos(bytes));

      if not res then Break; // if ReadFile failed, break
      // control loop execution time
      if TicksSince(StartTick) > TimerIntervals[ioOutput] div 2 then Break;
    until False;
  end;
end;

procedure TConsoleEmulator.TryWrite;
var
  InputPtr: PByte;
  ToWrite: Integer;
  bytes, StartTick: Cardinal;
  res: Boolean;
begin
  if FProcessId = 0 then Exit;
  if FInputStm = nil then Exit;
  if FHandles[ehStdIn] <> 0 then
  begin
    // copy input data from stream to buffer
    ToWrite := FInputStm.Read(FInputBuf[0], Length(FInputBuf));
    if ToWrite <= 0 then // nothing to write
    begin
      if FAutoCloseInput then
      begin
        CloseInput;
        SetTimer(ioInput, False);
      end;
      Exit;
    end;
    InputPtr := @FInputBuf[0];
    StartTick := GetTickCount;
    // write data in a loop
    repeat
      res := WriteFile(FHandles[ehStdIn], InputPtr^, ToWrite, bytes, nil);
      if not res then
        case GetLastError of
          ERROR_NO_DATA, // here: pipe closed
          ERROR_BROKEN_PIPE: // pipe closed on the other end
            CloseAndZeroHandle(FHandles[ehStdIn]);
          else // other error - report & close
          begin
            if Assigned(OnIOError) then
              OnIOError(Self, ioInput, GetLastError);
            CloseAndZeroHandle(FHandles[ehStdIn]);
          end;
        end; // case
      if bytes = 0 then Break;

      // if something was read, regardless the error, process it
      FLastActiveTick := GetTickCount;
      Inc(InputPtr, bytes);
      Dec(ToWrite, bytes);

      if not res then Break; // if WriteFile failed, break
      // control loop execution time
      if TicksSince(StartTick) > TimerIntervals[ioInput] div 2 then Break;
    until False;
    // ToWrite is amount of data unwritten so rewind the stream (hoping it supports that!)
    if ToWrite > 0 then
      FInputStm.Seek(-ToWrite, soCurrent);
  end;
//debug(timetostr(now)+' '+itos(FInputStm.Position));
end;

// по таймеру периодически проверять состояние запущенного процесса
// и считывать выводимую в трубу информацию

function TConsoleEmulator.WndProc(wnd: HWND; msg: UINT; wPar: WPARAM; lPar: LPARAM): LRESULT;
begin
  Result := 0;
  if (msg = WM_TIMER) and (FState = cesRunning) then
  begin
    if wPar = EventIDs[ioInput] then // write data from stream (if assigned) to the ehProcess input pipe
    begin
      TryWrite;
    end
    else if wPar = EventIDs[ioOutput] then // read data from ehProcess
    begin
      TryRead;
      // проверяем, не завершился ли ещё процесс, и если так, то меняем состояние
      if FProcessId = 0 then Exit;
      if (not GetExitCodeProcess(FHandles[ehProcess], FProcExitCode)) or (FProcExitCode <> STILL_ACTIVE) then
        begin ClearHandles; SetState(cesFinished); end
      // если нет - проверяем, не истёк ли таймаут неактивности
      else if FTimeout <> 0 then
        if TicksSince(FLastActiveTick) >= FTimeout*MSecsPerSec then
          Terminate(True);
    end // Output
    else Exit;
  end // msg = WM_TIMER
  else
    Result := DefWindowProc(wnd, msg, wPar, lPar);
end;

// Write the data to input pipe
function TConsoleEmulator.DataInput(const Data; DataLen: Integer): Integer;
var bytes: Cardinal;
begin
  if not WriteFile(FHandles[ehStdIn], Data, DataLen, bytes, nil) then
    Result := -1
  else
    Result := bytes;
end;

// посылка команды запущенному процессу через перехваченную трубу
procedure TConsoleEmulator.SendCmd(const Cmd: string);
var bytes : Integer;
    curr : Integer;
    CmdToSend: AnsiString;
begin
  // выполнять, только если все нужные хэндлы ненулевые
  if (FProcessId = 0) or (FHandles[ehStdIn] = 0) or (FHandles[ehStdOut] = 0) or
     (FState <> cesRunning) then Error(S_NotLaunched);
  CmdToSend := AnsiString(Cmd) + NL; // признак конца команды, иначе будет ждать
  curr := 1;
  while curr <= Length(CmdToSend) do
  begin
    bytes := DataInput(CmdToSend[curr], StrSize(CmdToSend)-curr+1);
    if bytes = -1 then Error('WriteFile: '+LastErrMsg);
    if bytes > 0 then Inc(curr, bytes) else Break; {}// repeat
  end;
end;

{$ENDREGION}

{$REGION 'TfrmConsole'}

{$IFDEF ConEm_VCL}

const MaxMemoLines = 500;

constructor TfrmConsole.Create(AOwner: TComponent; ATimeout: Cardinal);
begin
  CreateNew(AOwner);
  // init внутренние поля
  FMemoLineCompl := True;
  FThisLineCompl := False;
  FConsEmul := TConsoleEmulator.Create(ATimeout);
  FConsEmul.OnDataOutput := ConsEmulOnDataOutput;
  FConsEmul.OnStateChange := ConsEmulOnStateChange;
  // init себя
  Caption := S_FormCaption;
  ClientHeight := 370;
  ClientWidth := 730;
  Font.Size := 9;
  Font.Name := 'Tahoma';
  KeyPreview := True;
  Padding.Left := 5;
  Padding.Top := 5;
  Padding.Right := 5;
  Padding.Bottom := 5;
  Position := poDesktopCenter;
  OnKeyUp := FormKeyUp;
  // init контролы
  with TLabel.Create(Self) do
  begin;
    Parent := Self;
    SetBounds(8, 361, 17, 25);
    Anchors := [akLeft, akBottom];
    Caption := '>';
    Font.Size := 16;
    Font.Name := 'Tahoma';
    Font.Style := [fsBold];
  end;
  lblState := TLabel.Create(Self);
  with lblState do
  begin
    Parent := Self;
    SetBounds(8, 340, 232, 14);
    Anchors := [akLeft, akBottom];
    AutoSize := True;
  end;
  lblEmulCallback := TLabel.Create(Self);
  with lblEmulCallback do
  begin
    Parent := Self;
    top:=0;
    Align := alTop;
    AlignWithMargins := True;
    Margins.SetBounds(5,5,5,5);
    Caption := '';
  end;
  eCommand := TEdit.Create(Self);
  with eCommand do
  begin
    Parent := Self;
    SetBounds(31, 366, 500, 22);
    Anchors := [akLeft, akRight, akBottom];
  end;
  with TButton.Create(Self) do
  begin
    Parent := Self;
    SetBounds(545, 361, 95, 32);
    Anchors := [akRight, akBottom];
    Caption := S_BtnSendCaption;
    Default := True;
    OnClick := btnSendCmdClick;
  end;
  with TButton.Create(Self) do
  begin
    Parent := Self;
    SetBounds(645, 361, 90, 32);
    Anchors := [akRight, akBottom];
    Caption := S_BtnAbortCaption;
    OnClick := btnAbortClick;
  end;
  mConsole := TMemo.Create(Self);
  with mConsole do
  begin
    Parent := Self;
    Height := 305;
    Align := alTop;
    Anchors := [akLeft, akTop, akRight, akBottom];
    Color := clCream;
    Font.Size := 10;
    Font.Name := 'Courier';
    ReadOnly := True;
    ScrollBars := ssVertical;
    WordWrap := False;
  end;
end;

destructor TfrmConsole.Destroy;
begin
  FreeAndNil(FConsEmul);
  FreeAndNil(FLogFile);
  inherited;
end;

function TfrmConsole.GetLogFileName: string;
begin
  if FLogFile = nil then Result := '' else Result := FLogFile.FileName;
end;

procedure TfrmConsole.btnAbortClick(Sender: TObject);
begin
  FConsEmul.Terminate;
end;

procedure TfrmConsole.btnSendCmdClick(Sender: TObject);
begin
  FConsEmul.SendCmd(eCommand.Text);
  eCommand.SelectAll;
end;

// Поступили данные в консоль - пишем их в мемо и в лог-файл
procedure TfrmConsole.ConsEmulOnDataOutput(Sender: TConsoleEmulator; Data: PByte; DataLen: Integer);
var tmp: String;
    pData, pNl: PAnsiChar;
begin
  try
  pData := PAnsiChar(Data);
  OemToAnsiBuff(pData, pData, DataLen);
  if FLogFile <> nil then
    FLogFile.WriteBuffer(pData^, DataLen);
  mConsole.Lines.BeginUpdate;
  // если строк в мемо больше максимума, удаляем их
  if mConsole.Lines.Count > MaxMemoLines + 50 then
    while mConsole.Lines.Count > MaxMemoLines do mConsole.Lines.Delete(0);
  // цикл, пока не исчерпаем все данные
  while DataLen > 0 do
  begin
    // пропускаем все #10
    while (DataLen > 0) and (pData^ = #10) do
      begin Inc(pData); Dec(DataLen); end;
    // ищем #13, если не нашли - присваиваем ему указатель на конец строки
    pNl := AnsiStrScan(pData, #13);
    FThisLineCompl := pNl <> nil;
    if pNl = nil then pNl := PAnsiChar(pData+DataLen);
    // получаем строку и в зависимости от флага прибавляем к существующей строке
    // в мемо либо добавляем новую строку
    tmp := string(Copy(pData, 1, pNl-pData));
    with mConsole.Lines do
      if FMemoLineCompl
        then Add(tmp)
        else Strings[Count-1] := Strings[Count-1] + tmp;
    FMemoLineCompl := FThisLineCompl;
    Dec(DataLen, pNl-pData+1);
    Inc(pData, pNl-pData+1);
    if StrIsStartingFrom(tmp,ErrSign) then
      FErrorMsg := tmp;
  end;
  finally
    mConsole.Lines.EndUpdate;
    SendMessage(mConsole.{}handle, WM_VSCROLL, SB_BOTTOM, 0);
  end;
end;

// Процесс завершён - сообщаем об этом
procedure TfrmConsole.ConsEmulOnStateChange(Sender: TConsoleEmulator; State: TConsEmulState; ExitCode: Cardinal);
var ExitStr: string;
begin
  lblState.Caption := Format(S_LblStatePatt, [S_ConsEmulStateLabels[State], Sender.CmdLine]);
  case State of
    cesWaiting:
      begin
        FExitCode := 0; FErrorMsg := '';
      end;
    cesRunning:
      begin
        Log(Format(S_ProcessStatePatt, [DateTimeToStr(Now), Sender.CmdLine, ' ' + S_ConsEmulStateLabels[State]]));
        FExitCode := 0; FErrorMsg := '';
      end;
    cesFinished, cesTerminated, cesTerminatedByTimeout:
      begin
        FExitCode := ExitCode;
        if FErrorMsg <> ''
          then ExitStr := Format(S_ErrMsgPatt, [FErrorMsg])
          else ExitStr := '';
        // код процесса имеет смысл только при нормальном завершении
        if State = cesFinished then
          ExitStr := Format(S_ExitCodePatt, [FExitCode, ExitStr]);

        Log(Format(S_ProcessStatePatt, [DateTimeToStr(Now), '', S_ConsEmulStateLabels[State] + ExitStr]));
        lblState.Caption := lblState.Caption + ExitStr;
        if Assigned(OnProcessFinished) then OnProcessFinished(Self, State);
      end;
  end;
end;

// Скрытие формы по Escape
procedure TfrmConsole.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = VK_ESCAPE then Close;
end;

// Запуск приложения в консоли
function TfrmConsole.Launch(const CmdLine: string; LogFN: string; CurrDir: string; EnvVars: string): Boolean;
begin
  Result := False;
  try
     // если лог-файл другой, закрываем его и создаем заново
    if LogFN = ''
      then FLogFile := nil
      else
      begin
        FLogFile := TFileStream.Create(LogFN, fmCreate or fmOpenWrite);
        FLogFile.Seek( 0, soEnd);
      end;
    FConsEmul.Launch(CmdLine, CurrDir, EnvVars);
    Result := True;
  except
    on E: Exception do begin
      Log(Format(S_ErrLaunching, [CmdLine, E.Message]));
      lblState.Caption := Format(S_LblStatePatt, [S_ConsEmulStateLabels[FConsEmul.State], E.Message]);
      FErrorMsg := E.Message;
    end;
  end;
end;

// Запись строки в мемо и в файл
procedure TfrmConsole.Log(Msg: string);
var MsgAnsi: AnsiString;
begin
  // добавляем перевод строки, чтобы не склеивались
  if LeftStr(Msg, 2) <> NL then
    Msg := Msg + NL;
  mConsole.Lines.Add(Msg);
  MsgAnsi := AnsiString(NL+Msg);
  if FLogFile <> nil then
    FLogFile.WriteBuffer(MsgAnsi[ 1], Length(MsgAnsi));
end;

function TfrmConsole.IsRunning: Boolean;
begin
  Result := (FConsEmul.State=cesRunning);
end;
{$ENDIF}
{$ENDREGION}
end.