Why won't it die?
I've created a package that starts a simple HTTP server for testing purposes, but the method stop()
doesn't seem to want to stop the fork()
'ed process . Killing the process (via SIGHUP
) works fine outside of the object, but the call $server->stop
just doesn't work. Why?
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;
source to share
Even though it doesn't work, the process still exists until its parent resource receives it using wait
(2). Since the child never reaps (and since there is no permission), kill 0, $pid
it will always be successful. Fixed:
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);
}
source to share
Your routine stop
doesn't seem to be stopping anything. It dispatches kill 0
(which simply determines when a process is running), or HUP
. Do you want to send SIGTERM
or similar?
Also, what are you trying to achieve with $self->$pid
? When you execute fork()
, then the memory space of the parent and child is shared, so what you write in $self->pid
in the parent will not be visible to the child. So you need to write down the PID of the child in the child like
$self->pid = $$;
before
$self->server->start;
I'm a bit unsure which process you are trying to kill here, and which process is calling stop()
. I'm guessing it's not exactly the same, or you would probably just walk away from there and not guess with help kill
, etc.
source to share