16. Process Management and Communication

#-----------------------------
$output = `program args`;   # collect output into one multiline string
@output = `program args`;   # collect output into array, one line per element
#-----------------------------
open(README, "program args |") or die "Can't run program: $!\n";
while(<README>) {
    $output .= $_;
}
close(README);
#-----------------------------
`fsck -y /dev/rsd1a`;       # BAD AND SCARY
#-----------------------------
use POSIX qw(:sys_wait_h);

pipe(README, WRITEME);
if ($pid = fork) {
    # parent
    $SIG{CHLD} = sub { 1 while ( waitpid(-1, WNOHANG)) > 0 };
    close(WRITEME);
} else {
    die "cannot fork: $!" unless defined $pid;
    # child
    open(STDOUT, ">&=WRITEME")      or die "Couldn't redirect STDOUT: $!";
    close(README);
    exec($program, $arg1, $arg2)    or die "Couldn't run $program : $!\n";
}

while (<README>) {
    $string .= $_;
    # or  push(@strings, $_);
}
close(README);
#-----------------------------

#-----------------------------
$status = system("vi $myfile");
#-----------------------------
$status = system("vi", $myfile);
#-----------------------------
system("cmd1 args | cmd2 | cmd3 >outfile");
system("cmd args <infile >outfile 2>errfile");
#-----------------------------
$status = system($program, $arg1, $arg);
die "$program exited funny: $?" unless $status == 0;
#-----------------------------
if (($signo = system(@arglist)) &= 127) { 
    die "program killed by signal $signo\n";
}
#-----------------------------
if ($pid = fork) {
    # parent catches INT and berates user
    local $SIG{INT} = sub { print "Tsk tsk, no process interruptus\n" };
    waitpid($pid, 0);
} else {
    die "cannot fork: $!" unless defined $pid;
    # child ignores INT and does its thing
    $SIG{INT} = "IGNORE";
    exec("summarize", "/etc/logfiles")             or die "Can't exec: $!\n";
}
#-----------------------------
$shell = '/bin/tcsh';
system $shell '-csh';           # pretend it's a login shell
#-----------------------------
system {'/bin/tcsh'} '-csh';    # pretend it's a login shell
#-----------------------------
# call expn as vrfy
system {'/home/tchrist/scripts/expn'} 'vrfy', @ADDRESSES;
#-----------------------------
@args = ( "echo surprise" );

system @args;               # subject to shell escapes if @args == 1
system { $args[0] } @args;  # safe even with one-arg list
#-----------------------------

#-----------------------------
exec("archive *.data")
    or die "Couldn't replace myself with archive: $!\n";
#-----------------------------
exec("archive", "accounting.data")
    or die "Couldn't replace myself with archive: $!\n";
#-----------------------------
exec("archive accounting.data")
    or die "Couldn't replace myself with archive: $!\n";
#-----------------------------

#-----------------------------
$pid = open(README, "program arguments |")  or die "Couldn't fork: $!\n";
while (<README>) {
    # ...
}
close(README)                               or die "Couldn't close: $!\n";
#-----------------------------
$pid = open(WRITEME, "| program arguments") or die "Couldn't fork: $!\n";
print WRITEME "data\n";
close(WRITEME)                              or die "Couldn't close: $!\n";
#-----------------------------
$pid = open(F, "sleep 100000|");    # child goes to sleep
close(F);                           # and the parent goes to lala land
#-----------------------------
$pid = open(WRITEME, "| program args");
print WRITEME "hello\n";            # program will get hello\n on STDIN
close(WRITEME);                     # program will get EOF on STDIN
#-----------------------------
$pager = $ENV{PAGER} || '/usr/bin/less';  # XXX: might not exist
open(STDOUT, "| $pager");
#-----------------------------

#-----------------------------
head(100);
while (<>) {
    print;
} 

