Alien-ROOT

 view release on metacpan or  search on metacpan

inc/inc_IPC-Cmd/IPC/Cmd.pm  view on Meta::CPAN

=head1 NAME

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

=head1 SYNOPSIS

    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;


=head1 DESCRIPTION

IPC::Cmd allows you to run commands platform independently,
interactively if desired, but have them still work.

The C<can_run> function can tell you if a certain binary is installed
and if so where, whereas the C<run> function can actually execute any
of the commands you give it and give you a clear return value, as well
as adhere to your verbosity settings.

=head1 CLASS METHODS

=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )

Utility function that tells you if C<IPC::Run> is available.
If the C<verbose> flag is passed, it will print diagnostic messages
if L<IPC::Run> can not be found or loaded.

=cut


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

=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )

Utility function that tells you if C<IPC::Open3> is available.
If the verbose flag is passed, it will print diagnostic messages
if C<IPC::Open3> can not be found or loaded.

=cut


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

=head2 $bool = IPC::Cmd->can_capture_buffer

Utility function that tells you if C<IPC::Cmd> is capable of
capturing buffers in it's current configuration.

=cut

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

=head2 $bool = IPC::Cmd->can_use_run_forked

Utility function that tells you if C<IPC::Cmd> is capable of
providing C<run_forked> on the current platform.

=head1 FUNCTIONS

=head2 $path = can_run( PROGRAM );

C<can_run> takes only one argument: the name of a binary you wish
to locate. C<can_run> works much like the unix binary C<which> or the bash
command C<type>, which scans through your path, looking for the requested
binary.

Unlike C<which> and C<type>, this function is platform independent and
will also work on, for example, Win32.

If called in a scalar context it will return the full path to the binary
you asked for if it was found, or C<undef> if it was not.

If called in a list context and the global variable C<$INSTANCES> is a true
value, it will return a list of the full paths to instances
of the binary where found in C<PATH>, or an empty list if it was not found.

inc/inc_IPC-Cmd/IPC/Cmd.pm  view on Meta::CPAN

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

    require POSIX;

    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, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
      $flags |= POSIX::O_NONBLOCK;
      fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";

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

      $flags = 0;
      fcntl($child_info_socket, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
      $flags |= POSIX::O_NONBLOCK;
      fcntl($child_info_socket, POSIX::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;

inc/inc_IPC-Cmd/IPC/Cmd.pm  view on Meta::CPAN

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

      POSIX::_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
    if ( $ALLOW_NULL_ARGS ) {
      $cmd = [ grep { defined } @$cmd ] if ref $cmd;
    }
    else {
      $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) {