IPC::Cmd - finding and running system commands made easy

    use IPC::Cmd qw[can_run run run_forked];

    my $full_path = can_run('wget') or warn 'wget is not installed!';

    ### commands can be arrayrefs or strings ###
    my $cmd = "$full_path -b theregister.co.uk";
    my $cmd = [$full_path, '-b', 'theregister.co.uk'];

    ### in scalar context ###
    my $buffer;
    if( scalar run( command => $cmd,
                    verbose => 0,
                    buffer  => \$buffer,
                    timeout => 20 )
    ) {
        print "fetched webpage successfully: $buffer\n";
    }




    ### in list context ###
    my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) =
            run( command => $cmd, verbose => 0 );

    if( $success ) {
        print "this is what the command printed:\n";
        print join "", @$full_buf;
    }

    ### check for features
    print "IPC::Open3 available: "  . IPC::Cmd->can_use_ipc_open3;
    print "IPC::Run available: "    . IPC::Cmd->can_use_ipc_run;
    print "Can capture buffer: "    . IPC::Cmd->can_capture_buffer;

    ### don't have IPC::Cmd be verbose, ie don't print to stdout or
    ### stderr when running commands -- default is '0'
    $IPC::Cmd::VERBOSE = 0;

  use IPC::Cmd qw[run QUOTE];
  my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;

package IPC::Cmd;

use strict;

