Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss

[PATCH] Start revamping perlipc.pod

1 view
Skip to first unread message

Shlomi Fish

unread,
Sep 5, 2010, 1:03:41 AM9/5/10
to perl5-...@perl.org, perl-docu...@perl.org
Hi all,

Inspired by a message ot the perl documentation proejct, I started working on
revamping perlipc.pod here:

http://github.com/shlomif/perl/tree/perlipc-revamp

What I did so far is convert all tabs to spaces (as the indentation was very
erratic) and started modernising the code (adding line spaces, declare
variables with my, not cuddle else's, etc.). So far I've reached the named
pipes section in my code coverage, and I'm planning to convert the socket
examples to IO::Socket when I get to them.

Here's the patch I have so far, though it is possible that KMail will mangle
it.

Regards,

Shlomi Fish

diff --git a/pod/perlipc.pod b/pod/perlipc.pod
index 8d9ea97..4bc119b 100644
--- a/pod/perlipc.pod
+++ b/pod/perlipc.pod
@@ -21,11 +21,16 @@ running out of stack space, or hitting file size limit.

For example, to trap an interrupt signal, set up a handler like this:

+ our $shucks = 0;
+
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

@@ -43,18 +48,28 @@ system, or you can retrieve them from the Config module.
Set up an
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++;
+
+ if (!defined $Config{sig_name})
+ {
+ die "No sigs?";
+ }
+
+ my (%signo, @signame);
+
+ my $index = 0;
+
+ foreach my $name (split(' ', $Config{sig_name})) {
+ $signo{$name} = $index;
+ $signame[$index] = $name;
+
+ $index++;
}

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
@@ -76,11 +91,12 @@ automatically restored once your block is exited.
(Remember that local()
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
@@ -89,9 +105,9 @@ processes in the current process group (and sets $SIG{HUP}
to IGNORE so
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
@@ -99,7 +115,7 @@ actually affect a child process, but instead checks whether
it's alive
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
@@ -108,13 +124,13 @@ 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<%!>.

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
handlers:

- $SIG{INT} = sub { die "\nOutta here!\n" };
+ $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
@@ -125,10 +141,10 @@ 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;
+ $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...
@@ -137,15 +153,15 @@ or better still:

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...
@@ -164,25 +180,38 @@ example:
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) {
- # ...
+
+ # I'm the child - do something.
exit 0;
- } else {
- $children{$pid}=1;
+
+ }
+ else {
+
+ $children{$pid}=1;
# ...
system($command);
# ...
+
}
}

@@ -197,12 +226,16 @@ using longjmp() or throw() in other languages.
Here's an example:

eval {
- local $SIG{ALRM} = sub { die "alarm clock restart" };
+
+ local $SIG{ALRM} = sub { die "alarm clock restart"; };
+
alarm 10;
flock(FH, 2); # blocking write lock
alarm 0;
+
};
- if ($@ and $@ !~ /alarm clock restart/) { die }
+
+ if ($@ and $@ !~ /alarm clock restart/) { die; }

If the operation being timed out is system() or qx(), this technique
is liable to generate zombies. If this matters to you, you'll
@@ -244,16 +277,18 @@ info to show that it works and should be replaced with
the real code.

$|=1;

- # make the daemon cross-platform, so exec always calls the script
+ # Make the daemon cross-platform, so exec always calls the script
# itself with the right path, no matter how the script was invoked.
my $script = File::Basename::basename($0);
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 {
@@ -264,9 +299,12 @@ info to show that it works and should be replaced with
the real code.
code();

sub code {
+
print "PID: $$\n";
print "ARGV: @ARGV\n";
+
my $c = 0;
+
while (++$c) {
sleep 2;
print "$c\n";
@@ -294,9 +332,9 @@ systems, mkfifo(1). These may not be in your normal path.
#
$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";
}


@@ -315,18 +353,18 @@ to find out whether anyone (or anything) has
accidentally removed our fifo.
$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)
@@ -472,7 +510,7 @@ symbol to the second argument to open(). Here's how to
start
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: $! $?";
@@ -480,10 +518,10 @@ something up in a child process you intend to write to:
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: $! $?";

@@ -521,9 +559,9 @@ while readers of bogus commands return just a quick end of
file, writers
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:
@@ -566,14 +604,14 @@ output doesn't wind up on the user's terminal).
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
@@ -601,25 +639,25 @@ you opened whatever your kid writes to his STDOUT.
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
@@ -634,16 +672,16 @@ Here's a safe backtick or pipe open for read:
$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
}


