view release on metacpan or  search on metacpan

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

        __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 -']
    # ]