TProcess: trouble of kill

[sunjob]

TProcess: trouble of kill

день добрый.

исходная идея "проекта" - запуск "процесса", выхлоп приложения в текстовое поле и... желательно в отдельном потоке.
пока как-то не очень удачно :о)

TProcess выполняется в процедуре.
нужно иметь возможность "прекратить работу процесса", в любое время.
сам процесс (как-то работает) но попытка сделать abort не увенчалась, процесс заканчивает "сам по себе".
схемо/код упрощен, но, надеюсь, смысл понятен.

кидайте любые идеи, ссылки, чтив, помидоры, буду разбираться.

исходные
- linux / slaclware 14.2
- fpc 3.2.2
- lazarus 3.8.0 / gtk/qt4/5/

спасибо.

p.s.
наборосал мини-вариант, разбираюсь, проявились еще более непонятные "особенности" работы с "командами/консолью"
как что-то еще нащУпаю - дополню.

!!! пока удалил код примера !!!
уточню детали, дополню топик

p.s. 2 - дополнЯю

в данной теме, с лазарусом - все в порядке, все отрабатывает как задумано! (без вопросов)
проблемы были с запускаемым бинарником - он зависал как зомби, без выхлопа и процедура с TProcess так-же зависала в ожидании выхлопа...
коротко - как-то так.

[Seenkao]

поставить в очередь на удаление?

[sunjob]

сначало засомневался, что понимаю совет (или не разбираюсь в теме), задал вопрос ии:

Концепции «поставить в очередь на удаление» у TProcess не существует. Процесс не файл и не объект БД.

Исходя из ваших прошлых сообщений (fpKill не срабатывает, Process.Active := False не помогает), проблема не в синтаксисе, а в том, что сигнал не доходит или PID уже невалиден

а какую концепцию имели в виду вы?

[Alexander]

Если TProcess не принципиален, то может быть popen ? А чтобы управлять запуском/остановкой отделить его в thread.

[WAYFARER]

TProcess выполняется в процедуре.
нужно иметь возможность "прекратить работу процесса", в любое время.
сам процесс (как-то работает) но попытка сделать abort не увенчалась, процесс заканчивает "сам по себе".

Несколько сумбурно и не очень понятно. Пример нужен)

Исходя из ваших прошлых сообщений (fpKill не срабатывает, Process.Active := False не помогает), проблема не в синтаксисе, а в том, что сигнал не доходит или PID уже невалиден

PID берется из TProcess.ProcessID? Надо смотреть как запускается процесс. Вполне возможно что процесс не один и завершать надо дочерний или группу процессов. Код надо смотреть)

[sunjob]

день добрый!
все оказалось еще интереснее :о)
в данной теме, с лазарусом - все в порядке, все отрабатывает как задумано! (без вопросов)
проблемы были с запускаемым бинарником - он зависал как зомби, без выхлопа и процедура с TProcess так-же зависала в ожидании выхлопа...
коротко - как-то так.

[Alex2013]

Не совсем в тему но может пригодится ...

Код: Выделить всё

Procedure RunDosInMemo(CmdLine: String; AMemo: TMemo);
//(Более краткая версия )
Const
    ReadBuffer = 1023;
Var
    Security: TSecurityAttributes;
    OutReadPipe, OutWritePipe: tHandle; // труба для output'a консольной проги.
    InReadPipe, InWritePipe: tHandle; // труба для input'a консольной проги.
    ErrReadPipe, ErrWritePipe: tHandle; // труба для error's консольной проги.
    // InReadPipe, ErrReadPipe и объявлены для полноты картины,но не создаются и не используются.
    start: TStartUpInfo;
    ProcessInfo: TProcessInformation;
    Buffer: Pchar;
    BytesRead: DWord;
    Apprunning: DWord;
    avail : dword;
    notread:dword;
    stop:boolean;