BEGIN {

    use constant IS_VMS         => $^O eq 'VMS'                       ? 1 : 0;
    use constant IS_WIN32       => $^O eq 'MSWin32'                   ? 1 : 0;
    use constant IS_WIN98       => (IS_WIN32 and !Win32::IsWinNT())   ? 1 : 0;
    use constant ALARM_CLASS    => __PACKAGE__ . '::TimeOut';
    use constant SPECIAL_CHARS  => qw[< > | &];
    use constant QUOTE          => do { IS_WIN32 ? q["] : q['] };

    use Exporter    ();
    use vars        qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
                        $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
                        $INSTANCES
                    ];

    $VERSION        = '0.72';
    $VERBOSE        = 0;
    $DEBUG          = 0;
    $WARN           = 1;
    $USE_IPC_RUN    = IS_WIN32 && !IS_WIN98;
    $USE_IPC_OPEN3  = not IS_VMS;

    $CAN_USE_RUN_FORKED = 0;
    eval {
        require POSIX; POSIX->import();
        require IPC::Open3; IPC::Open3->import();
        require IO::Select; IO::Select->import();
        require IO::Handle; IO::Handle->import();
        require FileHandle; FileHandle->import();
        require Socket; Socket->import();
        require Time::HiRes; Time::HiRes->import();
        require Win32 if IS_WIN32;
    };
    $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;

    @ISA            = qw[Exporter];
    @EXPORT_OK      = qw[can_run run run_forked QUOTE];
}

require Carp;
use File::Spec;
use Params::Check               qw[check];
use Text::ParseWords            ();             # import ONLY if needed!
use Module::Load::Conditional   qw[can_load];
use Locale::Maketext::Simple    Style => 'gettext';

sub can_use_ipc_run     {
    my $self    = shift;
    my $verbose = shift || 0;

    ### IPC::Run doesn't run on win98
    return if IS_WIN98;

    ### if we dont have ipc::run, we obviously can't use it.
    return unless can_load(
                        modules => { 'IPC::Run' => '0.55' },
                        verbose => ($WARN && $verbose),
                    );

    ### otherwise, we're good to go
    return $IPC::Run::VERSION;
}

sub can_use_ipc_open3   {
    my $self    = shift;
    my $verbose = shift || 0;

    ### IPC::Open3 is not working on VMS because of a lack of fork.
    return if IS_VMS;

    ### IPC::Open3 works on every non-VMS platform platform, but it can't
    ### capture buffers on win32 :(
    return unless can_load(
        modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
        verbose => ($WARN && $verbose),
    );

    return $IPC::Open3::VERSION;
}

sub can_capture_buffer {
    my $self    = shift;

    return 1 if $USE_IPC_RUN    && $self->can_use_ipc_run;
    return 1 if $USE_IPC_OPEN3  && $self->can_use_ipc_open3;
    return;
}

sub can_run {
    my $command = shift;

    # a lot of VMS executables have a symbol defined
    # check those first
    if ( $^O eq 'VMS' ) {
        require VMS::DCLsym;
        my $syms = VMS::DCLsym->new;
        return $command if scalar $syms->getsym( uc $command );
    }

    require Config;
    require File::Spec;
    require ExtUtils::MakeMaker;

    my @possibles;

    if( File::Spec->file_name_is_absolute($command) ) {
        return MM->maybe_command($command);

    } else {
        for my $dir (
            (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
            File::Spec->curdir
        ) {
            next if ! $dir || ! -d $dir;
            my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command);
            push @possibles, $abs if $abs = MM->maybe_command($abs);
        }
    }
    return @possibles if wantarray and $INSTANCES;
    return shift @possibles;
}

{   my @acc = qw[ok error _fds];

    ### autogenerate accessors ###
    for my $key ( @acc ) {
        no strict 'refs';
        *{__PACKAGE__."::$key"} = sub {
            $_[0]->{$key} = $_[1] if @_ > 1;
            return $_[0]->{$key};
        }
    }
}

sub can_use_run_forked {
    return $CAN_USE_RUN_FORKED eq "1";
}

# incompatible with POSIX::SigAction
#
sub install_layered_signal {
  my ($s, $handler_code) = @_;

  my %available_signals = map {$_ => 1} keys %SIG;

  die("install_layered_signal got nonexistent signal name [$s]")
    unless defined($available_signals{$s});
  die("install_layered_signal expects coderef")
    if !ref($handler_code) || ref($handler_code) ne 'CODE';

  my $previous_handler = $SIG{$s};

  my $sig_handler = sub {
    my ($called_sig_name, @sig_param) = @_;

    # $s is a closure referring to real signal name
    # for which this handler is being installed.
    # it is used to distinguish between
    # real signal handlers and aliased signal handlers
    my $signal_name = $s;

    # $called_sig_name is a signal name which
    # was passed to this signal handler;
    # it doesn't equal $signal_name in case
    # some signal handlers in %SIG point
    # to other signal handler (CHLD and CLD,
    # ABRT and IOT)
    #
    # initial signal handler for aliased signal
    # calls some other signal handler which
    # should not execute the same handler_code again
    if ($called_sig_name eq $signal_name) {
      $handler_code->($signal_name);
    }

    # run original signal handler if any (including aliased)
    #
    if (ref($previous_handler)) {
      $previous_handler->($called_sig_name, @sig_param);
    }
  };

  $SIG{$s} = $sig_handler;
}

# give process a chance sending TERM,
# waiting for a while (2 seconds)
# and killing it with KILL
sub kill_gently {
  my ($pid, $opts) = @_;

  $opts = {} unless $opts;
  $opts->{'wait_time'} = 2 unless defined($opts->{'wait_time'});
  $opts->{'first_kill_type'} = 'just_process' unless $opts->{'first_kill_type'};
  $opts->{'final_kill_type'} = 'just_process' unless $opts->{'final_kill_type'};

  if ($opts->{'first_kill_type'} eq 'just_process') {
    kill(15, $pid);
  }
  elsif ($opts->{'first_kill_type'} eq 'process_group') {
    kill(-15, $pid);
  }

  my $child_finished = 0;
  my $wait_start_time = time();

  while (!$child_finished && $wait_start_time + $opts->{'wait_time'} > time()) {
    my $waitpid = waitpid($pid, WNOHANG);
    if ($waitpid eq -1) {
      $child_finished = 1;
    }
    Time::HiRes::usleep(250000); # quarter of a second
  }

  if (!$child_finished) {
    if ($opts->{'final_kill_type'} eq 'just_process') {
      kill(9, $pid);
    }
    elsif ($opts->{'final_kill_type'} eq 'process_group') {
      kill(-9, $pid);
    }
  }
}

sub open3_run {
  my ($cmd, $opts) = @_;

  $opts = {} unless $opts;

  my $child_in = FileHandle->new;
  my $child_out = FileHandle->new;
  my $child_err = FileHandle->new;
  $child_out->autoflush(1);
  $child_err->autoflush(1);

  my $pid = open3($child_in, $child_out, $child_err, $cmd);

  # push my child's pid to our parent
  # so in case i am killed parent
  # could stop my child (search for
  # child_child_pid in parent code)
  if ($opts->{'parent_info'}) {
    my $ps = $opts->{'parent_info'};
    print $ps "spawned $pid\n";
  }

  if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {

    # If the child process dies for any reason,
    # the next write to CHLD_IN is likely to generate
    # a SIGPIPE in the parent, which is fatal by default.
    # So you may wish to handle this signal.
    #
    # from http://perldoc.perl.org/IPC/Open3.html,
    # absolutely needed to catch piped commands errors.
    #
    local $SIG{'PIPE'} = sub { 1; };

    print $child_in $opts->{'child_stdin'};
  }
  close($child_in);

  my $child_output = {
    'out' => $child_out->fileno,
    'err' => $child_err->fileno,
    $child_out->fileno => {
      'parent_socket' => $opts->{'parent_stdout'},
      'scalar_buffer' => "",
      'child_handle' => $child_out,
      'block_size' => ($child_out->stat)[11] || 1024,
      },
    $child_err->fileno => {
      'parent_socket' => $opts->{'parent_stderr'},
      'scalar_buffer' => "",
      'child_handle' => $child_err,
      'block_size' => ($child_err->stat)[11] || 1024,
      },
    };

  my $select = IO::Select->new();
  $select->add($child_out, $child_err);

  # pass any signal to the child
  # effectively creating process
  # strongly attached to the child:
  # it will terminate only after child
  # has terminated (except for SIGKILL,
  # which is specially handled)
  foreach my $s (keys %SIG) {
    my $sig_handler;
    $sig_handler = sub {
      kill("$s", $pid);
      $SIG{$s} = $sig_handler;
    };
    $SIG{$s} = $sig_handler;
  }

  my $child_finished = 0;

  my $got_sig_child = 0;
  $SIG{'CHLD'} = sub { $got_sig_child = time(); };

  while(!$child_finished && ($child_out->opened || $child_err->opened)) {

    # parent was killed otherwise we would have got
    # the same signal as parent and process it same way
    if (getppid() eq "1") {

      # end my process group with all the children
      # (i am the process group leader, so my pid
      # equals to the process group id)
      #
      # same thing which is done
      # with $opts->{'clean_up_children'}
      # in run_forked
      #
      kill(-9, $$);

      exit 1;
    }

    if ($got_sig_child) {
      if (time() - $got_sig_child > 1) {
        # select->can_read doesn't return 0 after SIG_CHLD
        #
        # "On POSIX-compliant platforms, SIGCHLD is the signal
        # sent to a process when a child process terminates."
        # http://en.wikipedia.org/wiki/SIGCHLD
        #
        # nevertheless kill KILL wouldn't break anything here
        #
        kill (9, $pid);
        $child_finished = 1;
      }
    }

    Time::HiRes::usleep(1);

    foreach my $fd ($select->can_read(1/100)) {
      my $str = $child_output->{$fd->fileno};
      psSnake::die("child stream not found: $fd") unless $str;

      my $data;
      my $count = $fd->sysread($data, $str->{'block_size'});

      if ($count) {
        if ($str->{'parent_socket'}) {
          my $ph = $str->{'parent_socket'};
          print $ph $data;
        }
        else {
          $str->{'scalar_buffer'} .= $data;
        }
      }
      elsif ($count eq 0) {
        $select->remove($fd);
        $fd->close();
      }
      else {
        psSnake::die("error during sysread: " . $!);
      }
    }
  }

  my $waitpid_ret = waitpid($pid, 0);
  my $real_exit = $?;
  my $exit_value  = $real_exit >> 8;

  # since we've successfully reaped the child,
  # let our parent know about this.
  #
  if ($opts->{'parent_info'}) {
    my $ps = $opts->{'parent_info'};

    # child was killed, inform parent
    if ($real_exit & 127) {
      print $ps "$pid killed with " . ($real_exit & 127) . "\n";
    }

    print $ps "reaped $pid\n";
  }

  if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
    return $exit_value;
  }
  else {
    return {
      'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
      'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
      'exit_code' => $exit_value,
      };
  }
}

