Prozess starten + Rückgabewert für Delphi 2009

[Zerolith]

Habe heute nach genau so einer Funktion hier gesucht. Musste aber für Delphi 2009 ein paar Anpassungen machen.
(Leider find ich den Link grad nicht mehr)

Konnte den Code hier nur mit 2009 und XP testen. Theoretisch müsste es schon mit Delphi 6 funktionieren.

Hoffe es hilft jemandem.

Delphi-Quellcode:

function RunWaitAndCaptureOutput(CommandLine: ansistring; var Output: ansistring): DWord;
const
  BufSize = 1024;
var
  buf: array[0..BufSize - 1] of ansichar;
  si: STARTUPINFOA;
  sa: SECURITY_ATTRIBUTES;
  sd: SECURITY_DESCRIPTOR;
  pi: PROCESS_INFORMATION;
  newstdout, read_stdout: THandle;
  bytes_read: cardinal;
  bytes_available: cardinal;

  procedure ZeroBuffer;
  begin
    FillChar(Buf, SizeOf(Buf), 0);
  end;

  procedure RaiseError(str: string);
  var
    n: DWord;
  begin
    n := GetLastError;
    raise EReadError.CreateFmt('%s: %d/0x%x -%s', [Str, n, n, SysErrorMessage(n)]);
  end;

  procedure GetData;
  begin
    PeekNamedPipe(read_stdout, @buf, BufSize - 1, @bytes_read, @bytes_available, nil);
    if (bytes_read <> 0) then
    begin
      ZeroBuffer;
      if (bytes_available > BufSize - 1)
        then
        while (bytes_read >= BufSize - 1) do
        begin
          ReadFile(read_stdout, buf, BufSize - 1, bytes_read, nil);
          Output := Output + Buf;
          ZeroBuffer;
        end
      else
      begin
        ReadFile(read_stdout, buf, BufSize - 1, bytes_read, nil);
        Output := Output + Buf;
      end;
    end;
  end;

begin
  Output := '';
  Result := 255;

  if IsWindowsNT then
  begin
    InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);
    SetSecurityDescriptorDacl(@sd, true, nil, False);
    sa.lpSecurityDescriptor := @sd;
  end else
    sa.lpSecurityDescriptor := nil;

  sa.nLength := sizeof(SECURITY_ATTRIBUTES);
  sa.bInheritHandle := true; //allow inheritable handles

  if not (CreatePipe(read_stdout, newstdout, @sa, 0)) then
    RaiseError('CreatePipe');

  GetStartupInfoA(si);

  si.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  si.wShowWindow := SW_HIDE;
  si.hStdOutput := newstdout;
  si.hStdError := newstdout;

  if not (CreateProcessA(nil, PAnsiChar(CommandLine), nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si, pi)) then
  begin
    CloseHandle(newstdout);
    CloseHandle(read_stdout);
    RaiseError('CreateProcess');
  end;

  ZeroBuffer;
  while True do
  begin
    GetExitCodeProcess(pi.hProcess, Result);
    if (Result <> STILL_ACTIVE) then break;
    GetData;
  end;

  GetData;

  CloseHandle(pi.hThread);
  CloseHandle(pi.hProcess);
  CloseHandle(newstdout);
  CloseHandle(read_stdout);
end;

[Luckie]

Und was musstest du wie für D2009 anpassen?

[Zerolith]

zum einen die Parameter von String auf AnsiString

den Buffer auf AnsiChar

si: STARTUPINFO => auf STARTUPINFOA

CreateProcess auf CreateProcessA

und den Parameter PChar(CommandLine) auf PAnsiChar(CommandLine)

[toms]

Zitat:

Zitat von Zerolith

Habe heute nach genau so einer Funktion hier gesucht. Musste aber für Delphi 2009 ein paar Anpassungen machen.
(Leider find ich den Link grad nicht mehr)
[/delphi]

Die ursprüngliche Version wurde hier veröffentlicht.

