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

Тема в разделе "Delphi - Система", создана пользователем -, 5 янв 2010.

Статус темы:
Закрыта.
  1. Гость

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

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


    Код (Text):
    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;
     
  2. Гость

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

    Код (Text):
    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;
     
Загрузка...
Статус темы:
Закрыта.

Поделиться этой страницей