sub run_forked {
    ### container to store things in
    my $self = bless {}, __PACKAGE__;

    if (!can_use_run_forked()) {
        Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED");
        return;
    }

    my ($cmd, $opts) = @_;

    if (!$cmd) {
        Carp::carp("run_forked expects command to run");
        return;
    }

    $opts = {} unless $opts;
    $opts->{'timeout'} = 0 unless $opts->{'timeout'};
    $opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});

    # turned on by default
    $opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});

    # sockets to pass child stdout to parent
    my $child_stdout_socket;
    my $parent_stdout_socket;

    # sockets to pass child stderr to parent
    my $child_stderr_socket;
    my $parent_stderr_socket;

    # sockets for child -> parent internal communication
    my $child_info_socket;
    my $parent_info_socket;

    socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
      die ("socketpair: $!");
    socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
      die ("socketpair: $!");
    socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
      die ("socketpair: $!");

    $child_stdout_socket->autoflush(1);
    $parent_stdout_socket->autoflush(1);
    $child_stderr_socket->autoflush(1);
    $parent_stderr_socket->autoflush(1);
    $child_info_socket->autoflush(1);
    $parent_info_socket->autoflush(1);

    my $start_time = time();

    my $pid;
    if ($pid = fork) {

      # we are a parent
      close($parent_stdout_socket);
      close($parent_stderr_socket);
      close($parent_info_socket);

      my $flags;

      # prepare sockets to read from child

      $flags = 0;
      fcntl($child_stdout_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
      $flags |= O_NONBLOCK;
      fcntl($child_stdout_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";

      $flags = 0;
      fcntl($child_stderr_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
      $flags |= O_NONBLOCK;
      fcntl($child_stderr_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";

      $flags = 0;
      fcntl($child_info_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
      $flags |= O_NONBLOCK;
      fcntl($child_info_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";

  #    print "child $pid started\n";

      my $child_timedout = 0;
      my $child_finished = 0;
      my $child_stdout = '';
      my $child_stderr = '';
      my $child_merged = '';
      my $child_exit_code = 0;
      my $child_killed_by_signal = 0;
      my $parent_died = 0;

      my $got_sig_child = 0;
      my $got_sig_quit = 0;
      my $orig_sig_child = $SIG{'CHLD'};

      $SIG{'CHLD'} = sub { $got_sig_child = time(); };

      if ($opts->{'terminate_on_signal'}) {
        install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
      }

      my $child_child_pid;

      while (!$child_finished) {
        my $now = time();

        if ($opts->{'terminate_on_parent_sudden_death'}) {
          $opts->{'runtime'}->{'last_parent_check'} = 0
            unless defined($opts->{'runtime'}->{'last_parent_check'});

          # check for parent once each five seconds
          if ($now - $opts->{'runtime'}->{'last_parent_check'} > 5) {
            if (getppid() eq "1") {
              kill_gently ($pid, {
                'first_kill_type' => 'process_group',
                'final_kill_type' => 'process_group',
                'wait_time' => $opts->{'terminate_wait_time'}
                });
              $parent_died = 1;
            }

            $opts->{'runtime'}->{'last_parent_check'} = $now;
          }
        }

        # user specified timeout
        if ($opts->{'timeout'}) {
          if ($now - $start_time > $opts->{'timeout'}) {
            kill_gently ($pid, {
              'first_kill_type' => 'process_group',
              'final_kill_type' => 'process_group',
              'wait_time' => $opts->{'terminate_wait_time'}
              });
            $child_timedout = 1;
          }
        }

        # give OS 10 seconds for correct return of waitpid,
        # kill process after that and finish wait loop;
        # shouldn't ever happen -- remove this code?
        if ($got_sig_child) {
          if ($now - $got_sig_child > 10) {
            print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
            kill (-9, $pid);
            $child_finished = 1;
          }
        }

        if ($got_sig_quit) {
          kill_gently ($pid, {
            'first_kill_type' => 'process_group',
            'final_kill_type' => 'process_group',
            'wait_time' => $opts->{'terminate_wait_time'}
            });
          $child_finished = 1;
        }

        my $waitpid = waitpid($pid, WNOHANG);

        # child finished, catch it's exit status
        if ($waitpid ne 0 && $waitpid ne -1) {
          $child_exit_code = $? >> 8;
        }

        if ($waitpid eq -1) {
          $child_finished = 1;
          next;
        }

        # child -> parent simple internal communication protocol
        while (my $l = <$child_info_socket>) {
          if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) {
            $child_child_pid = $1;
            $l = $2;
          }
          if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) {
            $child_child_pid = undef;
            $l = $2;
          }
          if ($l =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) {
            $child_killed_by_signal = $1;
            $l = $2;
          }
        }

        while (my $l = <$child_stdout_socket>) {
          if (!$opts->{'discard_output'}) {
            $child_stdout .= $l;
            $child_merged .= $l;
          }

          if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
            $opts->{'stdout_handler'}->($l);
          }
        }
        while (my $l = <$child_stderr_socket>) {
          if (!$opts->{'discard_output'}) {
            $child_stderr .= $l;
            $child_merged .= $l;
          }
          if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
            $opts->{'stderr_handler'}->($l);
          }
        }

        Time::HiRes::usleep(1);
      }

      # $child_pid_pid is not defined in two cases:
      #  * when our child was killed before
      #    it had chance to tell us the pid
      #    of the child it spawned. we can do
      #    nothing in this case :(
      #  * our child successfully reaped its child,
      #    we have nothing left to do in this case
      #
      # defined $child_pid_pid means child's child
      # has not died but nobody is waiting for it,
      # killing it brutally.
      #
      if ($child_child_pid) {
        kill_gently($child_child_pid);
      }

      # in case there are forks in child which
      # do not forward or process signals (TERM) correctly
      # kill whole child process group, effectively trying
      # not to return with some children or their parts still running
      #
      # to be more accurate -- we need to be sure
      # that this is process group created by our child
      # (and not some other process group with the same pgid,
      # created just after death of our child) -- fortunately
      # this might happen only when process group ids
      # are reused quickly (there are lots of processes
      # spawning new process groups for example)
      #
      if ($opts->{'clean_up_children'}) {
        kill(-9, $pid);
      }

  #    print "child $pid finished\n";

      close($child_stdout_socket);
      close($child_stderr_socket);
      close($child_info_socket);

      my $o = {
        'stdout' => $child_stdout,
        'stderr' => $child_stderr,
        'merged' => $child_merged,
        'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
        'exit_code' => $child_exit_code,
        'parent_died' => $parent_died,
        'killed_by_signal' => $child_killed_by_signal,
        'child_pgid' => $pid,
        };

      my $err_msg = '';
      if ($o->{'exit_code'}) {
        $err_msg .= "exited with code [$o->{'exit_code'}]\n";
      }
      if ($o->{'timeout'}) {
        $err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
      }
      if ($o->{'parent_died'}) {
        $err_msg .= "parent died\n";
      }
      if ($o->{'stdout'}) {
        $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
      }
      if ($o->{'stderr'}) {
        $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
      }
      if ($o->{'killed_by_signal'}) {
        $err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
      }
      $o->{'err_msg'} = $err_msg;

      if ($orig_sig_child) {
        $SIG{'CHLD'} = $orig_sig_child;
      }
      else {
        delete($SIG{'CHLD'});
      }

      return $o;
    }
    else {
      die("cannot fork: $!") unless defined($pid);

      # create new process session for open3 call,
      # so we hopefully can kill all the subprocesses
      # which might be spawned in it (except for those
      # which do setsid theirselves -- can't do anything
      # with those)

      POSIX::setsid() || die("Error running setsid: " . $!);

      if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
        $opts->{'child_BEGIN'}->();
      }

      close($child_stdout_socket);
      close($child_stderr_socket);
      close($child_info_socket);

      my $child_exit_code;

      # allow both external programs
      # and internal perl calls
      if (!ref($cmd)) {
        $child_exit_code = open3_run($cmd, {
          'parent_info' => $parent_info_socket,
          'parent_stdout' => $parent_stdout_socket,
          'parent_stderr' => $parent_stderr_socket,
          'child_stdin' => $opts->{'child_stdin'},
          });
      }
      elsif (ref($cmd) eq 'CODE') {
        $child_exit_code = $cmd->({
          'opts' => $opts,
          'parent_info' => $parent_info_socket,
          'parent_stdout' => $parent_stdout_socket,
          'parent_stderr' => $parent_stderr_socket,
          'child_stdin' => $opts->{'child_stdin'},
          });
      }
      else {
        print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n";
        $child_exit_code = 1;
      }

      close($parent_stdout_socket);
      close($parent_stderr_socket);
      close($parent_info_socket);

      if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
        $opts->{'child_END'}->();
      }

      exit $child_exit_code;
    }
}

