Alien-ROOT
view release on metacpan or search on metacpan
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
});
}
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'}->();
}
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;
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
};
### 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
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
### 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
( run in 0.514 second using v1.01-cache-2.11-cpan-140bd7fdf52 )