Создание backup по сети

{$WARN SYMBOL_PLATFORM OFF}
procedure ExecuteFile(FileName : string; StdInput: RawByteString;
                      TimeOut: integer; aStdOutput, aErrOutput: TOutStr);
label
  Error;
type
  TPipeHandles = (IN_WRITE, IN_READ, OUT_WRITE, OUT_READ, ERR_WRITE, ERR_READ);
  TPipeArray = array[TPipeHandles] of THandle;
var
  i: cardinal;
  ph: TPipeHandles;
  sa: TSecurityAttributes;
  Pipes: TPipeArray;
  StartInf: TStartupInfo;
  ProcInf: TProcessInformation;
  Buf: array[0..1024] of AnsiChar;
  TimeStart: TDateTime;
  StdOutStr, ErrOutStr : RawByteString;

  procedure ReadOutput(aHnd : THandle; var aBufOut : RawByteString; aOutput: TOutStr);
  const TmpLen = 1000;
  var
    Idx : integer;
    TmpOut : RawByteString;
    BytesRead : cardinal;
  begin
    repeat
      SetLength(TmpOut, TmpLen);
      // Win32Check(
      ReadFile(aHnd, TmpOut[1], TmpLen - 1, BytesRead, nil);
      if BytesRead > 0 then begin
        SetLength(TmpOut, BytesRead);
        aBufOut := aBufOut + TmpOut;
        if AnsiStrings.AnsiPos(#13#10, TmpOut) > 0 then begin
          Idx := AnsiStrings.AnsiPos(#13#10, aBufOut);
          aStdOutput(copy(aBufOut, 1, Idx - 1));
          aBufOut := copy(aBufOut, Idx + 2, MaxInt);
        end;
      end;
    until BytesRead = 0;
  end;

begin
  StdOutStr := '';
  ProcInf.hProcess := INVALID_HANDLE_VALUE;
  for ph := Low(TPipeHandles) to High(TPipeHandles)
    do Pipes[ph] := INVALID_HANDLE_VALUE;
  // Создаем пайпы
  sa.nLength := sizeof(sa);
  sa.bInheritHandle := TRUE;
  sa.lpSecurityDescriptor := nil;
  try
    Win32Check(CreatePipe(Pipes[IN_READ], Pipes[IN_WRITE], @sa, 0));
    Win32Check(CreatePipe(Pipes[OUT_READ], Pipes[OUT_WRITE], @sa, 0));
    Win32Check(CreatePipe(Pipes[ERR_READ], Pipes[ERR_WRITE], @sa, 0));
    // Пишем StdIn
    StrPCopy(@Buf[0], stdInput + ^Z);
    Win32Check(WriteFile(Pipes[IN_WRITE], Buf, Length(stdInput), i, nil));
    // Хендл записи в StdIn надо закрыть - иначе выполняемая программа
    // может не прочитать или прочитать не весь StdIn.
    CloseHandle(Pipes[IN_WRITE]);
    Pipes[IN_WRITE] := INVALID_HANDLE_VALUE;
    // Структуры CreateProcess
    FillChar(StartInf, sizeof(TStartupInfo), 0);
    StartInf.cb := sizeof(TStartupInfo);
    StartInf.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
    StartInf.wShowWindow := SW_HIDE; // SW_SHOW; // SW_HIDE если надо запустить невидимо
    StartInf.hStdInput := Pipes[IN_READ];
    StartInf.hStdOutput := Pipes[OUT_WRITE];
    StartInf.hStdError  := Pipes[ERR_WRITE];
    Win32Check(CreateProcess(nil, PChar(FileName), nil, nil, True, NORMAL_PRIORITY_CLASS,
                             nil, nil, StartInf, ProcInf));
    // Хендл записи в StdOutput и StdError надо закрыть
    CloseHandle(Pipes[OUT_WRITE]);
    Pipes[OUT_WRITE] := INVALID_HANDLE_VALUE;
    CloseHandle(Pipes[ERR_WRITE]);
    Pipes[ERR_WRITE] := INVALID_HANDLE_VALUE;
    //
    TimeStart := Now;
    repeat
      i := WaitForSingleObject(ProcInf.hProcess, 100);
      // Если таймаут завершаем процесс
      if (Now - TimeStart) * SecsPerDay > TimeOut then begin
        // Пробуем завершить корректно
        CloseHandle(ProcInf.hThread);
        i := WaitForSingleObject(ProcInf.hProcess, 500);
        CloseHandle(ProcInf.hProcess);
        ProcInf.hProcess := INVALID_HANDLE_VALUE;
        // Если корректно не получилось - терминируем
        if i <> WAIT_OBJECT_0 then begin
          ProcInf.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, ProcInf.dwProcessId);
          if ProcInf.hProcess <> 0 then begin
            TerminateProcess(ProcInf.hProcess, 0);
            CloseHandle(ProcInf.hProcess);
            ProcInf.hProcess := INVALID_HANDLE_VALUE;
          end;
        end;
        raise ETimeOutException.Create('Process terminate on timeout');
      end;
      // Читаем StdOutput вывод
      ReadOutput(Pipes[OUT_READ], StdOutStr, aStdOutput);
      // Читаем StdError вывод
      ReadOutput(Pipes[ERR_READ], ErrOutStr, aErrOutput);
    until i = WAIT_OBJECT_0;
    //
    if StdOutStr <> ''
      then aStdOutput(StdOutStr);
    if ErrOutStr <> ''
      then aErrOutput(ErrOutStr);
  finally
    for ph := Low(TPipeHandles) to High(TPipeHandles) do
      if Pipes[ph] <> INVALID_HANDLE_VALUE
        then CloseHandle(Pipes[ph]);
    if ProcInf.hProcess <> INVALID_HANDLE_VALUE then begin
      CloseHandle(ProcInf.hProcess);
      CloseHandle(ProcInf.hThread);
    end;
  end;
end;
{$WARN SYMBOL_PLATFORM ON}

procedure TfrmDBArchive.btnRunBackupClick(Sender: TObject);
var CmdLine, OutS, ErrS : string;
begin
  if (edDBName.Text = '') or (edPassword.Text = '') then begin
    memLog.Lines.Add('Ошибка!');
    memLog.Lines.Add('Имя пользователя и пароль должны быть заданы!');
    exit;
  end;
  memLog.Lines.Clear;
 // c:\Firebird2.5\bin\gbak.exe -b localhost:arbat d:\arbat.fbk -user sysdba -pass 1
  CmdLine := edGBAKPath.Text + ' -b ' + MainAPI.DB.DBName + ' ' + edArchiveName.Text +
             ' -user ' + edDBName.Text + ' -pass ' + edPassword.Text;
  memLog.Lines.Add('Создание архива : ' + CmdLine);
  OutS := ''; ErrS := '';
  ExecuteFile(CmdLine, '', 1000,
    procedure(aStr : RawByteString)
    begin
      OutS := OutS + StringToWideString(aStr);
    end,
    procedure(aStr : RawByteString)
    begin
      ErrS := ErrS + StringToWideString(aStr);
    end
  );
  if ErrS <> '' then begin
    memLog.Lines.Add('Ошибка при выполнении бэкапа');
    memLog.Lines.Add(ErrS);
    memLog.Lines.Add(OutS);
  end else begin
    memLog.Lines.Add('Бэкап успешно создан!');
  end;
end;