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

diff --git a/pod/perlipc.pod b/pod/perlipc.pod

index 3de879f..4061dd1 100644 (file)
--- 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