<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package TAP::Parser::Iterator::Process;

use strict;
use warnings;

use Config;
use IO::Handle;

use base 'TAP::Parser::Iterator';

my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );

=head1 NAME

TAP::Parser::Iterator::Process - Iterator for process-based TAP sources

=head1 VERSION

Version 3.50

=cut

our $VERSION = '3.50';

=head1 SYNOPSIS

  use TAP::Parser::Iterator::Process;
  my %args = (
   command  =&gt; ['python', 'setup.py', 'test'],
   merge    =&gt; 1,
   setup    =&gt; sub { ... },
   teardown =&gt; sub { ... },
  );
  my $it   = TAP::Parser::Iterator::Process-&gt;new(\%args);
  my $line = $it-&gt;next;

=head1 DESCRIPTION

This is a simple iterator wrapper for executing external processes, used by
L&lt;TAP::Parser&gt;.  Unless you're writing a plugin or subclassing, you probably
won't need to use this module directly.

=head1 METHODS

=head2 Class Methods

=head3 C&lt;new&gt;

Create an iterator.  Expects one argument containing a hashref of the form:

   command  =&gt; \@command_to_execute
   merge    =&gt; $attempt_merge_stderr_and_stdout?
   setup    =&gt; $callback_to_setup_command
   teardown =&gt; $callback_to_teardown_command

Tries to uses L&lt;IPC::Open3&gt; &amp; L&lt;IO::Select&gt; to communicate with the spawned
process if they are available.  Falls back onto C&lt;open()&gt;.

=head2 Instance Methods

=head3 C&lt;next&gt;

Iterate through the process output, of course.

=head3 C&lt;next_raw&gt;

Iterate raw input without applying any fixes for quirky input syntax.

=head3 C&lt;wait&gt;

Get the wait status for this iterator's process.

=head3 C&lt;exit&gt;

Get the exit status for this iterator's process.

=cut

{

    no warnings 'uninitialized';
       # get around a catch22 in the test suite that causes failures on Win32:
    local $SIG{__DIE__} = undef;
    eval { require POSIX; &amp;POSIX::WEXITSTATUS(0) };
    if ($@) {
        *_wait2exit = sub { $_[1] &gt;&gt; 8 };
    }
    else {
        *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
    }
}

sub _use_open3 {
    my $self = shift;
    return unless $Config{d_fork} || $IS_WIN32;
    for my $module (qw( IPC::Open3 IO::Select )) {
        eval "use $module";
        return if $@;
    }
    return 1;
}

{
    my $got_unicode;

    sub _get_unicode {
        return $got_unicode if defined $got_unicode;
        eval 'use Encode qw(decode_utf8);';
        $got_unicode = $@ ? 0 : 1;

    }
}

# new() implementation supplied by TAP::Object

sub _initialize {
    my ( $self, $args ) = @_;

    my @command = @{ delete $args-&gt;{command} || [] }
      or die "Must supply a command to execute";

    $self-&gt;{command} = [@command];

    # Private. Used to frig with chunk size during testing.
    my $chunk_size = delete $args-&gt;{_chunk_size} || 65536;

    my $merge = delete $args-&gt;{merge};
    my ( $pid, $err, $sel );

    if ( my $setup = delete $args-&gt;{setup} ) {
        $setup-&gt;(@command);
    }

    my $out = IO::Handle-&gt;new;

    if ( $self-&gt;_use_open3 ) {

        # HOTPATCH {{{
        my $xclose = \&amp;IPC::Open3::xclose;
        no warnings;
        local *IPC::Open3::xclose = sub {
            my $fh = shift;
            no strict 'refs';
            return if ( fileno($fh) == fileno(STDIN) );
            $xclose-&gt;($fh);
        };

        # }}}

        if ($IS_WIN32) {
            $err = $merge ? '' : '&gt;&amp;STDERR';
            eval {
                $pid = open3(
                    '&lt;&amp;STDIN', $out, $merge ? '' : $err,
                    @command
                );
            };
            die "Could not execute (@command): $@" if $@;
            if ( $] &gt;= 5.006 ) {
                binmode($out, ":crlf");
            }
        }
        else {
            $err = $merge ? '' : IO::Handle-&gt;new;
            eval { $pid = open3( '&lt;&amp;STDIN', $out, $err, @command ); };
            die "Could not execute (@command): $@" if $@;
            $sel = $merge ? undef : IO::Select-&gt;new( $out, $err );
        }
    }
    else {
        $err = '';
        my $exec = shift @command;
        $exec = qq{"$exec"} if $exec =~ /\s/ and -x $exec;
        my $command
          = join( ' ', $exec, map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
        open( $out, "$command|" )
          or die "Could not execute ($command): $!";
    }

    $self-&gt;{out}        = $out;
    $self-&gt;{err}        = $err;
    $self-&gt;{sel}        = $sel;
    $self-&gt;{pid}        = $pid;
    $self-&gt;{exit}       = undef;
    $self-&gt;{chunk_size} = $chunk_size;

    if ( my $teardown = delete $args-&gt;{teardown} ) {
        $self-&gt;{teardown} = sub {
            $teardown-&gt;(@command);
        };
    }

    return $self;
}

