[Bps-public-commit] r11869 - in HTTP-Server-Simple: . t

[jesse at bestpractical.com]

Author: jesse
Date: Thu Apr 24 09:47:55 2008
New Revision: 11869

Modified:
   HTTP-Server-Simple/   (props changed)
   HTTP-Server-Simple/lib/HTTP/Server/Simple.pm
   HTTP-Server-Simple/t/01live.t

Log:
 r30058 at 115:  jesse | 2008-04-24 09:45:04 -0400
 * Patch from ntyni at iki.fi to make backgrounding of the standalone server's server process deterministic. [rt.cpan.org #28122]
 
       Queue: HTTP-Server-Simple
       Ticket <URL: http://rt.cpan.org/Ticket/Display.html?id=28122 >
 
       On Sun Sep 16 06:46:51 2007, ntyni at iki.fi wrote:
       On Mon Aug 27 06:46:48 2007, ntyni at iki.fi wrote:
 
       It would be nice if background() could wait until the server is ready. I
       suppose this would not be very hard to implement: just use a pipe
       between the processes when forking, and make the child send a message
       when it's ready. I can take a shot at a patch if you like.
 
       I'm attaching three patches: a testcase that fails with the current
       version, and two alternative proposals for fixing this. The first one
       makes the child send a SIGUSR1 to the parent when it's ready, the second
       one says "OK" into a pipe between them.
 
       Please consider adding something like this to make the behaviour
       deterministic.
 
       We have had the signal version of the patch in Debian for some time now,
       and it was recently noticed that it breaks the test suite of
       Test-HTTP-Server-Simple, which uses SIGUSR1 too. See
       <http://bugs.debian.org/477227> for more information.
 
       In hindsight, using a user signal in a library was probably a bad idea.
       So the pipe version would seem to be the better choice.
 
       I see there have been several releases since, and my test case patch
       doesn't apply cleanly anymore. I'm attaching an updated version of the
       patches.
 
       Please let me know if there's something else I can do to help get this
       integrated. I really think this is a bug worth fixing.
 
       Many thanks for your work on free software,
       -- 
       Niko Tyni
 


Modified: HTTP-Server-Simple/lib/HTTP/Server/Simple.pm
==============================================================================
--- HTTP-Server-Simple/lib/HTTP/Server/Simple.pm	(original)
+++ HTTP-Server-Simple/lib/HTTP/Server/Simple.pm	Thu Apr 24 09:47:55 2008
@@ -6,6 +6,7 @@
 use Socket;
 use Carp;
 use URI::Escape;
+use IO::Select;
 
 use vars qw($VERSION $bad_request_doc);
 $VERSION = '0.31';
@@ -215,15 +216,31 @@
 
 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;
     die "Can't fork: $!" unless defined($child);
-    return $child if $child;
+    if ($child) { # parent
+        my $s = IO::Select->new;
+        $s->add($readfh);
+        my @ready = $s->can_read(5);
+        die("child unresponsive for 5 seconds") if !@ready;
+        my $response = <$readfh>;
+        chomp $response;
+        die("child is confused: answer '$response' != 'OK'")
+            if $response ne "OK";
+        return $child;
+    }    
 
     if ( $^O !~ /MSWin32/ ) {
         require POSIX;
         POSIX::setsid()
             or die "Can't start a new session: $!";
     }
+    $self->{_parent_handle} = $writefh;
     $self->run();
 }
 
@@ -263,6 +280,7 @@
 	$self->after_setup_listener();
         *{"$pkg\::run"} = $self->_default_run;
     }
+    $self->_maybe_tell_parent();
 
     local $SIG{HUP} = sub { $SERVER_SHOULD_RUN = 0; };
 
@@ -400,6 +418,15 @@
         }
 }
 
+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};
+}
 
 
 

Modified: HTTP-Server-Simple/t/01live.t
==============================================================================
--- HTTP-Server-Simple/t/01live.t	(original)
+++ HTTP-Server-Simple/t/01live.t	Thu Apr 24 09:47:55 2008
@@ -1,7 +1,7 @@
 # -*- perl -*-
 
 use Socket;
-use Test::More tests => 10;
+use Test::More tests => 14;
 use strict;
 
 # This script assumes that `localhost' will resolve to a local IP
@@ -12,16 +12,31 @@
 
 use HTTP::Server::Simple;
 
+package SlowServer;
+# This test class just waits a while before it starts
+# accepting connections. This makes sure that CPAN #28122 is fixed:
+# background() shouldn't return prematurely.
+
+use base qw(HTTP::Server::Simple::CGI);
+sub setup_listener {
+    my $self = shift;
+    sleep 2;
+    $self->SUPER::setup_listener();
+}
+1;
+package main;
+
 my $DEBUG = 1 if @ARGV;
 
+my @classes = (qw(HTTP::Server::Simple SlowServer));
+for my $class (@classes)
 {
-    my $s=HTTP::Server::Simple->new($PORT);
+    my $s = $class->new($PORT);
     is($s->port(),$PORT,"Constructor set port correctly");
 
     my $pid=$s->background();
 
     like($pid, '/^-?\d+$/', 'pid is numeric');
-    select(undef,undef,undef,0.2); # wait a sec
 
     my $content=fetch("GET / HTTP/1.1", "");
 
@@ -35,7 +50,6 @@
     $s->host("localhost");
     my $pid=$s->background();
     diag("started server on $pid");
-    select(undef,undef,undef,0.2); # wait a sec
     like($pid, '/^-?\d+$/', 'pid is numeric');
 
     my $content=fetch("GET / HTTP/1.1", "");