1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
Author: Niko Tyni <ntyni@iki.fi>
Subject: Pipe version: parent waits for the child to say "OK" via a pipe
Forwarded: http://rt.cpan.org/Public/Bug/Display.html?id=28122
Bug: http://rt.cpan.org/Public/Bug/Display.html?id=28122
Bug-Debian: #439724, #477227
Last-Update: 2015-10-18
Reviewed-by: Nicholas Bamber <nicholas@periapt.co.uk>
--- a/lib/HTTP/Server/Simple.pm
+++ b/lib/HTTP/Server/Simple.pm
@@ -5,6 +5,7 @@
use FileHandle;
use Socket;
use Carp;
+use IO::Select;
use vars qw($VERSION $bad_request_doc);
$VERSION = '0.51';
@@ -240,9 +241,30 @@
sub background {
my $self = shift;
+
+ # set up a pipe so the child can tell the parent when it's ready
+ # to accept requests
+ my ($readfh, $writefh) = FileHandle::pipe;
+
my $child = fork;
croak "Can't fork: $!" unless defined($child);
- return $child if $child;
+
+ if ($child) { # parent
+ my $s = IO::Select->new;
+ $s->add($readfh);
+ my $now = time; my $left = 0;
+ my @ready;
+ while(not @ready and $left < 5) {
+ @ready = $s->can_read($left);
+ $left = time - $now;
+ }
+ die("child unresponsive for 5 seconds") if(not @ready);
+ my $response = <$readfh>;
+ chomp $response;
+ die("child is confused: answer '$response' != 'OK'")
+ if $response ne "OK";
+ return $child;
+ }
srand(); # after a fork, we need to reset the random seed
# or we'll get the same numbers in both branches
@@ -251,6 +273,8 @@
POSIX::setsid()
or croak "Can't start a new session: $!";
}
+
+ $self->{_parent_handle} = $writefh;
$self->run(@_); # should never return
exit; # just to be sure
}
@@ -300,6 +324,7 @@
$self->after_setup_listener();
*{"$pkg\::run"} = $self->_default_run;
}
+ $self->_maybe_tell_parent();
local $SIG{HUP} = sub { $SERVER_SHOULD_RUN = 0; };
@@ -451,6 +476,16 @@
}
}
+sub _maybe_tell_parent {
+ # inform the parent process that we're ready, if applicable
+ my $self = shift;
+ my $handle = $self->{_parent_handle};
+ return if !$handle;
+ print $handle "OK\n";
+ close $handle;
+ delete $self->{_parent_handle};
+}
+
=head2 stdio_handle [FILEHANDLE]
When called with an argument, sets the socket to the server to that arg.
|
