| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Завершение дочернего процесса [D7, WinXP]

Michail89 ©   (2010-01-05 11:00:00) 

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

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


function runSolve(CmdLine: string; TimeLimit: Cardinal = INFINITE; MemoryLimit: Cardinal = INFINITE): String;
var
 StartUpInfo: TStartUpInfo;
 ProcessInfo: TProcessInformation;
 dbg: _Debug_event;
 ContinueStatus: DWORD;
 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;

        ContinueStatus:=DBG_EXCEPTION_NOT_HANDLED;

         case dbg.dwDebugEventCode of
         EXIT_PROCESS_DEBUG_EVENT:
         begin
           Break;
         end;

         CREATE_PROCESS_DEBUG_EVENT, EXCEPTION_DEBUG_EVENT:
         begin
             res := 'RE';
           end;
        end;

        ContinueDebugEvent(dbg.dwProcessId, dbg.dwThreadId, ContinueStatus);

      end;

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

 end;

 Result := res;
end;


---

Michail89   (2010-01-19 22:31:00) [1]

А как тогда отловить RUNTIME ERROR, процесс в дебаге некорерктно работает.

---

Кука съела ник   (2010-01-05 16:28:00) [2]

используй SetInformationJobObject
http://msdn.microsoft.com/en-us/library/ms686216(VS.85).aspx

заполняй JOBOBJECT_BASIC_LIMIT_INFORMATION, там есть
PerProcessUserTimeLimit и PerJobUserTimeLimit

это то, что тебе надо, и не надо дополнительного кода

---

Michail89   (2010-01-05 15:34:00) [3]

Попробовал сделать через 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;



---

Michail89   (2010-01-05 14:05:00) [4]

Про Job слышал, ток инфы маловато.
т.е. JOb'ы убьют корректно программу ?
попробую постетить , спасибо

---

Кука съела ник   (2010-01-05 13:01:00) [5]

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


Используй Job - там эта функциональность уже заложена.

---

Michail89   (2010-01-05 12:02:00) [6]

Изменил код немного проще. Но ошибка осталась :(



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;


---

Ганя   (2010-01-05 11:24:00) [7]

если я правильно понял, и надо замерить время работы дочернего процесса, то
см. WaitForSingleObject
тайм-аут передается параметром

---

Наверх