VPF::Текст из консоли - Форум программистов

V0LT

Дата 9.12.2009, 20:48 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: 1
Всего: 2

Не поможете ли добрые люди с одним вопросом ... никак не могу добится что бы консоль выводила немедленно результат в переменную ...
Создаю поток и pipe, запускаю через CreateProcess консольное окно ... но увы на ReadFile виснет до конца выполнения приложения (при запуске его в консоле должно быть много букв и там прописываются проценты выполнения (как в UPX)) ... от ping проходят нормально частями а стороннее приложение хоть тресни ...

P.S. Как я понимаю проблема с выводом консоли у которой изменяется текст какой то строки в некой позиции ... с консолью что выводит текст наподобии write/writeln таких проблем нет

Это сообщение отредактировал(а) V0LT - 9.12.2009, 22:06

sCreator

Дата 9.12.2009, 23:28 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 84
Регистрация: 20.8.2009
Где: Московская област ь

Репутация: нет
Всего: 5

Тут недавно наткнулся, может поможет ( сам пока не пользовал ) ( автор в модуле не упомянут поэтому указать не могу )

Код


function ExecConsoleApp(const ApplicationName, Parameters: string;
  AppOutput: TStrings; {will receive output of child process}
  OnNewLine: TNotifyEvent {if assigned called on each new line}
  ): DWORD;
const
  CR = #$0D;
  LF = #$0A;
  TerminationWaitTime = 5000;
  ExeExt = '.EXE';
  ComExt = '.COM'; {the original dot com}

var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  SecurityAttributes: TSecurityAttributes;

  TempHandle,
    WriteHandle,
    ReadHandle: THandle;
  ReadBuf: array[0..$100] of Char;
  BytesRead: Cardinal;
  LineBuf: array[0..$100] of Char;
  LineBufPtr: Integer;
  Newline: Boolean;
  i: Integer;
  BinType, SubSyst: DWORD;

  Ext, CommandLine: string;
  AppNameBuf: array[0..MAX_PATH] of Char;
  ExeName: PChar;

{$IFDEF DEBUG}
  ReadCount: Integer;
  StartExec,
    EndExec,
    PerfFreq: Int64;
{$ENDIF}

  procedure OutputLine;
  begin
    LineBuf[LineBufPtr] := #0;
    with AppOutput do
      if Newline then
        Add(LineBuf)
      else
        Strings[Count - 1] := LineBuf; {should never happen with count = 0}
    Newline := false;
    LineBufPtr := 0;
    if Assigned(OnNewLine) then
      OnNewLine(AppOutput);
    ProcessMessages;
  end;