sub head {
    my $lines = shift || 20;
    return if $pid = open(STDOUT, "|-");
    die "cannot fork: $!" unless defined $pid;
    while (<STDIN>) {
        print;
        last unless --$lines ;
    } 
    exit;
} 
#-----------------------------
1: > Welcome to Linux, version 2.0.33 on a i686

2: > 

3: >     "The software required `Windows 95 or better', 

4: >      so I installed Linux."  
#-----------------------------
> 1: Welcome to Linux, Kernel version 2.0.33 on a i686

> 2: 

> 3:     "The software required `Windows 95 or better', 

> 4:      so I installed Linux."  
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# qnumcat - demo additive output filters

number();                   # push number filter on STDOUT
quote();                    # push quote filter on STDOUT

while (<>) {                # act like /bin/cat
    print;
} 

close STDOUT;               # tell kids we're done--politely
exit;

sub number {
    my $pid;
    return if $pid = open(STDOUT, "|-");
    die "cannot fork: $!" unless defined $pid;
    while (<STDIN>) { printf "%d: %s", $., $_ } 
    exit;
} 

sub quote {
    my $pid;
    return if $pid = open(STDOUT, "|-");
    die "cannot fork: $!" unless defined $pid;
    while (<STDIN>) { print "> $_" } 
    exit;
} 

#-----------------------------

