我创建了一个包来启动一个简单的 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;
最佳答案
虽然它没有运行,但该进程仍然存在,直到其父进程通过 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);
}
关于perl - 这为啥不死?,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/31815865/