sub run {
    ### container to store things in
    my $self = bless {}, __PACKAGE__;

    my %hash = @_;

    ### if the user didn't provide a buffer, we'll store it here.
    my $def_buf = '';

    my($verbose,$cmd,$buffer,$timeout);
    my $tmpl = {
        verbose => { default  => $VERBOSE,  store => \$verbose },
        buffer  => { default  => \$def_buf, store => \$buffer },
        command => { required => 1,         store => \$cmd,
                     allow    => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
        },
        timeout => { default  => 0,         store => \$timeout },
    };

    unless( check( $tmpl, \%hash, $VERBOSE ) ) {
        Carp::carp( loc( "Could not validate input: %1",
                         Params::Check->last_error ) );
        return;
    };

    $cmd = _quote_args_vms( $cmd ) if IS_VMS;

    ### strip any empty elements from $cmd if present
    $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;

    my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
    print loc("Running [%1]...\n", $pp_cmd ) if $verbose;

    ### did the user pass us a buffer to fill or not? if so, set this
    ### flag so we know what is expected of us
    ### XXX this is now being ignored. in the future, we could add diagnostic
    ### messages based on this logic
    #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;

    ### buffers that are to be captured
    my( @buffer, @buff_err, @buff_out );

    ### capture STDOUT
    my $_out_handler = sub {
        my $buf = shift;
        return unless defined $buf;

        print STDOUT $buf if $verbose;
        push @buffer,   $buf;
        push @buff_out, $buf;
    };

    ### capture STDERR
    my $_err_handler = sub {
        my $buf = shift;
        return unless defined $buf;

        print STDERR $buf if $verbose;
        push @buffer,   $buf;
        push @buff_err, $buf;
    };


    ### flag to indicate we have a buffer captured
    my $have_buffer = $self->can_capture_buffer ? 1 : 0;

    ### flag indicating if the subcall went ok
    my $ok;

    ### dont look at previous errors:
    local $?;
    local $@;
    local $!;

    ### we might be having a timeout set
    eval {
        local $SIG{ALRM} = sub { die bless sub {
            ALARM_CLASS .
            qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
        }, ALARM_CLASS } if $timeout;
        alarm $timeout || 0;

        ### IPC::Run is first choice if $USE_IPC_RUN is set.
        if( !IS_WIN32 and $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
            ### ipc::run handlers needs the command as a string or an array ref

            $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
                if $DEBUG;

            $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );

        ### since IPC::Open3 works on all platforms, and just fails on
        ### win32 for capturing buffers, do that ideally
        } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {

            $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
                if $DEBUG;

            ### in case there are pipes in there;
            ### IPC::Open3 will call exec and exec will do the right thing

            my $method = IS_WIN32 ? '_open3_run_win32' : '_open3_run';

            $ok = $self->$method(
                                    $cmd, $_out_handler, $_err_handler, $verbose
                                );

        ### if we are allowed to run verbose, just dispatch the system command
        } else {
            $self->_debug( "# Using system(). Have buffer: $have_buffer" )
                if $DEBUG;
            $ok = $self->_system_run( $cmd, $verbose );
        }

        alarm 0;
    };

    ### restore STDIN after duping, or STDIN will be closed for
    ### this current perl process!
    $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;

    my $err;
    unless( $ok ) {
        ### alarm happened
        if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
            $err = $@->();  # the error code is an expired alarm

        ### another error happened, set by the dispatchub
        } else {
            $err = $self->error;
        }
    }

    ### fill the buffer;
    $$buffer = join '', @buffer if @buffer;

    ### return a list of flags and buffers (if available) in list
    ### context, or just a simple 'ok' in scalar
    return wantarray
                ? $have_buffer
                    ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
                    : ($ok, $err )
                : $ok


}

