В Perl, убивая ребенка и его детей, когда ребенок был создан с помощью open

Question

Вот мой код с обработкой ошибок и другими вещами, удаленными для ясности:

sub launch_and_monitor {  

    my ($script, $timeout) = @_;

    sub REAPER {
        while ((my $child = waitpid(-1, &WNOHANG)) > 0) {}
        $SIG{CHLD} = \&REAPER;
    }
    $SIG{CHLD} = \&REAPER;

    my $pid = fork;
    if (defined $pid) {
        if ($pid == 0) {
            # in child
            monitor($timeout);
        }
        else {
            launch($script);
        }
    }
}

Подпрограмма запуска выполняет сценарий оболочки, который, в свою очередь, запускает другие процессы, например:

sub launch($) {

    my ($script) = @_;

    my $pid = open(PIPE, "$script|");

    # write pid to pidfile

    if ($pid != 0) {
        while(<PIPE>) {
            # do stuff with output
        }
        close(PIPE) or die $!;
    }
}

Монитор sub в основном просто ждет в течение определенного периода времени и затем пытается убить скрипт оболочки.

sub monitor($) {

    my ($timeout) = @_;

    sleep $timeout;

    # check if script is still running and if so get pid from pidfile
    if (...) {
        my $pid = getpid(...);        
        kill 9, $pid;
    }
}

Это убивает скрипт, однако не убивает ни один из его подпроцессов. Как исправить?

Answer 1

Вы можете сделать это с группами процессов, если ваша операционная система поддерживает их. Вы должны сделать процесс сценария лидером группы процессов. Дочерние процессы, которые он запускает, унаследуют группу процессов от своего родителя. Затем вы можете использовать команду kill для одновременной отправки сигнала каждому процессу в группе.

В launch(), вам нужно будет заменить open линия с одним, который разветвляется. Тогда в ребенка, вы бы позвонили setpgrp() перед выполнением команды. Должно работать что-то вроде следующего:

my $pid = open(PIPE, "-|");
if (0 == $pid) {
    setpgrp(0, 0);
    exec $script;
    die "exec failed: $!\n";
}
else {
    while(<PIPE>) {
        # do stuff with output
    }
    close(PIPE) or die $!;
}

Позже, чтобы убить процесс сценария и его дочерние элементы, отмените идентификатор процесса, который вы сигнализируете:

kill 9, -$pid;

Answer 2

Попробуйте добавить:

use POSIX qw(setsid);
setsid;

в верхней части вашего launch_and_monitor функция. Это поместит ваши процессы в отдельный сеанс и приведет к тому, что все завершится, когда выйдет лидер сеанса (т.е. мастер).

Answer 3

В общем, я не думаю, что вы можете ожидать распространения сигналов во все дочерние процессы; это не специфично для perl.

Тем не менее, вы можете использовать функцию сигнала группы процессов, встроенную в perl kill ():

... если сигнал отрицателен, он убивает группы процессов вместо процессов...

Возможно, вам нужно использовать setpgrp() в вашем (прямом) дочернем процессе, а затем изменить вызов kill на что-то вроде:

kill -9, $pgrp;

Answer 4

Уничтожение группы процессов работает, но не забывайте, что родитель тоже может быть убит один. Предполагая, что дочерние процессы имеют цикл обработки событий, они могут проверить родительский сокет, созданный в socketpair, перед выполнением fork() на достоверность. Фактически, select() завершает работу, когда родительский сокет исчезает, все, что нужно сделать, это проверить сокет.

Например:

use strict; use warnings;
use Socket;

$SIG{CHLD} = sub {};

socketpair(my $p, my $c, AF_UNIX, SOCK_STREAM, PF_UNSPEC) or die $!;

print "parent $$, fork 2 kids\n";
for (0..1){
    my $kid = fork();
    unless($kid){
        child_loop($p, $c);
        exit; 
    }
    print "parent $$, forked kid $kid\n";
}

print "parent $$, waiting 5s\n";
sleep 5;
print "parent $$ exit, closing sockets\n";

sub child_loop {
    my ($p_s, $c_s) = @_;
    print "kid: $$\n";
    close($c_s);
    my $rin = '';
    vec($rin, fileno($p_s), 1) = 1;
    while(1){
        select my $rout = $rin, undef, undef, undef;
        if(vec($rout, fileno($p_s), 1)){
            print "kid: $$, parent gone, exiting\n";
            last;
        }
    }
}

Работает так:

tim@mint:~$ perl ~/abc.pl
parent 5638, fork 2 kids
parent 5638, forked kid 5639
kid: 5639
parent 5638, forked kid 5640
parent 5638, waiting 5s
kid: 5640
parent 5638 exit, closing sockets
kid: 5640, parent gone, exiting
kid: 5639, parent gone, exiting
tim@mint:~$