Форум: "Основная";
Текущий архив: 2011.08.21;
Скачать: [xml.tar.bz2];
ВнизЗавершение дочернего процесса Найти похожие ветки
← →
Michail89 (2010-01-05 11:00) [0]Пишу прилодение которое многократно порождает дочернее приложение и смотрит как долго оно работает. Если лимит времени превышен, то дочерний процесс завершается и функция возвращает значение "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;
← →
Ганя (2010-01-05 11:24) [1]если я правильно понял, и надо замерить время работы дочернего процесса, то
см. WaitForSingleObject
тайм-аут передается параметром
← →
Michail89 (2010-01-05 12:02) [2]Изменил код немного проще. Но ошибка осталась :(
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 13:01) [3]
> Пишу прилодение которое многократно порождает дочернее приложение
> и смотрит как долго оно работает. Если лимит времени превышен,
> то дочерний процесс завершается и функция возвращает значение
> "TL" - Time Limit - т.е. превышен интервал ожидания
Используй Job - там эта функциональность уже заложена.
← →
Michail89 (2010-01-05 14:05) [4]Про Job слышал, ток инфы маловато.
т.е. JOb"ы убьют корректно программу ?
попробую постетить , спасибо
← →
Michail89 (2010-01-05 15:34) [5]Попробовал сделать через 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;
← →
Кука съела ник (2010-01-05 16:28) [6]используй SetInformationJobObject
http://msdn.microsoft.com/en-us/library/ms686216(VS.85).aspx
заполняй JOBOBJECT_BASIC_LIMIT_INFORMATION, там есть
PerProcessUserTimeLimit и PerJobUserTimeLimit
это то, что тебе надо, и не надо дополнительного кода
← →
Michail89 (2010-01-19 22:31) [7]А как тогда отловить RUNTIME ERROR, процесс в дебаге некорерктно работает.
Страницы: 1 вся ветка
Форум: "Основная";
Текущий архив: 2011.08.21;
Скачать: [xml.tar.bz2];
Память: 0.49 MB
Время: 0.005 c