File Coverage

blib/lib/Proc/Background.pm

Criterion	Covered	Total	%
statement	123	150	82.0
branch	67	114	58.7
condition	19	52	36.5
subroutine	22	28	78.5
pod	16	17	94.1
total	247	361	68.4

package Proc::Background;
$Proc::Background::VERSION = '1.31';
# ABSTRACT: Generic interface to Unix and Win32 background process management
require 5.004_04;

use strict;
use Exporter;
use Carp;
use Cwd;
use Scalar::Util;
@Proc::Background::ISA       = qw(Exporter);
@Proc::Background::EXPORT_OK = qw(timeout_system);

# Determine if the operating system is Windows.
my $is_windows = $^O eq 'MSWin32';
my $weaken_subref = Scalar::Util->can('weaken');

# Set up a regular expression that tests if the path is absolute and
# if it has a directory separator in it.  Also create a list of file
# extensions of append to the programs name to look for the real
# executable.
my $is_absolute_re;
my $has_dir_element_re;
my $path_sep;
my @extensions = ('');
if ($is_windows) {
  $is_absolute_re     = '^(?:(?:[a-zA-Z]:[\\\\/])|(?:[\\\\/]{2}\w+[\\\\/]))';
  $has_dir_element_re = "[\\\\/]";
  $path_sep           = "\\";
  push(@extensions, '.exe');
} else {
  $is_absolute_re     = "^/";
  $has_dir_element_re = "/";
  $path_sep           = "/";
}

# Make this class a subclass of Proc::Win32 or Proc::Unix.  Any
# unresolved method calls will go to either of these classes.
if ($is_windows) {
  require Proc::Background::Win32;
  unshift(@Proc::Background::ISA, 'Proc::Background::Win32');
} else {
  require Proc::Background::Unix;
  unshift(@Proc::Background::ISA, 'Proc::Background::Unix');
}

# Take either a relative or absolute path to a command and make it an
# absolute path.
sub _resolve_path {
  my $command = shift;

  return ( undef, 'empty command string' ) unless length $command;

  # Make the path to the progam absolute if it isn't already.  If the
  # path is not absolute and if the path contains a directory element
  # separator, then only prepend the current working to it.  If the
  # path is not absolute, then look through the PATH environment to
  # find the executable.  In all cases, look for the programs with any
  # extensions added to the original path name.
  my $path;
  if ($command =~ /$is_absolute_re/o) {
    foreach my $ext (@extensions) {
      my $p = "$command$ext";
      if (-f $p and -x _) {
        $path = $p;
        last;
      }
    }
    return defined $path? ( $path, undef ) : ( undef, "no executable program located at $command" );
  } else {
    my $cwd = cwd;
    if ($command =~ /$has_dir_element_re/o) {
      my $p1 = "$cwd$path_sep$command";
      foreach my $ext (@extensions) {
        my $p2 = "$p1$ext";
        if (-f $p2 and -x _) {
          $path = $p2;
          last;
        }
      }
    } else {
      foreach my $dir (split($is_windows ? ';' : ':', $ENV{PATH})) {
        next unless length $dir;
        $dir = "$cwd$path_sep$dir" unless $dir =~ /$is_absolute_re/o;
        my $p1 = "$dir$path_sep$command";
        foreach my $ext (@extensions) {
          my $p2 = "$p1$ext";
          if (-f $p2 and -x _) {
            $path = $p2;
            last;
          }
        }
        last if defined $path;
      }
    }
    return defined $path? ( $path, undef ) : ( undef, "cannot find absolute location of $command" );
  }
}

# Define the set of allowed options, to warn about unknown ones.
# Make it a method so subclasses can override it.
%Proc::Background::_available_options= (
  autodie => 1, command => 1, exe => 1,
  cwd => 1, stdin => 1, stdout => 1, stderr => 1,
  autoterminate => 1, die_upon_destroy => 1,
);

sub _available_options {
  return \%Proc::Background::_available_options;
}

