Test

From volax, 10 Years ago, written in Plain Text.

URL http://geopaste.scratchbook.ch/view/fe2ad890

Embed

unit Utils.ConsoleRedirector;

interface

uses

Windows;

type

TConsoleRedirector = class;

TConsoleFinishedEvent = procedure(Sender: TConsoleRedirector) of object;

TConsoleTextEvent = procedure(Sender: TConsoleRedirector; Text: string) of object;

TConsoleRedirector = class

private

FWorkingThread: THandle; // thread to receive the output of the child process

FStopEvent: THandle; // event to notify the redir thread to exit

FWorkingThreadId: Cardinal; // id of the redir thread

FWaitTime: Cardinal;

FOnStdoutText: TConsoleTextEvent;

FOnStderrText: TConsoleTextEvent;

FOnFinished: TConsoleFinishedEvent; // wait time to check the status of the child process

FStdInWritePipe: THandle; // write end of child's stdin pipe

FStdOutReadPipe: THandle; // read end of child's stdout pipe

FChildProcess: THandle;

protected

function LaunchChild(CommandLine: string; StdOutHandle, StdInHandle, StdErrHandle: THandle): Boolean;

function RedirectStdout: Integer;

procedure DestroyHandle(var Handle: THandle);

procedure DoStdOutEvent(Text: AnsiString); virtual;

procedure DoStdErrorEvent(Text: AnsiString); virtual;

procedure DoFinishedEvent; virtual;

public

constructor Create;

destructor Destroy; override;

function Open(CommandLine: string): Boolean;

procedure Close; virtual;

function Write(Text: AnsiString): Boolean;

property WaitTime: Cardinal read FWaitTime write FWaitTime;

property OnStdoutText: TConsoleTextEvent read FOnStdoutText write FOnStdoutText;

property OnStderrText: TConsoleTextEvent read FOnStderrText write FOnStderrText;

property OnFinished: TConsoleFinishedEvent read FOnFinished write FOnFinished;

end;

implementation

uses

SysUtils,

Math;

{ TConsoleRedirector }

procedure TConsoleRedirector.Close;

begin

if FWorkingThread <> 0 then

begin

// this function might be called from redir thread

if GetCurrentThreadId <> FWorkingThreadId then

begin

SetEvent(FStopEvent);

if WaitForSingleObject(FWorkingThread, 5000) = WAIT_TIMEOUT then

begin

DoStdErrorEvent('The redir thread is dead');

TerminateThread(FWorkingThread, Cardinal(-2));

end;

end;

DestroyHandle(FWorkingThread);

end;

DestroyHandle(FStopEvent);

DestroyHandle(FChildProcess);

DestroyHandle(FStdInWritePipe);

DestroyHandle(FStdOutReadPipe);

FWorkingThreadId := 0;

end;

constructor TConsoleRedirector.Create;

begin

inherited Create;

FStdInWritePipe := 0;

FStdOutReadPipe := 0;

FChildProcess := 0;

FWorkingThread := 0;

FStopEvent := 0;

FWorkingThreadId := 0;

FWaitTime := 100;

end;

destructor TConsoleRedirector.Destroy;

begin

Close;

inherited Destroy;

end;

procedure TConsoleRedirector.DestroyHandle(var Handle: THandle);

begin

if Handle <> 0 then

begin

CloseHandle(Handle);

Handle := 0;

end;

end;

function TConsoleRedirector.LaunchChild(CommandLine: string; StdOutHandle, StdInHandle, StdErrHandle: THandle): Boolean;

var

vPI: PROCESS_INFORMATION;

vSI: STARTUPINFO;

begin

// Set up the start up info struct.

ZeroMemory(@vSI, SizeOf(vSI));

vSI.cb := SizeOf(vSI);

vSI.hStdOutput := StdOutHandle;

vSI.hStdInput := StdInHandle;

vSI.hStdError := StdErrHandle;

vSI.wShowWindow := SW_HIDE;

vSI.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;

// Note that dwFlags must include STARTF_USESHOWWINDOW if we

