Prozess starten + Rückgabewert für Delphi 2009

[dkoehler]

Ich habe Apollonius' Code in eine Komponente umgeschrieben. Die CreateNoWindow Flag gibt an, ob das externe Programm in einem eigenen Fenster gestartet werden soll oder nicht. Über das OnProgress Ereignis kann man beim Einlesen der Were den Stand des internen Streams auswerten, wobei man über die ProcessInfo Variable erfährt, mit welchem Prozeß man es zu tun hat. Zum Starten und Einlesen der Rückgabewerte muß man ExecuteA() bzw. ExecuteW() aufrufen (es handelt sich um die AnsiString- und die WideString-Version von im Prinzip derselben Funktion).

Delphi-Quellcode:

interface

uses
  Windows, Classes, SysUtils;

type

  TAppLauncherProgressEvent = procedure(Sender: TObject; ProcessInfo: PROCESS_INFORMATION; Position: Int64) of object;

  TAppLauncher = class(TComponent)
  private
    FCreateNoWindow: Boolean;
    FOnProgress: TAppLauncherProgressEvent;
    FSecurityAttributes: SECURITY_ATTRIBUTES;
    FSecurityDescriptor: SECURITY_DESCRIPTOR;
    function CentralLoop(const ProcessInfo: PROCESS_INFORMATION; const ReadHandle: THandle; const OutputStream: TStream): DWord; inline;
  protected
    procedure DoProgress(ProcessInfo: PROCESS_INFORMATION; Position: Int64); virtual;
    procedure PreparePipe(out ReadHandle, WriteHandle: THandle); virtual; 
    function PrepareStartupInfoA(const StdOutput: THandle): STARTUPINFOA; virtual; 
    function PrepareStartupInfoW(const StdOutput: THandle): STARTUPINFOW; virtual; 

    property SecurityAttributes: SECURITY_ATTRIBUTES read FSecurityAttributes;
    property SecurityDescriptor: SECURITY_DESCRIPTOR read FSecurityDescriptor;
  public
    constructor Create(AOwner: TComponent); override;
    function ExecuteA(const Path, CmdLine: AnsiString; out Output: TBytes): DWORD;
    function ExecuteW(const Path, CmdLine: WideString; out Output: TBytes): DWORD;
  published
    property CreateNoWindow: Boolean read FCreateNoWindow write FCreateNoWindow default false;
    property OnProgress: TAppLauncherProgressEvent read FOnProgress write FOnProgress;
  end;

implementation

uses
  TeCanvas, Forms;

{ TAppLauncher }

constructor TAppLauncher.Create(AOwner: TComponent);
begin
  inherited;

  FCreateNoWindow := false;

  ZeroMemory(@FSecurityAttributes, SizeOf(FSecurityAttributes));

  if IsWindowsNT then
  begin
    InitializeSecurityDescriptor(@FSecurityDescriptor, SECURITY_DESCRIPTOR_REVISION);
    SetSecurityDescriptorDacl(@FSecurityDescriptor, True, nil, False);
    FSecurityAttributes.lpSecurityDescriptor := @FSecurityDescriptor;
  end else
    FSecurityAttributes.lpSecurityDescriptor := nil;

  FSecurityAttributes.nLength := SizeOf(SECURITY_ATTRIBUTES);
  FSecurityAttributes.bInheritHandle := True;
end;

procedure TAppLauncher.DoProgress(ProcessInfo: PROCESS_INFORMATION; Position: Int64);
begin
  if Assigned(FOnProgress) then
    FOnProgress(Self, ProcessInfo, Position);
end;

procedure TAppLauncher.PreparePipe(out ReadHandle,
  WriteHandle: THandle);
var
  PipeName: string;
