For example, to trap an interrupt signal, set up a handler like this:
+ our $shucks;
+
sub catch_zap {
- my $signame = shift;
- $shucks++;
- die "Somebody sent me a SIG$signame";
+ my $signame = shift;
+ $shucks++;
+ die "Somebody sent me a SIG$signame";
}
$SIG{INT} = 'catch_zap'; # could fail in modules
$SIG{INT} = \&catch_zap; # best strategy
use Config;
defined $Config{sig_name} || die "No sigs?";
foreach $name (split(' ', $Config{sig_name})) {
- $signo{$name} = $i;
- $signame[$i] = $name;
- $i++;
+ $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";
+ print "SIGALRM is $signo{ALRM}\n";
}
You may also choose to assign the strings C<'IGNORE'> or C<'DEFAULT'> as
values are "inherited" by functions called from within that block.)
sub precious {
- local $SIG{INT} = 'IGNORE';
- &more_functions;
+ local $SIG{INT} = 'IGNORE';
+ &more_functions;
}
sub more_functions {
- # interrupts still ignored, for now...
+ # interrupts still ignored, for now...
}
Sending a signal to a negative process ID means that you send the signal
it doesn't kill itself):
{
- local $SIG{HUP} = 'IGNORE';
- kill HUP => -$$;
- # snazzy writing of: kill('HUP', -$$)
+ local $SIG{HUP} = 'IGNORE';
+ kill HUP => -$$;
+ # snazzy writing of: kill('HUP', -$$)
}
Another interesting signal to send is signal number zero. This doesn't
or has changed its UID.
unless (kill 0 => $kid_pid) {
- warn "something wicked happened to $kid_pid";
+ warn "something wicked happened to $kid_pid";
}
When directed at a process whose UID is not identical to that
You may be able to determine the cause of failure using C<%!>.
unless (kill 0 => $pid or $!{EPERM}) {
- warn "$pid looks dead";
+ warn "$pid looks dead";
}
You might also want to employ anonymous functions for simple signal
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;
+ $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...
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.
+ 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) {
- $Kid_Status{$child} = $?;
- }
- $SIG{CHLD} = \&REAPER; # still loathe SysV
+ $Kid_Status{$child} = $?;
+ }
+ $SIG{CHLD} = \&REAPER; # still loathe SysV
}
$SIG{CHLD} = \&REAPER;
# do something that forks...
-Signal handling is also used for timeouts in Unix, While safely
+Note: qx(), system() and some modules for calling external commands do a
+fork() and wait() for the result. Thus, your signal handler (REAPER in the
+example) will be called. Since wait() was already called by system() or qx()
+the wait() in the signal handler will not see any more zombies and therefore
+block.
+
+The best way to prevent this issue is to use waitpid, as in the following
+example:
+
+ use POSIX ":sys_wait_h"; # for nonblocking read
+
+ my %children;
+
+ $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 (1) {
+ my $pid = fork();
+ if ($pid == 0) {
+ # ...
+ exit 0;
+ } else {
+ $children{$pid}=1;
+ # ...
+ system($command);
+ # ...
+ }
+ }
+
+Signal handling is also used for timeouts in Unix. While safely
protected within an C<eval{}> block, you set a signal handler to trap
alarm signals and then schedule to have one delivered to you in some
number of seconds. Then try your blocking operation, clearing the alarm
#
$ENV{PATH} .= ":/etc:/usr/etc";
if ( system('mknod', $path, 'p')
- && system('mkfifo', $path) )
+ && system('mkfifo', $path) )
{
- die "mk{nod,fifo} $path failed";
+ die "mk{nod,fifo} $path failed";
}
$FIFO = '.signature';
while (1) {
- unless (-p $FIFO) {
- unlink $FIFO;
- require POSIX;
- POSIX::mkfifo($FIFO, 0700)
- or die "can't mkfifo $FIFO: $!";
- }
-
- # next line blocks until there's a reader
- open (FIFO, "> $FIFO") || die "can't write $FIFO: $!";
- print FIFO "John Smith (smith\@host.org)\n", `fortune -s`;
- close FIFO;
- sleep 2; # to avoid dup signals
+ unless (-p $FIFO) {
+ unlink $FIFO;
+ require POSIX;
+ POSIX::mkfifo($FIFO, 0700)
+ or die "can't mkfifo $FIFO: $!";
+ }
+
+ # next line blocks until there's a reader
+ open (FIFO, "> $FIFO") || die "can't write $FIFO: $!";
+ print FIFO "John Smith (smith\@host.org)\n", `fortune -s`;
+ close FIFO;
+ sleep 2; # to avoid dup signals
}
=head2 Deferred Signals (Safe Signals)
convenience", and to do anything you wanted in your signal handler,
and be prepared to clean up core dumps now and again.
-In Perl 5.7.3 and later to avoid these problems signals are
-"deferred"-- that is when the signal is delivered to the process by
+Perl 5.7.3 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
something up in a child process you intend to write to:
open(SPOOLER, "| cat -v | lpr -h 2>/dev/null")
- || die "can't fork: $!";
+ || die "can't fork: $!";
local $SIG{PIPE} = sub { die "spooler pipe broke" };
print SPOOLER "stuff\n";
close SPOOLER || die "bad spool: $! $?";
And here's how to start up a child process you intend to read from:
open(STATUS, "netstat -an 2>&1 |")
- || die "can't fork: $!";
+ || die "can't fork: $!";
while (<STATUS>) {
- next if /^(tcp|udp)/;
- print;
+ next if /^(tcp|udp)/;
+ print;
}
close STATUS || die "bad netstat: $! $?";
to bogus command will trigger a signal they'd better be prepared to
handle. Consider:
- open(FH, "|bogus") or die "can't fork: $!";
- print FH "bang\n" or die "can't write: $!";
- close FH or die "can't close: $!";
+ open(FH, "|bogus") or die "can't fork: $!";
+ print FH "bang\n" or die "can't write: $!";
+ close FH or die "can't close: $!";
That won't blow up until the close, and it will blow up with a SIGPIPE.
To catch it, you could use this:
use POSIX 'setsid';
sub daemonize {
- chdir '/' or die "Can't chdir to /: $!";
- open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
- open STDOUT, '>/dev/null'
- or die "Can't write to /dev/null: $!";
- defined(my $pid = fork) or die "Can't fork: $!";
- exit if $pid;
- die "Can't start a new session: $!" if setsid == -1;
- open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
+ chdir '/' or die "Can't chdir to /: $!";
+ open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
+ open STDOUT, '>/dev/null'
+ or die "Can't write to /dev/null: $!";
+ defined(my $pid = fork) or die "Can't fork: $!";
+ exit if $pid;
+ die "Can't start a new session: $!" if setsid == -1;
+ open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
}
The fork() has to come before the setsid() to ensure that you aren't a
my $sleep_count = 0;
do {
- $pid = open(KID_TO_WRITE, "|-");
- unless (defined $pid) {
- warn "cannot fork: $!";
- die "bailing out" if $sleep_count++ > 6;
- sleep 10;
- }
+ $pid = open(KID_TO_WRITE, "|-");
+ unless (defined $pid) {
+ warn "cannot fork: $!";
+ die "bailing out" if $sleep_count++ > 6;
+ sleep 10;
+ }
} until defined $pid;
if ($pid) { # parent
- print KID_TO_WRITE @some_data;
- close(KID_TO_WRITE) || warn "kid exited $?";
+ print KID_TO_WRITE @some_data;
+ close(KID_TO_WRITE) || warn "kid exited $?";
} else { # child
- ($EUID, $EGID) = ($UID, $GID); # suid progs only
- open (FILE, "> /safe/file")
- || die "can't open /safe/file: $!";
- while (<STDIN>) {
- print FILE; # child's STDIN is parent's KID_TO_WRITE
- }
- exit; # don't forget this
+ ($EUID, $EGID) = ($UID, $GID); # suid progs only
+ open (FILE, "> /safe/file")
+ || die "can't open /safe/file: $!";
+ while (<STDIN>) {
+ print FILE; # child's STDIN is parent's KID_TO_WRITE
+ }
+ exit; # don't forget this
}
Another common use for this construct is when you need to execute
$pid = open(KID_TO_READ, "-|");
if ($pid) { # parent
- while (<KID_TO_READ>) {
- # do something interesting
- }
- close(KID_TO_READ) || warn "kid exited $?";
+ while (<KID_TO_READ>) {
+ # do something interesting
+ }
+ close(KID_TO_READ) || warn "kid exited $?";
} else { # child
- ($EUID, $EGID) = ($UID, $GID); # suid only
- exec($program, @options, @args)
- || die "can't exec program: $!";
- # NOTREACHED
+ ($EUID, $EGID) = ($UID, $GID); # suid only
+ exec($program, @options, @args)
+ || die "can't exec program: $!";
+ # NOTREACHED
}
$SIG{PIPE} = sub { die "whoops, $program pipe broke" };
if ($pid) { # parent
- for (@data) {
- print KID_TO_WRITE;
- }
- close(KID_TO_WRITE) || warn "kid exited $?";
+ for (@data) {
+ print KID_TO_WRITE;
+ }
+ close(KID_TO_WRITE) || warn "kid exited $?";
} else { # child
- ($EUID, $EGID) = ($UID, $GID);
- exec($program, @options, @args)
- || die "can't exec program: $!";
- # NOTREACHED
+ ($EUID, $EGID) = ($UID, $GID);
+ exec($program, @options, @args)
+ || die "can't exec program: $!";
+ # NOTREACHED
}
It is very easy to dead-lock a process using this form of open(), or
}
else {
# write to WRITER...
- exit;
+ exit;
}
}
else {
# do something with STDIN...
- exit;
+ exit;
}
In the above, the true parent does not want to write to the WRITER
$pid = fork();
defined $pid or die "fork failed; $!";
if ($pid) {
- close READER;
+ close READER;
if (my $sub_pid = fork()) {
close WRITER;
}
else {
# write to WRITER...
- exit;
+ exit;
}
# write to WRITER...
}
require 'Comm.pl';
$ph = open_proc('cat -n');
for (1..10) {
- print $ph "a line\n";
- print "got back ", scalar <$ph>;
+ print $ph "a line\n";
+ print "got back ", scalar <$ph>;
}
This way you don't have to have control over the source code of the
#!/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: failure?
- pipe(CHILD_RDR, PARENT_WTR); # XXX: failure?
+ use IO::Handle; # thousands of lines just for autoflush :-(
+ pipe(PARENT_RDR, CHILD_WTR); # XXX: failure?
+ pipe(CHILD_RDR, PARENT_WTR); # XXX: 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);
+ 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;
+ 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;
}
But you don't actually have to make two pipe calls. If you
# "the best ones always go both ways"
use Socket;
- use IO::Handle; # thousands of lines just for autoflush :-(
+ 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)
- or die "socketpair: $!";
+ or 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);
+ 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;
+ 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;
}
=head1 Sockets: Client/Server Communication
$port = shift || 2345; # random port
if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
die "No port" unless $port;
- $iaddr = inet_aton($remote) || die "no host: $remote";
+ $iaddr = inet_aton($remote) || die "no host: $remote";
$paddr = sockaddr_in($port, $iaddr);
$proto = getprotobyname('tcp');
- socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
connect(SOCK, $paddr) || die "connect: $!";
while (defined($line = <SOCK>)) {
- print $line;
+ print $line;
}
- close (SOCK) || die "close: $!";
+ close (SOCK) || die "close: $!";
exit;
And here's a corresponding server to go along with it. We'll
($port) = $port =~ /^(\d+)$/ or die "invalid port";
- socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ 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: $!";
+ pack("l", 1)) || die "setsockopt: $!";
+ bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
+ listen(Server,SOMAXCONN) || die "listen: $!";
logmsg "server started on port $port";
$SIG{CHLD} = \&REAPER;
for ( ; $paddr = accept(Client,Server); close Client) {
- my($port,$iaddr) = sockaddr_in($paddr);
- my $name = gethostbyaddr($iaddr,AF_INET);
+ 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
($port) = $port =~ /^(\d+)$/ or die "invalid port";
- socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ 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: $!";
+ pack("l", 1)) || die "setsockopt: $!";
+ bind(Server, sockaddr_in($port, INADDR_ANY))|| die "bind: $!";
+ listen(Server,SOMAXCONN) || die "listen: $!";
logmsg "server started on port $port";
printf "%-24s %8s %s\n", "localhost", 0, ctime(time());
foreach $host (@ARGV) {
- printf "%-24s ", $host;
- my $hisiaddr = inet_aton($host) || die "unknown host";
- my $hispaddr = sockaddr_in($port, $hisiaddr);
- socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
- connect(SOCKET, $hispaddr) || die "connect: $!";
- my $rtime = ' ';
- read(SOCKET, $rtime, 4);
- close(SOCKET);
- my $histime = unpack("N", $rtime) - $SECS_of_70_YEARS;
- printf "%8d %s\n", $histime - time, ctime($histime);
+ printf "%-24s ", $host;
+ my $hisiaddr = inet_aton($host) || die "unknown host";
+ my $hispaddr = sockaddr_in($port, $hisiaddr);
+ socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ connect(SOCKET, $hispaddr) || die "connect: $!";
+ my $rtime = ' ';
+ read(SOCKET, $rtime, 4);
+ close(SOCKET);
+ my $histime = unpack("N", $rtime) - $SECS_of_70_YEARS;
+ printf "%8d %s\n", $histime - time, ctime($histime);
}
=head2 Unix-Domain TCP Clients and Servers
You can test for these with Perl's B<-S> file test:
unless ( -S '/dev/log' ) {
- die "something's wicked with the log system";
+ die "something's wicked with the log system";
}
Here's a sample Unix-domain client:
my ($rendezvous, $line);
$rendezvous = shift || 'catsock';
- socket(SOCK, PF_UNIX, SOCK_STREAM, 0) || die "socket: $!";
- connect(SOCK, sockaddr_un($rendezvous)) || die "connect: $!";
+ socket(SOCK, PF_UNIX, SOCK_STREAM, 0) || die "socket: $!";
+ connect(SOCK, sockaddr_un($rendezvous)) || die "connect: $!";
while (defined($line = <SOCK>)) {
- print $line;
+ print $line;
}
exit;
my $uaddr = sockaddr_un($NAME);
my $proto = getprotobyname('tcp');
- socket(Server,PF_UNIX,SOCK_STREAM,0) || die "socket: $!";
+ socket(Server,PF_UNIX,SOCK_STREAM,0) || die "socket: $!";
unlink($NAME);
- bind (Server, $uaddr) || die "bind: $!";
- listen(Server,SOMAXCONN) || die "listen: $!";
+ bind (Server, $uaddr) || die "bind: $!";
+ listen(Server,SOMAXCONN) || die "listen: $!";
logmsg "server started on $NAME";
use POSIX ":sys_wait_h";
sub REAPER {
- my $child;
+ my $child;
while (($waitedpid = waitpid(-1,WNOHANG)) > 0) {
- logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
- }
- $SIG{CHLD} = \&REAPER; # loathe SysV
+ logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
+ }
+ $SIG{CHLD} = \&REAPER; # loathe SysV
}
$SIG{CHLD} = \&REAPER;
for ( $waitedpid = 0;
- accept(Client,Server) || $waitedpid;
- $waitedpid = 0, close Client)
+ accept(Client,Server) || $waitedpid;
+ $waitedpid = 0, close Client)
{
- next if $waitedpid;
- logmsg "connection on $NAME";
- spawn sub {
- print "Hello there, it's now ", scalar localtime, "\n";
- exec '/usr/games/fortune' or die "can't exec fortune: $!";
- };
+ next if $waitedpid;
+ logmsg "connection on $NAME";
+ spawn sub {
+ print "Hello there, it's now ", scalar localtime, "\n";
+ exec '/usr/games/fortune' or die "can't exec fortune: $!";
+ };
}
sub spawn {
- my $coderef = shift;
-
- 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
-
- 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();
+ my $coderef = shift;
+
+ 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
+
+ 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();
}
As you see, it's remarkably similar to the Internet domain TCP server, so
#!/usr/bin/perl -w
use IO::Socket;
$remote = IO::Socket::INET->new(
- Proto => "tcp",
- PeerAddr => "localhost",
- PeerPort => "daytime(13)",
- )
- or die "cannot connect to daytime port at localhost";
+ Proto => "tcp",
+ PeerAddr => "localhost",
+ PeerPort => "daytime(13)",
+ )
+ or die "cannot connect to daytime port at localhost";
while ( <$remote> ) { print }
When you run this program, you should get something back that
$EOL = "\015\012";
$BLANK = $EOL x 2;
foreach $document ( @ARGV ) {
- $remote = IO::Socket::INET->new( Proto => "tcp",
- PeerAddr => $host,
- PeerPort => "http(80)",
- );
- unless ($remote) { die "cannot connect to http daemon on $host" }
- $remote->autoflush(1);
- print $remote "GET $document HTTP/1.0" . $BLANK;
- while ( <$remote> ) { print }
- close $remote;
+ $remote = IO::Socket::INET->new( Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => "http(80)",
+ );
+ unless ($remote) { die "cannot connect to http daemon on $host" }
+ $remote->autoflush(1);
+ print $remote "GET $document HTTP/1.0" . $BLANK;
+ while ( <$remote> ) { print }
+ close $remote;
}
The web server handing the "http" service, which is assumed to be at
# create a tcp connection to the specified host and port
$handle = IO::Socket::INET->new(Proto => "tcp",
- PeerAddr => $host,
- PeerPort => $port)
- or die "can't connect to port $port on $host: $!";
+ PeerAddr => $host,
+ PeerPort => $port)
+ or die "can't connect to port $port on $host: $!";
- $handle->autoflush(1); # so output gets there right away
+ $handle->autoflush(1); # so output gets there right away
print STDERR "[Connected to $host:$port]\n";
# split the program into two processes, identical twins
# the if{} block runs only in the parent process
if ($kidpid) {
- # copy the socket to standard output
- while (defined ($line = <$handle>)) {
- print STDOUT $line;
- }
- kill("TERM", $kidpid); # send SIGTERM to child
+ # copy the socket to standard output
+ while (defined ($line = <$handle>)) {
+ print STDOUT $line;
+ }
+ kill("TERM", $kidpid); # send SIGTERM to child
}
# the else{} block runs only in the child process
else {
- # copy standard input to the socket
- while (defined ($line = <STDIN>)) {
- print $handle $line;
- }
+ # copy standard input to the socket
+ while (defined ($line = <STDIN>)) {
+ print $handle $line;
+ }
}
The C<kill> function in the parent's C<if> block is there to send a
my $byte;
while (sysread($handle, $byte, 1) == 1) {
- print STDOUT $byte;
+ print STDOUT $byte;
}
Making a system call for each byte you want to read is not very efficient
#!/usr/bin/perl -w
use IO::Socket;
- use Net::hostent; # for OO version of gethostbyaddr
+ use Net::hostent; # for OO version of gethostbyaddr
- $PORT = 9000; # pick something not in use
+ $PORT = 9000; # pick something not in use
$server = IO::Socket::INET->new( Proto => 'tcp',
LocalPort => $PORT,
printf "[Connect from %s]\n", $hostinfo ? $hostinfo->name : $client->peerhost;
print $client "Command? ";
while ( <$client>) {
- next unless /\S/; # blank line
+ 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`; }
use Sys::Hostname;
my ( $count, $hisiaddr, $hispaddr, $histime,
- $host, $iaddr, $paddr, $port, $proto,
- $rin, $rout, $rtime, $SECS_of_70_YEARS);
+ $host, $iaddr, $paddr, $port, $proto,
+ $rin, $rout, $rtime, $SECS_of_70_YEARS);
$SECS_of_70_YEARS = 2208988800;
printf "%-12s %8s %s\n", "localhost", 0, scalar localtime time;
$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: $!";
+ $count++;
+ $hisiaddr = inet_aton($host) || die "unknown host";
+ $hispaddr = sockaddr_in($port, $hisiaddr);
+ defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!";
}
$rin = '';
# 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--;
+ $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--;
}
Note that this example does not include any retries and may consequently
use IPC::SysV qw(IPC_PRIVATE IPC_RMID S_IRUSR S_IWUSR);
$size = 2000;
- $id = shmget(IPC_PRIVATE, $size, S_IRUSR|S_IWUSR) || die "$!";
+ $id = shmget(IPC_PRIVATE, $size, S_IRUSR|S_IWUSR) // die "$!";
print "shm key $id\n";
$message = "Message #1";
use IPC::SysV qw(IPC_CREAT);
$IPC_KEY = 1234;
- $id = semget($IPC_KEY, 10, 0666 | IPC_CREAT ) || die "$!";
+ $id = semget($IPC_KEY, 10, 0666 | IPC_CREAT ) // die "$!";
print "shm key $id\n";
Put this code in a separate file to be run in more than one process.