sub _open3_run_win32 {
  my $self    = shift;
  my $cmd     = shift;
  my $outhand = shift;
  my $errhand = shift;

  my $pipe = sub {
    socketpair($_[0], $_[1], AF_UNIX, SOCK_STREAM, PF_UNSPEC)
        or return undef;
    shutdown($_[0], 1);  # No more writing for reader
    shutdown($_[1], 0);  # No more reading for writer
    return 1;
  };

  my $open3 = sub {
    local (*TO_CHLD_R,     *TO_CHLD_W);
    local (*FR_CHLD_R,     *FR_CHLD_W);
    local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W);

    $pipe->(*TO_CHLD_R,     *TO_CHLD_W    ) or die $^E;
    $pipe->(*FR_CHLD_R,     *FR_CHLD_W    ) or die $^E;
    $pipe->(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $^E;

    my $pid = IPC::Open3::open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_);

    return ( $pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R );
  };

  $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
  $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );

  my ($pid, $to_chld, $fr_chld, $fr_chld_err) =
    $open3->( ( ref $cmd ? @$cmd : $cmd ) );

  my $in_sel  = IO::Select->new();
  my $out_sel = IO::Select->new();

  my %objs;

  $objs{ fileno( $fr_chld ) } = $outhand;
  $objs{ fileno( $fr_chld_err ) } = $errhand;
  $in_sel->add( $fr_chld );
  $in_sel->add( $fr_chld_err );

  close($to_chld);

  while ($in_sel->count() + $out_sel->count()) {
    my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef);

    for my $fh (@$ins) {
        my $obj = $objs{ fileno($fh) };
        my $buf;
        my $bytes_read = sysread($fh, $buf, 64*1024 ); #, length($buf));
        if (!$bytes_read) {
            $in_sel->remove($fh);
        }
        else {
	          $obj->( "$buf" );
	      }
      }

      for my $fh (@$outs) {
      }
  }

  waitpid($pid, 0);

  ### some error occurred
  if( $? ) {
        $self->error( $self->_pp_child_error( $cmd, $? ) );
        $self->ok( 0 );
        return;
  } else {
        return $self->ok( 1 );
  }
}