#-----------------------------
@ARGV = map { /\.(gz|Z)$/ ? "gzip -dc $_ |" : $_  } @ARGV;
while (<>) {
    # .......
} 
#-----------------------------
@ARGV = map { m#^\w+://# ? "GET $_ |" : $_ } @ARGV;
while (<>) {
    # .......
} 
#-----------------------------
$pwdinfo = `domainname` =~ /^(\(none\))?$/
                ? '< /etc/passwd'
                : 'ypcat  passwd |';

open(PWD, $pwdinfo)                 or die "can't open $pwdinfo: $!";
#-----------------------------
print "File, please? ";
chomp($file = <>);
open (FH, $file)                    or die "can't open $file: $!";
#-----------------------------

#-----------------------------
$output = `cmd 2>&1`;                          # with backticks
# or
$pid = open(PH, "cmd 2>&1 |");                 # with an open pipe
while (<PH>) { }                               # plus a read
#-----------------------------
$output = `cmd 2>/dev/null`;                   # with backticks
# or
$pid = open(PH, "cmd 2>/dev/null |");          # with an open pipe
while (<PH>) { }                               # plus a read
#-----------------------------
$output = `cmd 2>&1 1>/dev/null`;              # with backticks
# or
$pid = open(PH, "cmd 2>&1 1>/dev/null |");     # with an open pipe
while (<PH>) { }                               # plus a read
#-----------------------------
$output = `cmd 3>&1 1>&2 2>&3 3>&-`;           # with backticks
# or
$pid = open(PH, "cmd 3>&1 1>&2 2>&3 3>&-|");   # with an open pipe
while (<PH>) { }                               # plus a read
#-----------------------------
system("program args 1>/tmp/program.stdout 2>/tmp/program.stderr");
#-----------------------------
$output = `cmd 3>&1 1>&2 2>&3 3>&-`;        
#-----------------------------
$fd3 = $fd1;
$fd1 = $fd2;
$fd2 = $fd3;
$fd3 = undef;
#-----------------------------
system("prog args 1>tmpfile 2>&1");
system("prog args 2>&1 1>tmpfile");
#-----------------------------
# system ("prog args 1>tmpfile 2>&1");
$fd1 = "tmpfile";        # change stdout destination first
$fd2 = $fd1;             # now point stderr there, too
#-----------------------------
# system("prog args 2>&1 1>tmpfile");
$fd2 = $fd1;             # stderr same destination as stdout
$fd1 = "tmpfile";        # but change stdout destination 
#-----------------------------

#-----------------------------
use IPC::Open2;

open2(*README, *WRITEME, $program);
print WRITEME "here's your input\n";
$output = <README>;
close(WRITEME);
close(README);
#-----------------------------
open(DOUBLE_HANDLE, "| program args |")     # WRONG
#-----------------------------
use IPC::Open2;
use IO::Handle;

($reader, $writer) = (IO::Handle->new, IO::Handle->new);
open2($reader, $writer, $program);
#-----------------------------
eval {
    open2($readme, $writeme, @program_and_arguments);
};
if ($@) { 
    if ($@ =~ /^open2/) {
        warn "open2 failed: $!\n$@\n";
        return;
    }
    die;            # reraise unforeseen exception
}
#-----------------------------

#-----------------------------
@all = `($cmd | sed -e 's/^/stdout: /' ) 2>&1`;
for (@all) { push @{ s/stdout: // ? \@outlines : \@errlines }, $_ }
print "STDOUT:\n", @outlines, "\n";
print "STDERR:\n", @errlines, "\n";
#-----------------------------
open3(*WRITEHANDLE, *READHANDLE, *ERRHANDLE, "program to run");
#-----------------------------
use IPC::Open3;
$pid = open3(*HIS_IN, *HIS_OUT, *HIS_ERR, $cmd);
close(HIS_IN);  # give end of file to kid, or feed him
@outlines = <HIS_OUT>;              # read till EOF
@errlines = <HIS_ERR>;              # XXX: block potential if massive
print "STDOUT:\n", @outlines, "\n";
print "STDERR:\n", @errlines, "\n";
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# cmd3sel - control all three of kids in, out, and error.
use IPC::Open3;
use IO::Select;

$cmd = "grep vt33 /none/such - /etc/termcap";
$pid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $cmd);

$SIG{CHLD} = sub {
    print "REAPER: status $? on $pid\n" if waitpid($pid, 0) > 0
};

print CMD_IN "This line has a vt33 lurking in it\n";
close(CMD_IN);

$selector = IO::Select->new();
$selector->add(*CMD_ERR, *CMD_OUT);

while (@ready = $selector->can_read) {
    foreach $fh (@ready) {
        if (fileno($fh) == fileno(CMD_ERR)) {print "STDERR: ", scalar <CMD_ERR>}
        else                                {print "STDOUT: ", scalar <CMD_OUT>}
        $selector->remove($fh) if eof($fh);
    }
}

close(CMD_CUT);
close(CMD_ERR);

#-----------------------------

#-----------------------------
pipe(READER, WRITER);
if (fork) {
    # run parent code, either reading or writing, not both
} else {
    # run child code, either reading or writing, not both
}
#-----------------------------
if ($pid = open(CHILD, "|-")) {
        # run parent code, writing to child
} else {
    die "cannot fork: $!" unless defined $pid;
    # otherwise run child code here, reading from parent
}
#-----------------------------
if ($pid = open(CHILD, "-|")) {
    # run parent code, reading from child
} else {
    die "cannot fork: $!" unless defined $pid;
    # otherwise run child code here, writing to parent
}
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# pipe1 - use pipe and fork so parent can send to child

use IO::Handle;
pipe(READER, WRITER);
WRITER->autoflush(1);

if ($pid = fork) {
    close READER;
    print WRITER "Parent Pid $$ is sending this\n";
    close WRITER;
    waitpid($pid,0);
} else {
    die "cannot fork: $!" unless defined $pid;
    close WRITER;
    chomp($line = <READER>);
    print "Child Pid $$ just read this: `$line'\n";
    close READER;  # this will happen anyway
    exit;
}

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# pipe2 - use pipe and fork so child can send to parent

use IO::Handle;
pipe(READER, WRITER);
WRITER->autoflush(1);

if ($pid = fork) {
    close WRITER;
    chomp($line = <READER>);
    print "Parent Pid $$ just read this: `$line'\n";
    close READER;
    waitpid($pid,0);
} else {
    die "cannot fork: $!" unless defined $pid;
    close READER;
    print WRITER "Child Pid $$ is sending this\n";
    close WRITER;  # this will happen anyway
    exit;
}

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# pipe3 - use forking open so parent can send to child

use IO::Handle;
if ($pid = open(CHILD, "|-")) {
    CHILD->autoflush(1);
    print CHILD "Parent Pid $$ is sending this\n";
    close(CHILD);
} else {
    die "cannot fork: $!" unless defined $pid;
    chomp($line = <STDIN>);
    print "Child Pid $$ just read this: `$line'\n";
    exit;
}

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# pipe4 - use forking open so child can send to parent

use IO::Handle;
if ($pid = open(CHILD, "-|")) {
    chomp($line = <CHILD>);
    print "Parent Pid $$ just read this: `$line'\n";
    close(CHILD);
} else {
    die "cannot fork: $!" unless defined $pid;
    STDOUT->autoflush(1);
    print STDOUT "Child Pid $$ is sending this\n";
    exit;
}

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# pipe5 - bidirectional communication using two pipe pairs
#         designed for the socketpair-challenged
use IO::Handle;
pipe(PARENT_RDR, CHILD_WTR);
pipe(CHILD_RDR,  PARENT_WTR);
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;
}

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# pipe6 - bidirectional communication using socketpair
#   "the best ones always go both ways"

use Socket;
use IO::Handle;
# 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: $!";

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

#-----------------------------
socketpair(READER, WRITER, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
shutdown(READER, 1);        # no more writing for reader
shutdown(WRITER, 0);        # no more reading for writer
#-----------------------------

#-----------------------------
#% mkfifo /path/to/named.pipe
#-----------------------------
open(FIFO, "< /path/to/named.pipe")         or die $!;
while (<FIFO>) {
    print "Got: $_";
}
close(FIFO);
#-----------------------------
open(FIFO, "> /path/to/named.pipe")         or die $!;
print FIFO "Smoke this.\n";
close(FIFO);
#-----------------------------
#% mkfifo ~/.plan                    # isn't this everywhere yet?
#% mknod  ~/.plan p                  # in case you don't have mkfifo
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# dateplan - place current date and time in .plan file
while (1) {
    open(FIFO, "> $ENV{HOME}/.plan")
        or die "Couldn't open $ENV{HOME}/.plan for writing: $!\n";
    print FIFO "The current time is ", scalar(localtime), "\n";
    close FIFO;
    sleep 1;
}

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# fifolog - read and record log msgs from fifo

use IO::File;

$SIG{ALRM} = sub { close(FIFO) };   # move on to the next queued process

while (1) {
    alarm(0);                       # turn off alarm for blocking open
    open(FIFO, "< /tmp/log")        or die "Can't open /tmp/log : $!\n";
    alarm(1);                       # you have 1 second to log

    $service = <FIFO>;
    next unless defined $service;   # interrupted or nothing logged
    chomp $service;

    $message = <FIFO>;
    next unless defined $message;   # interrupted or nothing logged
    chomp $message;

    alarm(0);                       # turn off alarms for message processing

    if ($service eq "http") {
        # ignoring
    } elsif ($service eq "login") {
        # log to /var/log/login
        if ( open(LOG, ">> /tmp/login") ) {
            print LOG scalar(localtime), " $service $message\n";
            close(LOG);
        } else {
            warn "Couldn't log $service $message to /var/log/login : $!\n";
        }
    }
}

#-----------------------------
use POSIX qw(:errno_h);

$SIG{PIPE} = 'IGNORE';
# ...
$status = print FIFO "Are you there?\n";
if (!$status && $! == EPIPE) {
    warn "My reader has forsaken me!\n";
    next;
}
#-----------------------------
use POSIX;
print _POSIX_PIPE_BUF, "\n";
#-----------------------------

#-----------------------------
# download the following standalone program
#!/usr/bin/perl 
# sharetest - test shared variables across forks
use IPC::Shareable;

$handle = tie $buffer, 'IPC::Shareable', undef, { destroy => 1 };
$SIG{INT} = sub { die "$$ dying\n" };

for (1 .. 10) { 
    unless ($child = fork) {        # i'm the child
        die "cannot fork: $!" unless defined $child;
        squabble();
        exit;
    } 
    push @kids, $child;  # in case we care about their pids
}

while (1) {
    print "Buffer is $buffer\n";
    sleep 1;
} 
die "Not reached";

sub squabble {
    my $i = 0;
    while (1) { 
        next if $buffer =~ /^$$\b/o;  
        $handle->shlock();
        $i++;
        $buffer = "$$ $i";
        $handle->shunlock();
    }
} 

#-----------------------------

#-----------------------------
#% kill -l
#HUP INT QUIT ILL TRAP ABRT BUS FPE KILL USR1 SEGV USR2 PIPE 
#
#ALRM TERM CHLD CONT STOP TSTP TTIN TTOU URG XCPU XFSZ VTALRM 
#
#PROF WINCH POLL PWR
#-----------------------------
#% perl -e 'print join(" ", keys %SIG), "\n"'
#XCPU ILL QUIT STOP EMT ABRT BUS USR1 XFSZ TSTP INT IOT USR2 INFO TTOU
#
#ALRM KILL HUP URG PIPE CONT SEGV VTALRM PROF TRAP IO TERM WINCH CHLD
#
#FPE TTIN SYS
#-----------------------------
#% perl -MConfig -e 'print $Config{sig_name}'
#ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM
#
#TERM URG STOP TSTP CONT CHLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH
#
#INFO USR1 USR2 IOT
#-----------------------------
use Config;
defined $Config{sig_name} or die "No sigs?";
$i = 0;                     # Config prepends fake 0 signal called "ZERO".
foreach $name (split(' ', $Config{sig_name})) {
    $signo{$name} = $i;
    $signame[$i] = $name;
    $i++;
}
#-----------------------------

#-----------------------------
kill  9     => $pid;                    # send $pid a signal 9
kill -1     => $pgrp;                   # send whole job a signal 1
kill  USR1  => $$;                      # send myself a SIGUSR1
kill  HUP   => @pids;                   # send a SIGHUP to processes in @pids
#-----------------------------
use POSIX qw(:errno_h);

if (kill 0 => $minion) {
    print "$minion is alive!\n";
} elsif ($! == EPERM) {             # changed uid
    print "$minion has escaped my control!\n";
} elsif ($! == ESRCH) {
    print "$minion is deceased.\n";  # or zombied
} else {
    warn "Odd; I couldn't check on the status of $minion: $!\n";
}
#-----------------------------

#-----------------------------
$SIG{QUIT} = \&got_sig_quit;     # call &got_sig_quit for every SIGQUIT 
$SIG{PIPE} = 'got_sig_pipe';     # call main::got_sig_pipe for every SIGPIPE 
$SIG{INT}  = sub { $ouch++ };    # increment $ouch for every SIGINT
#-----------------------------
$SIG{INT} = 'IGNORE';            # ignore the signal INT
#-----------------------------
$SIG{STOP} = 'DEFAULT';          # restore default STOP signal handling
#-----------------------------

#-----------------------------
# the signal handler
sub ding {
    $SIG{INT} = \&ding;
    warn "\aEnter your name!\n";
}

# prompt for name, overriding SIGINT
sub get_name {
    local $SIG{INT} = \&ding;
    my $name;

    print "Kindly Stranger, please enter your name: ";
    chomp( $name = <> );
    return $name;
}
#-----------------------------

#-----------------------------
$SIG{INT} = \&got_int;
sub got_int {
    $SIG{INT} = \&got_int;          # but not for SIGCHLD!
    # ...
}
#-----------------------------
my $interrupted = 0;

sub got_int {
    $interrupted = 1;
    $SIG{INT} = 'DEFAULT';          # or 'IGNORE'
    die;
}

eval {
    $SIG{INT} = \&got_int;
    # ... long-running code that you don't want to restart
};

if ($interrupted) {
    # deal with the signal
}
#-----------------------------
$SIG{INT} = \&catcher;
sub catcher {
    $SIG{INT} = \&catcher;
    # ...
}
#-----------------------------
use Config;
print "Hurrah!\n" if $Config{d_sigaction};
#-----------------------------
#% egrep 'S[AV]_(RESTART|INTERRUPT)' /usr/include/*/signal.h
#-----------------------------

#-----------------------------
$SIG{INT} = 'IGNORE';
#-----------------------------
$SIG{INT} = \&tsktsk;

sub tsktsk {
    $SIG{INT} = \&tsktsk;           # See ``Writing A Signal Handler''
    warn "\aThe long habit of living indisposeth us for dying.\n";
}
#-----------------------------
#% stty -a
#speed 9600 baud; 38 rows; 80 columns;
#
#lflags: icanon isig iexten echo echoe -echok echoke -echonl echoctl
#
#	-echoprt -altwerase -noflsh -tostop -flusho pendin -nokerninfo
#
#	-extproc
#
#iflags: -istrip icrnl -inlcr -igncr ixon -ixoff ixany imaxbel -ignbrk
#
#	 brkint -inpck -ignpar -parmrk
#
#oflags: opost onlcr oxtabs
#
#cflags: cread cs8 -parenb -parodd hupcl -clocal -cstopb -crtscts -dsrflow
#
#	 -dtrflow -mdmbuf
#
#cchars: discard = ^O; dsusp = ^Y; eof = ^D; eol = <undef;>
#
#	 eol2 = <undef; erase = ^H; intr = ^C; kill = ^U; lnext = ^V;>
#
#	 min = 1; quit = ^\; reprint = ^R; start = ^Q; status = <undef;>
#
#	 stop = ^S; susp = ^Z; time = 0; werase = ^W;
#-----------------------------

#-----------------------------
$SIG{CHLD} = 'IGNORE';
#-----------------------------
use POSIX ":sys_wait_h";

$SIG{CHLD} = \&REAPER;
sub REAPER {
    my $stiff;
    while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
        # do something with $stiff if you want
    }
    $SIG{CHLD} = \&REAPER;                  # install *after* calling waitpid
}
#-----------------------------
$exit_value  = $? >> 8;
$signal_num  = $? & 127;
$dumped_core = $? & 128;
#-----------------------------
use POSIX qw(:signal_h :errno_h :sys_wait_h);

$SIG{CHLD} = \&REAPER;
sub REAPER {
    my $pid;

    $pid = waitpid(-1, &WNOHANG);

    if ($pid == -1) {
        # no child waiting.  Ignore it.
    } elsif (WIFEXITED($?)) {
        print "Process $pid exited.\n";
    } else {
        print "False alarm on $pid.\n";
    }
    $SIG{CHLD} = \&REAPER;          # in case of unreliable signals
}
#-----------------------------
use Config;
$has_nonblocking = $Config{d_waitpid} eq "define" ||
                   $Config{d_wait4}   eq "define";
#-----------------------------

#-----------------------------
use POSIX qw(:signal_h);

$sigset = POSIX::SigSet->new(SIGINT);    # define the signals to block
$old_sigset = POSIX::SigSet->new;        # where the old sigmask will be kept

unless (defined sigprocmask(SIG_BLOCK, $sigset, $old_sigset)) {
    die "Could not block SIGINT\n";
}
#-----------------------------
unless (defined sigprocmask(SIG_UNBLOCK, $old_sigset)) {
    die "Could not unblock SIGINT\n";
}
#-----------------------------
use POSIX qw(:signal_h);

$sigset = POSIX::SigSet->new( SIGINT, SIGKILL );
#-----------------------------

#-----------------------------
$SIG{ALRM} = sub { die "timeout" };

eval {
    alarm(3600);
    # long-time operations here
    alarm(0);
};

if ($@) {
    if ($@ =~ /timeout/) {
                            # timed out; do what you will here
    } else {
        alarm(0);           # clear the still-pending alarm
        die;                # propagate unexpected exception
    } 
} 
#-----------------------------

#-----------------------------
#Make is like Pascal: everybody likes it, so they go in and change it.
#					     --Dennis Ritchie
#%%
#I eschew embedded capital letters in names; to my prose-oriented eyes,
#they are too awkward to read comfortably. They jangle like bad typography.
#					     --Rob Pike
#%%
#God made the integers; all else is the work of Man.  
#					     --Kronecker
#%%
#I'd rather have :rofix than const.          --Dennis Ritchie
#%%
#If you want to program in C, program in C.  It's a nice language.
#I use it occasionally...   :-)              --Larry Wall
#%%
#Twisted cleverness is my only skill as a programmer.       
#					     --Elizabeth Zwicky
#%%
#Basically, avoid comments. If your code needs a comment to be understood,
#it would be better to rewrite it so it's easier to understand.  
#					     --Rob Pike
#%%
#Comments on data are usually much more helpful than on algorithms.  
#					     --Rob Pike
#%% 
#Programs that write programs are the happiest programs in the world.
#					     --Andrew Hume 
#%%
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# sigrand - supply random fortunes for .signature file

use strict;

# config section variables
use vars qw( $NG_IS_DIR $MKNOD $FULLNAME $FIFO $ART $NEWS $SIGS $SEMA
    	        $GLOBRAND $NAME );

# globals
use vars qw( $Home $Fortune_Path @Pwd );

################################################################
# begin configuration section 
# should really read from ~/.sigrandrc

gethome();

# for rec/humor/funny instead of rec.humor.funny
$NG_IS_DIR      = 1;    

$MKNOD          = "/bin/mknod";
$FULLNAME       = "$Home/.fullname";
$FIFO           = "$Home/.signature";
$ART            = "$Home/.article";
$NEWS           = "$Home/News";
$SIGS           = "$NEWS/SIGNATURES";
$SEMA           = "$Home/.sigrandpid";
$GLOBRAND       = 1/4;  # chance to use global sigs anyway

# $NAME should be (1) left undef to have program guess
# read address for signature maybe looking in ~/.fullname,
# (2) set to an exact address, or (3) set to empty string
# to be omitted entirely.

$NAME           = '';           # means no name used
## $NAME        = "me\@home.org\n";     

# end configuration section -- HOME and FORTUNE get autoconf'd
################################################################

setup();                # pull in inits
justme();               # make sure program not already running
fork && exit;           # background ourself and go away

open (SEMA, "> $SEMA")      	or die "can't write $SEMA: $!";
print SEMA "$$\n";
close(SEMA)                 	or die "can't close $SEMA: $!";

# now loop forever, writing a signature into the 
# fifo file.  if you don't have real fifos, change
# sleep time at bottom of loop to like 10 to update
# only every 10 seconds.
for (;;) {
    open (FIFO, "> $FIFO")		or die "can't write $FIFO: $!";
    my $sig = pick_quote();
    for ($sig) { 
        s/^((:?[^\n]*\n){4}).*$/$1/s;   # trunc to 4 lines
        s/^(.{1,80}).*? *$/$1/gm;       # trunc long lines
    }
    # print sig, with name if present, padded to four lines
    if ($NAME) { 
        print FIFO $NAME, "\n" x (3 - ($sig =~ tr/\n//)), $sig;
    } else {
        print FIFO $sig;
    }
    close FIFO;

    # Without a microsleep, the reading process doesn't finish before
    # the writer tries to open it again, which since the reader exists,
    # succeeds.  They end up with multiple signatures.  Sleep a tiny bit
    # between opens to give readers a chance to finish reading and close
    # our pipe so we can block when opening it the next time.

    select(undef, undef, undef, 0.2);   # sleep 1/5 second
}
die "XXX: NOT REACHED";         # you can't get here from anywhere

################################################################

# Ignore SIGPIPE in case someone opens us up and then closes the fifo
# without reading it; look in a .fullname file for their login name.
# Try to determine the fully qualified hostname.  Look our for silly
# ampersands in passwd entries.  Make sure we have signatures or fortunes.
# Build a fifo if we need to.

sub setup {
    $SIG{PIPE} = 'IGNORE';              

    unless (defined $NAME) {            # if $NAME undef in config
        if (-e $FULLNAME) {
    	        $NAME = `cat $FULLNAME`;
    	        die "$FULLNAME should contain only 1 line, aborting" 
    	            if $NAME =~ tr/\n// > 1;
        } else {
    	        my($user, $host);
    	        chop($host = `hostname`);
    	        ($host) = gethostbyname($host) unless $host =~ /\./;
    	        $user = $ENV{USER} || $ENV{LOGNAME} || $Pwd[0]
    	            or die "intruder alert";
    	        ($NAME = $Pwd[6]) =~ s/,.*//;
    	        $NAME =~ s/&/\u\L$user/g; # can't believe some folks still do this
    	        $NAME = "\t$NAME\t$user\@$host\n";
        } 
    }

    check_fortunes() if !-e $SIGS;

    unless (-p $FIFO) {         # -p checks whether it's a named pipe
        if (!-e _) {
    	         system("$MKNOD $FIFO p") && die "can't mknod $FIFO";
    	         warn "created $FIFO as a named pipe\n";
        } else {
    	         die "$0: won't overwrite file .signature\n";
        } 
    } else {
        warn "$0: using existing named pipe $FIFO\n";
    } 

    # get a good random number seed.  not needed if 5.004 or better.
    srand(time() ^ ($$ + ($$ << 15)));
}

# choose a random signature
sub pick_quote {
    my $sigfile = signame();
    if (!-e $sigfile) {
        return fortune();
    } 
    open (SIGS, "< $sigfile" )		or die "can't open $sigfile";
    local $/  = "%%\n";
    local $_;
    my $quip;
    rand($.) < 1 && ($quip = $_) while <SIGS>;
    close SIGS;
    chomp $quip;
    return $quip || "ENOSIG: This signature file is empty.\n";
} 

# See whether ~/.article contains a Newsgroups line.  if so, see the first
# group posted to and find out whether it has a dedicated set of fortunes.
# otherwise return the global one.  also, return the global one randomly
# now and then to spice up the sigs.
sub signame {
     (rand(1.0) > ($GLOBRAND) && open ART) || return $SIGS;   
     local $/  = '';
     local $_  = <ART>;
     my($ng)   = /Newsgroups:\s*([^,\s]*)/;
     $ng =~ s!\.!/!g if $NG_IS_DIR;     # if rn -/,  or SAVEDIR=%p/%c
     $ng = "$NEWS/$ng/SIGNATURES";
     return -f $ng ? $ng : $SIGS;
} 

# Call the fortune program with -s for short flag until
# we get a small enough fortune or ask too much.
sub fortune {
   local $_;
   my $tries = 0;
   do { 
       $_ = `$Fortune_Path -s`; 
   } until tr/\n// < 5 || $tries++ > 20;
   s/^/ /mg;
   $_ || " SIGRAND: deliver random signals to all processes.\n";
} 

# Make sure there's a fortune program.  Search 
# for its full path and set global to that.
sub check_fortunes {
    return if $Fortune_Path;    # already set
    for my $dir (split(/:/, $ENV{PATH}), '/usr/games') {
        return if -x ($Fortune_Path = "$dir/fortune");
    } 
    die "Need either $SIGS or a fortune program, bailing out";
} 

# figure out our directory
sub gethome {
    @Pwd = getpwuid($<);
    $Home = $ENV{HOME} || $ENV{LOGDIR} || $Pwd[7]
    		   or die "no home directory for user $<";
}

# "There can be only one."  --the Highlander
sub justme {
    if (open SEMA) {
        my $pid;
        chop($pid = <SEMA>);
        kill(0, $pid)		and die "$0 already running (pid $pid), bailing out";
        close SEMA;
    } 
} 

#-----------------------------