=head3 C&lt;handle_unicode&gt;

Upgrade the input stream to handle UTF8.

=cut

sub handle_unicode {
    my $self = shift;

    if ( $self-&gt;{sel} ) {
        if ( _get_unicode() ) {

            # Make sure our iterator has been constructed and...
            my $next = $self-&gt;{_next} ||= $self-&gt;_next;

            # ...wrap it to do UTF8 casting
            $self-&gt;{_next} = sub {
                my $line = $next-&gt;();
                return decode_utf8($line) if defined $line;
                return;
            };
        }
    }
    else {
        if ( $] &gt;= 5.008 ) {
            eval 'binmode($self-&gt;{out}, ":utf8")';
        }
    }

}

##############################################################################

sub wait { shift-&gt;{wait} }
sub exit { shift-&gt;{exit} }

sub _next {
    my $self = shift;

    if ( my $out = $self-&gt;{out} ) {
        if ( my $sel = $self-&gt;{sel} ) {
            my $err        = $self-&gt;{err};
            my @buf        = ();
            my $partial    = '';                    # Partial line
            my $chunk_size = $self-&gt;{chunk_size};
            return sub {
                return shift @buf if @buf;

                READ:
                while ( my @ready = $sel-&gt;can_read ) {
                    for my $fh (@ready) {
                        my $got = sysread $fh, my ($chunk), $chunk_size;

                        if ( $got == 0 ) {
                            $sel-&gt;remove($fh);
                        }
                        elsif ( $fh == $err ) {
                            print STDERR $chunk;    # echo STDERR
                        }
                        else {
                            $chunk   = $partial . $chunk;
                            $partial = '';

                            # Make sure we have a complete line
                            unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
                                my $nl = rindex $chunk, "\n";
                                if ( $nl == -1 ) {
                                    $partial = $chunk;
                                    redo READ;
                                }
                                else {
                                    $partial = substr( $chunk, $nl + 1 );
                                    $chunk = substr( $chunk, 0, $nl );
                                }
                            }

                            push @buf, split /\n/, $chunk;
                            return shift @buf if @buf;
                        }
                    }
                }

                # Return partial last line
                if ( length $partial ) {
                    my $last = $partial;
                    $partial = '';
                    return $last;
                }

                $self-&gt;_finish;
                return;
            };
        }
        else {
            return sub {
                local $/ = "\n"; # to ensure lines
                if ( defined( my $line = &lt;$out&gt; ) ) {
                    chomp $line;
                    return $line;
                }
                $self-&gt;_finish;
                return;
            };
        }
    }
    else {
        return sub {
            $self-&gt;_finish;
            return;
        };
    }
}

sub next_raw {
    my $self = shift;
    return ( $self-&gt;{_next} ||= $self-&gt;_next )-&gt;();
}

sub _finish {
    my $self = shift;

    my $status = $?;

    # Avoid circular refs
    $self-&gt;{_next} = sub {return}
      if $] &gt;= 5.006;

    # If we have a subprocess we need to wait for it to terminate
    if ( defined $self-&gt;{pid} ) {
        if ( $self-&gt;{pid} == waitpid( $self-&gt;{pid}, 0 ) ) {
            $status = $?;
        }
    }

    ( delete $self-&gt;{out} )-&gt;close if $self-&gt;{out};

    # If we have an IO::Select we also have an error handle to close.
    if ( $self-&gt;{sel} ) {
        ( delete $self-&gt;{err} )-&gt;close;
        delete $self-&gt;{sel};
    }
    else {
        $status = $?;
    }

    # Sometimes we get -1 on Windows. Presumably that means status not
    # available.
    $status = 0 if $IS_WIN32 &amp;&amp; $status == -1;

    $self-&gt;{wait} = $status;
    $self-&gt;{exit} = $self-&gt;_wait2exit($status);

    if ( my $teardown = $self-&gt;{teardown} ) {
        $teardown-&gt;();
    }

    return $self;
}

=head3 C&lt;get_select_handles&gt;

Return a list of filehandles that may be used upstream in a select()
call to signal that this Iterator is ready. Iterators that are not
handle based should return an empty list.

=cut

sub get_select_handles {
    my $self = shift;
    return grep $_, ( $self-&gt;{out}, $self-&gt;{err} );
}

1;

=head1 ATTRIBUTION

Originally ripped off from L&lt;Test::Harness&gt;.

=head1 SEE ALSO

L&lt;TAP::Object&gt;,
L&lt;TAP::Parser&gt;,
L&lt;TAP::Parser::Iterator&gt;,

=cut

</pre></body></html>