view release on metacpan or  search on metacpan

lib/IPC/Run.pm  view on Meta::CPAN

                        _debug(
                            "kid ",               $kid->{NUM},   " to write ", $op->{KFD},
                            " to CODE via pty '", $op->{PTY_ID}, "'"
                        ) if _debugging_details;
                    }
                    else {
                        croak( "'" . ref($dest) . "' not allowed as a sink for output redirection" );
                    }

                    $op->{FD}                       = $self->{PTYS}->{ $op->{PTY_ID} }->fileno;
                    $op->{TFD}                      = undef;                                      # The fd isn't known until after fork().
                    $output_fds_accum[ $op->{KFD} ] = $op;
                    $op->_init_filters;
                }
                elsif ( $op->{TYPE} eq '|' ) {
                    _debug( "pipelining $kid->{NUM} and " . ( $kid->{NUM} + 1 ) ) if _debugging_details;
                    ( $pipe_read_fd, $op->{TFD} ) = _pipe;
                    if (Win32_MODE) {
                        _dont_inherit($pipe_read_fd);
                        _dont_inherit( $op->{TFD} );
                    }
                    @output_fds_accum = ();
                }
                elsif ( $op->{TYPE} eq '&' ) {
                    @output_fds_accum = ();
                }    # end if $op->{TYPE} tree
                1;
            };    # end eval
            unless ($ok) {
                push @errs, $@;
                _debug 'caught ', $@ if _debugging;
            }
        }    # end for ( OPS }
    }

    if (@errs) {
        for (@close_on_fail) {
            _close($_);
            $_ = undef;
        }
        for ( keys %{ $self->{PTYS} } ) {
            next unless $self->{PTYS}->{$_};
            close $self->{PTYS}->{$_};
            $self->{PTYS}->{$_} = undef;
        }
        die join( '', @errs );
    }

    ## give all but the last child all of the output file descriptors
    ## These will be reopened (and thus rendered useless) if the child
    ## dup2s on to these descriptors, since we unshift these.  This way
    ## each process emits output to the same file descriptors that the
    ## last child will write to.  This is probably not quite correct,
    ## since each child should write to the file descriptors inherited
    ## from the parent.
    ## TODO: fix the inheritance of output file descriptors.
    ## NOTE: This sharing of OPS among kids means that we can't easily put
    ## a kid number in each OPS structure to ping the kid when all ops
    ## have closed (when $self->{PIPES} has emptied).  This means that we
    ## need to scan the KIDS whenever @{$self->{PIPES}} is empty to see
    ## if there any of them are still alive.
    for ( my $num = 0; $num < $#{ $self->{KIDS} }; ++$num ) {
        for ( reverse @output_fds_accum ) {
            next unless defined $_;
            _debug(
                'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD},
                ' to ', ref $_->{DEST}
            ) if _debugging_details;
            unshift @{ $self->{KIDS}->[$num]->{OPS} }, $_;
        }
    }

    ## Open the debug pipe if we need it
    ## Create the list of PIPES we need to scan and the bit vectors needed by
    ## select().  Do this first so that _cleanup can _clobber() them if an
    ## exception occurs.
    @{ $self->{PIPES} } = ();
    $self->{RIN} = '';
    $self->{WIN} = '';
    $self->{EIN} = '';
    ## PIN is a vec()tor that indicates who's paused.
    $self->{PIN} = '';
    for my $kid ( @{ $self->{KIDS} } ) {
        for ( @{ $kid->{OPS} } ) {
            if ( defined $_->{FD} ) {
                _debug(
                    'kid ',    $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD},
                    ' is my ', $_->{FD}
                ) if _debugging_details;
                vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1;

                #	    vec( $self->{EIN}, $_->{FD}, 1 ) = 1;
                push @{ $self->{PIPES} }, $_;
            }
        }
    }

    for my $io ( @{ $self->{IOS} } ) {
        my $fd = $io->fileno;
        vec( $self->{RIN}, $fd, 1 ) = 1 if $io->mode =~ /r/;
        vec( $self->{WIN}, $fd, 1 ) = 1 if $io->mode =~ /w/;

        #      vec( $self->{EIN}, $fd, 1 ) = 1;
        push @{ $self->{PIPES} }, $io;
    }

    ## Put filters on the end of the filter chains to read & write the pipes.
    ## Clear pipe states
    for my $pipe ( @{ $self->{PIPES} } ) {
        $pipe->{SOURCE_EMPTY} = 0;
        $pipe->{PAUSED}       = 0;
        if ( $pipe->{TYPE} =~ /^>/ ) {
            my $pipe_reader = sub {
                my ( undef, $out_ref ) = @_;

                return undef unless defined $pipe->{FD};
                return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 );

                vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0;

                _debug_desc_fd( 'reading from', $pipe ) if _debugging_details;

lib/IPC/Run.pm  view on Meta::CPAN

    croak "harness has not been started" unless $self->{STATE} >= _started;

    _debug "** closing stdin" if _debugging;

    # Match all input pipe types: '<' (plain), '<pipe', '<pty<', etc.
    # _clobber() handles each type appropriately: for regular pipes it
    # closes the fd (signaling EOF to the child); for input ptys it
    # removes them from the select vectors without closing the pty
    # master (consistent with _clobber's existing pty safety logic).
    for my $pipe ( @{ $self->{PIPES} } ) {
        next unless $pipe->{TYPE} =~ /^</;
        $self->_clobber($pipe);
    }

    return $self;
}

=pod

=item started

Returns TRUE if the harness has been started and has not yet finished.
This is useful when a harness may or may not have been started by the
caller, and you want to conditionally start it:

    $h->start unless $h->started;

=cut

sub started {
    my IPC::Run $self = shift;
    return $self->{STATE} >= _started;
}

=item pumpable

Returns TRUE if calling pump() won't throw an immediate "process ended
prematurely" exception.  This means that there are open I/O channels or
active processes. May yield the parent processes' time slice for 0.01
second if all pipes are to the child and all are paused.  In this case
we can't tell if the child is dead, so we yield the processor and
then attempt to reap the child in a nonblocking way.

To wait for child processes to exit during an event loop, poll
C<$h->pumpable> until it returns false, then call C<finish>.
See also L</finished> to test whether the harness has already been
finished.

=cut

## Undocumented feature (don't depend on it outside this module):
## returns -1 if we have I/O channels open, or >0 if no I/O channels
## open, but we have kids running.  This allows the select loop
## to poll for child exit.
sub pumpable {
    my IPC::Run $self = shift;

    ## There's a catch-22 we can get in to if there is only one pipe left
    ## open to the child and it's paused (ie the SCALAR it's tied to
    ## is '').  It's paused, so we're not select()ing on it, so we don't
    ## check it to see if the child attached to it is alive and it stays
    ## in @{$self->{PIPES}} forever.  So, if all pipes are paused, see if
    ## we can reap the child.
    return -1 if grep !$_->{PAUSED}, @{ $self->{PIPES} };

    ## See if the child is dead.
    $self->reap_nb;
    return 0 unless $self->_running_kids;

    ## If we reap_nb and it's not dead yet, yield to it to see if it
    ## exits.
    ##
    ## A better solution would be to unpause all the pipes, but I tried that
    ## and it never errored on linux.  Sigh.
    select undef, undef, undef, 0.0001;

    ## try again
    $self->reap_nb;
    return 0 unless $self->_running_kids;

    return -1;    ## There are pipes waiting
}

sub _running_kids {
    my IPC::Run $self = shift;
    return grep
      defined $_->{PID} && !defined $_->{RESULT},
      @{ $self->{KIDS} };
}

=pod

=item reap_nb

Attempts to reap child processes, but does not block.

Does not currently take any parameters, one day it will allow specific
children to be reaped.

Only call this from a signal handler if your C<perl> is recent enough
to have safe signal handling (5.6.1 did not, IIRC, but it was being discussed
on perl5-porters).  Calling this (or doing any significant work) in a signal
handler on older C<perl>s is asking for seg faults.

=cut

my $still_runnings;

sub reap_nb {
    my IPC::Run $self = shift;

    local $cur_self = $self;

    ## No more pipes, look to see if all the kids yet live, reaping those
    ## that haven't.  I'd use $SIG{CHLD}/$SIG{CLD}, but that's broken
    ## on older (SYSV) platforms and perhaps less portable than waitpid().
    ## This could be slow with a lot of kids, but that's rare and, well,
    ## a lot of kids is slow in the first place.
    ## Oh, and this keeps us from reaping other children the process
    ## may have spawned.
    for my $kid ( @{ $self->{KIDS} } ) {