PLEAC-Perl 教程 - Process Management (Perl进阶者极力推荐)

16. Process Management and Communication

<script type="text/javascript"> </script> <script type="text/javascript" src="http://ads.shoppingads.com/pagead/show_sa_ads.js"> </script>

Gathering Output from a Program

#----------------------------- $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); #-----------------------------

Running Another Program

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

Replacing the Current Program with a Different One

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

Reading or Writing to Another Program

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

Filtering Your Own Output

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

Preprocessing Input

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

Reading STDERR from a Program

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

Controlling Input and Output of Another Program

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

Controlling the Input, Output, and Error of Another Program

#----------------------------- @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); #-----------------------------

Communicating Between Related Processes

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

Making a Process Look Like a File with Named Pipes

#----------------------------- #% 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"; #-----------------------------

Sharing Variables in Different Processes

#----------------------------- # 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(); } } #-----------------------------

Listing Available Signals

#----------------------------- #% 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++; } #-----------------------------

Sending a Signal

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

Installing a Signal Handler

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

Temporarily Overriding a Signal Handler

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

Writing a Signal Handler

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

Catching Ctrl-C

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

Avoiding Zombie Processes

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

Blocking Signals

#----------------------------- 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 ); #-----------------------------

Timing Out an Operation

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

Program: sigrand

#----------------------------- #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(___FCKpd___21lt;); $Home = $ENV{HOME} || $ENV{LOGDIR} || $Pwd[7] or die "no home directory for user ___FCKpd___21lt;"; } # "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; } } #-----------------------------