@@ -654,16 +692,16 @@ And here's a safe pipe open for writing:
$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
@@ -685,12 +723,12 @@ writer. Consider this code:
}
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
@@ -711,13 +749,13 @@ open() which sets one file descriptor to another, as
below:
$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...
}
@@ -817,8 +855,8 @@ pseudo-ttys to make your program behave more reasonably:
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
@@ -843,27 +881,27 @@ handles to STDIN and STDOUT and call other processes.
#!/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
@@ -874,31 +912,31 @@ have the socketpair() system call, it will do this all
for 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
@@ -958,17 +996,17 @@ Here's a sample TCP client using Internet-domain
sockets:
$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
@@ -992,11 +1030,11 @@ instead.

($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";

@@ -1005,15 +1043,15 @@ instead.
$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
@@ -1036,11 +1074,11 @@ go back to service a new client.

($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";

@@ -1161,16 +1199,16 @@ differ from the system on which it's being run:
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
@@ -1187,7 +1225,7 @@ domain sockets can show up in the file system with an
ls(1) listing.
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:
@@ -1198,10 +1236,10 @@ 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;

@@ -1222,10 +1260,10 @@ to be on the localhost, and thus everything works
right.
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";

@@ -1233,49 +1271,49 @@ to be on the localhost, and thus everything works
right.

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
@@ -1315,11 +1353,11 @@ that the server there cares to provide.
#!/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
@@ -1389,15 +1427,15 @@ something to the server before fetching the server's
response.
$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
@@ -1472,11 +1510,11 @@ Here's the code:

# 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
@@ -1484,18 +1522,18 @@ Here's the code:

# 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
@@ -1509,7 +1547,7 @@ following:

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
@@ -1578,9 +1616,9 @@ Here's the code. We'll

#!/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,
@@ -1597,7 +1635,7 @@ Here's the code. We'll
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`; }
@@ -1641,8 +1679,8 @@ with TCP, you'd have to use a different socket handle
for each host.
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;

@@ -1658,10 +1696,10 @@ with TCP, you'd have to use a different socket handle
for each host.
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 = '';
@@ -1669,14 +1707,14 @@ with TCP, you'd have to use a different socket handle
for each host.

# 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


--
-----------------------------------------------------------------
Shlomi Fish http://www.shlomifish.org/
Freecell Solver - http://fc-solve.berlios.de/

God considered inflicting XSLT as the tenth plague of Egypt, but then
decided against it because he thought it would be too evil.

Please reply to list if it's a mailing list post - http://shlom.in/reply .

Leon Timmermans

unread,
Sep 5, 2010, 9:57:38 AM9/5/10
to Shlomi Fish, perl5-...@perl.org, perl-docu...@perl.org
On Sun, Sep 5, 2010 at 7:03 AM, Shlomi Fish <shl...@iglu.org.il> wrote:
> Inspired by a message ot the perl documentation proejct, I started working on
> revamping perlipc.pod here:

Good idea :-)

> What I did so far is convert all tabs to spaces (as the indentation was very
> erratic) and started modernising the code (adding line spaces, declare
> variables with my, not cuddle else's, etc.). So far I've reached the named
> pipes section in my code coverage, and I'm planning to convert the socket
> examples to IO::Socket when I get to them.

Some of my ideas and questions for perlipc would be:

* Reorganize the order of chapters. Signals *really* should not be the
first thing on the list. In fact they should probably leave only SysV
IPC behind them. Named pipes should probably also be moved down.
* Convert all glob filehandles to lexical filehandles.
* Convert all open's to the 3+ argument form where possible.
* Make it use more core and CPAN modules instead of reinventing code
(e.g. autodie, IPC::System::Simple, IPC::Signal, IO::Pipe, etc…).
* Are there actually still operating systems out there where perl has
SysV behavior for signal handlers? Probably some rather old
installations of SysV derived unices, but I think this is no longer
relevant except maybe in perlport.
* Should SysV IPC be covered at all? I've never seen a Perl program
use it in the wild. Rightly so if you ask me, because using it from
Perl sucks even more than using it from C.

Leon

Shlomi Fish

unread,
Sep 5, 2010, 11:01:08 AM9/5/10
to perl5-...@perl.org, Jesse Vincent, perl-docu...@perl.org
On Sunday 05 September 2010 17:58:54 Shlomi Fish wrote:
> On Sunday 05 September 2010 08:13:02 Jesse Vincent wrote:

> > On Sun, Sep 05, 2010 at 08:03:41AM +0300, Shlomi Fish wrote:
> > > Hi all,
> > >
> > > Inspired by a message ot the perl documentation proejct, I started
> > > working on revamping perlipc.pod here:
> > >
> > > http://github.com/shlomif/perl/tree/perlipc-revamp
> > >
> > > What I did so far is convert all tabs to spaces (as the indentation was
> > > very erratic) and started modernising the code
> >
> > Shlomi,
> >
> > Thanks for starting to look at perlipc. Is there a chance you could send
> > your patch as a series that splits out the whitespace changes from the
> > code/prose changes? Heavy whitespace changes tend to make it much
> > harder to review "contentful" changes in a patch, since there are
> > so many lines of diff that aren't actually semantically meaningful.
> >
> > Thanks,
> > Jesse
>
> Thanks to the git history, I can. Here is the tabs->spaces patch and the
> next reply will contain the code/prose changes. I've marked the transition
> in the repository using the «perlipc_pod_after_changing_tabs_to_spaces»
> tag.
>
> Regards,
>
> Shlomi Fish
>

And here's the code/prose changes patch which works againt the version after
the tabs->spaces conversion:

Regards,

Shlomi Fish

diff --git a/pod/perlipc.pod b/pod/perlipc.pod
index 9c556d0..4bc119b 100644
--- a/pod/perlipc.pod
+++ b/pod/perlipc.pod
@@ -48,11 +48,21 @@ system, or you can retrieve them from the Config module.

Set up an
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++;
+
+ if (!defined $Config{sig_name})
+ {
+ die "No sigs?";
+ }
+
+ my (%signo, @signame);
+
+ my $index = 0;
+
+ foreach my $name (split(' ', $Config{sig_name})) {
+ $signo{$name} = $index;
+ $signame[$index] = $name;
+
+ $index++;
}

So to check whether signal 17 and SIGALRM were the same, do just this:

@@ -82,8 +92,9 @@ values are "inherited" by functions called from within that
block.)

sub precious {


local $SIG{INT} = 'IGNORE';
- &more_functions;

+ more_functions();
}
+
sub more_functions {


# interrupts still ignored, for now...
}

@@ -119,7 +130,7 @@ You may be able to determine the cause of failure using
C<%!>.


You might also want to employ anonymous functions for simple signal
handlers:

- $SIG{INT} = sub { die "\nOutta here!\n" };
+ $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

@@ -169,25 +180,38 @@ example:

@@ -202,12 +226,16 @@ using longjmp() or throw() in other languages.


Here's an example:

eval {
- local $SIG{ALRM} = sub { die "alarm clock restart" };
+
+ local $SIG{ALRM} = sub { die "alarm clock restart"; };
+
alarm 10;
flock(FH, 2); # blocking write lock
alarm 0;
+
};
- if ($@ and $@ !~ /alarm clock restart/) { die }
+
+ if ($@ and $@ !~ /alarm clock restart/) { die; }

If the operation being timed out is system() or qx(), this technique
is liable to generate zombies. If this matters to you, you'll

@@ -249,16 +277,18 @@ info to show that it works and should be replaced with

the real code.

$|=1;

- # make the daemon cross-platform, so exec always calls the script
+ # Make the daemon cross-platform, so exec always calls the script
# itself with the right path, no matter how the script was invoked.
my $script = File::Basename::basename($0);
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 {

@@ -269,9 +299,12 @@ info to show that it works and should be replaced with

the real code.
code();

sub code {
+
print "PID: $$\n";
print "ARGV: @ARGV\n";
+
my $c = 0;
+
while (++$c) {
sleep 2;
print "$c\n";

--

-----------------------------------------------------------------
Shlomi Fish http://www.shlomifish.org/

Understand what Open Source is - http://shlom.in/oss-fs

Shlomi Fish

unread,
Sep 5, 2010, 10:58:54 AM9/5/10
to perl5-...@perl.org, Jesse Vincent, perl-docu...@perl.org
On Sunday 05 September 2010 08:13:02 Jesse Vincent wrote:
> On Sun, Sep 05, 2010 at 08:03:41AM +0300, Shlomi Fish wrote:
> > Hi all,
> >
> > Inspired by a message ot the perl documentation proejct, I started
> > working on revamping perlipc.pod here:
> >
> > http://github.com/shlomif/perl/tree/perlipc-revamp
> >
> > What I did so far is convert all tabs to spaces (as the indentation was
> > very erratic) and started modernising the code
>
> Shlomi,
>
> Thanks for starting to look at perlipc. Is there a chance you could send
> your patch as a series that splits out the whitespace changes from the
> code/prose changes? Heavy whitespace changes tend to make it much
> harder to review "contentful" changes in a patch, since there are
> so many lines of diff that aren't actually semantically meaningful.
>
> Thanks,
> Jesse

Thanks to the git history, I can. Here is the tabs->spaces patch and the next
reply will contain the code/prose changes. I've marked the transition in the
repository using the «perlipc_pod_after_changing_tabs_to_spaces» tag.

Regards,

Shlomi Fish

diff --git a/pod/perlipc.pod b/pod/perlipc.pod
index 8d9ea97..9c556d0 100644


--- a/pod/perlipc.pod
+++ b/pod/perlipc.pod
@@ -21,11 +21,16 @@ running out of stack space, or hitting file size limit.

For example, to trap an interrupt signal, set up a handler like this:

+ our $shucks = 0;
+
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

@@ -45,16 +50,16 @@ 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++;

+ $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

@@ -76,11 +81,11 @@ automatically restored once your block is exited.

(Remember that local()
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

@@ -89,9 +94,9 @@ processes in the current process group (and sets $SIG{HUP}

to IGNORE so
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

@@ -99,7 +104,7 @@ actually affect a child process, but instead checks whether

it's alive
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

@@ -108,7 +113,7 @@ 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<%!>.

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

@@ -125,10 +130,10 @@ 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;
+ $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...

@@ -137,15 +142,15 @@ or better still:



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...

@@ -294,9 +299,9 @@ systems, mkfifo(1). These may not be in your normal path.


#
$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";
}


@@ -315,18 +320,18 @@ to find out whether anyone (or anything) has

@@ -472,7 +477,7 @@ symbol to the second argument to open(). Here's how to

start
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: $! $?";

@@ -480,10 +485,10 @@ something up in a child process you intend to write to:


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: $! $?";

@@ -521,9 +526,9 @@ while readers of bogus commands return just a quick end of

file, writers
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:

@@ -566,14 +571,14 @@ output doesn't wind up on the user's terminal).


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

@@ -601,25 +606,25 @@ you opened whatever your kid writes to his STDOUT.

@@ -634,16 +639,16 @@ Here's a safe backtick or pipe open for read:


$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
}


@@ -654,16 +659,16 @@ And here's a safe pipe open for writing:


$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

@@ -685,12 +690,12 @@ writer. Consider this code:


}
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

@@ -711,13 +716,13 @@ open() which sets one file descriptor to another, as

below:
$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...
}

@@ -817,8 +822,8 @@ pseudo-ttys to make your program behave more reasonably:


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

@@ -843,27 +848,27 @@ handles to STDIN and STDOUT and call other processes.

@@ -874,31 +879,31 @@ have the socketpair() system call, it will do this all

@@ -958,17 +963,17 @@ Here's a sample TCP client using Internet-domain

sockets:
$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

@@ -992,11 +997,11 @@ instead.



($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";

@@ -1005,15 +1010,15 @@ instead.


$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

@@ -1036,11 +1041,11 @@ go back to service a new client.



($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";

@@ -1161,16 +1166,16 @@ differ from the system on which it's being run:


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

@@ -1187,7 +1192,7 @@ domain sockets can show up in the file system with an

ls(1) listing.
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:

@@ -1198,10 +1203,10 @@ 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;

@@ -1222,10 +1227,10 @@ to be on the localhost, and thus everything works

right.
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";

@@ -1233,49 +1238,49 @@ to be on the localhost, and thus everything works

@@ -1315,11 +1320,11 @@ that the server there cares to provide.


#!/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

@@ -1389,15 +1394,15 @@ something to the server before fetching the server's

response.
$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

@@ -1472,11 +1477,11 @@ Here's the code:



# 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

@@ -1484,18 +1489,18 @@ Here's the code:



# 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

@@ -1509,7 +1514,7 @@ following:



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

@@ -1578,9 +1583,9 @@ Here's the code. We'll



#!/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,

@@ -1597,7 +1602,7 @@ Here's the code. We'll


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`; }

@@ -1641,8 +1646,8 @@ with TCP, you'd have to use a different socket handle

for each host.
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;

@@ -1658,10 +1663,10 @@ with TCP, you'd have to use a different socket handle

for each host.
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 = '';

@@ -1669,14 +1674,14 @@ with TCP, you'd have to use a different socket handle

for each host.

# 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


--
-----------------------------------------------------------------
Shlomi Fish http://www.shlomifish.org/

http://www.shlomifish.org/humour/ways_to_do_it.html

Ævar Arnfjörð Bjarmason

unread,
Sep 5, 2010, 11:22:02 AM9/5/10
to Shlomi Fish, perl5-...@perl.org, Jesse Vincent, perl-docu...@perl.org

That's way too verbose. I don't find anything wrong with the original,
but maybe:

die "No sigs?" unless defined $Config{sig_name}

Or even, to depend on recent perls:

$Config{sig_name} // die "No sigs?";

Or maybe skip the whole thing? Are there really modern platforms with
no $Config{sig_name}?

> +    my (%signo, @signame);
> +
> +    my $index = 0;
> +
> +    foreach my $name (split(' ', $Config{sig_name})) {

Maybe use "for" since we're touching this'

> +        $signo{$name} = $index;
> +        $signame[$index] = $name;
> +
> +        $index++;

I think using "$index" instead of the obviously temporary and local
"$i" is bad style.

>     }
>
>  So to check whether signal 17 and SIGALRM were the same, do just this:
> @@ -82,8 +92,9 @@ values are "inherited" by functions called from within that
> block.)
>
>     sub precious {
>         local $SIG{INT} = 'IGNORE';
> -        &more_functions;
> +        more_functions();

Good. Using & makes me think "does this actually need to remove a
stack frame" which complexifies the example a lot.

>     }
> +
>     sub more_functions {
>         # interrupts still ignored, for now...
>     }
> @@ -119,7 +130,7 @@ You may be able to determine the cause of failure using
> C<%!>.
>  You might also want to employ anonymous functions for simple signal
>  handlers:
>
> -    $SIG{INT} = sub { die "\nOutta here!\n" };
> +    $SIG{INT} = sub { die "\nOutta here!\n"; };

