view release on metacpan or  search on metacpan

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

    
    ### 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(

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

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