begin
  {Find out about app}
  Ext := UpperCase(ExtractFileExt(ApplicationName));
  if (Ext = '.BAT') or ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Ext = '.CMD')) then
  begin {just have a bash}
    FmtStr(CommandLine, '"%s" %s', [ApplicationName, Parameters])
  end else
    if (Ext = '') or (Ext = ExeExt) or (Ext = ComExt) then {locate and test the application}
    begin
      if SearchPath(nil, PChar(ApplicationName), ExeExt, SizeOf(AppNameBuf), AppNameBuf, ExeName) = 0 then
        raise EInOutError.CreateFmt('Файл %s не найден', [ApplicationName]);
      if Ext = ComExt then
        BinType := SCS_DOS_BINARY
      {in fact, there is no way of telling, but we will just try to run the program. NT is
      equally ignorant and will blindly run anything with a .COM extension}
      else
        GetExecutableInfo(AppNameBuf, BinType, SubSyst);
      if ((BinType = SCS_DOS_BINARY) or (BinType = SCS_DPMI_BINARY)) and
        (Win32Platform = VER_PLATFORM_WIN32_NT) then
        FmtStr(CommandLine, 'cmd /c""%s" %s"', [AppNameBuf, Parameters])
      else
        if (BinType = SCS_32BIT_BINARY) and (SubSyst = IMAGE_SUBSYSTEM_WINDOWS_CUI) then
          FmtStr(CommandLine, '"%s" %s', [AppNameBuf, Parameters])
        else
          raise EInOutError.Create('Образ исполняемого файла не является поддерживаемым типом')
            {Supported types are Win32 Console or MSDOS under Windows NT only}
    end else
    begin
      raise EInOutError.CreateFmt('Файл %s имеет неправильное расширение', [ApplicationName])
    end;

  FillChar(StartupInfo, SizeOf(StartupInfo), 0);
  FillChar(ReadBuf, SizeOf(ReadBuf), 0);
  FillChar(SecurityAttributes, SizeOf(SecurityAttributes), 0);
{$IFDEF DEBUG}
  ReadCount := 0;
  if QueryPerformanceFrequency(PerfFreq) then
    QueryPerformanceCounter(StartExec);
{$ENDIF}
  LineBufPtr := 0;
  Newline := true;
  with SecurityAttributes do
  begin
    ProcessMessages;
    nLength := Sizeof(SecurityAttributes);
    bInheritHandle := true
  end;
  if not CreatePipe(ReadHandle, WriteHandle, @SecurityAttributes, 0) then
    RaiseLastOSError;
  {create a pipe to act as StdOut for the child. The write end will need
   to be inherited by the child process}
  try
    {Read end should not be inherited by child process}
    if Win32Platform = VER_PLATFORM_WIN32_NT then
    begin
      if not SetHandleInformation(ReadHandle, HANDLE_FLAG_INHERIT, 0) then
        RaiseLastOSError
    end else
    begin
      ProcessMessages;
      {SetHandleInformation does not work under Window95, so we
      have to make a copy then close the original}
      if not DuplicateHandle(GetCurrentProcess, ReadHandle,
        GetCurrentProcess, @TempHandle, 0, True, DUPLICATE_SAME_ACCESS) then
        RaiseLastOSError;
      CloseHandle(ReadHandle);
      ReadHandle := TempHandle
    end;

    with StartupInfo do
    begin
      ProcessMessages;
      cb := SizeOf(StartupInfo);
      dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      wShowWindow := SW_HIDE;
      hStdOutput := WriteHandle
    end;
    if not CreateProcess(nil, PChar(CommandLine),
      nil, nil,
      true, {inherit kernel object handles from parent}
      CREATE_NO_WINDOW,
      nil,
      nil,
      StartupInfo,
      ProcessInfo) then
      RaiseLastOSError;

    CloseHandle(ProcessInfo.hThread);
    {not interested in threadhandle - close it}

    CloseHandle(WriteHandle);
    try
      while ReadFile(ReadHandle, ReadBuf, SizeOf(ReadBuf), BytesRead, nil) do
      begin
        ProcessMessages;
        {There are much more efficient ways of doing this: we don't really
        need two buffers, but we do need to scan for CR & LF &&&}
{$IFDEF Debug}
        Inc(ReadCount);
{$ENDIF}
        for i := 0 to BytesRead - 1 do
        begin
          ProcessMessages;
          if (ReadBuf[i] = LF) then
          begin
            Newline := true
          end else
            if (ReadBuf[i] = CR) then
            begin
              OutputLine
            end else
            begin
              LineBuf[LineBufPtr] := ReadBuf[i];
              Inc(LineBufPtr);
              if LineBufPtr >= (SizeOf(LineBuf) - 1) then {line too long - force a break}
              begin
                Newline := true;
                OutputLine
              end
            end
        end
      end;
      WaitForSingleObject(ProcessInfo.hProcess, TerminationWaitTime);
      GetExitCodeProcess(ProcessInfo.hProcess, Result);
      OutputLine {flush the line buffer}

{$IFDEF DEBUG}; {that's how much I dislike null statements!
                   Is there a nobel prize for pedantry?}
      if PerfFreq > 0 then
      begin
        QueryPerformanceCounter(EndExec);
        AppOutput.Add(Format('Отладка: (readcount = %d), ExecTime = %.3f мс',
          [ReadCount, ((EndExec - StartExec) * 1000.0) / PerfFreq]))
      end else
      begin
        AppOutput.Add(Format('Отладка: (readcount = %d)', [ReadCount]))
      end
{$ENDIF}
    finally
      CloseHandle(ProcessInfo.hProcess)
    end
  finally
    CloseHandle(ReadHandle)
  end
