Интерактивная работа с консолью

 
unit con_redir_mail;
interface
uses windows, sysutils;
type
  TRedirConsMailSlot = class
  private
    FnameSlotRead: string;
    FReadLocal: thandle;
    FwriteRemote: thandle;
 
    FnameSlotWrite: string;
    FwriteLocal: thandle;
    FreadRemote: thandle;
    ferr: integer;
    fpi: TProcessInformation;
    Fdir: string;
    Fapp: string;
    Fcmdline: string;
 
  public
    procedure writeconsol(s: ansistring);
    function GetMsgCount: integer;
    function GetMsgSize: dword;
    function WaitMesaage(time_out: dword): boolean;
    function ReadConsol: string;
    destructor destroy; overload;
    property dir: string read Fdir write Fdir;
    property App: string read Fapp write Fapp;
    property Cmdline: string read Fcmdline write Fcmdline;
 
    procedure inithand;
    procedure RunApp;
    constructor create;
  end;
 
implementation
 
function TRedirConsMailSlot.GetMsgSize: dword;
var
  sz, cnt: cardinal;
begin
  GetMailslotInfo(FReadLocal, nil, sz, @cnt, nil);
  if cnt <> 0 then
    result := sz
  else
    result := 0;
end;
 
procedure TRedirConsMailSlot.inithand;
var
  sa: SECURITY_ATTRIBUTES;
   tmp1:thandle;
begin
  sa.nLength := SizeOf(SECURITY_ATTRIBUTES);
  sa.bInheritHandle := True;
  sa.lpSecurityDescriptor := nil;
 
  // создаем слот через который будем читать консоль  дочернего процесса
  FnameSlotRead := '\\.\mailslot\' + inttostr(gettickcount());
  FReadLocal := CreateMailslot(pchar(FnameSlotRead), 0, MAILSLOT_WAIT_FOREVER, @sa);
 // SetHandleInformation(FReadLocal, HANDLE_FLAG_INHERIT, 0);
 
  FwriteRemote := createfile(pchar(FnameSlotRead), GENERIC_WRITE, FILE_SHARE_write or FILE_SHARE_READ , @sa, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL, 0);
 SetHandleInformation(FwriteRemote, HANDLE_FLAG_INHERIT, 0);
 
 {  if not DuplicateHandle(GetCurrentProcess(), FwriteRemote,
    GetCurrentProcess(), @tmp1, 0, false, DUPLICATE_SAME_ACCESS) then
    exit;
   closehandle(fwriteremote);
   fwriteremote:=tmp1;  }
 
 
  // создаем слот через который будем писать в консоль дочернего процесса
  FnameSlotWrite := '\\.\mailslot\' + inttostr(gettickcount() + 123);
  FreadRemote := CreateMailslot(pchar(FnameSlotWrite), 0, MAILSLOT_WAIT_FOREVER, @sa);
   SetHandleInformation(FreadRemote, HANDLE_FLAG_INHERIT, 0);
 
   { if not DuplicateHandle(GetCurrentProcess(), FreadRemote,
    GetCurrentProcess(), @tmp1, 0, false, DUPLICATE_SAME_ACCESS) then
    exit;
     closehandle(FreadRemote);
     FreadRemote:=tmp1;     }
 
 
  FwriteLocal := createfile(pchar(FnameSlotWrite), GENERIC_WRITE, FILE_SHARE_write or FILE_SHARE_READ, @sa, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL, 0);
  //SetHandleInformation(FwriteLocal, HANDLE_FLAG_INHERIT, 0);
end;
 
destructor TRedirConsMailSlot.destroy;
begin
 
  if FReadLocal <> 0 then
    closehandle(FReadLocal);
  if FwriteRemote <> 0 then
    closehandle(FwriteRemote);
  if FwriteLocal <> 0 then
    closehandle(FwriteLocal);
  if FreadRemote <> 0 then
    closehandle(FreadRemote);
  TerminateProcess(fpi.hProcess, 0);
  // if fpi.hThread <> 0 then
  // CloseHandle(fpi.hThread);
  if fpi.hProcess <> 0 then
    closehandle(fpi.hProcess);
 
end;
 
function TRedirConsMailSlot.GetMsgCount: integer;
var
  sz, cnt: cardinal;
begin
  GetMailslotInfo(FReadLocal, nil, sz, @cnt, nil);
  result := cnt;
end;
 
function TRedirConsMailSlot.ReadConsol: string;
var
  msz: dword;
  buf: ansistring;
begin
  result := '';
  msz := GetMsgSize();
  while msz <> 0 do
  begin
    setlength(buf, msz);
    fileread(FReadLocal, buf[1], msz);
    result := result + buf;
    msz := GetMsgSize();
  end;
end;
 
procedure TRedirConsMailSlot.RunApp;
var
  si: TStartupInfo;
begin
  inithand;
  FillChar(si, SizeOf(TStartupInfo), 0);
  si.dwFlags :=  STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES ;
  si.wShowWindow :=SW_Show; //SW_HIDE;
  si.hStdOutput := FwriteRemote;
  si.hStdError := FwriteRemote;
  si.hStdInput := FreadRemote;
 
  sleep(1000);
  if not CreateProcess(pchar(Fapp), pchar(Fcmdline), nil, nil, true, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, pchar(Fdir), si, fpi) then
  begin
    // MessageBox(0, PChar('error CreateProcess #' + IntToStr(GetLastError)), nil, MB_OK);
    ferr := 2;
    Exit;
  end;
end;
 
function TRedirConsMailSlot.WaitMesaage(time_out: dword): boolean;
var
  start_timer: uint64;
begin
  result := True;
  start_timer := gettickcount();
  while (gettickcount() - start_timer) < time_out do
  begin
    if GetMsgCount <> 0 then
    begin
      result := True;
      Exit;
    end;
 
    sleep(5);
  end;
 
end;
 
procedure TRedirConsMailSlot.writeconsol(s: ansistring);
var
  witten: cardinal;
begin
  if not writefile(FwriteLocal, s[1], length(s), witten, nil) then
    ferr := 9;
end;
 
constructor TRedirConsMailSlot.create;
begin
  FnameSlotRead := '';
  FReadLocal := 0;
  FwriteRemote := 0;
  FnameSlotWrite := '';
  FwriteLocal := 0;
  FreadRemote := 0;
  ferr := 0;
  FillChar(fpi, SizeOf(fpi), 0);
end;
 
end.

 var  xx:TRedirConsMailSlot;
 ss:string;
begin
    xx:=TRedirConsMailSlot.create;
    xx.App:='D:\PRJ\Mprojects\pjsip_adapt\pipes_prj_ua\pip_vcl\tconsol.exe';
    xx.dir:='D:\PRJ\Mprojects\pjsip_adapt\pipes_prj_ua\pip_vcl\';
    xx.Cmdline:=' ';
    xx.runapp;
 
    if xx.WaitMesaage(1024*2) then
    begin
    ss :=xx.ReadConsol;
    memo1.Lines.Add(ss);
    end;
 
    xx.Free;
end