begin
  PipeName := '\\.\pipe\' + IntToHex(Random(MaxInt), 8) + IntToHex(GetCurrentProcessId, 8) + IntToHex(Random(MaxInt), 8);

  ReadHandle := CreateNamedPipe(PChar(PipeName), PIPE_ACCESS_INBOUND or FILE_FLAG_OVERLAPPED, 0, 1, 1024, 1024, 0, nil);
  if ReadHandle = INVALID_HANDLE_VALUE then
    RaiseLastOSError;
  try
    WriteHandle := CreateFile(PChar(PipeName), GENERIC_WRITE, FILE_SHARE_READ, @SecurityAttributes, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    if WriteHandle = INVALID_HANDLE_VALUE then
      RaiseLastOSError;
  except
    CloseHandle(ReadHandle);
  end;
end;

function TAppLauncher.PrepareStartupInfoA(const StdOutput: THandle): STARTUPINFOA;
begin
  ZeroMemory(@Result, SizeOf(Result));
  Result.cb := SizeOf(Result);
  Result.dwFlags := STARTF_USESTDHANDLES;
  Result.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
  Result.hStdOutput := StdOutput;
  Result.hStdError := StdOutput;
end;

function TAppLauncher.PrepareStartupInfoW(const StdOutput: THandle): STARTUPINFOW;
begin
  ZeroMemory(@Result, SizeOf(Result));
  Result.cb := SizeOf(Result);
  Result.dwFlags := STARTF_USESTDHANDLES;
  Result.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
  Result.hStdOutput := StdOutput;
  Result.hStdError := StdOutput;
end;

function TAppLauncher.CentralLoop(const ProcessInfo: PROCESS_INFORMATION; const ReadHandle: THandle; const OutputStream: TStream): DWord;
const
  BUFFER_SIZE = 512;
var
  OvLapped: OVERLAPPED;
  BytesRead: Cardinal;
  Buffer: array[0..BUFFER_SIZE - 1] of Byte;

  HandleArray: array[0..1] of THandle;
begin
  ZeroMemory(@OvLapped, SizeOf(OvLapped));
  OvLapped.hEvent := CreateEvent(nil, True, False, nil);
  try
    HandleArray[0] := ProcessInfo.hProcess;
    HandleArray[1] := OvLapped.hEvent;
    if not ReadFile(ReadHandle, Buffer, BUFFER_SIZE, BytesRead, @OvLapped)
       and (GetLastError <> ERROR_IO_PENDING) then
      RaiseLastOSError;

    while WaitForMultipleObjects(2, @HandleArray, False, INFINITE) = WAIT_OBJECT_0 + 1 do
    begin
      if not GetOverlappedResult(ReadHandle, OvLapped, BytesRead, False) then
        RaiseLastOSError;
      OutputStream.Write(Buffer, BytesRead);

      ResetEvent(OvLapped.hEvent);
      if not ReadFile(ReadHandle, Buffer, BUFFER_SIZE, BytesRead, @OvLapped)
         and (GetLastError <> ERROR_IO_PENDING) then
        RaiseLastOSError;

      DoProgress(ProcessInfo, OutputStream.Position);
    end;

    GetExitCodeProcess(ProcessInfo.hProcess, Result);
  finally
    CloseHandle(OvLapped.hEvent);
  end;
end;

function TAppLauncher.ExecuteA(const Path, CmdLine: AnsiString;
  out Output: TBytes): DWORD;
var
  lpPath, lpCmdLine: PAnsiChar;
  StartupInf: STARTUPINFOA;
  ProcessInfo: PROCESS_INFORMATION;

  WriteHandle, ReadHandle: THandle;
  dwCreationFlags: Cardinal;
  BytesStream: TBytesStream;
begin
  PreparePipe(ReadHandle, WriteHandle);
  try
    try

      StartupInf := PrepareStartupInfoA(WriteHandle);

      if CreateNoWindow then
        dwCreationFlags := CREATE_NO_WINDOW
      else
        dwCreationFlags := 0;
      if Path = '' then
        lpPath := nil
      else
        lpPath := PAnsiChar(Path);
      if CmdLine = '' then
        lpCmdLine := nil
      else begin
        lpCmdLine := PAnsiChar(CmdLine);
      end;
      if not CreateProcessA(lpPath, lpCmdLine, nil, nil, True, dwCreationFlags, nil, nil, StartupInf, ProcessInfo) then
        RaiseLastOSError;

      try
        CloseHandle(ProcessInfo.hThread);

        BytesStream := TBytesStream.Create(nil);
        try
          Result := CentralLoop(ProcessInfo, ReadHandle, BytesStream);
          Output := BytesStream.Bytes;
        finally
          BytesStream.Free;
        end;

      finally
        CloseHandle(ProcessInfo.hProcess);
      end;

    finally
      CloseHandle(WriteHandle);
    end;
  finally
    CloseHandle(ReadHandle);
  end;
end;

function TAppLauncher.ExecuteW(const Path, CmdLine: WideString; out Output: TBytes): DWORD;
var
  lpPath, lpCmdLine: PWideChar;
  StartupInf: STARTUPINFOW;
  ProcessInfo: PROCESS_INFORMATION;

  WriteHandle, ReadHandle: THandle;
  dwCreationFlags: Cardinal;
  BytesStream: TBytesStream;

  CmdLineCopy: WideString;
begin
  PreparePipe(ReadHandle, WriteHandle);
  try
    try

      StartupInf := PrepareStartupInfoW(WriteHandle);

      if CreateNoWindow then
        dwCreationFlags := CREATE_NO_WINDOW
      else
        dwCreationFlags := 0;
      if Path = '' then
        lpPath := nil
      else
        lpPath := PWideChar(Path);
      if CmdLine = '' then
        lpCmdLine := nil
      else begin
        // We need to work with a copy of CmdLine. Cf. the Microsoft
        // documentation on the CreateProcess method: "The Unicode version of
        // this function, CreateProcessW, can modify the contents of this
        // string. Therefore, this parameter cannot be a pointer to read-only
        // memory (such as a const variable or a literal string). If this
        // parameter is a constant string, the function may cause an access
        // violation.
        CmdLineCopy := CmdLine;
        UniqueString(CmdLineCopy);
        lpCmdLine := PWideChar(CmdLineCopy);
      end;
      if not CreateProcessW(lpPath, lpCmdLine, nil, nil, True, dwCreationFlags, nil, nil, StartupInf, ProcessInfo) then
        RaiseLastOSError;

      try
        CloseHandle(ProcessInfo.hThread);

        BytesStream := TBytesStream.Create(nil);
        try
          Result := CentralLoop(ProcessInfo, ReadHandle, BytesStream);
          Output := BytesStream.Bytes;
        finally
          BytesStream.Free;
        end;

      finally
        CloseHandle(ProcessInfo.hProcess);
      end;

    finally
      CloseHandle(WriteHandle);
    end;
  finally
    CloseHandle(ReadHandle);
  end;
end;