perl - 这为啥不死？

Question

我创建了一个包来启动一个简单的 HTTP 服务器以进行测试，但 stop() 方法似乎并不想停止 fork()'ed 过程。终止进程(通过 SIGHUP)在对象外部可以正常工作，但调用 $server->stop 就不起作用。为什么？

package MockHub;
use Moose;
use HTTP::Server::Brick;
use JSON;
use Log::Any qw($log);
use English qw(-no_match_vars);

has 'server' => (
    'is'       => 'ro',
    'lazy'     => 1,
    'isa'      => 'HTTP::Server::Brick',
    'builder'  => '_build_server',
    'init_arg' => undef
);
has 'port'  => ( 'is' => 'ro', 'isa' => 'Int' );
has 'pid'   => ( 'is' => 'rw', 'isa' => 'Int', 'init_arg' => undef );
has 'token' => ( 'is' => 'rw', 'isa' => 'Str', 'init_arg' => undef );
has 'log'   => ( 'is' => 'ro', 'isa' => 'Log::Any::Proxy', 'default' => sub { Log::Any->get_logger() } );

sub start {
    my $self = shift;        

    my $pid = fork;

    # Spawn the server in a child process.
    if (!defined $pid) {
        die qq{Can't fork: $!};
    }
    elsif ($pid == 0) { # child 
        $self->server->start;
        exit; # exit after server exits
    }
    else { # parent 
        $self->pid($pid);
        return $pid;
    }
}

sub _build_server {
    my ($self) = @_;

    my $port   = $self->port;
    my $pid    = $self->pid || 'NO PID';
    my $server = HTTP::Server::Brick->new( port => $port );
    $server->mount(
        '/foo' => {
            'handler' => sub {
                my ( $req, $res ) = @_;
                my $token = substr( $req->{'path_info'}, 1 );    # remove leading slash
                $self->token($token);
                $res->header( 'Content-Type' => 'application/json' );
                $res->add_content( encode_json( { 'success' => 1, 'message' => 'Process Report Received' } ) );
                1;
            },
            'wildcard' => 1,
        },
    );
    $server->mount(
        '/token' => {
            'handler' => sub {
                my ( $req, $res ) = @_;
                my $token = $self->token || '';
                $res->header( 'Content-Type' => 'text/plain' );
                $res->add_content($token);
                1;
            },
        },
    );

    return $server;
}

sub stop {
    my ($self) = @_;

    my $pid = $self->pid || die q{No PID};

    if (kill 0, $pid) {
        sleep 1;
        kill 'HUP', $pid;
        if (kill 0, $pid) {
            warn q{Server will not die!};
        }
    }
    else {
        warn q{Server not running};
    }
}
__PACKAGE__->meta->make_immutable;

Answer 1

虽然它没有运行，但该进程仍然存在，直到其父进程通过 wait(2) 获取它为止。由于子进程永远不会被收割(并且不存在权限问题)，因此 kill 0, $pid 将始终成功。已修复:

sub stop {
    my ($self) = @_;

    my $pid = $self->pid
        or die("No child to stop.\n");

    kill(TERM => $pid);
        or die("Can't kill child.\n");

    if (!eval {{
        local $SIG{ALRM} = sub { die "timeout\n" };
        alarm(15);
        waitpid($pid, 0) > 0
            or die("Can't reap child.\n");

        return 1;  # No exception
    }}) {
        die($@) if $@ ne "timeout\n";

        warn("Forcing child to end.\n");
        kill(KILL => $pid)
            or die("Can't kill child.\n");

        waitpid($pid, 0) > 0
            or die("Can't reap child.\n");
    }

    $self->pid(0);
}