$shucks++;
die "Somebody sent me a SIG$signame";
}
- $SIG{INT} = __PACKAGE__ . "::catch_zap";
+ $SIG{INT} = __PACKAGE__ . "::catch_zap";
$SIG{INT} = \&catch_zap; # best strategy
-Prior to Perl 5.7.3 it was necessary to do as little as you possibly
+Prior to Perl 5.8.0 it was necessary to do as little as you possibly
could in your handler; notice how all we do is set a global variable
and then raise an exception. That's because on most systems,
libraries are not re-entrant; particularly, memory allocation and I/O
dump - see L</Deferred Signals (Safe Signals)> below.
The names of the signals are the ones listed out by C<kill -l> on your
-system, or you can retrieve them from the Config module. Set up an
-@signame list indexed by number to get the name and a %signo hash table
-indexed by name to get the number:
-
- use Config;
- defined($Config{sig_name}) || die "No sigs?";
- foreach $name (split(" ", $Config{sig_name})) {
- $signo{$name} = $i;
- $signame[$i] = $name;
- $i++;
- }
-
-So to check whether signal 17 and SIGALRM were the same, do just this:
-
- print "signal #17 = $signame[17]\n";
- if ($signo{ALRM}) {
- print "SIGALRM is $signo{ALRM}\n";
- }
+system, or you can retrieve them using the CPAN module L<IPC::Signal>.
You may also choose to assign the strings C<"IGNORE"> or C<"DEFAULT"> as
the handler, in which case Perl will try to discard the signal or do the
C<-1> on such platforms.
Some signals can be neither trapped nor ignored, such as the KILL and STOP
-(but not the TSTP) signals. One strategy for temporarily ignoring signals
-is to use a local() on that hash element, automatically restoring a
-previous value once your block is exited. Remember that values created by
-the dynamically-scoped local() are "inherited" by functions called from
-within their caller's scope.
-
- sub precious {
- local $SIG{INT} = "IGNORE";
- more_functions();
- }
- sub more_functions {
- # interrupts still ignored, for now...
- }
+(but not the TSTP) signals. Note that ignoring signals makes them disappear.
+If you only want them blocked temporarily without them getting lost you'll
+have to use POSIX' sigprocmask.
Sending a signal to a negative process ID means that you send the signal
to the entire Unix process group. This code sends a hang-up signal to all
-processes in the current process group, and also sets $SIG{HUP} to C<"IGNORE">
+processes in the current process group, and also sets $SIG{HUP} to C<"IGNORE">
so it doesn't kill itself:
# block scope for local
Another interesting signal to send is signal number zero. This doesn't
actually affect a child process, but instead checks whether it's alive
-or has changed its UID.
+or has changed its UIDs.
unless (kill 0 => $kid_pid) {
warn "something wicked happened to $kid_pid";
}
-When directed at a process whose UID is not identical to that
-of the sending process, signal number zero may fail because
-you lack permission to send the signal, even though the process is alive.
-You may be able to determine the cause of failure using C<%!>.
+Signal number zero may fail because you lack permission to send the
+signal when directed at a process whose real or saved UID is not
+identical to the real or effective UID of the sending process, even
+though the process is alive. You may be able to determine the cause of
+failure using C<$!> or C<%!>.
unless (kill(0 => $pid) || $!{EPERM}) {
warn "$pid looks dead";
$SIG{INT} = sub { die "\nOutta here!\n" };
-But that will be problematic for the more complicated handlers that need
-to reinstall themselves. Because Perl's signal mechanism is currently
-based on the signal(3) function from the C library, you may sometimes be so
-unfortunate as to run on systems where that function is "broken"; that
-is, it behaves in the old unreliable SysV way rather than the newer, more
-reasonable BSD and POSIX fashion. So you'll see defensive people writing
-signal handlers like this:
-
- sub REAPER {
- $waitedpid = wait;
- # loathe SysV: it makes us not only reinstate
- # the handler, but place it after the wait
- $SIG{CHLD} = \&REAPER;
- }
- $SIG{CHLD} = \&REAPER;
- # now do something that forks...
-
-or better still:
+SIGCHLD handlers require some special care. If a second child dies
+while in the signal handler caused by the first death, we won't get
+another signal. So must loop here else we will leave the unreaped child
+as a zombie. And the next time two children die we get another zombie.
+And so on.
use POSIX ":sys_wait_h";
- sub REAPER {
- my $child;
- # If a second child dies while in the signal handler caused by the
- # first death, we won't get another signal. So must loop here else
- # we will leave the unreaped child as a zombie. And the next time
- # two children die we get another zombie. And so on.
- while (($child = waitpid(-1, WNOHANG)) > 0) {
+ $SIG{CHLD} = sub {
+ while ((my $child = waitpid(-1, WNOHANG)) > 0) {
$Kid_Status{$child} = $?;
}
- $SIG{CHLD} = \&REAPER; # still loathe SysV
- }
- $SIG{CHLD} = \&REAPER;
+ };
# do something that forks...
Be careful: qx(), system(), and some modules for calling external commands
do a fork(), then wait() for the result. Thus, your signal handler
-(C<&REAPER> in the example) will be called. Because wait() was already
-called by system() or qx(), the wait() in the signal handler will see no
-more zombies and will therefore block.
+will be called. Because wait() was already called by system() or qx(),
+the wait() in the signal handler will see no more zombies and will
+therefore block.
The best way to prevent this issue is to use waitpid(), as in the following
example:
$SIG{CHLD} = sub {
# don't change $! and $? outside handler
local ($!, $?);
- my $pid = waitpid(-1, WNOHANG);
- return if $pid == -1;
- return unless defined $children{$pid};
- delete $children{$pid};
- cleanup_child($pid, $?);
+ while ( (my $pid = waitpid(-1, WNOHANG)) > 0 ) {
+ delete $children{$pid};
+ cleanup_child($pid, $?);
+ }
};
while (1) {
alarm signals and then schedule to have one delivered to you in some
number of seconds. Then try your blocking operation, clearing the alarm
when it's done but not before you've exited your C<eval{}> block. If it
-goes off, you'll use die() to jump out of the block, much as you might
-using longjmp() or throw() in other languages.
+goes off, you'll use die() to jump out of the block.
Here's an example:
need to do your own fork() and exec(), and kill the errant child process.
For more complex signal handling, you might see the standard POSIX
-module. Lamentably, this is almost entirely undocumented, but
-the F<t/lib/posix.t> file from the Perl source distribution has some
-examples in it.
+module. Lamentably, this is almost entirely undocumented, but the
+F<ext/POSIX/t/sigaction.t> file from the Perl source distribution has
+some examples in it.
=head2 Handling the SIGHUP Signal in Daemons
signal handler. When you want to tell the daemon to reread the file,
simply send it the C<SIGHUP> signal.
-Not all platforms automatically reinstall their (native) signal
-handlers after a signal delivery. This means that the handler works
-the first time the signal is sent, only. The solution to this problem
-is to use C<POSIX> signal handlers if available; their behavior
-is well-defined.
-
The following example implements a simple daemon, which restarts
itself every time the C<SIGHUP> signal is received. The actual code is
located in the subroutine C<code()>, which just prints some debugging
info to show that it works; it should be replaced with the real code.
- #!/usr/bin/perl -w
+ #!/usr/bin/perl
+
+ use strict;
+ use warnings;
use POSIX ();
use FindBin ();
use File::Basename ();
- use File::Spec::Functions;
+ use File::Spec::Functions qw(catfile);
$| = 1;
my $SELF = catfile($FindBin::Bin, $script);
# POSIX unmasks the sigprocmask properly
- my $sigset = POSIX::SigSet->new();
- my $action = POSIX::SigAction->new("sigHUP_handler",
- $sigset,
- &POSIX::SA_NODEFER);
- POSIX::sigaction(&POSIX::SIGHUP, $action);
-
- sub sigHUP_handler {
+ $SIG{HUP} = sub {
print "got SIGHUP\n";
exec($SELF, @ARGV) || die "$0: couldn't restart: $!";
- }
+ };
code();
print "PID: $$\n";
print "ARGV: @ARGV\n";
my $count = 0;
- while (++$count) {
+ while (1) {
sleep 2;
- print "$count\n";
+ print ++$count, "\n";
}
}
-=head1 Named Pipes
-
-A named pipe (often referred to as a FIFO) is an old Unix IPC
-mechanism for processes communicating on the same machine. It works
-just like regular anonymous pipes, except that the
-processes rendezvous using a filename and need not be related.
-
-To create a named pipe, use the C<POSIX::mkfifo()> function.
-
- use POSIX qw(mkfifo);
- mkfifo($path, 0700) || 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, though.
-
- # system return val is backwards, so && not ||
- #
- $ENV{PATH} .= ":/etc:/usr/etc";
- if ( system("mknod", $path, "p")
- && system("mkfifo", $path) )
- {
- die "mk{nod,fifo} $path failed";
- }
-
-
-A fifo is convenient when you want to connect a process to an unrelated
-one. When you open a fifo, the program will block until there's something
-on the other end.
-
-For example, let's say you'd like to have your F<.signature> file be a
-named pipe that has a Perl program on the other end. Now every time any
-program (like a mailer, news reader, finger program, etc.) tries to read
-from that file, the reading program will read the new signature from your
-program. We'll use the pipe-checking file-test operator, B<-p>, to find
-out whether anyone (or anything) has accidentally removed our fifo.
-
- chdir(); # go home
- my $FIFO = ".signature";
-
- while (1) {
- unless (-p $FIFO) {
- unlink $FIFO; # discard any failure, will catch later
- require POSIX; # delayed loading of heavy module
- POSIX::mkfifo($FIFO, 0700)
- || die "can't mkfifo $FIFO: $!";
- }
-
- # next line blocks till there's a reader
- open (FIFO, "> $FIFO") || die "can't open $FIFO: $!";
- print FIFO "John Smith (smith\@host.org)\n", `fortune -s`;
- close(FIFO) || die "can't close $FIFO: $!";
- sleep 2; # to avoid dup signals
- }
-
=head2 Deferred Signals (Safe Signals)
-Before Perl 5.7.3, installing Perl code to deal with signals exposed you to
+Before Perl 5.8.0, installing Perl code to deal with signals exposed you to
danger from two things. First, few system library functions are
re-entrant. If the signal interrupts while Perl is executing one function
(like malloc(3) or printf(3)), and your signal handler then calls the same
convenience", and to do anything you wanted in your signal handler,
and be prepared to clean up core dumps now and again.
-Perl 5.7.3 and later avoid these problems by "deferring" signals. That is,
+Perl 5.8.0 and later avoid these problems by "deferring" signals. That is,
when the signal is delivered to the process by the system (to the C code
that implements Perl) a flag is set, and the handler returns immediately.
Then at strategic "safe" points in the Perl interpreter (e.g. when it is
about to execute a new opcode) the flags are checked and the Perl level
handler from %SIG is executed. The "deferred" scheme allows much more
flexibility in the coding of signal handlers as we know the Perl
-interpreter is in a safe state, and that we are not in a system library function when the handler is called. However the implementation does
+interpreter is in a safe state, and that we are not in a system library
+function when the handler is called. However the implementation does
differ from previous Perls in the following ways:
=over 4
opcode (e.g. a regular expression operation on a very large string) will
not be seen until the current opcode completes.
-If a signal of any given type fires multiple times during an opcode
+If a signal of any given type fires multiple times during an opcode
(such as from a fine-grained timer), the handler for that signal will
be called only once, after the opcode completes; all other
instances will be discarded. Furthermore, if your system's signal queue
checks the signal flags and calls %SIG handlers before resuming IO
operation.)
-The default in Perl 5.7.3 and later is to automatically use
+The default in Perl 5.8.0 and later is to automatically use
the C<:perlio> layer.
+Note that it is not advisable to access a file handle within a signal
+handler where that signal has interrupted an I/O operation on that same
+handle. While perl will at least try hard not to crash, there are no
+guarantees of data integrity; for example, some data might get dropped or
+written twice.
+
Some networking library functions like gethostbyname() are known to have
their own implementations of timeouts which may conflict with your
timeouts. If you have problems with such functions, try using the POSIX
try something like the following:
- use POSIX qw(SIGALRM);
- POSIX::sigaction(SIGALRM,
- POSIX::SigAction->new(sub { die "alarm" }))
- || die "Error setting SIGALRM handler: $!\n";
+ use POSIX qw(SIGALRM);
+ POSIX::sigaction(SIGALRM,
+ POSIX::SigAction->new(sub { die "alarm" }))
+ || die "Error setting SIGALRM handler: $!\n";
Another way to disable the safe signal behavior locally is to use
the C<Perl::Unsafe::Signals> module from CPAN, which affects
SA_RESTART flag when installing %SIG handlers. This meant that
restartable system calls would continue rather than returning when
a signal arrived. In order to deliver deferred signals promptly,
-Perl 5.7.3 and later do I<not> use SA_RESTART. Consequently,
+Perl 5.8.0 and later do I<not> use SA_RESTART. Consequently,
restartable system calls can fail (with $! set to C<EINTR>) in places
where they previously would have succeeded.
The default C<:perlio> layer retries C<read>, C<write>
-and C<close> as described above; interrupted C<wait> and
+and C<close> as described above; interrupted C<wait> and
C<waitpid> calls will always be retried.
=item Signals as "faults"
Certain signals like SEGV, ILL, and BUS are generated by virtual memory
-addressing errors and similiar "faults". These are normally fatal: there is
-little a Perl-level handler can do with them. So Perl now delivers them
+addressing errors and similar "faults". These are normally fatal: there is
+little a Perl-level handler can do with them. So Perl delivers them
immediately rather than attempting to defer them.
=item Signals triggered by operating system state
memory corruption, set the environment variable C<PERL_SIGNALS> to
C<"unsafe">. This feature first appeared in Perl 5.8.1.
+=head1 Named Pipes
+
+A named pipe (often referred to as a FIFO) is an old Unix IPC
+mechanism for processes communicating on the same machine. It works
+just like regular anonymous pipes, except that the
+processes rendezvous using a filename and need not be related.
+
+To create a named pipe, use the C<POSIX::mkfifo()> function.
+
+ use POSIX qw(mkfifo);
+ mkfifo($path, 0700) || 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, though.
+
+ # system return val is backwards, so && not ||
+ #
+ $ENV{PATH} .= ":/etc:/usr/etc";
+ if ( system("mknod", $path, "p")
+ && system("mkfifo", $path) )
+ {
+ die "mk{nod,fifo} $path failed";
+ }
+
+
+A fifo is convenient when you want to connect a process to an unrelated
+one. When you open a fifo, the program will block until there's something
+on the other end.
+
+For example, let's say you'd like to have your F<.signature> file be a
+named pipe that has a Perl program on the other end. Now every time any
+program (like a mailer, news reader, finger program, etc.) tries to read
+from that file, the reading program will read the new signature from your
+program. We'll use the pipe-checking file-test operator, B<-p>, to find
+out whether anyone (or anything) has accidentally removed our fifo.
+
+ chdir(); # go home
+ my $FIFO = ".signature";
+
+ while (1) {
+ unless (-p $FIFO) {
+ unlink $FIFO; # discard any failure, will catch later
+ require POSIX; # delayed loading of heavy module
+ POSIX::mkfifo($FIFO, 0700)
+ || die "can't mkfifo $FIFO: $!";
+ }
+
+ # next line blocks till there's a reader
+ open (FIFO, "> $FIFO") || die "can't open $FIFO: $!";
+ print FIFO "John Smith (smith\@host.org)\n", `fortune -s`;
+ close(FIFO) || die "can't close $FIFO: $!";
+ sleep 2; # to avoid dup signals
+ }
+
=head1 Using open() for IPC
Perl's basic open() statement can also be used for unidirectional
to handle. Consider:
open(FH, "|bogus") || die "can't fork: $!";
- print FH "bang\n"; # neither necessary nor sufficient
+ print FH "bang\n"; # neither necessary nor sufficient
# to check print retval!
close(FH) || die "can't close: $!";
standard file descriptors from and to F</dev/null> so that random
output doesn't wind up on the user's terminal.
- use POSIX "setsid";
+ use POSIX "setsid";
- sub daemonize {
- chdir("/") || die "can't chdir to /: $!";
- open(STDIN, "< /dev/null") || die "can't read /dev/null: $!";
- open(STDOUT, "> /dev/null") || die "can't write to /dev/null: $!";
- defined(my $pid = fork()) || die "can't fork: $!";
- exit if $pid; # non-zero now means I am the paren
- (setsid() != -1) || die "Can't start a new session: $!"
- open(STDERR, ">&STDOUT") || die "can't dup stdout: $!";
- }
+ sub daemonize {
+ chdir("/") || die "can't chdir to /: $!";
+ open(STDIN, "< /dev/null") || die "can't read /dev/null: $!";
+ open(STDOUT, "> /dev/null") || die "can't write to /dev/null: $!";
+ defined(my $pid = fork()) || die "can't fork: $!";
+ exit if $pid; # non-zero now means I am the parent
+ (setsid() != -1) || die "Can't start a new session: $!";
+ open(STDERR, ">&STDOUT") || die "can't dup stdout: $!";
+ }
The fork() has to come before the setsid() to ensure you aren't a
process group leader; the setsid() will fail if you are. If your
system doesn't have the setsid() function, open F</dev/tty> and use the
C<TIOCNOTTY> ioctl() on it instead. See tty(4) for details.
-Non-Unix users should check their C<< I<Your_OS>::Process >> module for
+Non-Unix users should check their C<< I<Your_OS>::Process >> module for
other possible solutions.
=head2 Safe Pipe Opens
STDIN. If you open a pipe I<from> minus, you can read from the filehandle
you opened whatever your kid writes to I<his> STDOUT.
- use English qw[ -no_match_vars ];
+ use English;
my $PRECIOUS = "/path/to/some/safe/file";
my $sleep_count;
my $pid;
}
} until defined $pid;
- if ($pid) { # I am the parent
+ if ($pid) { # I am the parent
print KID_TO_WRITE @some_data;
close(KID_TO_WRITE) || warn "kid exited $?";
} else { # I am the child
# drop permissions in setuid and/or setgid programs:
- ($EUID, $EGID) = ($UID, $GID);
- open (OUTFILE, "> $PRECIOUS")
+ ($EUID, $EGID) = ($UID, $GID);
+ open (OUTFILE, "> $PRECIOUS")
|| die "can't open $PRECIOUS: $!";
while (<STDIN>) {
print OUTFILE; # child's STDIN is parent's KID_TO_WRITE
}
It is very easy to dead-lock a process using this form of open(), or
-indeed with any use of pipe() with multiple subprocesses. The
+indeed with any use of pipe() with multiple subprocesses. The
example above is "safe" because it is simple and calls exec(). See
L</"Avoiding Pipe Deadlocks"> for general safety principles, but there
are extra gotchas with Safe Pipe Opens.
One would use either of these:
- open(PS_PIPE, "-|", "ps", "aux")
+ open(PS_PIPE, "-|", "ps", "aux")
|| die "can't open ps pipe: $!";
@ps_args = qw[ ps aux ];
Because there are more than three arguments to open(), forks the ps(1)
command I<without> spawning a shell, and reads its standard output via the
C<PS_PIPE> filehandle. The corresponding syntax to I<write> to command
-pipes is to use C<"|-"> in place of C<"-|">.
+pipes is to use C<"|-"> in place of C<"-|">.
This was admittedly a rather silly example, because you're using string
literals whose content is perfectly safe. There is therefore no cause to
pattern and indeed even the filenames themselves might hold metacharacters.
Be aware that these operations are full Unix forks, which means they may
-not be correctly implemented on all alien systems. Additionally, these are
-not true multithreading. To learn more about threading, see the F<modules>
-file mentioned below in the SEE ALSO section.
+not be correctly implemented on all alien systems.
=head2 Avoiding Pipe Deadlocks
=for TODO
Hold on, is this even true? First it says that socketpair() is avoided
-for portability, but then it says it probably won't work except on
+for portability, but then it says it probably won't work except on
Unixy systems anyway. Which one of those is true?
Here's an example of using open2():
reopen the appropriate handles to STDIN and STDOUT and call other processes.
(The following example lacks proper error checking.)
- #!/usr/bin/perl -w
- # pipe1 - bidirectional communication using two pipe pairs
- # designed for the socketpair-challenged
- use IO::Handle; # thousands of lines just for autoflush :-(
- pipe(PARENT_RDR, CHILD_WTR); # XXX: check failure?
- pipe(CHILD_RDR, PARENT_WTR); # XXX: check failure?
- CHILD_WTR->autoflush(1);
- PARENT_WTR->autoflush(1);
-
- if ($pid = fork()) {
- close PARENT_RDR;
- close PARENT_WTR;
- print CHILD_WTR "Parent Pid $$ is sending this\n";
- chomp($line = <CHILD_RDR>);
- print "Parent Pid $$ just read this: `$line'\n";
- close CHILD_RDR; close CHILD_WTR;
- waitpid($pid, 0);
- } else {
- die "cannot fork: $!" unless defined $pid;
- close CHILD_RDR;
- close CHILD_WTR;
-
chomp($line = <PARENT_RDR>);
- print "Child Pid $$ just read this: `$line'\n";
- print PARENT_WTR "Child Pid $$ is sending this\n";
- close PARENT_RDR;
- close PARENT_WTR;
- exit(0);
- }
+ #!/usr/bin/perl -w
+ # pipe1 - bidirectional communication using two pipe pairs
+ # designed for the socketpair-challenged
+ use IO::Handle; # thousands of lines just for autoflush :-(
+ pipe(PARENT_RDR, CHILD_WTR); # XXX: check failure?
+ pipe(CHILD_RDR, PARENT_WTR); # XXX: check failure?
+ CHILD_WTR->autoflush(1);
+ PARENT_WTR->autoflush(1);
+
+ if ($pid = fork()) {
+ close PARENT_RDR;
+ close PARENT_WTR;
+ print CHILD_WTR "Parent Pid $$ is sending this\n";
+ chomp($line = <CHILD_RDR>);
+ print "Parent Pid $$ just read this: '$line'\n";
+ close CHILD_RDR; close CHILD_WTR;
+ waitpid($pid, 0);
+ } else {
+ die "cannot fork: $!" unless defined $pid;
+ close CHILD_RDR;
+ close CHILD_WTR;
+ chomp($line = <PARENT_RDR>);
+ print "Child Pid $$ just read this: '$line'\n";
+ print PARENT_WTR "Child Pid $$ is sending this\n";
+ close PARENT_RDR;
+ close PARENT_WTR;
+ exit(0);
+ }
But you don't actually have to make two pipe calls. If you
have the socketpair() system call, it will do this all for you.
- #!/usr/bin/perl -w
- # pipe2 - bidirectional communication using socketpair
- # "the best ones always go both ways"
-
- use Socket;
- use IO::Handle; # thousands of lines just for autoflush :-(
-
- # We say AF_UNIX because although *_LOCAL is the
- # POSIX 1003.1g form of the constant, many machines
- # still don't have it.
- socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
- || die "socketpair: $!";
-
- CHILD->autoflush(1);
- PARENT->autoflush(1);
-
- if ($pid = fork()) {
- close PARENT;
- print CHILD "Parent Pid $$ is sending this\n";
- chomp($line = <CHILD>);
- print "Parent Pid $$ just read this: `$line'\n";
- close CHILD;
- waitpid($pid, 0);
- } else {
- die "cannot fork: $!" unless defined $pid;
- close CHILD;
-
chomp($line = <PARENT>);
- print "Child Pid $$ just read this: '$line'\n";
- print PARENT "Child Pid $$ is sending this\n";
- close PARENT;
- exit(0);
- }
+ #!/usr/bin/perl -w
+ # pipe2 - bidirectional communication using socketpair
+ # "the best ones always go both ways"
+
+ use Socket;
+ use IO::Handle; # thousands of lines just for autoflush :-(
+
+ # We say AF_UNIX because although *_LOCAL is the
+ # POSIX 1003.1g form of the constant, many machines
+ # still don't have it.
+ socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
+ || die "socketpair: $!";
+
+ CHILD->autoflush(1);
+ PARENT->autoflush(1);
+
+ if ($pid = fork()) {
+ close PARENT;
+ print CHILD "Parent Pid $$ is sending this\n";
+ chomp($line = <CHILD>);
+ print "Parent Pid $$ just read this: '$line'\n";
+ close CHILD;
+ waitpid($pid, 0);
+ } else {
+ die "cannot fork: $!" unless defined $pid;
+ close CHILD;
+ chomp($line = <PARENT>);
+ print "Child Pid $$ just read this: '$line'\n";
+ print PARENT "Child Pid $$ is sending this\n";
+ close PARENT;
+ exit(0);
+ }
=head1 Sockets: Client/Server Communication
One of the major problems with ancient, antemillennial socket code in Perl
was that it used hard-coded values for some of the constants, which
severely hurt portability. If you ever see code that does anything like
-explicitly setting C<$AF_INET = 2>, you know you're in for big trouble.
+explicitly setting C<$AF_INET = 2>, you know you're in for big trouble.
An immeasurably superior approach is to use the C<Socket> module, which more
reliably grants access to the various constants and functions you'll need.
conformant (be strict in what you provide), but they also recommend
accepting a lone "\012" on input (be lenient in what you require).
We haven't always been very good about that in the code in this manpage,
-but unless you're on a Mac from way back in its pre-Unix dark ages, you'll
+but unless you're on a Mac from way back in its pre-Unix dark ages, you'll
probably be ok.
=head2 Internet TCP Clients and Servers
on a particular interface (like the external side of a gateway
or firewall machine), fill this in with your real address instead.
- #!/usr/bin/perl -Tw
- use strict;
- BEGIN { $ENV{PATH} = "/usr/bin:/bin" }
- use Socket;
- use Carp;
- my $EOL = "\015\012";
-
- sub logmsg { print "$0 $$: @_ at ", scalar localtime(), "\n" }
+ #!/usr/bin/perl -Tw
+ use strict;
+ BEGIN { $ENV{PATH} = "/usr/bin:/bin" }
+ use Socket;
+ use Carp;
+ my $EOL = "\015\012";
- my $port = shift || 2345;
- die "invalid port" unless if $port =~ /^ \d+ $/x;
+ sub logmsg { print "$0 $$: @_ at ", scalar localtime(), "\n" }
- my $proto = getprotobyname("tcp");
+ my $port = shift || 2345;
+ die "invalid port" unless $port =~ /^ \d+ $/x;
- socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
- setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
- || die "setsockopt: $!";
- bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
- listen(Server, SOMAXCONN) || die "listen: $!";
+ my $proto = getprotobyname("tcp");
- logmsg "server started on port $port";
+ socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
+ || die "setsockopt: $!";
+ bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
+ listen(Server, SOMAXCONN) || die "listen: $!";
- my $paddr;
+ logmsg "server started on port $port";
- $SIG{CHLD} = \&REAPER;
+ my $paddr;
- for ( ; $paddr = accept(Client, Server); close Client) {
- my($port, $iaddr) = sockaddr_in($paddr);
- my $name = gethostbyaddr($iaddr, AF_INET);
+ for ( ; $paddr = accept(Client, Server); close Client) {
+ my($port, $iaddr) = sockaddr_in($paddr);
+ my $name = gethostbyaddr($iaddr, AF_INET);
- logmsg "connection from $name [",
- inet_ntoa($iaddr), "]
- at port $port";
+ logmsg "connection from $name [",
+ inet_ntoa($iaddr), "]
+ at port $port";
- print Client "Hello there, $name, it's now ",
- scalar localtime(), $EOL;
- }
+ print Client "Hello there, $name, it's now ",
+ scalar localtime(), $EOL;
+ }
-And here's a multithreaded version. It's multithreaded in that
+And here's a multitasking version. It's multitasked in that
like most typical servers, it spawns (fork()s) a slave server to
handle the client request so that the master server can quickly
go back to service a new client.
- #!/usr/bin/perl -Tw
- use strict;
- BEGIN { $ENV{PATH} = "/usr/bin:/bin" }
- use Socket;
- use Carp;
- my $EOL = "\015\012";
-
- sub spawn; # forward declaration
- sub logmsg { print "$0 $$: @_ at ", scalar localtime(), "\n" }
-
- my $port = shift || 2345;
- die "invalid port" unless if $port =~ /^ \d+ $/x;
-
- my $proto = getprotobyname("tcp");
+ #!/usr/bin/perl -Tw
+ use strict;
+ BEGIN { $ENV{PATH} = "/usr/bin:/bin" }
+ use Socket;
+ use Carp;
+ my $EOL = "\015\012";
- socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
- setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
- || die "setsockopt: $!";
- bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
- listen(Server, SOMAXCONN) || die "listen: $!";
+ sub spawn; # forward declaration
+ sub logmsg { print "$0 $$: @_ at ", scalar localtime(), "\n" }
- logmsg "server started on port $port";
+ my $port = shift || 2345;
+ die "invalid port" unless $port =~ /^ \d+ $/x;
- my $waitedpid = 0;
- my $paddr;
+ my $proto = getprotobyname("tcp");
- use POSIX ":sys_wait_h";
- use Errno;
+ socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
+ || die "setsockopt: $!";
+ bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
+ listen(Server, SOMAXCONN) || die "listen: $!";
- sub REAPER {
- 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
- }
+ logmsg "server started on port $port";
- $SIG{CHLD} = \&REAPER;
+ my $waitedpid = 0;
+ my $paddr;
- while (1) {
- $paddr = accept(Client, Server) || do {
- # try again if accept() returned because got a signal
- next if $!{EINTR};
- die "accept: $!";
- };
- my ($port, $iaddr) = sockaddr_in($paddr);
- my $name = gethostbyaddr($iaddr, AF_INET);
+ use POSIX ":sys_wait_h";
+ use Errno;
- logmsg "connection from $name [",
- inet_ntoa($iaddr),
- "] at port $port";
+ sub REAPER {
+ 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
+ }
- 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;
- }
+ $SIG{CHLD} = \&REAPER;
+
+ while (1) {
+ $paddr = accept(Client, Server) || do {
+ # try again if accept() returned because got a signal
+ 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;
+ sub spawn {
+ 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;
- unless (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;
+ unless (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
Within the while loop we call accept() and check to see if it returns
a false value. This would normally indicate a system error needs
to be reported. However, the introduction of safe signals (see
-L</Deferred Signals (Safe Signals)> above) in Perl 5.7.3 means that
+L</Deferred Signals (Safe Signals)> above) in Perl 5.8.0 means that
accept() might also be interrupted when the process receives a signal.
This typically happens when one of the forked subprocesses exits and
-notifies the parent process with a CHLD signal.
+notifies the parent process with a CHLD signal.
If accept() is interrupted by a signal, $! will be set to EINTR.
If this happens, we can safely continue to the next iteration of
the loop and another call to accept(). It is important that your
-signal handling code not modify the value of $!, or else this test
+signal handling code not modify the value of $!, or else this test
will 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
+it inevitably does when it has no more children waiting, it
updates the local copy and leaves the original unchanged.
You should use the B<-T> flag to enable taint checking (see L<perlsec>)
printf "%-24s ", $host;
my $hisiaddr = inet_aton($host) || die "unknown host";
my $hispaddr = sockaddr_in($port, $hisiaddr);
- socket(SOCKET, PF_INET, SOCK_STREAM, $proto)
+ socket(SOCKET, PF_INET, SOCK_STREAM, $proto)
|| die "socket: $!";
connect(SOCKET, $hispaddr) || die "connect: $!";
my $rtime = pack("C4", ());
unless (defined($pid = fork())) {
logmsg "cannot fork: $!";
return;
- }
+ }
elsif ($pid) {
logmsg "begat $pid";
return; # I'm the parent
- }
+ }
else {
# I'm the child -- go spawn
}
=head1 TCP Clients with IO::Socket
For those preferring a higher-level interface to socket programming, the
-IO::Socket module provides an object-oriented approach. IO::Socket has
-been included in the standard Perl distribution ever since Perl 5.004. If
-you're running an earlier version of Perl (in which case, how are you
-reading this manpage?), just fetch IO::Socket from CPAN, where you'll also
+IO::Socket module provides an object-oriented approach. If for some reason
+you lack this module, you can just fetch IO::Socket from CPAN, where you'll also
find modules providing easy interfaces to the following systems: DNS, FTP,
Ident (RFC 931), NIS and NISPlus, NNTP, Ping, POP3, SMTP, SNMP, SSLeay,
Telnet, and Time--to name just a few.
PeerAddr => "localhost",
PeerPort => "daytime(13)",
)
- || die "can't connect to daytime service on localhost";
+ || die "can't connect to daytime service on localhost";
while (<$remote>) { print }
When you run this program, you should get something back that
This server accepts one of five different commands, sending output back to
the client. Unlike most network servers, this one handles only one
-incoming client at a time. Multithreaded servers are covered in
+incoming client at a time. Multitasking servers are covered in
Chapter 16 of the Camel.
Here's the code. We'll
$client->autoflush(1);
print $client "Welcome to $0; type help for command list.\n";
$hostinfo = gethostbyaddr($client->peeraddr);
- printf "[Connect from %s]\n", $hostinfo ? $hostinfo->name : $client->peerhost;
+ printf "[Connect from %s]\n",
+ $hostinfo ? $hostinfo->name : $client->peerhost;
print $client "Command? ";
while ( <$client>) {
- next unless /\S/; # blank line
- if (/quit|exit/i) { last }
- elsif (/date|time/i) { printf $client "%s\n", scalar localtime() }
- elsif (/who/i ) { print $client `who 2>&1` }
- elsif (/cookie/i ) { print $client `/usr/games/fortune 2>&1` }
- elsif (/motd/i ) { print $client `cat /etc/motd 2>&1` }
+ next unless /\S/; # blank line
+ if (/quit|exit/i) { last }
+ elsif (/date|time/i) { printf $client "%s\n", scalar localtime() }
+ elsif (/who/i ) { print $client `who 2>&1` }
+ elsif (/cookie/i ) { print $client `/usr/games/fortune 2>&1` }
+ elsif (/motd/i ) { print $client `cat /etc/motd 2>&1` }
else {
print $client "Commands: quit date who cookie motd\n";
}
using select() to do a timed-out wait for I/O. To do something similar
with TCP, you'd have to use a different socket handle for each host.
- #!/usr/bin/perl -w
- use strict;
- use Socket;
- use Sys::Hostname;
-
- my ( $count, $hisiaddr, $hispaddr, $histime,
- $host, $iaddr, $paddr, $port, $proto,
- $rin, $rout, $rtime, $SECS_OF_70_YEARS);
-
- $SECS_OF_70_YEARS = 2_208_988_800;
-
- $iaddr = gethostbyname(hostname());
- $proto = getprotobyname("udp");
- $port = getservbyname("time", "udp");
- $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick
-
- socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!";
- bind(SOCKET, $paddr) || die "bind: $!";
-
- $| = 1;
- printf "%-12s %8s %s\n", "localhost", 0, scalar localtime();
- $count = 0;
- for $host (@ARGV) {
- $count++;
- $hisiaddr = inet_aton($host) || die "unknown host";
- $hispaddr = sockaddr_in($port, $hisiaddr);
- defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!";
- }
+ #!/usr/bin/perl -w
+ use strict;
+ use Socket;
+ use Sys::Hostname;
+
+ my ( $count, $hisiaddr, $hispaddr, $histime,
+ $host, $iaddr, $paddr, $port, $proto,
+ $rin, $rout, $rtime, $SECS_OF_70_YEARS);
+
+ $SECS_OF_70_YEARS = 2_208_988_800;
+
+ $iaddr = gethostbyname(hostname());
+ $proto = getprotobyname("udp");
+ $port = getservbyname("time", "udp");
+ $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick
+
+ socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!";
+ bind(SOCKET, $paddr) || die "bind: $!";
+
+ $| = 1;
+ printf "%-12s %8s %s\n", "localhost", 0, scalar localtime();
+ $count = 0;
+ for $host (@ARGV) {
+ $count++;
+ $hisiaddr = inet_aton($host) || die "unknown host";
+ $hispaddr = sockaddr_in($port, $hisiaddr);
+ defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!";
+ }
- $rin = "";
- vec($rin, fileno(SOCKET), 1) = 1;
-
- # timeout after 10.0 seconds
- while ($count && select($rout = $rin, undef, undef, 10.0)) {
- $rtime = "";
- $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;
- printf "%-12s ", $host;
- printf "%8d %s\n", $histime - time(), scalar localtime($histime);
- $count--;
- }
+ $rin = "";
+ vec($rin, fileno(SOCKET), 1) = 1;
+
+ # timeout after 10.0 seconds
+ while ($count && select($rout = $rin, undef, undef, 10.0)) {
+ $rtime = "";
+ $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;
+ printf "%-12s ", $host;
+ printf "%8d %s\n", $histime - time(), scalar localtime($histime);
+ $count--;
+ }
This example does not include any retries and may consequently fail to
contact a reachable host. The most prominent reason for this is congestion
print "read : '$buff'\n";
# the buffer of shmread is zero-character end-padded.
- substr($buff, index($buff, "\0")) = "":
+ substr($buff, index($buff, "\0")) = "";
print "un" unless $buff eq $message;
print "swell\n";
$IPC_KEY = 1234;
$id = semget($IPC_KEY, 10, 0666 | IPC_CREAT);
- defined($id) || die "shmget: $!";
- print "shm key $id\n";
+ defined($id) || die "semget: $!";
+ print "sem id $id\n";
Put this code in a separate file to be run in more than one process.
Call the file F<take>:
$IPC_KEY = 1234;
$id = semget($IPC_KEY, 0, 0);
- defined($id) || die "shmget: $!";
+ defined($id) || die "semget: $!";
$semnum = 0;
$semflag = 0;
semop($id, $opstring) || die "semop: $!";
The SysV IPC code above was written long ago, and it's definitely
-clunky looking. For a more modern look, see the IPC::SysV module
-which is included with Perl starting from Perl 5.005.
+clunky looking. For a more modern look, see the IPC::SysV module.
A small example demonstrating SysV message queues:
manpage describes the low-level interface to sockets. Besides the obvious
functions in L<perlfunc>, you should also check out the F<modules> file at
your nearest CPAN site, especially
-L<http://www.cpan.org/modules/00modlist.long.html#ID5_Networking_>.
+L<http://www.cpan.org/modules/00modlist.long.html#ID5_Networking_>.
See L<perlmodlib> or best yet, the F<Perl FAQ> for a description
-of what CPAN is and where to get it if the previous link doesn't work
+of what CPAN is and where to get it if the previous link doesn't work
for you.
Section 5 of CPAN's F<modules> file is devoted to "Networking, Device
https://perl5.git.perl.org / perl5.git / blobdiff