[Zerolith]

Zitat:

Zitat von toms

Zitat:

Zitat von Zerolith

Habe heute nach genau so einer Funktion hier gesucht. Musste aber für Delphi 2009 ein paar Anpassungen machen.
(Leider find ich den Link grad nicht mehr)
[/delphi]

Die ursprüngliche Version wurde hier veröffentlicht.

Ah, Dankeschön!

[Luckie]

Zitat:

Zitat von Zerolith

zum einen die Parameter von String auf AnsiString

den Buffer auf AnsiChar

si: STARTUPINFO => auf STARTUPINFOA

CreateProcess auf CreateProcessA

und den Parameter PChar(CommandLine) auf PAnsiChar(CommandLine)

Warum denn das? D2009 benutzt standardmäßig Unicode und du biegst alles wieder auf Ansi zurück?

[Apollonius]

Overlapped IO ist etwas Feines. Ich hasse es, wenn ich Code mit derartigen Schleifen sehe. Windows stellt nicht umsonst Funktionen zum Warten bereit.

[Luckie]

Ah, das wollte ich auch schon mal machen, habe es aber nicht hinbekommen. Könntest du das mal bitte machen, wenn du weißt, wie es geht?

[Apollonius]

Bitte sehr.

Delphi-Quellcode:

//Either Path or CmdLine may be empty.
function CreateProcessAndReadOutput(Path: String; CmdLine: String; out Output: String): DWord;
const BUFFER_SIZE = 512;
var lpPath, lpCmdLine: PChar;
    StartupInf: STARTUPINFO;
    ProcessInfo: PROCESS_INFORMATION;

    PipeName: String;
    SecAttr: SECURITY_ATTRIBUTES;
    WriteHandle, ReadHandle: THandle;

    OvLapped: OVERLAPPED;
    BytesRead: Cardinal;
    Buffer: array[0..BUFFER_SIZE - 1] of Byte;
    BufStr: AnsiString;

    HandleArray: array[0..1] of THandle;
begin
  Output := '';

  if Path = '' then
    lpPath := nil
  else
    lpPath := PChar(Path);
  if CmdLine = '' then
    lpCmdLine := nil
  else
    lpCmdLine := PChar(CmdLine);

  ZeroMemory(@SecAttr, SizeOf(SecAttr));
  SecAttr.nLength := SizeOf(SecAttr);
  SecAttr.bInheritHandle := True;

  PipeName := '\\.\pipe\8F66970600BF4D84BAA77F3936C04BE0' + 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, @SecAttr, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    if WriteHandle = INVALID_HANDLE_VALUE then
      RaiseLastOSError;
    try
      ZeroMemory(@StartupInf, SizeOf(StartupInf));
      StartupInf.cb := SizeOf(StartupInf);
      StartupInf.dwFlags := STARTF_USESTDHANDLES;
      StartupInf.hStdOutput := WriteHandle;
      StartupInf.hStdError := WriteHandle;
      //Input uses our console.
      StartupInf.hStdInput := GetStdHandle(STD_INPUT_HANDLE);

      if not CreateProcess(lpPath, lpCmdLine, nil, nil, True, 0, nil, nil, StartupInf, ProcessInfo) then
        RaiseLastOSError;

      CloseHandle(ProcessInfo.hThread);
      try
        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, nil, @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;
            SetString(BufStr, PAnsiChar(@Buffer), BytesRead);
            Output := Output + BufStr;

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

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

[Dezipaitor]

Die Serverseite der Pipe sollte durch

Delphi-Quellcode:

1. FlushFileBuffers(hPipe); 
2. DisconnectNamedPipe(hPipe); 
CloseHandle(hPipe);

beendet werden.
Durch 1. wird der letzte WriteCall (vom Server) auch vollständig durchgeführt.
Durch 2. wird die Pipe auch wirklich geschlossen und nicht einfach der Pipe Handle Referenzzähler um eins nach unten gesetzt.