// use the wShowWindow flags. This also assumes that the

// CreateProcess() call will use CREATE_NEW_CONSOLE.

// Launch the child process.

if not CreateProcess(nil, PChar(CommandLine), nil, nil, True, CREATE_NEW_CONSOLE, nil, nil, vSI, vPI) then

Result := False

else

begin

FChildProcess := vPI.hProcess;

// Close any unuseful handles

CloseHandle(vPI.hThread);

Result := True;

end;

end;

// thread to receive output of the child process

function OutputThread(lpvThreadParam: Pointer): Cardinal; stdcall;

var

vWaitHandles: array [0 .. 1] of THandle;

vRedirector: TConsoleRedirector;

vWaitResult: Cardinal;

vRedirectResult: Integer;

begin

vRedirector := TConsoleRedirector(lpvThreadParam);

vWaitHandles[0] := vRedirector.FChildProcess;

vWaitHandles[1] := vRedirector.FStopEvent;

// redirect stdout till there's no more data.

vRedirectResult := vRedirector.RedirectStdout;

while vRedirectResult > 0 do

begin

// check if the child process has terminated.

vWaitResult := WaitForMultipleObjects(2, @vWaitHandles, False, vRedirector.FWaitTime);

case vWaitResult of

WAIT_OBJECT_0: // the child process ended

begin

vRedirectResult := vRedirector.RedirectStdout;

if vRedirectResult > 0 then

vRedirectResult := 0;

Break;

end;

WAIT_OBJECT_0 + 1: // m_hEvtStop was signalled

begin

vRedirectResult := 1; // cancelled

Break;

end;

end;

// Next redirect:

vRedirectResult := vRedirector.RedirectStdout;

end;

// close handles

vRedirector.Close;

Result := vRedirectResult;

end;

function TConsoleRedirector.Open(CommandLine: string): Boolean;

var

vStdOutReadPipe: THandle; // parent stdout read handle

vStdOutWritePipe, vStdErrWritePipe: THandle; // child stdout write handle

vStdInWritePipe: THandle; // parent stdin write handle

vStdInReadPipe: THandle; // child stdin read handle

vSA: SECURITY_ATTRIBUTES;

begin

Close;

Result := False;

vStdOutReadPipe := 0;

vStdOutWritePipe := 0;

vStdErrWritePipe := 0;

vStdInWritePipe := 0;

vStdInReadPipe := 0;

// Set up the security attributes struct.

vSA.nLength := SizeOf(SECURITY_ATTRIBUTES);

vSA.lpSecurityDescriptor := nil;

vSA.bInheritHandle := True;

try

// Create a child stdout pipe.

if not CreatePipe(vStdOutReadPipe, vStdOutWritePipe, @vSA, 0) then

RaiseLastOSError;

// Create a duplicate of the stdout write handle for the std

// error write handle. This is necessary in case the child

// application closes one of its std output handles.

if not DuplicateHandle(GetCurrentProcess, vStdOutWritePipe, GetCurrentProcess, @vStdErrWritePipe, 0, True, DUPLICATE_SAME_ACCESS) then

RaiseLastOSError;

// Create a child stdin pipe.

if not CreatePipe(vStdInReadPipe, vStdInWritePipe, @vSA, 0) then

RaiseLastOSError;

// Create new stdout read handle and the stdin write handle.

// Set the inheritance properties to FALSE. Otherwise, the child

// inherits the these handles; resulting in non-closeable

// handles to the pipes being created.

if not DuplicateHandle(GetCurrentProcess, vStdOutReadPipe, GetCurrentProcess, @FStdOutReadPipe, 0, False {make it uninheritable}, DUPLICATE_SAME_ACCESS) then

RaiseLastOSError;

if not DuplicateHandle(GetCurrentProcess, vStdInWritePipe, GetCurrentProcess, @FStdInWritePipe, 0, False {make it uninheritable}, DUPLICATE_SAME_ACCESS) then

RaiseLastOSError;

// Close inheritable copies of the handles we do not want to

