/inc/Proc/Simple.pm
Perl | 496 lines | 218 code | 102 blank | 176 comment | 36 complexity | d519d188b218e9114f2a89288d92ac20 MD5 | raw file
- #line 1
- ######################################################################
- package Proc::Simple;
- ######################################################################
- # Copyright 1996-2001 by Michael Schilli, all rights reserved.
- #
- # This program is free software, you can redistribute it and/or
- # modify it under the same terms as Perl itself.
- #
- # The newest version of this module is available on
- # http://perlmeister.com/devel
- # or on your favourite CPAN site under
- # CPAN/modules/by-author/id/MSCHILLI
- #
- ######################################################################
- #line 108
- require 5.003;
- use strict;
- use vars qw($VERSION %EXIT_STATUS %INTERVAL
- %DESTROYED);
- use POSIX;
- use IO::Handle;
- $VERSION = '1.31';
- ######################################################################
- # Globals: Debug and the mysterious waitpid nohang constant.
- ######################################################################
- my $Debug = 0;
- my $WNOHANG = get_system_nohang();
- ######################################################################
- #line 146
- ######################################################################
- # $proc_obj=Proc::Simple->new(); - Constructor
- ######################################################################
- sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = {};
-
- # Init instance variables
- $self->{'kill_on_destroy'} = undef;
- $self->{'signal_on_destroy'} = undef;
- $self->{'pid'} = undef;
- $self->{'redirect_stdout'} = undef;
- $self->{'redirect_stderr'} = undef;
- bless($self, $class);
- }
- ######################################################################
- #line 226
- ######################################################################
- # $ret = $proc_obj->start("prg"); - Launch process
- ######################################################################
- sub start {
- my $self = shift;
- my ($func, @params) = @_;
- # Reap Zombies automatically
- $SIG{'CHLD'} = \&THE_REAPER;
- # Fork a child process
- $self->{'pid'} = fork();
- return 0 unless defined $self->{'pid'}; # return Error if fork failed
- if($self->{pid} == 0) { # Child
- # Mark it as process group leader, so that we can kill
- # the process group later. Note that there's a race condition
- # here because there's a window in time (while you're reading
- # this comment) between child startup and its new process group
- # id being defined. This means that killpg() to the child during
- # this time frame will fail. Proc::Simple's kill() method deals l
- # with it, see comments there.
- POSIX::setsid();
- $self->dprt("setsid called ($$)");
- if (defined $self->{'redirect_stderr'}) {
- $self->dprt("STDERR -> $self->{'redirect_stderr'}");
- open(STDERR, ">$self->{'redirect_stderr'}") ;
- autoflush STDERR 1 ;
- }
- if (defined $self->{'redirect_stdout'}) {
- $self->dprt("STDOUT -> $self->{'redirect_stdout'}");
- open(STDOUT, ">$self->{'redirect_stdout'}") ;
- autoflush STDOUT 1 ;
- }
- if(ref($func) eq "CODE") {
- $self->dprt("Launching code");
- $func->(@params); exit 0; # Start perl subroutine
- } else {
- $self->dprt("Launching $func @params");
- exec $func, @params; # Start shell process
- exit 0; # In case something goes wrong
- }
- } elsif($self->{'pid'} > 0) { # Parent:
- $INTERVAL{$self->{'pid'}}{'t0'} = time();
- $self->dprt("START($self->{'pid'})");
- # Register PID
- $EXIT_STATUS{$self->{'pid'}} = undef;
- $INTERVAL{$self->{'pid'}}{'t1'} = undef;
- return 1; # return OK
- } else {
- return 0; # this shouldn't occur
- }
- }
- ######################################################################
- #line 295
- ######################################################################
- # $ret = $proc_obj->poll(); - Check process status
- # 1="running" 0="not running"
- ######################################################################
- sub poll {
- my $self = shift;
- $self->dprt("Polling");
- # There's some weirdness going on with the signal handler.
- # It runs into timing problems, so let's have poll() call
- # the REAPER every time to make sure we're getting rid of
- # defuncts.
- $self->THE_REAPER();
- if(defined($self->{pid})) {
- if(CORE::kill(0, $self->{pid})) {
- $self->dprt("POLL($self->{pid}) RESPONDING");
- return 1;
- } else {
- $self->dprt("POLL($self->{pid}) NOT RESPONDING");
- }
- } else {
- $self->dprt("POLL(NOT DEFINED)");
- }
- 0;
- }
- ######################################################################
- #line 342
- ######################################################################
- # $ret = $proc_obj->kill([SIGXXX]); - Send signal to process
- # Default-Signal: SIGTERM
- ######################################################################
- sub kill {
- my $self = shift;
- my $sig = shift;
- # If no signal specified => SIGTERM-Signal
- $sig = POSIX::SIGTERM() unless defined $sig;
- # Use numeric signal if we get a string
- if( $sig !~ /^[-\d]+$/ ) {
- $sig =~ s/^SIG//g;
- $sig = eval "POSIX::SIG${sig}()";
- }
- # Process initialized at all?
- if( !defined $self->{'pid'} ) {
- $self->dprt("No pid set");
- return 0;
- }
- # Send signal
- if(CORE::kill($sig, $self->{'pid'})) {
- $self->dprt("KILL($sig, $self->{'pid'}) OK");
- # now kill process group of process to make sure that shell
- # processes containing shell characters, which get launched via
- # "sh -c" are killed along with their launching shells.
- # This might fail because of the race condition explained in
- # start(), so we ignore the outcome.
- CORE::kill(-$sig, $self->{'pid'});
- } else {
- $self->dprt("KILL($sig, $self->{'pid'}) failed ($!)");
- return 0;
- }
- 1;
- }
- ######################################################################
- #line 398
- ######################################################################
- # Method to set the kill_on_destroy flag
- ######################################################################
- sub kill_on_destroy {
- my $self = shift;
- if (@_) { $self->{kill_on_destroy} = shift; }
- return $self->{kill_on_destroy};
- }
- ######################################################################
- #line 420
- ######################################################################
- # Send a signal on destroy
- # undef means send the default signal (SIGTERM)
- ######################################################################
- sub signal_on_destroy {
- my $self = shift;
- if (@_) { $self->{signal_on_destroy} = shift; }
- return $self->{signal_on_destroy};
- }
- ######################################################################
- #line 450
- ######################################################################
- sub redirect_output {
- ######################################################################
- my $self = shift ;
- ($self->{'redirect_stdout'}, $self->{'redirect_stderr'}) = @_ ;
- 1 ;
- }
- ######################################################################
- #line 471
- ######################################################################
- sub pid {
- ######################################################################
- my $self = shift;
- # Allow the pid to be set - assume this is only
- # done internally so don't document this behaviour in the
- # pod.
- if (@_) { $self->{'pid'} = shift; }
- return $self->{'pid'};
- }
- ######################################################################
- #line 494
- ######################################################################
- sub t0 {
- ######################################################################
- my $self = shift;
- return $INTERVAL{$self->{'pid'}}{'t0'};
- }
- ######################################################################
- #line 513
- ######################################################################
- sub t1 {
- ######################################################################
- my $self = shift;
- return $INTERVAL{$self->{'pid'}}{'t1'};
- }
- #line 531
- ######################################################################
- # Destroy method
- # This is run automatically on undef
- # Should probably not bother if a poll shows that the process is not
- # running.
- ######################################################################
- sub DESTROY {
- my $self = shift;
- # Localize special variables so that the exit status from waitpid
- # doesn't leak out, causing exit status to be incorrect.
- local( $., $@, $!, $^E, $? );
- # Processes never started don't have to be cleaned up in
- # any special way.
- return unless $self->pid();
- # If the kill_on_destroy flag is true then
- # We need to send a signal to the process
- if ($self->kill_on_destroy) {
- $self->dprt("Kill on DESTROY");
- if (defined $self->signal_on_destroy) {
- $self->kill($self->signal_on_destroy);
- } else {
- $self->dprt("Sending KILL");
- $self->kill;
- }
- }
- delete $EXIT_STATUS{ $self->pid };
- if( $self->poll() ) {
- $DESTROYED{ $self->pid } = 1;
- }
- }
- ######################################################################
- #line 574
- ######################################################################
- # returns the exit status of the child process, undef if the child
- # hasn't yet exited
- ######################################################################
- sub exit_status{
- my( $self ) = @_;
- return $EXIT_STATUS{ $self->pid };
- }
- ######################################################################
- #line 595
- ######################################################################
- # waits until the child process terminates and then
- # returns the exit status of the child process.
- ######################################################################
- sub wait {
- my $self = shift;
- local $SIG{CHLD}; # disable until we're done
- my $pid = $self->pid();
- # test if the signal handler reap'd this pid some time earlier or even just
- # a split second before localizing $SIG{CHLD} above; also kickout if
- # they've wait'd or waitpid'd on this pid before ...
- return $EXIT_STATUS{$pid} if defined $EXIT_STATUS{$pid};
- # all systems support FLAGS==0 (accg to: perldoc -f waitpid)
- my $res = waitpid $pid, 0;
- my $rc = $?;
- $INTERVAL{$pid}{'t1'} = time();
- $EXIT_STATUS{$pid} = $rc;
- dprt("", "For $pid, reaped '$res' with exit_status=$rc");
- return $rc;
- }
- ######################################################################
- # Reaps processes, uses the magic WNOHANG constant
- ######################################################################
- sub THE_REAPER {
- # Localize special variables so that the exit status from waitpid
- # doesn't leak out, causing exit status to be incorrect.
- local( $., $@, $!, $^E, $? );
- my $child;
- my $now = time();
- if(defined $WNOHANG) {
- # Try to reap every process we've ever started and
- # whichs Proc::Simple object hasn't been destroyed.
- #
- # This is getting really ugly. But if we just call the REAPER
- # for every SIG{CHLD} event, code like this will fail:
- #
- # use Proc::Simple;
- # $proc = Proc::Simple->new(); $proc->start(\&func); sleep(5);
- # sub func { open(PIPE, "/bin/ls |"); @a = <PIPE>; sleep(1);
- # close(PIPE) or die "PIPE failed"; }
- #
- # Reason: close() doesn't like it if the spawn has
- # been reaped already. Oh well.
- #
- # First, check if we can reap the processes which
- # went out of business because their kill_on_destroy
- # flag was set and their objects were destroyed.
- foreach my $pid (keys %DESTROYED) {
- if(my $res = waitpid($pid, $WNOHANG) > 0) {
- # We reaped a zombie
- delete $DESTROYED{$pid};
- dprt("", "Reaped: $pid");
- }
- }
-
- foreach my $pid (keys %EXIT_STATUS) {
- dprt("", "Trying to reap $pid");
- if( defined $EXIT_STATUS{$pid} ) {
- dprt("", "exit status of $pid is defined - not reaping");
- next;
- }
- if(my $res = waitpid($pid, $WNOHANG) > 0) {
- # We reaped a truly running process
- $EXIT_STATUS{$pid} = $?;
- $INTERVAL{$pid}{'t1'} = $now;
- dprt("", "Reaped: $pid");
- } else {
- dprt("", "waitpid returned '$res'");
- }
- }
- } else {
- # If we don't have $WNOHANG, we don't have a choice anyway.
- # Just reap everything.
- dprt("", "reap everything for lack of WNOHANG");
- $child = CORE::wait();
- $EXIT_STATUS{$child} = $?;
- $INTERVAL{$child}{'t1'} = $now;
- }
- # Don't reset signal handler for crappy sysV systems. Screw them.
- # This caused problems with Irix 6.2
- # $SIG{'CHLD'} = \&THE_REAPER;
- }
- ######################################################################
- #line 700
- # Proc::Simple::debug($level) - Turn debug on/off
- sub debug { $Debug = shift; }
- ######################################################################
- #line 715
- sub cleanup {
- for my $pid ( keys %INTERVAL ) {
- if( !exists $DESTROYED{ $pid } ) {
- # process has been reaped already, safe to delete
- # its start/stop time
- delete $INTERVAL{ $pid };
- }
- }
- }
- ######################################################################
- # Internal debug print function
- ######################################################################
- sub dprt {
- my $self = shift;
- if($Debug) {
- require Time::HiRes;
- my ($seconds, $microseconds) = Time::HiRes::gettimeofday();
- print "[$seconds.$microseconds] ", ref($self), "> @_\n";
- }
- }
- ######################################################################
- sub get_system_nohang {
- ######################################################################
- # This is for getting the WNOHANG constant of the system -- but since
- # the waitpid(-1, &WNOHANG) isn't supported on all Unix systems, and
- # we still want Proc::Simple to run on every system, we have to
- # quietly perform some tests to figure out if -- or if not.
- # The function returns the constant, or undef if it's not available.
- ######################################################################
- my $nohang;
- open(SAVEERR, ">&STDERR");
- # If the system doesn't even know /dev/null, forget about it.
- open(STDERR, ">/dev/null") || return undef;
- # Close stderr, since some weirdo POSIX modules write nasty
- # error messages
- close(STDERR);
- # Check for the constant
- eval 'use POSIX ":sys_wait_h"; $nohang = &WNOHANG;';
- # Re-open STDERR
- open(STDERR, ">&SAVEERR");
- close(SAVEERR);
- # If there was an error, return undef
- return undef if $@;
- return $nohang;
- }
- 1;
- __END__