Em Perl, filho matando e seus filhos quando criança foi criado usando open

Question

Aqui está o meu código, com tratamento de erros e outras coisas removidos para maior clareza:

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);
        }
    }
}

O sub lançamento executa um script shell que nos lançamentos em outros processos, assim:

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 $!;
    }
}

O Monitor Sub basicamente apenas espera por um período de tempo especificado e, em seguida, tentativas de matar o shell script.

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;
    }
}

Isso mata o script, no entanto, ele não mata qualquer de sub processos. Como corrigir?

Answer 1

Você pode fazer isso com grupos de processos, se o seu sistema operacional suporta-los. Você precisa fazer o processo de script de se tornar um líder de grupo de processo. A criança processa que ele seja executado herdarão o grupo de processos de seu pai. Você pode então usar kill para enviar um sinal para cada processo no grupo ao mesmo tempo.

Em launch(), você precisará substituir a linha open com um que garfos. Em seguida, no filho, você chamaria setpgrp() antes exec'ing o comando. Algo como o seguinte deve funcionar:

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 $!;
}

Mais tarde, para matar o processo de script e seus filhos, nega o ID do processo que você está de sinalização:

kill 9, -$pid;

Answer 2

Em geral, eu não acho que você pode esperar sinais a serem propagadas para todos os processos filhos; este não é específico para perl.

Dito isso, você pode ser capaz de usar o processo de grupo recurso de sinal embutido no perl kill () :

... Se o sinal é negativo, ele mata grupos de processos em vez de processos ...

Você provavelmente precisará usar setpgrp () em seu processo filho (direta) , em seguida, altere sua chamada kill para algo como:

kill -9, $pgrp;

Answer 3

Tente adicionar:

use POSIX qw(setsid);
setsid;

no topo da sua função launch_and_monitor. Isto irá colocar os seus processos em uma sessão separada, e porque as coisas para sair quando o líder da sessão (ou seja, o mestre) saídas.

Answer 4

Matar um processgroup funciona, mas não se esqueça do pai pode ser morto sozinho também. Assumindo processos filhos têm um ciclo de eventos, eles podem verificar o soquete pai que foi criado em um socketpair antes fazendo o fork () para válido até. Na verdade, seleccione () saídas de forma limpa quando tomada o pai se foi, tudo o que precisa ser feito é verificar a tomada.

por exemplo:.

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;
        }
    }
}

Funciona como este:

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:~$