Overly verbose IMO. If we're going to be applying this sort of thing
consistently. But maybe it's easier for people that want to add extra
stuff to the function, dunno.

>
>  But that will be problematic for the more complicated handlers that need
>  to reinstall themselves.  Because Perl's signal mechanism is currently
> @@ -169,25 +180,38 @@ example:
>     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, $?);
>     };

Why put \n\n after everything here?

Since you're touching this anyway adding a message to the die would be
useful.

Shlomi Fish

unread,
Sep 14, 2010, 6:42:32 PM9/14/10
to perl5-...@perl.org, Ævar Arnfjörð Bjarmason, Jesse Vincent, perl-docu...@perl.org
Hi,

sorry for the late response.

Well, using || before die is not a good practice. Maybe we can change it to
"or". I personally usually use "or die" only after open and friends.

> but maybe:
>
> die "No sigs?" unless defined $Config{sig_name}
>
> Or even, to depend on recent perls:
>
> $Config{sig_name} // die "No sigs?";
>
> Or maybe skip the whole thing? Are there really modern platforms with
> no $Config{sig_name}?

Don't know.

>
> > + my (%signo, @signame);
> > +
> > + my $index = 0;
> > +
> > + foreach my $name (split(' ', $Config{sig_name})) {
>
> Maybe use "for" since we're touching this'
>

What?

The general convention is to use "for" for C-style for loops and "foreach" for
iterating over a list.

> > + $signo{$name} = $index;
> > + $signame[$index] = $name;
> > +
> > + $index++;
>
> I think using "$index" instead of the obviously temporary and local
> "$i" is bad style.
>

$index here is local and temporary. Before my patch it was package-scoped. We
can argue about whether it should be "$i" or "$index" all day, but I strive
for clarity of intentions.


> > }
> >
> > So to check whether signal 17 and SIGALRM were the same, do just this:
> > @@ -82,8 +92,9 @@ values are "inherited" by functions called from within
> > that block.)
> >
> > sub precious {
> > local $SIG{INT} = 'IGNORE';
> > - &more_functions;
> > + more_functions();
>
> Good. Using & makes me think "does this actually need to remove a
> stack frame" which complexifies the example a lot.
>

:-).