end;

Если не помогло то пиши как сам делал будем посмотреть.

V0LT

Дата 11.12.2009, 15:36 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: 1
Всего: 2

Не Работает smile

точнее работает но снова тупо ждёт конца выполнения

Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, SyncObjs, uChildProc;

type
  TForm1 = class(TForm)
    btn1: TButton;
    mmo1: TMemo;
    procedure btn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TEThread = class(TThread)
  private
    List: TStringList;
    procedure add(Output: TStringList);
  protected
    constructor Create;
    procedure Execute; override;
  end;

  TCEvent = procedure(Output: TStringList) of object;
const
  SCS_VXD_BINARY = 6;  {linear executable. Could be OS/2. NT thinks DOS!}
  SCS_WIN32_DLL = 7;
  SCS_DPMI_BINARY = 8; {guessing a bit here. Based on NE header loader flags}
var
  Form1: TForm1;

implementation

{$R *.dfm}


procedure GetExecutableInfo( const Filename: String; var BinaryType, Subsystem: DWORD);
var
  f: File;
  ImageDosHeader: IMAGE_DOS_HEADER;
  ImageFileHeader: IMAGE_FILE_HEADER;
  ImageOptionalHeader: IMAGE_OPTIONAL_HEADER;
  Signature: DWORD;
  NEType: Byte;
  OldFileMode: integer;
