X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pod%2Fperlipc.pod;h=4061dd1aabc4258243cd541079b87fa3abd0287c;hb=e40b81a3dd247b1a29fc78399677b77b78b5f183;hp=efae6875efcfc57892b5666c22e65bdfed96791e;hpb=b432a67249666bce4aa3385263660dc667d150d7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pod/perlipc.pod b/pod/perlipc.pod index efae687..4061dd1 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -246,7 +246,12 @@ mechanism for processes communicating on the same machine. It works just like a regular, connected anonymous pipes, except that the processes rendezvous using a filename and don't have to be related. -To create a named pipe, use the Unix command mknod(1) or on some +To create a named pipe, use the C function. + + use POSIX qw(mkfifo); + mkfifo($path, 0700) or die "mkfifo $path failed: $!"; + +You can also use the Unix command mknod(1) or on some systems, mkfifo(1). These may not be in your normal path. # system return val is backwards, so && not || @@ -272,13 +277,13 @@ to find out whether anyone (or anything) has accidentally removed our fifo. chdir; # go home $FIFO = '.signature'; - $ENV{PATH} .= ":/etc:/usr/games"; while (1) { unless (-p $FIFO) { unlink $FIFO; - system('mknod', $FIFO, 'p') - && die "can't mknod $FIFO: $!"; + require POSIX; + POSIX::mkfifo($FIFO, 0700) + or die "can't mkfifo $FIFO: $!"; } # next line blocks until there's a reader @@ -304,7 +309,7 @@ There were two things you could do, knowing this: be paranoid or be pragmatic. The paranoid approach was to do as little as possible in your signal handler. Set an existing integer variable that already has a value, and return. This doesn't help you if you're in a slow system call, -which will just restart. That means you have to C to longjump(3) out +which will just restart. That means you have to C to longjmp(3) out of the handler. Even this is a little cavalier for the true paranoiac, who avoids C in a handler because the system I out to get you. The pragmatic approach was to say "I know the risks, but prefer the @@ -910,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 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) even if we aren't running setuid or setgid. This is always a good idea @@ -1007,7 +1036,7 @@ differ from the system on which it's being run: my $rtime = ' '; read(SOCKET, $rtime, 4); close(SOCKET); - my $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ; + my $histime = unpack("N", $rtime) - $SECS_of_70_YEARS; printf "%8d %s\n", $histime - time, ctime($histime); } @@ -1511,7 +1540,7 @@ with TCP, you'd have to use a different socket handle for each host. ($hispaddr = recv(SOCKET, $rtime, 4, 0)) || die "recv: $!"; ($port, $hisiaddr) = sockaddr_in($hispaddr); $host = gethostbyaddr($hisiaddr, AF_INET); - $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ; + $histime = unpack("N", $rtime) - $SECS_of_70_YEARS; printf "%-12s ", $host; printf "%8d %s\n", $histime - time, scalar localtime($histime); $count--; @@ -1532,10 +1561,10 @@ you weren't wanting it to. Here's a small example showing shared memory usage. - use IPC::SysV qw(IPC_PRIVATE IPC_RMID S_IRWXU); + use IPC::SysV qw(IPC_PRIVATE IPC_RMID S_IRUSR S_IWUSR); $size = 2000; - $id = shmget(IPC_PRIVATE, $size, S_IRWXU) || die "$!"; + $id = shmget(IPC_PRIVATE, $size, S_IRUSR|S_IWUSR) || die "$!"; print "shm key $id\n"; $message = "Message #1"; @@ -1610,9 +1639,9 @@ which is included with Perl starting from Perl 5.005. A small example demonstrating SysV message queues: - use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU); + use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRUSR S_IWUSR); - my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); + my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRUSR | S_IWUSR); my $sent = "message"; my $type_sent = 1234;