Bug #27223 for NetServer-Generic: Forking server exits after reaping children [PATCH SUPPLIED]

-- Demonstration -- I used to following script to test the module: use NetServer::Generic; my $server = NetServer::Generic->new; $server->port(9000); $server->run(); # Server should now run until $server->quit is called print "Server has stopped running :(\n"; Use a telnet client to access the server on port 9000. You will see the default echo server. Type 'bye'. The connection should close, but the server should remain running waiting for other connections. Instead you will see that the server exits. -- Explanation -- Mostly SIGCHLD is received while that main server process is waiting on $main_sock->accept() for a new connection. When a child process exits, SIGCHLD is received and that wait is interrupted. Once the signal is handled by &reap_child and control returns, Perl does not restart the relevant system call for $main_sock->accept, which instead returns undef. This is interpreted as an error and the server ends. -- Proposed Fix - Patch Attached -- Set a flag whenever &reap_child is called. If $main_sock->accept() fails, test this flag and restart the $main_sock->accept() call if we were interrupted. A patch is attached. I've tried as far as possible to keep to the same style conventions - and I hope the wide scope of the $NetServer::Signal_Flag variable I've introduced doesn't offend you too much :) I hope this proves useful. I've found this module a great help - thanks. FYI I'm running NetServer-Generic-1.03, perl v5.8.8 on Linux 2.6.18-gentoo-r5 #8 SMP PREEMPT

--- /home/nick/Perl-NetServer-Test/NetServer-Generic-1.03/Generic.pm 2000-12-12 19:20:54.000000000 +0000 +++ /usr/lib/perl5/vendor_perl/5.8.8/NetServer/Generic.pm 2007-05-21 16:08:11.000000000 +0000 @@ -564,6 +564,11 @@ $NetServer::Debug = 0; +# $NetServer::Signal_Flag; if non-zero, we were interrupted to service a signal +# Perhaps we want to reset this flag and resume what we were doing before +$NetServer::Signal_Flag = 0; + + # here is a default callback routine. It basically echoes back anything # you sent to the server, unless the line begins with quit, bye, or # exit -- in which case it kills the server (rather than simply exiting). @@ -675,6 +680,8 @@ } sub reap_child { + # This sub is called when we receive a SIGCHLD + $NetServer::Signal_Flag = 1; do {} while waitpid(-1, WNOHANG) > 0; } @@ -1067,7 +1074,24 @@ # now loop, forking whenever a new connection arrives on the listener $self->root_pid($$); # set server root PID - while (my ($new_sock) = $main_sock->accept()) { + while (1) { + + # $NetServer::Signal_Flag is set by the SIGCHLD handler which + # can interrupt us while waiting on $main_sock->accept() + # For some reason this call is not restarted by Perl + # when the signal handling function returns, so we need to + # check and restart ourselves if need be. + $NetServer::Signal_Flag = 0; + my ($new_sock) = $main_sock->accept(); + if (!$new_sock && $NetServer::Signal_Flag) { + # We were interrupted + redo; + } elsif (!$new_sock) { + # Some other error occurred - give up + last; + } + + # If we get here, then we have a valid socket connection &$ante_fork_callback($self) if ( defined $ante_fork_callback ); my $x_time = [ gettimeofday ]; # millisecond timer to track duration my $pid = fork();