view release on metacpan or  search on metacpan

nsis/ipc_run/Run.txt  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;

nsis/ipc_run/Run.txt  view on Meta::CPAN

    $self->_select_loop;
    return $self->pumpable;

    #   };
    #   if ( $@ ) {
    #      my $x = $@;
    #      _debug $x if _debugging && $x;
    #      eval { $self->_cleanup };
    #      warn $@ if $@;
    #      die $x;
    #   }
    #   return $r;
}

=pod

=item pump_nb

   pump_nb $h;
   $h->pump_nb;

"pump() non-blocking", pumps if anything's ready to be pumped, returns
immediately otherwise.  This is useful if you're doing some long-running
task in the foreground, but don't want to starve any child processes.

=cut

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

    $self->{non_blocking} = 1;
    my $r = eval { $self->pump };
    $self->{non_blocking} = 0;
    die $@ if $@;
    return $r;
}

=pod

=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.

=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} } ) {