> > }
> > +
> > sub more_functions {
> > # interrupts still ignored, for now...
> > }
> > @@ -119,7 +130,7 @@ You may be able to determine the cause of failure
> > using C<%!>.
> > You might also want to employ anonymous functions for simple signal
> > handlers:
> >
> > - $SIG{INT} = sub { die "\nOutta here!\n" };
> > + $SIG{INT} = sub { die "\nOutta here!\n"; };
>
> Overly verbose IMO. If we're going to be applying this sort of thing
> consistently. But maybe it's easier for people that want to add extra
> stuff to the function, dunno.

I think one semicolon won't make such a difference. And PBP recommends
terminating all statements with a semi-colon even if they are the last ones in
a block (and for good reasons).

>
> > But that will be problematic for the more complicated handlers that need
> > to reinstall themselves. Because Perl's signal mechanism is currently
> > @@ -169,25 +180,38 @@ example:
> > 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, $?);
> > };
>
> Why put \n\n after everything here?

Well, I was trying to split the code into paragraphs (again - see PBP), but I
may have overdone it.

Doesn't it rethrow the exception as it is?

Regards,

Shlomi Fish

--
-----------------------------------------------------------------
Shlomi Fish http://www.shlomifish.org/

"The Human Hacking Field Guide" - http://shlom.in/hhfg

