Bug #28122 for HTTP-Server-Simple: Random test results PASS 362 : FAIL 10

On Thu Jul 12 14:18:41 2007, SARTAK wrote: Show quoted text
Of course, I tried it, and it didn't fail after 10 make tests, so I've changed my mind! Here's a patch that, if the connection failed, tries to reconnect after 2s and lets the user know why the connection failed. Had to do some refactoring to avoid code duplication. Shawn M Moore

diff -Nurb HTTP-Server-Simple-0.27/t/01live.t HTTP-Server-Simple-0.27-new/t/01live.t --- HTTP-Server-Simple-0.27/t/01live.t 2007-01-17 13:31:43.000000000 -0500 +++ HTTP-Server-Simple-0.27-new/t/01live.t 2007-07-12 15:04:01.000000000 -0400 @@ -58,11 +58,12 @@ # this function may look excessive, but hopefully will be very useful # in identifying common problems -sub fetch { - my @response; - my $alarm = 0; - my $stage = "init"; +my ($alarm, $stage, $iaddr, $paddr, $proto, @response); + +sub fetch { + $alarm = 0; + $stage = "init"; my %messages = ( "init" => "inner contemplation", @@ -84,9 +85,24 @@ $alarm = 1; }; - my ($iaddr, $paddr, $proto, $message); + undef $iaddr; + undef $paddr; + undef $proto; + undef @response; + + my $message = join "", map { "$_\015\012" } @_; + + # this entire cycle should finish way before this timer expires + alarm(10); + + connection($message, 0); +} - $message = join "", map { "$_\015\012" } @_; +sub connection { + my $message = shift; + my $recursed = shift; + + my @response; my %states = ( 'init' => sub { "lookup"; }, @@ -110,9 +126,6 @@ "close" => sub { close SOCK; "done"; }, ); - # this entire cycle should finish way before this timer expires - alarm(5); - my $next; $stage = $next while (!$alarm && $stage ne "done" @@ -120,9 +133,14 @@ warn "early exit from `$stage' stage; $!" unless $next; + if ($stage eq 'connect' && !$recursed) { + warn "this is probably due to a timing problem -- if you have a slower CPU or it's under high load, the server may not have had enough time to initialize everything before the test tried to connect to it. trying again in 2s"; + # reset alarm because sleep uses SIGALRM + alarm 0; sleep 2; alarm 8; + return connection($message, 1); + } + # bank on the test testing for something in the response. return join "", @response; - - } diff -Nurb HTTP-Server-Simple-0.27/t/04cgi.t HTTP-Server-Simple-0.27-new/t/04cgi.t --- HTTP-Server-Simple-0.27/t/04cgi.t 2007-01-17 13:31:43.000000000 -0500 +++ HTTP-Server-Simple-0.27-new/t/04cgi.t 2007-07-12 15:04:29.000000000 -0400 @@ -69,12 +69,14 @@ wait or die "counldn't wait for sub-process completion"; } +# this function may look excessive, but hopefully will be very useful +# in identifying common problems -sub fetch { +my ($alarm, $stage, $iaddr, $paddr, $proto, @response); - my @response; - my $alarm = 0; - my $stage = "init"; +sub fetch { + $alarm = 0; + $stage = "init"; my %messages = ( "init" => "inner contemplation", @@ -96,9 +98,24 @@ $alarm = 1; }; - my ($iaddr, $paddr, $proto, $message); + undef $iaddr; + undef $paddr; + undef $proto; + undef @response; - $message = join "", map { "$_\015\012" } @_; + my $message = join "", map { "$_\015\012" } @_; + + # this entire cycle should finish way before this timer expires + alarm(10); + + connection($message, 0); +} + +sub connection { + my $message = shift; + my $recursed = shift; + + my @response; my %states = ( 'init' => sub { "lookup"; }, @@ -122,9 +139,6 @@ "close" => sub { close SOCK; "done"; }, ); - # this entire cycle should finish way before this timer expires - alarm(5); - my $next; $stage = $next while (!$alarm && $stage ne "done" @@ -132,12 +146,18 @@ warn "early exit from `$stage' stage; $!" unless $next; + if ($stage eq 'connect' && !$recursed) { + warn "this is probably due to a timing problem -- if you have a slower CPU or it's under high load, the server may not have had enough time to initialize everything before the test tried to connect to it. trying again in 2s"; + # reset alarm because sleep uses SIGALRM + alarm 0; sleep 2; alarm 8; + return connection($message, 1); + } + # bank on the test testing for something in the response. return join "", @response; - - } + { package CGIServer; use base qw(HTTP::Server::Simple::CGI);

On Sun Sep 16 06:46:51 2007, ntyni@iki.fi wrote: Show quoted text
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 ntyni@debian.org

diff --git a/lib/HTTP/Server/Simple.pm b/lib/HTTP/Server/Simple.pm index ba2430e..f5bcfea 100755 --- a/lib/HTTP/Server/Simple.pm +++ b/lib/HTTP/Server/Simple.pm @@ -6,6 +6,7 @@ use FileHandle; use Socket; use Carp; use URI::Escape; +use IO::Select; use vars qw($VERSION $bad_request_doc); $VERSION = '0.31'; @@ -215,15 +216,31 @@ Run the server in the background. returns pid. 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 @@ sub run { $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 _process_request { } } +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}; +} diff --git a/t/01live.t b/t/01live.t index e1b35a2..e779731 100644 --- a/t/01live.t +++ b/t/01live.t @@ -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 @@ my $PORT = 8000 + $$; 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 @@ my $DEBUG = 1 if @ARGV; $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", "");