// be inherited.

DestroyHandle(vStdOutReadPipe);

DestroyHandle(vStdInWritePipe);

// launch the child process

if not LaunchChild(CommandLine, vStdOutWritePipe, vStdInReadPipe, vStdErrWritePipe) then

RaiseLastOSError;

// Child is launched. Close the parents copy of those pipe

// handles that only the child should have open.

// Make sure that no handles to the write end of the stdout pipe

// are maintained in this process or else the pipe will not

// close when the child process exits and ReadFile will hang.

DestroyHandle(vStdOutWritePipe);

DestroyHandle(vStdInReadPipe);

DestroyHandle(vStdErrWritePipe);

// Launch a thread to receive output from the child process.

FStopEvent := CreateEvent(nil, True, False, nil);

FWorkingThread := Windows.CreateThread(nil, 0, @OutputThread, self, 0, FWorkingThreadId);

if FWorkingThread = 0 then

RaiseLastOSError;

Result := True;

except

on E: Exception do

begin

DestroyHandle(vStdOutReadPipe);

DestroyHandle(vStdOutWritePipe);

DestroyHandle(vStdErrWritePipe);

DestroyHandle(vStdInWritePipe);

DestroyHandle(vStdInReadPipe);

Close;

DoStdErrorEvent(AnsiString(E.Message));

//DONE: raise;

end;

end;

end;

// redirect the child process's stdout:

// return: 1: no more data, 0: child terminated, -1: os error

function TConsoleRedirector.RedirectStdout: Integer;

const

cBufferSize = 255;

var

vBytesAvailable, vBytesRead, vErrorCode: Cardinal;

vBuffer: array [0 .. cBufferSize] of AnsiChar;

begin

// Проверяем количество доступных байт в пайпе:

while PeekNamedPipe(FStdOutReadPipe, nil, 0, nil, @vBytesAvailable, nil) do

begin

// Если чтение успешно, но байт больше нет, то программа завершилась, выходим:

if vBytesAvailable = 0 then

begin

Result := 1; // not data available

Exit;

end;

vBytesRead := 0;

if not ReadFile(FStdOutReadPipe, vBuffer, Min(cBufferSize, vBytesAvailable), vBytesRead, nil) or (vBytesRead = 0) then

Break; // error, the child might ended

vBuffer[vBytesRead] := #0;

OemToAnsi(vBuffer, vBuffer);

DoStdOutEvent(vBuffer);

end;

// pipe has been ended or pipe closing in progress:

vErrorCode := GetLastError;

if (vErrorCode = ERROR_BROKEN_PIPE) or (vErrorCode = ERROR_NO_DATA) then

begin

DoFinishedEvent;

Result := 0; // child process ended

Exit;

end;

