From: Rafael Garcia-Suarez Date: Tue, 28 Nov 2006 10:45:06 +0000 (+0000) Subject: Add IPC::Cmd to the core X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0d4ddeff7e483fb28046cb7e890e4a921c128f6c;p=p5sagit%2Fp5-mst-13.2.git Add IPC::Cmd to the core p4raw-id: //depot/perl@29401 --- diff --git a/MANIFEST b/MANIFEST index 08cb019..ea1068a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1798,6 +1798,10 @@ lib/IO/Zlib/t/large.t Tests for IO::Zlib lib/IO/Zlib/t/tied.t Tests for IO::Zlib lib/IO/Zlib/t/uncomp1.t Tests for IO::Zlib lib/IO/Zlib/t/uncomp2.t Tests for IO::Zlib +lib/IPC/Cmd.pm IPC::Cmd +lib/IPC/Cmd/t/01_IPC-Cmd.t IPC::Cmd tests +lib/IPC/Cmd/t/02_Interactive.t IPC::Cmd tests +lib/IPC/Cmd/t/src/child.pl IPC::Cmd tests lib/IPC/Open2.pm Open a two-ended pipe lib/IPC/Open2.t See if IPC::Open2 works lib/IPC/Open3.pm Open a three-ended pipe! diff --git a/lib/IPC/Cmd.pm b/lib/IPC/Cmd.pm new file mode 100644 index 0000000..c941c76 --- /dev/null +++ b/lib/IPC/Cmd.pm @@ -0,0 +1,783 @@ +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 Exporter (); + use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG + $USE_IPC_RUN $USE_IPC_OPEN3 $WARN + ]; + + $VERSION = '0.36'; + $VERBOSE = 0; + $DEBUG = 0; + $WARN = 1; + $USE_IPC_RUN = IS_WIN32 && !IS_WIN98; + $USE_IPC_OPEN3 = not IS_VMS; + + @ISA = qw[Exporter]; + @EXPORT_OK = qw[can_run run]; +} + +require Carp; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Style => 'gettext'; + +=pod + +=head1 NAME + +IPC::Cmd - finding and running system commands made easy + +=head1 SYNOPSIS + + use IPC::Cmd qw[can_run run]; + + 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 ) + ) { + print "fetched webpage successfully: $buffer\n"; + } + + + ### in list context ### + my( $success, $error_code, $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, interactively if desired, +platform independent but have them still work. + +The C function can tell you if a certain binary is installed +and if so where, whereas the C 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 $bool = IPC::Cmd->can_use_ipc_run( [VERBOSE] ) + +Utility function that tells you if C is available. +If the verbose flag is passed, it will print diagnostic messages +if C 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 1; +} + +=head2 $bool = IPC::Cmd->can_use_ipc_open3( [VERBOSE] ) + +Utility function that tells you if C is available. +If the verbose flag is passed, it will print diagnostic messages +if C can not be found or loaded. + +=cut + + +sub can_use_ipc_open3 { + my $self = shift; + my $verbose = shift || 0; + + ### ipc::open3 works on every 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 1; +} + +=head2 $bool = IPC::Cmd->can_capture_buffer + +Utility function that tells you if C 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 && !IS_WIN32; + return; +} + + +=head1 FUNCTIONS + +=head2 $path = can_run( PROGRAM ); + +C takes but a single argument: the name of a binary you wish +to locate. C works much like the unix binary C or the bash +command C, which scans through your path, looking for the requested +binary . + +Unlike C and C, this function is platform independent and +will also work on, for example, Win32. + +It will return the full path to the binary you asked for if it was +found, or C if it was not. + +=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; + + 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}) { + my $abs = File::Spec->catfile($dir, $command); + return $abs if $abs = MM->maybe_command($abs); + } + } +} + +=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR] ); + +C takes 3 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. + +See L for remarks on how commands are parsed and their +limitations. + +=item verbose + +This controls whether all output of a command should also be printed +to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers +require C to be installed or your system able to work with +C). + +It will default to the global setting of C<$IPC::Cmd::VERBOSE>, +which by default is 0. + +=item buffer + +This will hold all the output of a command. It needs to be a reference +to a scalar. +Note that this will hold both the STDOUT and STDERR messages, and you +have no way of telling which is which. +If you require this distinction, run the C command in list context +and inspect the individual buffers. + +Of course, this requires that the underlying call supports buffers. See +the note on buffers right above. + +=back + +C will return a simple C or C when called in scalar +context. +In list context, you will be returned a list of the following items: + +=over 4 + +=item success + +A simple boolean indicating if the command executed without errors or +not. + +=item errorcode + +If the first element of the return value (success) was 0, then some +error occurred. This second element is the error code the command +you requested exited with, if available. + +=item full_buffer + +This is an arrayreference containing all the output the command +generated. +Note that buffers are only available if you have C installed, +or if your system is able to work with C -- See below). +This element will be C if this is not the case. + +=item out_buffer + +This is an arrayreference containing all the output sent to STDOUT the +command generated. +Note that buffers are only available if you have C installed, +or if your system is able to work with C -- See below). +This element will be C if this is not the case. + +=item error_buffer + +This is an arrayreference containing all the output sent to STDERR the +command generated. +Note that buffers are only available if you have C installed, +or if your system is able to work with C -- See below). +This element will be C if this is not the case. + +=back + +See the C Section below to see how C decides +what modules or function calls to use when issuing a command. + +=cut + +sub run { + my %hash = @_; + + ### if the user didn't provide a buffer, we'll store it here. + my $def_buf = ''; + + my($verbose,$cmd,$buffer); + 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' } + }, + }; + + unless( check( $tmpl, \%hash, $VERBOSE ) ) { + Carp::carp(loc("Could not validate input: %1", Params::Check->last_error)); + return; + }; + + print loc("Running [%1]...\n", (ref $cmd ? "@$cmd" : $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 = __PACKAGE__->can_capture_buffer ? 1 : 0; + + ### flag indicating if the subcall went ok + my $ok; + + ### IPC::Run is first choice if $USE_IPC_RUN is set. + if( $USE_IPC_RUN and __PACKAGE__->can_use_ipc_run( 1 ) ) { + ### ipc::run handlers needs the command as a string or an array ref + + __PACKAGE__->_debug( "# Using IPC::Run. Have buffer: $have_buffer" ) + if $DEBUG; + + $ok = __PACKAGE__->_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 __PACKAGE__->can_use_ipc_open3( 1 ) ) { + + __PACKAGE__->_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 + $ok = __PACKAGE__->_open3_run( + ( ref $cmd ? "@$cmd" : $cmd ), + $_out_handler, $_err_handler, $verbose + ); + + ### if we are allowed to run verbose, just dispatch the system command + } else { + __PACKAGE__->_debug( "# Using system(). Have buffer: $have_buffer" ) + if $DEBUG; + $ok = __PACKAGE__->_system_run( (ref $cmd ? "@$cmd" : $cmd), $verbose ); + } + + ### 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, $?, \@buffer, \@buff_out, \@buff_err) + : ($ok, $? ) + : $ok + + +} + +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] + ); + __PACKAGE__->__dup_fds( @fds_to_dup ); + + + my $pid = IPC::Open3::open3( + '<&STDIN', + (IS_WIN32 ? '>&STDOUT' : $kidout), + (IS_WIN32 ? '>&STDERR' : $kiderror), + $cmd + ); + + ### 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 epxlicit break statement + ### code courtesy of theorbtwo from #london.pm + 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; + + ### child process is done printing. + last OUTER if $h == $kidout and $len == 0 + } + } + + waitpid $pid, 0; # wait for it to die + + ### restore STDIN after duping, or STDIN will be closed for + ### this current perl process! + __PACKAGE__->__reopen_fds( @fds_to_dup ); + + return if $?; # some error occurred + return 1; +} + + +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; + if( ref $cmd ) { + my $aref = []; + for my $item (@$cmd) { + if( $item =~ /([<>|&])/ ) { + push @command, $aref, $item; + $aref = []; + $special_chars .= $1; + } else { + push @$aref, $item; + } + } + push @command, $aref; + } else { + @command = map { if( /([<>|&])/ ) { + $special_chars .= $1; $_; + } else { + [ split / +/ ] + } + } split( /\s*([<>|&])\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 + return IPC::Run::run( @command, + fileno(STDOUT).'>', + $_out_handler, + fileno(STDERR).'>', + $_err_handler + ); +} + +sub _system_run { + my $self = shift; + my $cmd = shift; + my $verbose = shift || 0; + + my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR]; + __PACKAGE__->__dup_fds( @fds_to_dup ); + + ### system returns 'true' on failure -- the exit code of the cmd + system( $cmd ); + + __PACKAGE__->__reopen_fds( @fds_to_dup ); + + return if $?; + return 1; +} + +{ 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 compatibilty. 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 + 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 compatibilty. 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; +} + + +1; + + +__END__ + +=head1 HOW IT WORKS + +C will try to execute your command using the following logic: + +=over 4 + +=item * + +If you have C installed, and the variable C<$IPC::Cmd::USE_IPC_RUN> +is set to true (See the C Section) use that to execute +the command. You will have the full output available in buffers, interactive commands are sure to work and you are guaranteed to have your verbosity +settings honored cleanly. + +=item * + +Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true +(See the C Section), try to execute the command using +C. Buffers will be available on all platforms except C, +interactive commands will still execute cleanly, and also your verbosity +settings will be adhered to nicely; + +=item * + +Otherwise, if you have the verbose argument set to true, we fall back +to a simple system() call. We cannot capture any buffers, but +interactive commands will still work. + +=item * + +Otherwise we will try and temporarily redirect STDERR and STDOUT, do a +system() call with your command and then re-open STDERR and STDOUT. +This is the method of last resort and will still allow you to execute +your commands cleanly. However, no buffers will be available. + +=back + +=head1 Global Variables + +The behaviour of IPC::Cmd can be altered by changing the following +global variables: + +=head2 $IPC::Cmd::VERBOSE + +This controls whether IPC::Cmd will print any output from the +commands to the screen or not. The default is 0; + +=head2 $IPC::Cmd::USE_IPC_RUN + +This variable controls whether IPC::Cmd will try to use L +when available and suitable. Defaults to true if you are on C. + +=head2 $IPC::Cmd::USE_IPC_OPEN3 + +This variable controls whether IPC::Cmd will try to use L +when available and suitable. Defaults to true. + +=head2 $IPC::Cmd::WARN + +This variable controls whether run time warnings should be issued, like +the failure to load an C module you explicitly requested. + +Defaults to true. Turn this off at your own risk. + +=head1 Caveats + +=over 4 + +=item Whitespace + +When you provide a string as this argument, the string will be +split on whitespace to determine the individual elements of your +command. Although this will usually just Do What You Mean, it may +break if you have files or commands with whitespace in them. + +If you do not wish this to happen, you should provide an array +reference, where all parts of your command are already separated out. +Note however, if there's extra or spurious whitespace in these parts, +the parser or underlying code may not interpret it correctly, and +cause an error. + +Example: +The following code + + gzip -cdf foo.tar.gz | tar -xf - + +should either be passed as + + "gzip -cdf foo.tar.gz | tar -xf -" + +or as + + ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-'] + +But take care not to pass it as, for example + + ['gzip -cdf foo.tar.gz', '|', 'tar -xf -'] + +Since this will lead to issues as described above. + +=item IO Redirect + +Currently it is too complicated to parse your command for IO +Redirections. For capturing STDOUT or STDERR there is a work around +however, since you can just inspect your buffers for the contents. + +=back + +=head1 See Also + +C, C + +=head1 AUTHOR + +This module by +Jos Boumans Ekane@cpan.orgE. + +=head1 ACKNOWLEDGEMENTS + +Thanks to James Mastros and Martijn van der Streek for their +help in getting IPC::Open3 to behave nicely. + +=head1 COPYRIGHT + +This module is +copyright (c) 2002 - 2006 Jos Boumans Ekane@cpan.orgE. +All rights reserved. + +This library is free software; +you may redistribute and/or modify it under the same +terms as Perl itself. diff --git a/lib/IPC/Cmd/t/01_IPC-Cmd.t b/lib/IPC/Cmd/t/01_IPC-Cmd.t new file mode 100644 index 0000000..1607002 --- /dev/null +++ b/lib/IPC/Cmd/t/01_IPC-Cmd.t @@ -0,0 +1,208 @@ +## IPC::Cmd test suite ### + +BEGIN { chdir 't' if -d 't' }; + +use strict; +use lib qw[../lib]; +use File::Spec (); +use Test::More 'no_plan'; + +my $Class = 'IPC::Cmd'; +my @Funcs = qw[run can_run]; +my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer]; +my $IsWin32 = $^O eq 'MSWin32'; +my $Verbose = @ARGV ? 1 : 0; + +use_ok( $Class, $_ ) for @Funcs; +can_ok( $Class, $_ ) for @Funcs, @Meths; +can_ok( __PACKAGE__, $_ ) for @Funcs; + +my $Have_IPC_Run = $Class->can_use_ipc_run; +my $Have_IPC_Open3 = $Class->can_use_ipc_open3; + +$IPC::Cmd::VERBOSE = $IPC::Cmd::VERBOSE = $Verbose; + +### run tests in various configurations, based on what modules we have +my @Prefs = ( + [ $Have_IPC_Run, $Have_IPC_Open3 ], + [ 0, $Have_IPC_Open3 ], + [ 0, 0 ] +); + +### can_run tests +{ + ok( can_run('perl'), q[Found 'perl' in your path] ); + ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existant binary] ); +} + +### run tests +{ ### list of commands and regexes matching output ### + my $map = [ + # command # output regex + [ "$^X -v", qr/larry\s+wall/i, ], + [ [$^X, '-v'], qr/larry\s+wall/i, ], + [ "$^X -eprint+42 | $^X -neprint", qr/42/, ], + [ [$^X,qw[-eprint+42 |], $^X, qw|-neprint|], qr/42/, ], + ]; + + ### for each configuarion + for my $pref ( @Prefs ) { + diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" ) + if $Verbose; + + $IPC::Cmd::USE_IPC_RUN = $IPC::Cmd::USE_IPC_RUN = $pref->[0]; + $IPC::Cmd::USE_IPC_OPEN3 = $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1]; + + ### for each command + for my $aref ( @$map ) { + my $cmd = $aref->[0]; + my $regex = $aref->[1]; + + my $pp_cmd = ref $cmd ? "@$cmd" : "$cmd"; + diag( "Running '$pp_cmd' as " . (ref $cmd ? "ARRAY" : "SCALAR") ) + if $Verbose; + + ### in scalar mode + { diag( "Running scalar mode" ) if $Verbose; + my $buffer; + my $ok = run( command => $cmd, buffer => \$buffer ); + + ok( $ok, "Ran command succesfully" ); + + SKIP: { + skip "No buffers available", 1 + unless $Class->can_capture_buffer; + + like( $buffer, $regex, + " Buffer filled properly" ); + } + } + + ### in list mode + { diag( "Running list mode" ) if $Verbose; + my @list = run( command => $cmd ); + ok( $list[0], "Command ran successfully" ); + ok( !$list[1], " No error code set" ); + + my $list_length = $Class->can_capture_buffer ? 5 : 2; + is( scalar(@list), $list_length, + " Output list has $list_length entries" ); + + SKIP: { + skip "No buffers available", 6 + unless $Class->can_capture_buffer; + + ### the last 3 entries from the RV, are they array refs? + isa_ok( $list[$_], 'ARRAY' ) for 2..4; + + like( "@{$list[2]}", $regex, + " Combined buffer holds output" ); + + like( "@{$list[3]}", qr/$regex/, + " Stdout buffer filled" ); + is( scalar( @{$list[4]} ), 0, + " Stderr buffer empty" ); + } + } + } + } +} + + +### test failures +{ ### for each configuarion + for my $pref ( @Prefs ) { + diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" ) + if $Verbose; + + $IPC::Cmd::USE_IPC_RUN = $IPC::Cmd::USE_IPC_RUN = $pref->[0]; + $IPC::Cmd::USE_IPC_OPEN3 = $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1]; + + my $ok = run( command => "$^X -ledie" ); + ok( !$ok, "Failure caught" ); + } +} + +__END__ + + +### check if IPC::Run is already loaded, if so, IPC::Run tests +### from IPC::Run are known to fail on win32 +my $Skip_IPC_Run = ($^O eq 'MSWin32' && exists $INC{'IPC/Run.pm'}) ? 1 : 0; + +use_ok( 'IPC::Cmd' ) or diag "Cmd.pm not found. Dying", die; + +IPC::Cmd->import( qw[can_run run] ); + +### silence it ### +$IPC::Cmd::VERBOSE = $IPC::Cmd::VERBOSE = $ARGV[0] ? 1 : 0; + +{ + ok( can_run('perl'), q[Found 'perl' in your path] ); + ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existant binary] ); +} + + +{ ### list of commands and regexes matching output ### + my $map = [ + ["$^X -v", qr/larry\s+wall/i, ], + [[$^X, '-v'], qr/larry\s+wall/i, ], + ["$^X -eprint1 | $^X -neprint", qr/1/, ], + [[$^X,qw[-eprint1 |], $^X, qw|-neprint|], qr/1/, ], + ]; + + my @prefs = ( [1,1], [0,1], [0,0] ); + + ### if IPC::Run is already loaded,remove tests involving IPC::Run + ### when on win32 + shift @prefs if $Skip_IPC_Run; + + for my $pref ( @prefs ) { + $IPC::Cmd::USE_IPC_RUN = $IPC::Cmd::USE_IPC_RUN = $pref->[0]; + $IPC::Cmd::USE_IPC_OPEN3 = $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1]; + + for my $aref ( @$map ) { + my $cmd = $aref->[0]; + my $regex = $aref->[1]; + + my $Can_Buffer; + my $captured; + my $ok = run( command => $cmd, + buffer => \$captured, + ); + + ok($ok, q[Successful run of command] ); + + SKIP: { + skip "No buffers returned", 1 unless $captured; + like( $captured, $regex, q[ Buffer filled] ); + + ### if we get here, we have buffers ### + $Can_Buffer++; + } + + my @list = run( command => $cmd ); + ok( $list[0], "Command ran successfully" ); + ok( !$list[1], " No error code set" ); + + SKIP: { + skip "No buffers, cannot do buffer tests", 3 + unless $Can_Buffer; + + ok( (grep /$regex/, @{$list[2]}), + " Out buffer filled" ); + SKIP: { + skip "IPC::Run bug prevents separated " . + "stdout/stderr buffers", 2 if $pref->[0]; + + ok( (grep /$regex/, @{$list[3]}), + " Stdout buffer filled" ); + ok( @{$list[4]} == 0, + " Stderr buffer empty" ); + } + } + } + } +} + + diff --git a/lib/IPC/Cmd/t/02_Interactive.t b/lib/IPC/Cmd/t/02_Interactive.t new file mode 100644 index 0000000..a8d48a0 --- /dev/null +++ b/lib/IPC/Cmd/t/02_Interactive.t @@ -0,0 +1,110 @@ +BEGIN { chdir 't' if -d 't' }; +BEGIN { use lib '../lib' }; + +use strict; +use File::Spec; + +### only run interactive tests when there's someone that can answer them +use Test::More -t STDOUT + ? 'no_plan' + : ( skip_all => "No interactive tests from harness" ); + +my $Class = 'IPC::Cmd'; +my $Child = File::Spec->catfile( qw[src child.pl] ); +my @FDs = 0..20; +my $IsWin32 = $^O eq 'MSWin32'; + +use_ok( $Class, 'run' ); +$IPC::Cmd::DEBUG = 1; + +my $Have_IPC_Run = $Class->can_use_ipc_run; +my $Have_IPC_Open3 = $Class->can_use_ipc_open3; + +### configurations to test IPC::Cmd with +my @Conf = ( + [ $Have_IPC_Run, $Have_IPC_Open3 ], + [ 0, $Have_IPC_Open3 ], + [ 0, 0 ] +); + + + + +### first, check which FD's are open. they should be open +### /after/ we run our tests as well. +### 0, 1 and 2 should be open, as they are STDOUT, STDERR and STDIN +### XXX 2 are opened by Test::Builder at least.. this is 'whitebox' +### knowledge, so unsafe to test against. around line 1322: +# sub _open_testhandles { +# return if $Opened_Testhandles; +# # We dup STDOUT and STDERR so people can change them in their +# # test suites while still getting normal test output. +# open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; +# open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; +# $Opened_Testhandles = 1; +# } + +my @Opened; +{ for ( @FDs ) { + my $fh; + my $rv = open $fh, "<&$_"; + push @Opened, $_ if $rv; + } + diag( "Opened FDs: @Opened" ); + cmp_ok( scalar(@Opened), '>=', 3, + "At least 3 FDs are opened" ); +} + +for my $aref ( @Conf ) { + + ### stupid warnings + local $IPC::Cmd::USE_IPC_RUN = $aref->[0]; + local $IPC::Cmd::USE_IPC_RUN = $aref->[0]; + + local $IPC::Cmd::USE_IPC_OPEN3 = $aref->[1]; + local $IPC::Cmd::USE_IPC_OPEN3 = $aref->[1]; + + diag("Config: IPC::Run = $aref->[0] IPC::Open3 = $aref->[1]"); + ok( -t STDIN, "STDIN attached to a tty" ); + + for my $cmd ( qq[$^X $Child], qq[$^X $Child | $^X -neprint] ) { + + diag("Please enter some input. It will be echo'd back to you"); + my $buffer; + my $ok = run( command => $cmd, verbose => 1, buffer => \$buffer ); + + ok( $ok, " Command '$cmd' ran succesfully" ); + + SKIP: { + skip "No buffers available", 1 unless $Class->can_capture_buffer; + ok( defined $buffer, " Input captured" ); + } + } +} + +### check we didnt leak any FHs +{ ### should be opened + my %open = map { $_ => 1 } @Opened; + + for ( @FDs ) { + my $fh; + my $rv = open $fh, "<&=$_"; + + ### these should be open + if( $open{$_} ) { + ok( $rv, "FD $_ opened" ); + ok( $fh, " FH indeed opened" ); + is( fileno($fh), $_, " Opened at the correct fileno($_)" ); + } else { + ok( !$rv, "FD $_ not opened" ); + ok( !(fileno($fh)), " FH indeed closed" ); + + ### extra debug info if tests fail +# use Devel::Peek; +# use Data::Dumper; +# diag( "RV=$rv FH=$fh Fileno=". fileno($fh). Dump($fh) ) if $rv; +# diag( Dumper( [stat $fh] ) ) if $rv; + + } + } +} diff --git a/lib/IPC/Cmd/t/src/child.pl b/lib/IPC/Cmd/t/src/child.pl new file mode 100644 index 0000000..3c19825 --- /dev/null +++ b/lib/IPC/Cmd/t/src/child.pl @@ -0,0 +1,4 @@ +$|++; +print "# Child has TTY? " . (-t STDIN ? "YES" : "NO" ) . $/; +print $_ = <>; +