Why won't this die? - perl

Question

I've created a package that starts a simple HTTP server for testing purposes, but the stop() method doesn't seem to want to stop the fork()'ed process. Killing the process (via SIGHUP) works fine outside of the object, but calling $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;

Answer 1

Although it's not running, the process still exists until its parent reaps it reaped by wait(2). Since the child is never reaped (and since there's no permission issue), kill 0, $pid will always succeed. 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);
}

Answer 2

Your stop subroutine does not appear to stop anything. It sends kill 0 (which merely detects when the process is running), or a HUP. Don't you want to send SIGTERM or similar?
Also, what are you trying to achieve with $self->$pid? When you do the fork(), then the memory space of parent and child are separated, so what you write into $self->pid in the parent will not be visible to the child. You thus need to record the PID of the child in the child, e.g.
$self->pid = $$;
before
$self->server->start;
I'm a little unsure exactly which process you are trying to kill here, and which process is calling stop(). I'm presuming these aren't exactly the same or you'd surely just have quit from there rather than muck around with kill etc.