This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add IPC::Cmd to the core
authorRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Tue, 28 Nov 2006 10:45:06 +0000 (10:45 +0000)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Tue, 28 Nov 2006 10:45:06 +0000 (10:45 +0000)
p4raw-id: //depot/perl@29401

MANIFEST
lib/IPC/Cmd.pm [new file with mode: 0644]
lib/IPC/Cmd/t/01_IPC-Cmd.t [new file with mode: 0644]
lib/IPC/Cmd/t/02_Interactive.t [new file with mode: 0644]
lib/IPC/Cmd/t/src/child.pl [new file with mode: 0644]

index 08cb019..ea1068a 100644 (file)
--- 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 (file)
index 0000000..c941c76
--- /dev/null
@@ -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<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 $bool = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
+
+Utility function that tells you if C<IPC::Run> is available. 
+If the verbose flag is passed, it will print diagnostic messages
+if C<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 1;                    
+}
+
+=head2 $bool = 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 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<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 && !IS_WIN32; 
+    return;
+}
+
+
+=head1 FUNCTIONS
+
+=head2 $path = can_run( PROGRAM );
+
+C<can_run> takes but a single 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.
+
+It will return the full path to the binary you asked for if it was
+found, or C<undef> 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<run> 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<CAVEATS> 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<IPC::Run> to be installed or your system able to work with
+C<IPC::Open3>).
+
+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<run> 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<run> will return a simple C<true> or C<false> 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<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> 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<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> 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<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=back
+
+See the C<HOW IT WORKS> Section below to see how C<IPC::Cmd> 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<run> will try to execute your command using the following logic:
+
+=over 4
+
+=item *
+
+If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
+is set to true (See the C<GLOBAL VARIABLES> 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<GLOBAL VARIABLES> Section), try to execute the command using
+C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
+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<IPC::Run>
+when available and suitable. Defaults to true if you are on C<Win32>.
+
+=head2 $IPC::Cmd::USE_IPC_OPEN3
+
+This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
+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<IPC::*> 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<IPC::Run>, C<IPC::Open3>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=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 E<lt>kane@cpan.orgE<gt>.
+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 (file)
index 0000000..1607002
--- /dev/null
@@ -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 (file)
index 0000000..a8d48a0
--- /dev/null
@@ -0,0 +1,110 @@
+BEGIN { chdir 't' if -d 't' };\r
+BEGIN { use lib '../lib' };\r
+\r
+use strict;\r
+use File::Spec;\r
+\r
+### only run interactive tests when there's someone that can answer them\r
+use Test::More -t STDOUT\r
+                    ? 'no_plan' \r
+                    : ( skip_all => "No interactive tests from harness" );\r
+\r
+my $Class   = 'IPC::Cmd';\r
+my $Child   = File::Spec->catfile( qw[src child.pl] );\r
+my @FDs     = 0..20;\r
+my $IsWin32 = $^O eq 'MSWin32';\r
+\r
+use_ok( $Class, 'run' );\r
+$IPC::Cmd::DEBUG = 1;\r
+\r
+my $Have_IPC_Run    = $Class->can_use_ipc_run;\r
+my $Have_IPC_Open3  = $Class->can_use_ipc_open3;\r
+\r
+### configurations to test IPC::Cmd with\r
+my @Conf = ( \r
+    [ $Have_IPC_Run, $Have_IPC_Open3 ], \r
+    [ 0,             $Have_IPC_Open3 ], \r
+    [ 0,             0 ] \r
+);\r
+\r
+\r
+\r
+\r
+### first, check which FD's are open. they should be open\r
+### /after/ we run our tests as well.\r
+### 0, 1 and 2 should be open, as they are STDOUT, STDERR and STDIN\r
+### XXX 2 are opened by Test::Builder at least.. this is 'whitebox'\r
+### knowledge, so unsafe to test against. around line 1322:\r
+# sub _open_testhandles {\r
+#     return if $Opened_Testhandles;\r
+#     # We dup STDOUT and STDERR so people can change them in their\r
+#     # test suites while still getting normal test output.\r
+#     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";\r
+#     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";\r
+#     $Opened_Testhandles = 1;\r
+# }\r
+\r
+my @Opened;\r
+{   for ( @FDs ) {\r
+        my $fh;\r
+        my $rv = open $fh, "<&$_";\r
+        push @Opened, $_ if $rv;\r
+    }\r
+    diag( "Opened FDs: @Opened" );\r
+    cmp_ok( scalar(@Opened), '>=', 3,\r
+                                "At least 3 FDs are opened" );\r
+}\r
+\r
+for my $aref ( @Conf ) {\r
+\r
+    ### stupid warnings\r
+    local $IPC::Cmd::USE_IPC_RUN    = $aref->[0];\r
+    local $IPC::Cmd::USE_IPC_RUN    = $aref->[0];\r
+\r
+    local $IPC::Cmd::USE_IPC_OPEN3  = $aref->[1];\r
+    local $IPC::Cmd::USE_IPC_OPEN3  = $aref->[1];\r
+\r
+    diag("Config: IPC::Run = $aref->[0] IPC::Open3 = $aref->[1]");\r
+    ok( -t STDIN,               "STDIN attached to a tty" );\r
+    \r
+    for my $cmd ( qq[$^X $Child], qq[$^X $Child | $^X -neprint] ) {\r
+    \r
+        diag("Please enter some input. It will be echo'd back to you");\r
+        my $buffer;\r
+        my $ok = run( command => $cmd, verbose => 1, buffer => \$buffer );\r
+    \r
+        ok( $ok,                    "   Command '$cmd' ran succesfully" );\r
+    \r
+        SKIP: {\r
+            skip "No buffers available", 1 unless $Class->can_capture_buffer;\r
+            ok( defined $buffer,    "   Input captured" );\r
+        }\r
+    }\r
+}\r
+\r
+### check we didnt leak any FHs\r
+{   ### should be opened\r
+    my %open = map { $_ => 1 } @Opened;\r
+    \r
+    for ( @FDs ) {\r
+        my $fh;\r
+        my $rv = open $fh, "<&=$_";\r
+     \r
+        ### these should be open \r
+        if( $open{$_} ) {\r
+            ok( $rv,                "FD $_ opened" );\r
+            ok( $fh,                "   FH indeed opened" );\r
+            is( fileno($fh), $_,    "   Opened at the correct fileno($_)" );\r
+        } else {\r
+            ok( !$rv,               "FD $_ not opened" );\r
+            ok( !(fileno($fh)),     "   FH indeed closed" );\r
+\r
+            ### extra debug info if tests fail\r
+#             use Devel::Peek;\r
+#             use Data::Dumper;\r
+#             diag( "RV=$rv FH=$fh Fileno=". fileno($fh). Dump($fh) ) if $rv;\r
+#             diag( Dumper( [stat $fh] ) )                            if $rv;\r
+\r
+        }\r
+    }\r
+}\r
diff --git a/lib/IPC/Cmd/t/src/child.pl b/lib/IPC/Cmd/t/src/child.pl
new file mode 100644 (file)
index 0000000..3c19825
--- /dev/null
@@ -0,0 +1,4 @@
+$|++;
+print "# Child has TTY? " . (-t STDIN ? "YES" : "NO" ) . $/;
+print $_ = <>;
+