# We want the created object to live in Proc::Background instead of
# the OS specific class so that generic method calls can be used.
sub new {
  my $class = shift;

  # The parameters are an optional %options hashref followed by any number
  # of arguments to become the @argv for exec().  If options are given, check
  # the keys for typos.
  my $options;
  if (@_ and ref $_[0] eq 'HASH') {
    $options= shift;
    my $known= $class->_available_options;
    my @unknown= grep !$known->{$_}, keys %$options;
    carp "Unknown options: ".join(', ', @unknown)
      if @unknown;
  }
  else {
    $options= {};
  }

  my $self= bless {}, $class;
  $self->{_autodie}= 1 if $options->{autodie};

  # Resolve any confusion between the 'command' option and positional @argv params.
  # Store the command in $self->{_command} so that the ::Unix and ::Win32 don't have
  # to deal with it redundantly.
  my $cmd= $options->{command};
  if (defined $cmd) {
    croak "Can't use both 'command' option and command argument list"
      if @_;
    # Can be an arrayref or a single string
    croak "command must be a non-empty string or an arrayref of strings"
      unless (ref $cmd eq 'ARRAY' && defined $cmd->[0] && length $cmd->[0])
        or (!ref $cmd && defined $cmd && length $cmd);
  }
  else {
    # Back-compat: maintain original API quirks
    confess "Proc::Background::new called with insufficient number of arguments"
      unless @_;
    return $self->_fatal('command is undefined') unless defined $_[0];

    # Interpret the parameters as an @argv if there is more than one,
    # or if the 'exe' option was given.
    $cmd= (@_ > 1 || defined $options->{exe})? [ @_ ] : $_[0];
  }

  $self->{_command}= $cmd;
  $self->{_exe}= $options->{exe} if defined $options->{exe};

  # Also back-compat: failing to fork or CreateProcess returns undef
  return unless $self->_start($options);

  # Save the start time
  $self->{_start_time} = time;

  if ($options->{autoterminate} || $options->{die_upon_destroy}) {
    $self->autoterminate(1);
  }

  return $self;
}

# The original API returns undef from the constructor in case of various errors.
# The autodie option converts these undefs into exceptions.
sub _fatal {
  my ($self, $message)= @_;
  croak $message if $self->{_autodie};
  warn "$0: $message";
  return undef;
}

sub autoterminate {
  my ($self, $newval)= @_;
  if (@_ > 1 and ($newval xor $self->{_die_upon_destroy})) {
    if ($newval) {
      # Global destruction can break this feature, because there are no guarantees
      # on which order object destructors are called.  In order to avoid that, need
      # to run all the ->die methods during END{}, and that requires weak
      # references which weren't available until 5.8
      $weaken_subref->( $Proc::Background::_die_upon_destroy{$self+0}= $self )
        if $weaken_subref;
      # could warn about it for earlier perl... but has been broken for 15 years and
      # who is still using < 5.8 anyway?
    }
    else {
      delete $Proc::Background::_die_upon_destroy{$self+0};
    }
    $self->{_die_upon_destroy}= $newval? 1 : 0;
  }
  $self->{_die_upon_destroy} || 0
}

sub DESTROY {
  my $self = shift;
  if ($self->{_die_upon_destroy}) {
    # During a mainline exit() $? is the prospective exit code from the
    # parent program. Preserve it across any waitpid() in die()
    local $?;
    $self->terminate;
    delete $Proc::Background::_die_upon_destroy{$self+0};
  }
}

END {
  # Child processes need killed before global destruction, else the
  # Win32::Process objects might get destroyed first.
  for (grep defined, values %Proc::Background::_die_upon_destroy) {
    $_->terminate;
    delete $_->{_die_upon_destroy}
  }
  %Proc::Background::_die_upon_destroy= ();
}