sub _open3_run {
    my $self            = shift;
    my $cmd             = shift;
    my $_out_handler    = shift;
    my $_err_handler    = shift;
    my $verbose         = shift || 0;

    ### Following code are adapted from Friar 'abstracts' in the
    ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
    ### XXX that code didn't work.
    ### we now use the following code, thanks to theorbtwo

    ### define them beforehand, so we always have defined FH's
    ### to read from.
    use Symbol;
    my $kidout      = Symbol::gensym();
    my $kiderror    = Symbol::gensym();

    ### Dup the filehandle so we can pass 'our' STDIN to the
    ### child process. This stops us from having to pump input
    ### from ourselves to the childprocess. However, we will need
    ### to revive the FH afterwards, as IPC::Open3 closes it.
    ### We'll do the same for STDOUT and STDERR. It works without
    ### duping them on non-unix derivatives, but not on win32.
    my @fds_to_dup = ( IS_WIN32 && !$verbose
                            ? qw[STDIN STDOUT STDERR]
                            : qw[STDIN]
                        );
    $self->_fds( \@fds_to_dup );
    $self->__dup_fds( @fds_to_dup );

    ### pipes have to come in a quoted string, and that clashes with
    ### whitespace. This sub fixes up such commands so they run properly
    $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );

    ### dont stringify @$cmd, so spaces in filenames/paths are
    ### treated properly
    my $pid = eval {
        IPC::Open3::open3(
                    '<&STDIN',
                    (IS_WIN32 ? '>&STDOUT' : $kidout),
                    (IS_WIN32 ? '>&STDERR' : $kiderror),
                    ( ref $cmd ? @$cmd : $cmd ),
                );
    };

    ### open3 error occurred
    if( $@ and $@ =~ /^open3:/ ) {
        $self->ok( 0 );
        $self->error( $@ );
        return;
    };

    ### use OUR stdin, not $kidin. Somehow,
    ### we never get the input.. so jump through
    ### some hoops to do it :(
    my $selector = IO::Select->new(
                        (IS_WIN32 ? \*STDERR : $kiderror),
                        \*STDIN,
                        (IS_WIN32 ? \*STDOUT : $kidout)
                    );

    STDOUT->autoflush(1);   STDERR->autoflush(1);   STDIN->autoflush(1);
    $kidout->autoflush(1)   if UNIVERSAL::can($kidout,   'autoflush');
    $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');

    ### add an explicit break statement
    ### code courtesy of theorbtwo from #london.pm
    my $stdout_done = 0;
    my $stderr_done = 0;
    OUTER: while ( my @ready = $selector->can_read ) {

        for my $h ( @ready ) {
            my $buf;

            ### $len is the amount of bytes read
            my $len = sysread( $h, $buf, 4096 );    # try to read 4096 bytes

            ### see perldoc -f sysread: it returns undef on error,
            ### so bail out.
            if( not defined $len ) {
                warn(loc("Error reading from process: %1", $!));
                last OUTER;
            }

            ### check for $len. it may be 0, at which point we're
            ### done reading, so don't try to process it.
            ### if we would print anyway, we'd provide bogus information
            $_out_handler->( "$buf" ) if $len && $h == $kidout;
            $_err_handler->( "$buf" ) if $len && $h == $kiderror;

            ### Wait till child process is done printing to both
            ### stdout and stderr.
            $stdout_done = 1 if $h == $kidout   and $len == 0;
            $stderr_done = 1 if $h == $kiderror and $len == 0;
            last OUTER if ($stdout_done && $stderr_done);
        }
    }

    waitpid $pid, 0; # wait for it to die

    ### restore STDIN after duping, or STDIN will be closed for
    ### this current perl process!
    ### done in the parent call now
    # $self->__reopen_fds( @fds_to_dup );

    ### some error occurred
    if( $? ) {
        $self->error( $self->_pp_child_error( $cmd, $? ) );
        $self->ok( 0 );
        return;
    } else {
        return $self->ok( 1 );
    }
}

