|
|
Perl/FAQ/Управление и взаимодействие с процессами
Материал из Wiki.crossplatform.ru
[править] 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($<);
$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;
}
}
#-----------------------------
|
