view release on metacpan or  search on metacpan

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

    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>,

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

        $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 ) {