En perl, matar al niño y sus hijos cuando el niño se creó usando abierto

kill children

Question

Aquí está mi código, con el manejo de errores y otras cosas eliminadas para mayor claridad:

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

El subinicio de ejecución ejecuta un script de shell que a su vez inicia otros procesos, así:

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

El monitor secundario básicamente solo espera durante un período de tiempo específico y luego intenta eliminar el script de shell.

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

Esto mata el script, sin embargo, no mata ninguno de sus subprocesos. ¿Como arreglar?

Answer 1

En general, no creo que pueda esperar que las señales se propaguen en todos los procesos secundarios; esto no es específico de Perl.

Dicho esto, es posible que pueda usar la característica de señal de grupo de procesos incorporada en perl kill () :

... si SIGNAL es negativo, mata grupos de procesos en lugar de procesos ...

Probablemente necesites usar setpgrp () en tu proceso hijo (directo), luego cambia tu llamada de muerte a algo como:

kill -9, $pgrp;

Answer 2

Prueba agregar:

use POSIX qw(setsid);
setsid;

en la parte superior de tu función launch_and_monitor . Esto colocará sus procesos en una sesión separada y hará que las cosas salgan cuando salga el líder de la sesión (es decir, el maestro).

Answer 3

Puede hacer esto con grupos de procesos, si su sistema operativo los admite. Necesita hacer que el proceso de script se convierta en un líder de grupo de proceso. Los procesos secundarios que ejecuta heredarán el grupo de procesos de sus padres. Luego puede usar kill para enviar una señal a cada proceso en el grupo al mismo tiempo.

En el launch() , deberá reemplazar la línea open por una que se bifurca. Luego en el niño, llamarías a setpgrp() antes de ejecutar el comando. Algo como lo siguiente debería 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 $!;
}

Más tarde, para eliminar el proceso de script y sus hijos, anule la identificación del proceso que está señalando:

kill 9, -$pid;

Answer 4

Matar a un grupo de procesos funciona, pero no olvides que el padre también puede ser asesinado solo. Suponiendo que los procesos hijo tienen un bucle de evento, pueden verificar el socket padre que se creó en un par de socket antes de hacer el fork () para la validez. De hecho, select () limpiamente sale cuando el socket principal se ha ido, todo lo que se necesita hacer es verificar el socket.

P.ej:

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 así:

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