Завершение отлаживаемого дочернего процесса

[dudeboy]

Пишу прилодение которое многократно порождает дочернее приложение и смотрит как долго оно работает. Если лимит времени превышен, то дочерний процесс завершается и функция возвращает значение 'TL' - Time Limit - т.е. превышен интервал ожидания. Проблема в том что дечернее приложение не завершается после окончания работы функции (ProcessExplorer так говорит), а вновь вызванная ниже функция дает нормальный результат работы приложения. Т.е. получается цепочка результатов вызовов функций:
TimeLimit, Accept, TimeLimit, Accept, TimeLimit, Accept ...

Как добиться корректного завершения дочернего процесса ?

PHP код:

function runSolve(CmdLine: string; TimeLimit: Cardinal = INFINITE; MemoryLimit: Cardinal = INFINITE): String;
var
  StartUpInfo: TStartUpInfo;
  ProcessInfo: TProcessInformation;
  dbg: _Debug_event;
  run: Boolean;
  tick: Cardinal;
  res: String;
begin
  res := 'AC';

  with StartUpInfo do begin
    cb := sizeof(StartUpInfo);
    lpReserved := nil;
    lpDesktop := nil;
    lpTitle := PChar('External program "' + CmdLine + '"');
    dwFlags := 0;
    cbReserved2 := 0;
    lpReserved2 := nil;
  end;

  
  run := CreateProcess(
    nil,                     //Полный путь к исполняемому модулю программы
    PChar(runCMDsolve),      //Строка параметров
    nil,                     //Атрибуты защиты для нового процесса
    nil,                     //Атрибуты защиты для первого потока созданного приложением
    False,                   //Флаг наследования от процесса производящего запуск
    DEBUG_PROCESS or DEBUG_ONLY_THIS_PROCESS,   //Флаг способа создания процесса и его приоритет
    nil,                     //Блок среды
    nil,                     //Текущий диск и каталог
    StartupInfo,             //Используется для настройки свойств процесса, например расположения окон и заголовок
    ProcessInfo              //Информация о созданном процессе. Инициализируется самой функцией
  );



  if run then begin
    tick:=GetTickCount;
    res := 'AC';

    try

          while True do begin
              if (getTickCount - tick) > (TimeLimit*1000) then begin
                res := 'TL';
                TerminateProcess(ProcessInfo.hProcess, 0);
                break;
              end;

          if not WaitForDebugEvent(dbg, 100) then begin
            Application.ProcessMessages;
            Continue;
          end;
          ContinueDebugEvent(dbg.dwProcessId, dbg.dwThreadId, DBG_CONTINUE);

          if (dbg.dwDebugEventCode = EXCEPTION_DEBUG_EVENT) and (dbg.Exception.ExceptionRecord.ExceptionCode <> EXCEPTION_SINGLE_STEP) and (dbg.Exception.ExceptionRecord.ExceptionCode <> EXCEPTION_BREAKPOINT) then begin
            res := 'RE';
            TerminateProcess(ProcessInfo.hProcess, 0);
          end;

          if dbg.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT then break;
        end;

  
    finally
        CloseHandle(ProcessInfo.hThread);
        CloseHandle(ProcessInfo.hProcess);
    end;

  end;


  Result := res;
end; 


[mihali4]

http://www.programmersforum.ru/showthread.php?t=12099

[dudeboy]

Попробовал сделать через JOB, но результат тотже

function runSolve(CmdLine: string; TimeLimit: Cardinal = INFINITE; MemoryLimit: Cardinal = INFINITE): String;
var
  StartUpInfo: TStartUpInfo;
  ProcessInfo: TProcessInformation;
  dbg: _Debug_event;
  run: Boolean;
  tick: Cardinal;
  res: String;
  hJob: THandle;
begin

  res := 'RE1';

  with StartUpInfo do begin
    cb := sizeof(StartUpInfo);
    lpReserved := nil;
    lpDesktop := nil;
    lpTitle := PChar('External program "' + CmdLine + '"');
    dwFlags := 0;
    cbReserved2 := 0;
    lpReserved2 := nil;
  end;

  (*  СДЕЛАТЬ ЗАЩИТУ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *)
  run := CreateProcess(
    nil,                     //Полный путь к исполняемому модулю программы
    PChar(runCMDsolve),      //Строка параметров
    nil,                     //Атрибуты защиты для нового процесса
    nil,                     //Атрибуты защиты для первого потока созданного приложением
    False,                   //Флаг наследования от процесса производящего запуск
    DEBUG_PROCESS or DEBUG_ONLY_THIS_PROCESS,   //Флаг способа создания процесса и его приоритет
    nil,                     //Блок среды
    nil,                     //Текущий диск и каталог
    StartupInfo,             //Используется для настройки свойств процесса, например расположения окон и заголовок
    ProcessInfo              //Информация о созданном процессе. Инициализируется самой функцией
  );



  if run then begin
    hJob := CreateJobObjectA(nil, 'MyJob');
    AssignProcessToJobObject(hjob, ProcessInfo.hProcess);
    tick:=GetTickCount;
    res := 'AC';

	  try
	      while True do begin
      		if (getTickCount - tick) > (TimeLimit*1000) then begin
      		  res := 'TL';
            TerminateJobObject(hJob, 0);
//		        TerminateProcess(ProcessInfo.hProcess, 0);
      		  break;
      		end;

          if not WaitForDebugEvent(dbg, 100) then begin
            Application.ProcessMessages;
            Continue;
          end;
          ContinueDebugEvent(dbg.dwProcessId, dbg.dwThreadId, DBG_CONTINUE);

          if (dbg.dwDebugEventCode = EXCEPTION_DEBUG_EVENT) and (dbg.Exception.ExceptionRecord.ExceptionCode <> EXCEPTION_SINGLE_STEP) and (dbg.Exception.ExceptionRecord.ExceptionCode <> EXCEPTION_BREAKPOINT) then begin
            res := 'RE';
            TerminateJobObject(hJob, 0);
//            TerminateProcess(ProcessInfo.hProcess, 0);
            break;
          end;

          if dbg.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT then break;
        end;

    finally
//      TerminateProcess(ProcessInfo.hProcess, 0);
//      TerminateJobObject(hJob, 0);
	    CloseHandle(ProcessInfo.hThread);
	    CloseHandle(ProcessInfo.hProcess);
	  end;

  end;


  Result := res;
end;