Alien-ROOT
view release on metacpan or search on metacpan
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
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.
=cut
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;
}
=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
C<run> takes 4 arguments:
=over 4
=item command
This is the command to execute. It may be either a string or an array
reference.
This is a required argument.
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
$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 );
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
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() ],
( run in 1.083 second using v1.01-cache-2.11-cpan-64ef6c95b5d )