begin
  OldFileMode:=FileMode;
  FileMode:=fmOpenRead;
  AssignFile(f, Filename);
  Reset(f, 1); {note that this will fail if file is open. this is a bug really,
                but not a big one. Use Api File calls to work around}
  try
    BlockRead(f, ImageDosHeader, Sizeof(ImageDosHeader));
    if (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) then {not executable}
      raise EInOutError.Create('Dos signature not present');
    try   {16 bit dos program might not have new header}
      Seek(f, ImageDosHeader._lfanew);
      BlockRead(f, Signature, SizeOf(Signature));
      Signature:= Signature and $FFFF;
    except
      on EInOutError do
        Signature:= 0
    end;
    case Signature of
      IMAGE_OS2_SIGNATURE: {New Executable}
      begin
        Seek(f, FilePos(f) + $32); {loader flags are $36 bytes into NE header, but we
                                    have already read 4 bytes for PE signature}
        BlockRead(f, NEType, SizeOf(NEType));
        case NEType of
          1: BinaryType:= SCS_DPMI_BINARY;  {guessing a bit here}
          2: BinaryType:= SCS_WOW_BINARY;
        else
          BinaryType:= SCS_OS216_BINARY; {presumably. I don't have one to check the loader flags!}
        end
      end;
      IMAGE_OS2_SIGNATURE_LE: BinaryType:= SCS_VXD_BINARY;
      IMAGE_NT_SIGNATURE: BinaryType:= SCS_32BIT_BINARY;
    else
      BinaryType:= SCS_DOS_BINARY;
    end;
    Subsystem:= IMAGE_SUBSYSTEM_UNKNOWN;
    if (BinaryType = SCS_32BIT_BINARY)then
    begin
      BlockRead(f, ImageFileHeader, SizeOf(ImageFileHeader));
      if (ImageFileHeader.Characteristics and IMAGE_FILE_EXECUTABLE_IMAGE) = 0 then
        raise EInOutError.Create('File is not executable');  {could be COFF obj}
      if (ImageFileHeader.Characteristics and IMAGE_FILE_DLL) = IMAGE_FILE_DLL then
      begin
        BinaryType:= SCS_WIN32_DLL
      end else
      begin
        BlockRead(f, ImageOptionalHeader, SizeOf(ImageOptionalHeader));
        Subsystem:= ImageOptionalHeader.Subsystem
      end
    end
  finally
    CloseFile(f);
    FileMode:=OldFileMode;
  end
end;

function ExecConsoleApp(const ApplicationName, Parameters: string;
  AppOutput: TStringList; {will receive output of child process}
  OnNewLine: TCEvent {if assigned called on each new line}
  ): DWORD;
const
  CR = #$0D;
  LF = #$0A;
  TerminationWaitTime = 5000;
  ExeExt = '.EXE';
  ComExt = '.COM'; {the original dot com}
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  SecurityAttributes: TSecurityAttributes;
  TempHandle,
    WriteHandle,
    ReadHandle: THandle;
  ReadBuf: array[0..$100] of Char;
  BytesRead: Cardinal;
  LineBuf: array[0..$100] of Char;
  LineBufPtr: Integer;
  Newline: Boolean;
  i: Integer;
  BinType, SubSyst: DWORD;
  Ext, CommandLine: string;
  AppNameBuf: array[0..MAX_PATH] of Char;
  ExeName: PChar;
{$IFDEF DEBUG}
  ReadCount: Integer;
  StartExec,
    EndExec,
    PerfFreq: Int64;
{$ENDIF}
  procedure OutputLine;
  begin
    LineBuf[LineBufPtr] := #0;
    with AppOutput do
      if Newline then
        Add(LineBuf)
      else
        Strings[Count - 1] := LineBuf; {should never happen with count = 0}
    Newline := false;
    LineBufPtr := 0;
    if Assigned(OnNewLine) then
      OnNewLine(AppOutput);
    Application.ProcessMessages;
  end;
begin
  {Find out about app}
  Ext := UpperCase(ExtractFileExt(ApplicationName));
  if (Ext = '.BAT') or ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Ext = '.CMD')) then
  begin {just have a bash}
    FmtStr(CommandLine, '"%s" %s', [ApplicationName, Parameters])
  end else
    if (Ext = '') or (Ext = ExeExt) or (Ext = ComExt) then {locate and test the application}
    begin
      if SearchPath(nil, PChar(ApplicationName), ExeExt, SizeOf(AppNameBuf), AppNameBuf, ExeName) = 0 then
        raise EInOutError.CreateFmt('Файл %s не найден', [ApplicationName]);
      if Ext = ComExt then
        BinType := SCS_DOS_BINARY
      {in fact, there is no way of telling, but we will just try to run the program. NT is
      equally ignorant and will blindly run anything with a .COM extension}
      else
        GetExecutableInfo(AppNameBuf, BinType, SubSyst);
      if ((BinType = SCS_DOS_BINARY) or (BinType = SCS_DPMI_BINARY)) and
        (Win32Platform = VER_PLATFORM_WIN32_NT) then
        FmtStr(CommandLine, 'cmd /c""%s" %s"', [AppNameBuf, Parameters])
      else
        if (BinType = SCS_32BIT_BINARY) and (SubSyst = IMAGE_SUBSYSTEM_WINDOWS_CUI) then
          FmtStr(CommandLine, '"%s" %s', [AppNameBuf, Parameters])
        else
          raise EInOutError.Create('Образ исполняемого файла не является поддерживаемым типом')
            {Supported types are Win32 Console or MSDOS under Windows NT only}
    end else
    begin
      raise EInOutError.CreateFmt('Файл %s имеет неправильное расширение', [ApplicationName])
    end;
  FillChar(StartupInfo, SizeOf(StartupInfo), 0);
  FillChar(ReadBuf, SizeOf(ReadBuf), 0);
  FillChar(SecurityAttributes, SizeOf(SecurityAttributes), 0);
{$IFDEF DEBUG}
  ReadCount := 0;
  if QueryPerformanceFrequency(PerfFreq) then
    QueryPerformanceCounter(StartExec);
{$ENDIF}
  LineBufPtr := 0;
  Newline := true;
  with SecurityAttributes do
  begin
    Application.ProcessMessages;
    nLength := Sizeof(SecurityAttributes);
    bInheritHandle := true
  end;
  if not CreatePipe(ReadHandle, WriteHandle, @SecurityAttributes, 0) then
    RaiseLastOSError;
  {create a pipe to act as StdOut for the child. The write end will need
   to be inherited by the child process}
  try
    {Read end should not be inherited by child process}
    if Win32Platform = VER_PLATFORM_WIN32_NT then
    begin
      if not SetHandleInformation(ReadHandle, HANDLE_FLAG_INHERIT, 0) then
        RaiseLastOSError
    end else
    begin
      Application.ProcessMessages;
      {SetHandleInformation does not work under Window95, so we
      have to make a copy then close the original}
      if not DuplicateHandle(GetCurrentProcess, ReadHandle,
        GetCurrentProcess, @TempHandle, 0, True, DUPLICATE_SAME_ACCESS) then
        RaiseLastOSError;
      CloseHandle(ReadHandle);
      ReadHandle := TempHandle
    end;
    with StartupInfo do
    begin
      Application.ProcessMessages;
      cb := SizeOf(StartupInfo);
      dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      wShowWindow := SW_HIDE;
      hStdOutput := WriteHandle
    end;
    if not CreateProcess(nil, PChar(CommandLine),
      nil, nil,
      true, {inherit kernel object handles from parent}
      CREATE_NO_WINDOW,
      nil,
      nil,
      StartupInfo,
      ProcessInfo) then
      RaiseLastOSError;
    CloseHandle(ProcessInfo.hThread);
    {not interested in threadhandle - close it}
    CloseHandle(WriteHandle);
    try
      while ReadFile(ReadHandle, ReadBuf, SizeOf(ReadBuf), BytesRead, nil) do
      begin
        Application.ProcessMessages;
        {There are much more efficient ways of doing this: we don't really
        need two buffers, but we do need to scan for CR & LF &&&}
{$IFDEF Debug}
        Inc(ReadCount);
{$ENDIF}
        for i := 0 to BytesRead - 1 do
        begin
          Application.ProcessMessages;
          if (ReadBuf[i] = LF) then
          begin
            Newline := true
          end else
            if (ReadBuf[i] = CR) then
            begin
              OutputLine
            end else
            begin
              LineBuf[LineBufPtr] := ReadBuf[i];
              Inc(LineBufPtr);
              if LineBufPtr >= (SizeOf(LineBuf) - 1) then {line too long - force a break}
              begin
                Newline := true;
                OutputLine
              end
            end
        end
      end;
      WaitForSingleObject(ProcessInfo.hProcess, TerminationWaitTime);
      GetExitCodeProcess(ProcessInfo.hProcess, Result);
      OutputLine {flush the line buffer}
{$IFDEF DEBUG}; {that's how much I dislike null statements!
                   Is there a nobel prize for pedantry?}
      if PerfFreq > 0 then
      begin
        QueryPerformanceCounter(EndExec);
        AppOutput.Add(Format('Отладка: (readcount = %d), ExecTime = %.3f мс',
          [ReadCount, ((EndExec - StartExec) * 1000.0) / PerfFreq]))
      end else
      begin
        AppOutput.Add(Format('Отладка: (readcount = %d)', [ReadCount]))
      end
{$ENDIF}
    finally
      CloseHandle(ProcessInfo.hProcess)
    end
  finally
    CloseHandle(ReadHandle)
  end
