[perl #39835] Patch for perlipc.pod to update TCP server example wrt safe signals and accept()

From: Andy Wardley (via RT) <perlbug-followup@perl.org>
Message-ID: <rt-3.6.HEAD-20371-1152897103-1865.39835-75-0@perl.org>

p4raw-id: //depot/perl@28622

1 files changed, 72 insertions, 48 deletions

diff --git a/pod/perlipc.pod b/pod/perlipc.pod
index 3de879fc0a..4061dd1aab 100644
--- a/pod/perlipc.pod
+++ b/pod/perlipc.pod
@@ -915,67 +915,91 @@ go back to service a new client.
     my $paddr;
 
     use POSIX ":sys_wait_h";
+    use Errno;
+
     sub REAPER {
-	my $child;
-        while (($waitedpid = waitpid(-1,WNOHANG)) > 0) {
-	    logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
-	}
-	$SIG{CHLD} = \&REAPER;  # loathe sysV
+        local $!;   # don't let waitpid() overwrite current error
+        while ((my $pid = waitpid(-1,WNOHANG)) > 0 && WIFEXITED($?)) {
+            logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
+        }
+        $SIG{CHLD} = \&REAPER;  # loathe sysV
     }
 
     $SIG{CHLD} = \&REAPER;
 
-    for ( $waitedpid = 0;
-	  ($paddr = accept(Client,Server)) || $waitedpid;
-	  $waitedpid = 0, close Client)
-    {
-	next if $waitedpid and not $paddr;
-	my($port,$iaddr) = sockaddr_in($paddr);
-	my $name = gethostbyaddr($iaddr,AF_INET);
-
-	logmsg "connection from $name [",
-		inet_ntoa($iaddr), "]
-		at port $port";
-
-	spawn sub {
-	    $|=1;
-	    print "Hello there, $name, it's now ", scalar localtime, $EOL;
-	    exec '/usr/games/fortune'		# XXX: `wrong' line terminators
-		or confess "can't exec fortune: $!";
-	};
-
+    while(1) {
+        $paddr = accept(Client, Server) || do {
+            # try again if accept() returned because a signal was received
+            next if $!{EINTR};
+            die "accept: $!";
+        };
+        my ($port, $iaddr) = sockaddr_in($paddr);
+        my $name = gethostbyaddr($iaddr, AF_INET);
+
+        logmsg "connection from $name [",
+               inet_ntoa($iaddr),
+               "] at port $port";
+
+        spawn sub {
+            $|=1;
+            print "Hello there, $name, it's now ", scalar localtime, $EOL;
+            exec '/usr/games/fortune'       # XXX: `wrong' line terminators
+                or confess "can't exec fortune: $!";
+        };
+        close Client;
     }
 
     sub spawn {
-	my $coderef = shift;
+        my $coderef = shift;
 
-	unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
-	    confess "usage: spawn CODEREF";
-	}
+        unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
+            confess "usage: spawn CODEREF";
+        }
 
-	my $pid;
-	if (!defined($pid = fork)) {
-	    logmsg "cannot fork: $!";
-	    return;
-	} elsif ($pid) {
-	    logmsg "begat $pid";
-	    return; # I'm the parent
-	}
-	# else I'm the child -- go spawn
+        my $pid;
+        if (! defined($pid = fork)) {
+            logmsg "cannot fork: $!";
+            return;
+        } 
+        elsif ($pid) {
+            logmsg "begat $pid";
+            return; # I'm the parent
+        }
+        # else I'm the child -- go spawn
 
-	open(STDIN,  "<&Client")   || die "can't dup client to stdin";
-	open(STDOUT, ">&Client")   || die "can't dup client to stdout";
-	## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
-	exit &$coderef();
+        open(STDIN,  "<&Client")   || die "can't dup client to stdin";
+        open(STDOUT, ">&Client")   || die "can't dup client to stdout";
+        ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
+        exit &$coderef();
     }
 
-This server takes the trouble to clone off a child version via fork() for
-each incoming request.  That way it can handle many requests at once,
-which you might not always want.  Even if you don't fork(), the listen()
-will allow that many pending connections.  Forking servers have to be
-particularly careful about cleaning up their dead children (called
-"zombies" in Unix parlance), because otherwise you'll quickly fill up your
-process table.
+This server takes the trouble to clone off a child version via fork()
+for each incoming request.  That way it can handle many requests at
+once, which you might not always want.  Even if you don't fork(), the
+listen() will allow that many pending connections.  Forking servers
+have to be particularly careful about cleaning up their dead children
+(called "zombies" in Unix parlance), because otherwise you'll quickly
+fill up your process table.  The REAPER subroutine is used here to
+call waitpid() for any child processes that have finished, thereby
+ensuring that they terminate cleanly and don't join the ranks of the
+living dead.
+
+Within the while loop we call accept() and check to see if it returns
+a false value.  This would normally indicate a system error that needs
+to be reported.  However the introduction of safe signals (see
+L</Deferred Signals (Safe Signals)> above) in Perl 5.7.3 means that
+accept() may also be interrupted when the process receives a signal.
+This typically happens when one of the forked sub-processes exits and
+notifies the parent process with a CHLD signal.  
+
+If accept() is interrupted by a signal then $! will be set to EINTR.
+If this happens then we can safely continue to the next iteration of
+the loop and another call to accept().  It is important that your
+signal handling code doesn't modify the value of $! or this test will
+most likely fail.  In the REAPER subroutine we create a local version
+of $! before calling waitpid().  When waitpid() sets $! to ECHILD (as
+it inevitably does when it has no more children waiting), it will
+update the local copy leaving the original unchanged.
 
 We suggest that you use the B<-T> flag to use taint checking (see L<perlsec>)
 even if we aren't running setuid or setgid.  This is always a good idea