# Reap the child.  If the first argument is false, then return immediately.
# Else, block waiting for the process to exit.  If no second argument is
# given, wait forever, else wait for that number of seconds.
# If the wait was sucessful, then delete
# $self->{_os_obj} and set $self->{_exit_value} to the OS specific
# class return of _reap.  Return 1 if we sucessfully waited, 0
# otherwise.
sub _reap {
  my ($self, $blocking, $wait_seconds) = @_;

  return 0 unless exists($self->{_os_obj});

  # Try to wait on the process.  Use the OS dependent wait call using
  # the Proc::Background::*::waitpid call, which returns one of three
  # values.
  #   (0, exit_value)	: sucessfully waited on.
  #   (1, undef)	: process already reaped and exit value lost.
  #   (2, undef)	: process still running.
  my ($result, $exit_value) = $self->_waitpid($blocking, $wait_seconds);
  if ($result == 0 or $result == 1) {
    $self->{_exit_value} = defined($exit_value) ? $exit_value : 0;
    delete $self->{_os_obj};
    # Save the end time of the class.
    $self->{_end_time} = time;
    return 1;
  }
  return 0;
}

sub alive {
  my $self = shift;

  # If $self->{_os_obj} is not set, then the process is definitely
  # not running.
  return 0 unless exists($self->{_os_obj});

  # If $self->{_exit_value} is set, then the process has already finished.
  return 0 if exists($self->{_exit_value});

  # Try to reap the child.  If it doesn't reap, then it's alive.
  !$self->_reap(0);
}

sub suspended {
  $_[0]->{_suspended}? 1 : 0
}

sub suspend {
  my $self= shift;
  return $self->_fatal("can't suspend, process has exited")
    if !$self->{_os_obj};
  $self->{_suspended} = 1 if $self->_suspend;
  return $self->{_suspended};
}

sub resume {
  my $self= shift;
  return $self->_fatal("can't resume, process has exited")
    if !$self->{_os_obj};
  $self->{_suspended} = 0 if $self->_resume;
  return !$self->{_suspended};
}

sub wait {
  my ($self, $timeout_seconds) = @_;

  # If $self->{_exit_value} exists, then we already waited.
  return $self->{_exit_value} if exists($self->{_exit_value});

  carp "calling ->wait on a suspended process" if $self->{_suspended};

  # If neither _os_obj or _exit_value are set, then something is wrong.
  return undef if !exists($self->{_os_obj});

  # Otherwise, wait for the process to finish.
  return $self->_reap(1, $timeout_seconds)? $self->{_exit_value} : undef;
}

sub terminate { shift->die(@_) }
sub die {
  my $self = shift;

  croak "process is already terminated" if $self->{_autodie} && !$self->{_os_obj};

  # See if the process has already died.
  return 1 unless $self->alive;

  # Kill the process using the OS specific method.
  $self->_terminate(@_? ([ @_ ]) : ());

  # See if the process is still alive.
  !$self->alive;
}

sub command {
  $_[0]->{_command};
}

sub exe {
  $_[0]->{_exe}
}

sub start_time {
  $_[0]->{_start_time};
}

sub exit_code {
  return undef unless exists $_[0]->{_exit_value};
  return $_[0]->{_exit_value} >> 8;
}

sub exit_signal {
  return undef unless exists $_[0]->{_exit_value};
  return $_[0]->{_exit_value} & 127;
}

sub end_time {
  $_[0]->{_end_time};
}

sub pid {
  $_[0]->{_pid};
}

sub timeout_system {
  unless (@_ > 1) {
    confess "$0: timeout_system passed too few arguments.\n";
  }

  my $timeout = shift;
  unless ($timeout =~ /^\d+(?:\.\d*)?$/ or $timeout =~ /^\.\d+$/) {
    confess "$0: timeout_system passed a non-positive number first argument.\n";
  }

  my $proc = Proc::Background->new(@_) or return;
  my $end_time = $proc->start_time + $timeout;
  my $delay= $timeout;
  while ($delay > 0 && defined $proc->{_os_obj}) {
    last if defined $proc->wait($delay);
    # If it times out, it's likely that wait() already waited the entire duration.
    # But, if it got interrupted, there might be time remaining.
    # But, if the system clock changes, this could break horribly.  Constrain it to a sane value.
    my $t= time;
    if ($t < $end_time - $delay) { # time moved backward!
      $end_time= $t + $delay;
    } else {
      $delay= $end_time - $t;
    }
  }

  my $alive = $proc->alive;
  $proc->terminate if $alive;

  if (wantarray) {
    return ($proc->wait, $alive);
  } else {
    return $proc->wait;
  }
}

1;

__END__