end;

//==============================================================================
// Начинаем страдать хернёй
//==============================================================================

constructor TEThread.Create;
begin
  FreeOnTerminate := True;
  inherited Create(false);
end;

procedure TEThread.add(Output: TStringList);
begin
  Form1.mmo1.Lines.Assign(Output);
end;

procedure TEThread.Execute;
var
  d: TStringList;
  sd: DWORD;
  Method: TCEvent;
begin
  d := TStringList.Create;
  Method := add;
  ExecConsoleApp('precomp','-r arch.pcf',d, Method);
end;


procedure TForm1.btn1Click(Sender: TObject);
var
  e,d,f,a: TStringList;
  sd: DWORD;
  Method: TCEvent;
  EThread: TEThread;
begin
  EThread := TEThread.Create;
end;

end.

Это сообщение отредактировал(а) V0LT - 11.12.2009, 15:41

sCreator

Дата 11.12.2009, 19:26 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 84
Регистрация: 20.8.2009
Где: Московская област ь

Репутация: нет
Всего: 5

Пока несколько советов:
- в STARTUPINFO есть еще hStdError для вывода сообщений ошибок обычно он считается более быстрым выводом и поэтому возможно проценты выводятся через него.
Попробуй для начала подсоединиться к нему вместо hStdOutput.
Если получится, тогда уже можно пробовать и от туда и от туда, пока вычитал что ReadFile ждет до конца вывода или заполнения буфера
- кстати можно попробовать буфер уменьшить.
- можно попробовать сперва без Thread там вроде вставлены ProcessMessages а они только для основного процесса нужны.