Begin
    stop := false;
    With Security Do Begin // инициализация структуры
        nlength := SizeOf(TSecurityAttributes);
        binherithandle := true;
        lpsecuritydescriptor := Nil;
    End;
    Createpipe(InReadPipe, InWritePipe, @Security, 0);
    Createpipe(ErrReadPipe, ErrWritePipe, @Security, 0);
    If Createpipe(OutReadPipe, OutWritePipe, @Security, 0) Then Begin
        // создали трубу для выхлопа бэкграунд-приложения
        Buffer := AllocMem(ReadBuffer + 1);
        // создали буфер для чтения
        FillChar(Start, Sizeof(Start), #0);
        // заполнили содержимое стартовой структуры #0
        start.cb := SizeOf(start);
        start.hStdOutput := OutWritePipe;
        start.hStdError := OutWritePipe;
        start.hStdInput := InReadPipe;
        (*************************************************************
            такой себе опширненьний комментарий...
            Оказывается, мать их так, если сделать перенаправление
            вывода в трубы, но не читать его, то если он(вывод)
            будет достаточно длинный и сможет переполнить буфер,
            который изначально отводится под трубу, то пишущий поток
            остановится и будет ждать пока не освободится место в
            буфере трубы. Как только оно освободилось, он сможет
            продолжать работу и писать дальше.
 
            start.hStdOutput := OutWritePipe;
            start.hStdError := OutWritePipe;
 
            почему собственно такой странный код: два потока
            перенаправлены в одну трубу?
            Потому что некоторые замечательные проги типа 7zip свой
            вывод направляют не в StdOut, а почему то в StdErr...
            и если для этих двух потоков назначить две разных трубы,
            а читать только одну, то произойдет то, что описано выше.
            РРРРРРРРРРРРРРРРРРРРРРРРР!!!!!!!!! сопли, слюни, ярость и
            буйное помешательство на почве программирования под винду.
 
            Может стоит сделать две трубы и читать каждую в отдельное
            мемо???
        **************************************************************)
        start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
        start.wShowWindow := SW_HIDE;
        // окно прячем
 
        If CreateProcess(Nil, PChar(CmdLine), @Security, @Security, true, NORMAL_PRIORITY_CLASS,
            Nil, Nil, start, ProcessInfo) Then Begin
            // создали процесс
            Repeat
                Apprunning := WaitForSingleObject(ProcessInfo.hProcess, 100);
                PeekNamedPipe(OutReadPipe, @Buffer[0], ReadBuffer, @BytesRead, @avail, @notread);
                // PeekNamedPipe копирует из буфера трубы и оставляет его в первоначальном состоянии
                // в то время как ReadFile читая из трубы - опустошает ее.
                // PeekNamedPipe можно использовать для того чтобы узнать сколько данных есть в трубе
                // и если в PeekNamedPipe передать 2 и 3 параметры пустыми, то она просто скажет
                // сколько данных есть в трубе
                if avail > 0 then begin
                    ReadFile(OutReadPipe, Buffer[0], BytesRead, BytesRead, Nil); // *******
                    // ReadFile при чтении из трубы опустошает ее(трубы) буфер.
                end
                else begin
                    if Apprunning <> 258 then
                        stop := true;
                end;
                // читаем через читающий конец трубы из вывода консоли
                Buffer[BytesRead] := #0;
                // последний символ #0 - конец буфера
                OemToAnsi(Buffer, Buffer);
                // перевели из кодировки DOS в кодировку WIN
                AMemo.Text := AMemo.text + String(Buffer);
                // то что прочитали приписали к тексту в мемо
                Application.ProcessMessages;
                // обработали очередь сообщений
//            Until ((Apprunning <> WAIT_TIMEOUT) or (avail < 0));
            Until stop;
            // прервемся когда процесс завершится
        End;
        FreeMem(Buffer); // освободили буфер
        CloseHandle(ProcessInfo.hProcess); // закрыли все хендлы
        CloseHandle(ProcessInfo.hThread);
        CloseHandle(OutReadPipe);
        CloseHandle(OutWritePipe);
        CloseHandle(InReadPipe);
        CloseHandle(InWritePipe);
        CloseHandle(ErrReadPipe);
        CloseHandle(ErrWritePipe);
    End;
    // конец.
End;

Обычно TerminateProcess(hProcess, NO_ERROR); достаточно но если процесс порождает процессы то лучше использовать что-то вроде KillProcessTree

Код: Выделить всё

function KillProcessTree(const PID: Cardinal;F:boolean=True ): boolean;
var hProc, hSnap,
    hChildProc  : THandle;
    pe          : TProcessEntry32;
    bCont       : BOOL;
    Int:TIniFile;
begin
    Result := true;
    FillChar(pe, SizeOf(pe), #0);
    pe.dwSize := SizeOf(pe);

    hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

    if (hSnap <> INVALID_HANDLE_VALUE) then
    begin

        if (Process32First(hSnap, pe)) then
        begin
            hProc := OpenProcess(PROCESS_ALL_ACCESS, false, PID);

            if (hProc <> 0) then
            begin
                if F then begin
                Result := Result and TerminateProcess(hProc, 1);
                WaitForSingleObject(hProc, INFINITE);
                end
                else  GenerateConsoleCtrlEvent (CTRL_CLOSE_EVENT {CTRL_C_EVENTC TRL_BREAK_EVENT},hProc);
                CloseHandle(hProc);
            end;

            bCont := true;
            while bCont do
            begin
                if (pe.th32ParentProcessID = PID) then
                begin
                    KillProcessTree(pe.th32ProcessID,F);

                    hChildProc := OpenProcess(PROCESS_ALL_ACCESS, FALSE, pe.th32ProcessID);

                    if (hChildProc <> 0) then
                    begin
                        if F then begin
                        Result := Result and TerminateProcess(hChildProc, 1);
                        WaitForSingleObject(hChildProc, INFINITE);
                        end
                        else  GenerateConsoleCtrlEvent (CTRL_CLOSE_EVENT {CTRL_C_EVENT CTRL_BREAK_EVENT}, hChildProc);

                        CloseHandle(hChildProc);
                    end;
                end;
                bCont := Process32Next(hSnap, pe);
            end;
        end;

        CloseHandle(hSnap);
    end;
end;

[sunjob]

да не, чЕ мудрить? я ее из руЖа грохаю, наповал! :о)

[Alex2013]

Тфу извиняюсь... мусор

[Alex2013]

да не, чЕ мудрить? я ее из руЖа грохаю, наповал! :о)

Это тоже вариант ...

[ALLIGATOR]

Была похожая проблема
Точно сути не помню, как решил но, дело было то ли в том, что нужно было считать попробовать байты, а я ждал через ожидание наличия данных или как-то так... в общем попробуй просто в цикле читать всё время