### Text::ParseWords::shellwords() uses unix semantics. that will break
### on win32
{   my $parse_sub = IS_WIN32
                        ? __PACKAGE__->can('_split_like_shell_win32')
                        : Text::ParseWords->can('shellwords');

    sub _ipc_run {
        my $self            = shift;
        my $cmd             = shift;
        my $_out_handler    = shift;
        my $_err_handler    = shift;

        STDOUT->autoflush(1); STDERR->autoflush(1);

        ### a command like:
        # [
        #     '/usr/bin/gzip',
        #     '-cdf',
        #     '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
        #     '|',
        #     '/usr/bin/tar',
        #     '-tf -'
        # ]
        ### needs to become:
        # [
        #     ['/usr/bin/gzip', '-cdf',
        #       '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
        #     '|',
        #     ['/usr/bin/tar', '-tf -']
        # ]


        my @command;
        my $special_chars;

        my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
        if( ref $cmd ) {
            my $aref = [];
            for my $item (@$cmd) {
                if( $item =~ $re ) {
                    push @command, $aref, $item;
                    $aref = [];
                    $special_chars .= $1;
                } else {
                    push @$aref, $item;
                }
            }
            push @command, $aref;
        } else {
            @command = map { if( $_ =~ $re ) {
                                $special_chars .= $1; $_;
                             } else {
#                                [ split /\s+/ ]
                                 [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
                             }
                        } split( /\s*$re\s*/, $cmd );
        }

        ### if there's a pipe in the command, *STDIN needs to
        ### be inserted *BEFORE* the pipe, to work on win32
        ### this also works on *nix, so we should do it when possible
        ### this should *also* work on multiple pipes in the command
        ### if there's no pipe in the command, append STDIN to the back
        ### of the command instead.
        ### XXX seems IPC::Run works it out for itself if you just
        ### dont pass STDIN at all.
        #     if( $special_chars and $special_chars =~ /\|/ ) {
        #         ### only add STDIN the first time..
        #         my $i;
        #         @command = map { ($_ eq '|' && not $i++)
        #                             ? ( \*STDIN, $_ )
        #                             : $_
        #                         } @command;
        #     } else {
        #         push @command, \*STDIN;
        #     }

        # \*STDIN is already included in the @command, see a few lines up
        my $ok = eval { IPC::Run::run(   @command,
                                fileno(STDOUT).'>',
                                $_out_handler,
                                fileno(STDERR).'>',
                                $_err_handler
                            )
                        };

        ### all is well
        if( $ok ) {
            return $self->ok( $ok );

        ### some error occurred
        } else {
            $self->ok( 0 );

            ### if the eval fails due to an exception, deal with it
            ### unless it's an alarm
            if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
                $self->error( $@ );

            ### if it *is* an alarm, propagate
            } elsif( $@ ) {
                die $@;

            ### some error in the sub command
            } else {
                $self->error( $self->_pp_child_error( $cmd, $? ) );
            }

            return;
        }
    }
}

sub _system_run {
    my $self    = shift;
    my $cmd     = shift;
    my $verbose = shift || 0;

    ### pipes have to come in a quoted string, and that clashes with
    ### whitespace. This sub fixes up such commands so they run properly
    $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );

    my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
    $self->_fds( \@fds_to_dup );
    $self->__dup_fds( @fds_to_dup );

    ### system returns 'true' on failure -- the exit code of the cmd
    $self->ok( 1 );
    system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
        $self->error( $self->_pp_child_error( $cmd, $? ) );
        $self->ok( 0 );
    };

    ### done in the parent call now
    #$self->__reopen_fds( @fds_to_dup );

    return unless $self->ok;
    return $self->ok;
}

{   my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;


    sub __fix_cmd_whitespace_and_special_chars {
        my $self = shift;
        my $cmd  = shift;

        ### command has a special char in it
        if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {

            ### since we have special chars, we have to quote white space
            ### this *may* conflict with the parsing :(
            my $fixed;
            my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;

            $self->_debug( "# Quoted $fixed arguments containing whitespace" )
                    if $DEBUG && $fixed;

            ### stringify it, so the special char isn't escaped as argument
            ### to the program
            $cmd = join ' ', @cmd;
        }

        return $cmd;
    }
}

### Command-line arguments (but not the command itself) must be quoted
### to ensure case preservation. Borrowed from Module::Build with adaptations.
### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
### quoting for run() on VMS
sub _quote_args_vms {
  ### Returns a command string with proper quoting so that the subprocess
  ### sees this same list of args, or if we get a single arg that is an
  ### array reference, quote the elements of it (except for the first)
  ### and return the reference.
  my @args = @_;
  my $got_arrayref = (scalar(@args) == 1
                      && UNIVERSAL::isa($args[0], 'ARRAY'))
                   ? 1
                   : 0;

  @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1;

  my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;

  ### Do not quote qualifiers that begin with '/' or previously quoted args.
  map { if (/^[^\/\"]/) {
          $_ =~ s/\"/""/g;     # escape C<"> by doubling
          $_ = q(").$_.q(");
        }
  }
    ($got_arrayref ? @{$args[0]}
                   : @args
    );

  $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);

  return $got_arrayref ? $args[0]
                       : join(' ', @args);
}