у тебя вывод из нити в мемо без синхронизации - не смертельно но как то я такое допустил и у меня была неприятность ( подробности непомню )

Интересно бы самому попробовать - если этот precomp без большого окружения работает выложи с каким нибуть pcf.
Во всяком случае в случае удачи отпишись. ( случай интересный - авось когда и самому сгодится ).
Ну а при неудачи естесно пиши, а я постараюсь у себя с эмулировать.

Будут еще мысли сообщу.

V0LT

Дата 11.12.2009, 19:39 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: 1
Всего: 2

- кстати можно попробовать буфер уменьшить (делал - 0 эффекта)
- можно попробовать сперва без Thread (делал - 0 эффекта)
- у тебя вывод из нити в мемо без синхронизации (непринципиально - Method выполняется только после окончания работы precomp.exe)

http://schnaader.info/precomp.html
Прекомпрессия: precomp -slow image.zip
На выходе имеем файл image.pcf - это и есть файл с разжатыми zLib-потоками, который, в отличие от оригинала image.zip, жмётся тем же севензипом на ура (в результате размер архива уменьшается на 5-30%).
Обратная рекомпрессия: precomp -r image.pcf
На выходе имеем файл image.zip, т.е. исходный оригинал.
хочу брать процентики выполнения ...

Возьмите любой большой zip архив (300 - 500 мб хватит) выполни precomp -slow arch.zip
получится arch.pcf и вот с ним я работаю

P.S. Знаю через какое место делается такое (что бы печатать в нужном месте консоли .. а читать видимо придется ещё извращённее сделать)

Это сообщение отредактировал(а) V0LT - 11.12.2009, 19:49

sCreator

Дата 16.12.2009, 10:56 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 84
Регистрация: 20.8.2009
Где: Московская област ь

Репутация: нет
Всего: 5

Вчера вечером посидел над данным вопросом.
Пробовал и с precomp.exe и просто сделал тест:

Код


program consolOutTest;
{$APPTYPE CONSOLE}
uses
  SysUtils, ExecTools;
type
  TOutConLine = class
    class procedure AddLine(const line: string);
  end;
{ TOutConLine }
class procedure TOutConLine.AddLine(const line: string);
begin
  Writeln(line);
end;
var
  i: string;
begin
  Writeln('Run test consolOutTest');
  Writeln('');
  WaitExec('PrecompTest', TOutConLine.AddLine);
  Writeln('');
  Writeln('Stop test consolOutTest');
  Read(i);
end.

Вот функция без блокировки ReadFile:

Код


type
  TOutputLine = procedure(const line: string) of object;

function WaitExec(const commandLine: string; const customOutput: TOutputLine = nil;
  currentDirectory: string = ''): DWORD;

function WaitExecConsolOut(const commandLine: string): DWORD;

implementation

uses
  SysUtils, StrUtils;

function WaitExec(const commandLine: string; const customOutput: TOutputLine = nil;
  currentDirectory: string = ''): DWORD;
const
  lineBreak = #13#10;
var
  piece: string;
  inputPipe, outputPipe: Cardinal;
  byteCount: DWORD;

  securityAttributes: TSecurityAttributes;
  processInfo: TProcessInformation;
  startupInfo: TStartupInfo;

  breakPos: Integer;
  lpMode: DWORD;
  flushbuf: PChar;