<rindolf> She's a hot chick. But she smokes.
<go|dfish> She can smoke as long as she's smokin'.

Jacinta Richardson

unread,
Sep 14, 2010, 9:13:04 PM9/14/10
to Shlomi Fish, perl5-...@perl.org, Ævar Arnfjörð Bjarmason, Jesse Vincent, perl-docu...@perl.org
Shlomi Fish wrote:

>>> - if ($@ and $@ !~ /alarm clock restart/) { die }
>>> +
>>> + if ($@ and $@ !~ /alarm clock restart/) { die; }
>> Since you're touching this anyway adding a message to the die would be
>> useful.
>
> Doesn't it rethrow the exception as it is?

die LIST

[....]

If LIST is empty and $@ already contains a value (typically
from a previous eval) that value is reused after appending
"\t...propagated". This is useful for propagating exceptions:

eval { ... };
die unless $@ =~ /Expected exception/;


Looks correct to me, although as I hate having to remember/search for special
cases like this, I'd prefer

if ($@ and $@ !~ /alarm clock restart/) { die $@ }

although this is not technically the same thing.

J

--
("`-''-/").___..--''"`-._ | Jacinta Richardson |
`6_ 6 ) `-. ( ).`-.__.`) | Perl Training Australia |
(_Y_.)' ._ ) `._ `. ``-..-' | +61 3 9354 6001 |
_..`--'_..-_/ /--'_.' ,' | con...@perltraining.com.au |
(il),-'' (li),' ((!.-' | www.perltraining.com.au |

0 new messages