DoStdErrorEvent('Read stdout pipe error' + #13#10);

Result := -1; // os error

end;

function TConsoleRedirector.Write(Text: AnsiString): Boolean;

var

vBytesWritten: Cardinal;

begin

if FStdInWritePipe <> 0 then

if Text <> '' then

Result := WriteFile(FStdInWritePipe, Text[1], Length(Text), vBytesWritten, nil)

else

Result := True

else

Result := False;

end;

procedure TConsoleRedirector.DoFinishedEvent;

begin

if Assigned(FOnFinished) then

FOnFinished(self);

end;

procedure TConsoleRedirector.DoStdErrorEvent(Text: AnsiString);

begin

if Assigned(FOnStderrText) then

FOnStderrText(self, string(Text));

end;

procedure TConsoleRedirector.DoStdOutEvent(Text: AnsiString);

begin

if Assigned(FOnStdoutText) then

FOnStdoutText(self, string(Text));

end;

end.

Author

Title

Language

Your paste - Paste your paste here

unit Utils.ConsoleRedirector;

interface

uses
  Windows;

type

TConsoleRedirector = class;

TConsoleFinishedEvent = procedure(Sender: TConsoleRedirector) of object;

TConsoleTextEvent = procedure(Sender: TConsoleRedirector; Text: string) of object;

TConsoleRedirector = class
  private
    FWorkingThread: THandle; // thread to receive the output of the child process
    FStopEvent: THandle; // event to notify the redir thread to exit
    FWorkingThreadId: Cardinal; // id of the redir thread
    FWaitTime: Cardinal;
    FOnStdoutText: TConsoleTextEvent;
    FOnStderrText: TConsoleTextEvent;
    FOnFinished: TConsoleFinishedEvent; // wait time to check the status of the child process
    FStdInWritePipe: THandle; // write end of child's stdin pipe
    FStdOutReadPipe: THandle; // read end of child's stdout pipe
    FChildProcess: THandle;
  protected
    function LaunchChild(CommandLine: string; StdOutHandle, StdInHandle, StdErrHandle: THandle): Boolean;
    function RedirectStdout: Integer;
    procedure DestroyHandle(var Handle: THandle);
    procedure DoStdOutEvent(Text: AnsiString); virtual;
    procedure DoStdErrorEvent(Text: AnsiString); virtual;
    procedure DoFinishedEvent; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    function Open(CommandLine: string): Boolean;
    procedure Close; virtual;
    function Write(Text: AnsiString): Boolean;
    property WaitTime: Cardinal read FWaitTime write FWaitTime;
    property OnStdoutText: TConsoleTextEvent read FOnStdoutText write FOnStdoutText;
    property OnStderrText: TConsoleTextEvent read FOnStderrText write FOnStderrText;
    property OnFinished: TConsoleFinishedEvent read FOnFinished write FOnFinished;
  end;

implementation

uses
  SysUtils,
  Math;

{ TConsoleRedirector }

procedure TConsoleRedirector.Close;
begin
  if FWorkingThread &lt;&gt; 0 then
  begin
    // this function might be called from redir thread
    if GetCurrentThreadId &lt;&gt; FWorkingThreadId then
    begin
      SetEvent(FStopEvent);
      if WaitForSingleObject(FWorkingThread, 5000) = WAIT_TIMEOUT then
      begin
        DoStdErrorEvent('The redir thread is dead');
        TerminateThread(FWorkingThread, Cardinal(-2));
      end;
    end;
    DestroyHandle(FWorkingThread);
  end;

DestroyHandle(FStopEvent);
  DestroyHandle(FChildProcess);
  DestroyHandle(FStdInWritePipe);
  DestroyHandle(FStdOutReadPipe);
  FWorkingThreadId := 0;
end;

constructor TConsoleRedirector.Create;
begin
  inherited Create;
  FStdInWritePipe := 0;
  FStdOutReadPipe := 0;
  FChildProcess := 0;
  FWorkingThread := 0;
  FStopEvent := 0;
  FWorkingThreadId := 0;
  FWaitTime := 100;
end;

destructor TConsoleRedirector.Destroy;
begin
  Close;
  inherited Destroy;
end;

procedure TConsoleRedirector.DestroyHandle(var Handle: THandle);
begin
  if Handle &lt;&gt; 0 then
  begin
    CloseHandle(Handle);
    Handle := 0;
  end;
end;

function TConsoleRedirector.LaunchChild(CommandLine: string; StdOutHandle, StdInHandle, StdErrHandle: THandle): Boolean;
var
  vPI: PROCESS_INFORMATION;
  vSI: STARTUPINFO;
begin
  // Set up the start up info struct.
  ZeroMemory(@vSI, SizeOf(vSI));
  vSI.cb := SizeOf(vSI);
  vSI.hStdOutput := StdOutHandle;
  vSI.hStdInput := StdInHandle;
  vSI.hStdError := StdErrHandle;
  vSI.wShowWindow := SW_HIDE;
  vSI.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;

// Note that dwFlags must include STARTF_USESHOWWINDOW if we
  // use the wShowWindow flags. This also assumes that the
  // CreateProcess() call will use CREATE_NEW_CONSOLE.

// Launch the child process.
  if not CreateProcess(nil, PChar(CommandLine), nil, nil, True, CREATE_NEW_CONSOLE, nil, nil, vSI, vPI) then
    Result := False
  else
  begin
    FChildProcess := vPI.hProcess;
    // Close any unuseful handles
    CloseHandle(vPI.hThread);
    Result := True;
  end;
end;

// thread to receive output of the child process
function OutputThread(lpvThreadParam: Pointer): Cardinal; stdcall;
var
  vWaitHandles: array [0 .. 1] of THandle;
  vRedirector: TConsoleRedirector;
  vWaitResult: Cardinal;
  vRedirectResult: Integer;
begin
  vRedirector := TConsoleRedirector(lpvThreadParam);
  vWaitHandles[0] := vRedirector.FChildProcess;
  vWaitHandles[1] := vRedirector.FStopEvent;

// redirect stdout till there's no more data.
  vRedirectResult := vRedirector.RedirectStdout;
  while vRedirectResult &gt; 0 do
  begin
    // check if the child process has terminated.
    vWaitResult := WaitForMultipleObjects(2, @vWaitHandles, False, vRedirector.FWaitTime);
    case vWaitResult of
      WAIT_OBJECT_0: // the child process ended
      begin
        vRedirectResult := vRedirector.RedirectStdout;
        if vRedirectResult &gt; 0 then
          vRedirectResult := 0;
        Break;
      end;
      WAIT_OBJECT_0 + 1: // m_hEvtStop was signalled
      begin
        vRedirectResult := 1; // cancelled
        Break;
      end;
    end;

// Next redirect:
    vRedirectResult := vRedirector.RedirectStdout;
  end;

// close handles
  vRedirector.Close;
  Result := vRedirectResult;
end;

function TConsoleRedirector.Open(CommandLine: string): Boolean;
var
  vStdOutReadPipe: THandle; // parent stdout read handle
  vStdOutWritePipe, vStdErrWritePipe: THandle; // child stdout write handle
  vStdInWritePipe: THandle; // parent stdin write handle
  vStdInReadPipe: THandle; // child stdin read handle
  vSA: SECURITY_ATTRIBUTES;
begin
  Close;
  Result := False;
  vStdOutReadPipe := 0;
  vStdOutWritePipe := 0;
  vStdErrWritePipe := 0;
  vStdInWritePipe := 0;
  vStdInReadPipe := 0;

// Set up the security attributes struct.
  vSA.nLength := SizeOf(SECURITY_ATTRIBUTES);
  vSA.lpSecurityDescriptor := nil;
  vSA.bInheritHandle := True;

try
    // Create a child stdout pipe.
    if not CreatePipe(vStdOutReadPipe, vStdOutWritePipe, @vSA, 0) then
      RaiseLastOSError;

// Create a duplicate of the stdout write handle for the std
    // error write handle. This is necessary in case the child
    // application closes one of its std output handles.
    if not DuplicateHandle(GetCurrentProcess, vStdOutWritePipe, GetCurrentProcess, @vStdErrWritePipe, 0, True, DUPLICATE_SAME_ACCESS) then
      RaiseLastOSError;

// Create a child stdin pipe.
    if not CreatePipe(vStdInReadPipe, vStdInWritePipe, @vSA, 0) then
      RaiseLastOSError;

// Create new stdout read handle and the stdin write handle.
    // Set the inheritance properties to FALSE. Otherwise, the child
    // inherits the these handles; resulting in non-closeable
    // handles to the pipes being created.
    if not DuplicateHandle(GetCurrentProcess, vStdOutReadPipe, GetCurrentProcess, @FStdOutReadPipe, 0, False {make it uninheritable}, DUPLICATE_SAME_ACCESS) then
      RaiseLastOSError;

if not DuplicateHandle(GetCurrentProcess, vStdInWritePipe, GetCurrentProcess, @FStdInWritePipe, 0, False {make it uninheritable}, DUPLICATE_SAME_ACCESS) then
      RaiseLastOSError;

// Close inheritable copies of the handles we do not want to
    // be inherited.
    DestroyHandle(vStdOutReadPipe);
    DestroyHandle(vStdInWritePipe);

// launch the child process
    if not LaunchChild(CommandLine, vStdOutWritePipe, vStdInReadPipe, vStdErrWritePipe) then
      RaiseLastOSError;

// Child is launched. Close the parents copy of those pipe
    // handles that only the child should have open.
    // Make sure that no handles to the write end of the stdout pipe
    // are maintained in this process or else the pipe will not
    // close when the child process exits and ReadFile will hang.
    DestroyHandle(vStdOutWritePipe);
    DestroyHandle(vStdInReadPipe);
    DestroyHandle(vStdErrWritePipe);

// Launch a thread to receive output from the child process.
    FStopEvent := CreateEvent(nil, True, False, nil);
    FWorkingThread := Windows.CreateThread(nil, 0, @OutputThread, self, 0, FWorkingThreadId);
    if FWorkingThread = 0 then
      RaiseLastOSError;

Result := True;
  except
    on E: Exception do
    begin
      DestroyHandle(vStdOutReadPipe);
      DestroyHandle(vStdOutWritePipe);
      DestroyHandle(vStdErrWritePipe);
      DestroyHandle(vStdInWritePipe);
      DestroyHandle(vStdInReadPipe);
      Close;
      DoStdErrorEvent(AnsiString(E.Message));
      //DONE: raise;
    end;
  end;
end;

// redirect the child process's stdout:
// return: 1: no more data, 0: child terminated, -1: os error
function TConsoleRedirector.RedirectStdout: Integer;
const
  cBufferSize = 255;
var
  vBytesAvailable, vBytesRead, vErrorCode: Cardinal;
  vBuffer: array [0 .. cBufferSize] of AnsiChar;
begin
  // Проверяем количество доступных байт в пайпе:
  while PeekNamedPipe(FStdOutReadPipe, nil, 0, nil, @vBytesAvailable, nil) do
  begin
    // Если чтение успешно, но байт больше нет, то программа завершилась, выходим:
    if vBytesAvailable = 0 then
    begin
      Result := 1; // not data available
      Exit;
    end;

vBytesRead := 0;
    if not ReadFile(FStdOutReadPipe, vBuffer, Min(cBufferSize, vBytesAvailable), vBytesRead, nil) or (vBytesRead = 0) then
      Break; // error, the child might ended

vBuffer[vBytesRead] := #0;
    OemToAnsi(vBuffer, vBuffer);
    DoStdOutEvent(vBuffer);
  end;

// pipe has been ended or pipe closing in progress:
  vErrorCode := GetLastError;
  if (vErrorCode = ERROR_BROKEN_PIPE) or (vErrorCode = ERROR_NO_DATA) then
  begin
    DoFinishedEvent;
    Result := 0; // child process ended
    Exit;
  end;

DoStdErrorEvent('Read stdout pipe error' + #13#10);
  Result := -1; // os error
end;

function TConsoleRedirector.Write(Text: AnsiString): Boolean;
var
  vBytesWritten: Cardinal;
begin
  if FStdInWritePipe &lt;&gt; 0 then
    if Text &lt;&gt; '' then
      Result := WriteFile(FStdInWritePipe, Text[1], Length(Text), vBytesWritten, nil)
    else
      Result := True
  else
    Result := False;
end;

procedure TConsoleRedirector.DoFinishedEvent;
begin
  if Assigned(FOnFinished) then
    FOnFinished(self);
end;

procedure TConsoleRedirector.DoStdErrorEvent(Text: AnsiString);
begin
  if Assigned(FOnStderrText) then
    FOnStderrText(self, string(Text));
end;

procedure TConsoleRedirector.DoStdOutEvent(Text: AnsiString);
begin
  if Assigned(FOnStdoutText) then
    FOnStdoutText(self, string(Text));
end;

end.

Create Shorturl - Create a shorter url that redirects to your paste?

Private - Private paste aren't shown in recent listings.

Delete After - When should we delete your paste?

Reply to "Test"