begin
  securityAttributes.nLength := SizeOf(TSecurityAttributes);
  securityAttributes.bInheritHandle := True;
  securityAttributes.lpSecurityDescriptor := nil;

  if Assigned(customOutput) then
    if not CreatePipe(inputPipe, outputPipe, @securityAttributes, 0) then
      RaiseLastOSError();             //  }

  try
    ZeroMemory(@startupInfo, SizeOf(TStartupInfo));
    startupInfo.cb := SizeOf(TStartupInfo);
    startupInfo.dwFlags := STARTF_USESHOWWINDOW;
    startupInfo.wShowWindow := SW_SHOW;

    if Assigned(customOutput) then
    begin
      if not SetHandleInformation(inputPipe, HANDLE_FLAG_INHERIT, 0) then
        RaiseLastOSError;  //}

      if not SetHandleInformation(outputPipe, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT) then
        RaiseLastOSError;  //}

      startupInfo.hStdError := outputPipe;
      startupInfo.hStdOutput := outputPipe;
      startupInfo.dwFlags := startupInfo.dwFlags or STARTF_USESTDHANDLES;
      startupInfo.wShowWindow := SW_HIDE;
    end;

    if currentDirectory = '' then
      currentDirectory := GetCurrentDir();
                                                         //   false
    if not CreateProcess(nil, PChar(commandLine), nil, nil, True,
        CREATE_NO_WINDOW,//   DETACHED_PROCESS
        nil,
        PChar(currentDirectory), startupInfo, processInfo)
    then
      RaiseLastOSError();
    try
//      WaitForInputIdle(processInfo.hProcess, 1000);
      CloseHandle(processInfo.hThread);
      if Assigned(customOutput) then
      begin
        piece := '';
        repeat
          Result := WaitForSingleObject(processInfo.hProcess, 200);
          if Result = WAIT_FAILED then
            RaiseLastOSError();

          PeekNamedPipe(inputPipe, nil, 0, nil, @byteCount, nil);
          if byteCount > 0 then
          begin
            SetLength(piece, byteCount + DWORD(Length(piece))); // DWORD( - чтобы убрать Warning "Combining signed and unsigned..."
            ReadFile(inputPipe, (PChar(piece) + Length(piece) - byteCount)^, Length(piece), byteCount, nil);
            OemToChar(PChar(piece), PChar(piece));

            breakPos := Pos(lineBreak, piece);
            while breakPos > 0 do
            begin
              customOutput(LeftStr(piece, breakPos - 1));
              Delete(piece, 1, breakPos + Length(lineBreak) - 1);
              breakPos := Pos(lineBreak, piece);
            end;

          end;

        until Result <> WAIT_TIMEOUT;

        if Length(piece) > 0 then
          customOutput(piece);

      end
      else // if Assigned(customOutput)
        Result := WaitForSingleObject(processInfo.hProcess, INFINITE);

    finally
      CloseHandle(processInfo.hProcess);

    end;

  finally
    if Assigned(customOutput) then
    begin
      CloseHandle(inputPipe);
      CloseHandle(outputPipe);
    end;
  end;

end;

Но это не помогает.
Как только к создаваемому процессу присоединяется pipe, вывод изи него становится буферизированным даже на экран. ( пробовал без скрытия консоли )
По идеи этот буфер назначается последним параметром в CreatePipe(inputPipe, outputPipe, @securityAttributes, 0) ( если 0 - задается системой ) - но мои попытки смены размера этого буфера положительных результатов не дали.
Причем это не зависит от выдачи символов #8 для затирания процентов или вывода построчно, а зависит только от наполнения буфера pipe.
Пробовал еще

Код


      lpMode := PIPE_NOWAIT or PIPE_READMODE_MESSAGE;
      SetNamedPipeHandleState(outputPipe, lpMode, nil, nil); //}

Без результатно.
Пока вижу 2 варианта для проб:
- создавать NamedPipe.
- работать с буфером консоли создаваемого процесса ( если это возможно ).
Будет что новенькое - отпишусь.

V0LT

Дата 17.12.2009, 17:59 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: 1
Всего: 2

Спасибо Creator, всё тщетно ... сделал методом дзена smile

В IDA рассмотрел сия экзешник, пропатчил - проблема решена (Windows 7 в пролёте ... там сия метод не заработал)

Это сообщение отредактировал(а) V0LT - 17.12.2009, 18:00

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: WinAPI и системное программирование \| Следующая тема »