### XXX this is cribbed STRAIGHT from M::B 0.30 here:
### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
### XXX this *should* be integrated into text::parsewords
sub _split_like_shell_win32 {
  # As it turns out, Windows command-parsing is very different from
  # Unix command-parsing.  Double-quotes mean different things,
  # backslashes don't necessarily mean escapes, and so on.  So we
  # can't use Text::ParseWords::shellwords() to break a command string
  # into words.  The algorithm below was bashed out by Randy and Ken
  # (mostly Randy), and there are a lot of regression tests, so we
  # should feel free to adjust if desired.

  local $_ = shift;

  my @argv;
  return @argv unless defined() && length();

  my $arg = '';
  my( $i, $quote_mode ) = ( 0, 0 );

  while ( $i < length() ) {

    my $ch      = substr( $_, $i  , 1 );
    my $next_ch = substr( $_, $i+1, 1 );

    if ( $ch eq '\\' && $next_ch eq '"' ) {
      $arg .= '"';
      $i++;
    } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
      $arg .= '\\';
      $i++;
    } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
      $quote_mode = !$quote_mode;
      $arg .= '"';
      $i++;
    } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
          ( $i + 2 == length()  ||
        substr( $_, $i + 2, 1 ) eq ' ' )
        ) { # for cases like: a"" => [ 'a' ]
      push( @argv, $arg );
      $arg = '';
      $i += 2;
    } elsif ( $ch eq '"' ) {
      $quote_mode = !$quote_mode;
    } elsif ( $ch eq ' ' && !$quote_mode ) {
      push( @argv, $arg ) if defined( $arg ) && length( $arg );
      $arg = '';
      ++$i while substr( $_, $i + 1, 1 ) eq ' ';
    } else {
      $arg .= $ch;
    }

    $i++;
  }

  push( @argv, $arg ) if defined( $arg ) && length( $arg );
  return @argv;
}



{   use File::Spec;
    use Symbol;

    my %Map = (
        STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
        STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
        STDIN  => [qw|<&|, \*STDIN,  Symbol::gensym() ],
    );

    ### dups FDs and stores them in a cache
    sub __dup_fds {
        my $self    = shift;
        my @fds     = @_;

        __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;

        for my $name ( @fds ) {
            my($redir, $fh, $glob) = @{$Map{$name}} or (
                Carp::carp(loc("No such FD: '%1'", $name)), next );

            ### MUST use the 2-arg version of open for dup'ing for
            ### 5.6.x compatibility. 5.8.x can use 3-arg open
            ### see perldoc5.6.2 -f open for details
            open $glob, $redir . fileno($fh) or (
                        Carp::carp(loc("Could not dup '$name': %1", $!)),
                        return
                    );

            ### we should re-open this filehandle right now, not
            ### just dup it
            ### Use 2-arg version of open, as 5.5.x doesn't support
            ### 3-arg version =/
            if( $redir eq '>&' ) {
                open( $fh, '>' . File::Spec->devnull ) or (
                    Carp::carp(loc("Could not reopen '$name': %1", $!)),
                    return
                );
            }
        }

        return 1;
    }

    ### reopens FDs from the cache
    sub __reopen_fds {
        my $self    = shift;
        my @fds     = @_;

        __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;

        for my $name ( @fds ) {
            my($redir, $fh, $glob) = @{$Map{$name}} or (
                Carp::carp(loc("No such FD: '%1'", $name)), next );

            ### MUST use the 2-arg version of open for dup'ing for
            ### 5.6.x compatibility. 5.8.x can use 3-arg open
            ### see perldoc5.6.2 -f open for details
            open( $fh, $redir . fileno($glob) ) or (
                    Carp::carp(loc("Could not restore '$name': %1", $!)),
                    return
                );

            ### close this FD, we're not using it anymore
            close $glob;
        }
        return 1;

    }
}

sub _debug {
    my $self    = shift;
    my $msg     = shift or return;
    my $level   = shift || 0;

    local $Carp::CarpLevel += $level;
    Carp::carp($msg);

    return 1;
}

sub _pp_child_error {
    my $self    = shift;
    my $cmd     = shift or return;
    my $ce      = shift or return;
    my $pp_cmd  = ref $cmd ? "@$cmd" : $cmd;


    my $str;
    if( $ce == -1 ) {
        ### Include $! in the error message, so that the user can
        ### see 'No such file or directory' versus 'Permission denied'
        ### versus 'Cannot fork' or whatever the cause was.
        $str = "Failed to execute '$pp_cmd': $!";

    } elsif ( $ce & 127 ) {
        ### some signal
        $str = loc( "'%1' died with signal %d, %s coredump\n",
               $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');

    } else {
        ### Otherwise, the command run but gave error status.
        $str = "'$pp_cmd' exited with value " . ($ce >> 8);
    }

    $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;

    return $str;
}

1;