这个怎么不死

Question

我已经创建了一个包来启动一个简单的 HTTP 服务器用于测试目的，但是 stop() 方法似乎不想停止 fork() 的进程。终止进程（通过 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

您的 stop 子例程似乎没有停止任何操作。它发送 kill 0（仅检测进程何时为运行）或 HUP。您不想发送 SIGTERM 或类似的吗？

另外，你想用 $self->$pid 达到什么目的？当你做fork()的时候，那么父子的内存space是分开的，所以你在父子里写入$self->pid的东西，子子是看不到的。因此需要在child中记录child的PID，例如

$self->pid = $$;

之前

$self->server->start;

我有点不确定您要在这里杀死哪个进程，以及哪个进程正在调用 stop()。我假设这些并不完全相同，或者你肯定会从那里退出而不是乱搞 kill 等

Answer 2

虽然它不是运行，但该进程仍然存在，直到它的 parent 收割它被 wait(2) 收割。因为 child 永远不会被收割（并且因为没有权限问题），所以 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);
}

这个怎么不死

Why won't this die?

perl

fork