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

Test-Harness documentation Contained in the Test-Harness distribution.

Index

Code Index:

NAME

Top

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

VERSION

Top

Version 3.23

SYNOPSIS

Top

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

DESCRIPTION

Top

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

METHODS

Top

Class Methods

new

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

   command  => \@command_to_execute
   merge    => $attempt_merge_stderr_and_stdout?
   setup    => $callback_to_setup_command
   teardown => $callback_to_teardown_command

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

Instance Methods

next

Iterate through the process output, of course.

next_raw

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

wait

Get the wait status for this iterator's process.

exit

Get the exit status for this iterator's process.

handle_unicode

Upgrade the input stream to handle UTF8.

get_select_handles

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.

ATTRIBUTION

Top

Originally ripped off from Test::Harness.

SEE ALSO

Top

TAP::Object, TAP::Parser, TAP::Parser::Iterator,

Test-Harness documentation Contained in the Test-Harness distribution. 
package TAP::Parser::Iterator::Process;

use strict;
use vars qw($VERSION @ISA);

use TAP::Parser::Iterator ();
use Config;
use IO::Handle;

@ISA = 'TAP::Parser::Iterator';

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


$VERSION = '3.23';


{

    local $^W;    # no warnings
       # get around a catch22 in the test suite that causes failures on Win32:
    local $SIG{__DIE__} = undef;
    eval { require POSIX; &POSIX::WEXITSTATUS(0) };
    if ($@) {
        *_wait2exit = sub { $_[1] >> 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->{command} || [] }
      or die "Must supply a command to execute";

    $self->{command} = [@command];

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

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

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

    my $out = IO::Handle->new;

    if ( $self->_use_open3 ) {

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

        # }}}

        if ($IS_WIN32) {
            $err = $merge ? '' : '>&STDERR';
            eval {
                $pid = open3(
                    '<&STDIN', $out, $merge ? '' : $err,
                    @command
                );
            };
            die "Could not execute (@command): $@" if $@;
            if ( $] >= 5.006 ) {

                # Kludge to avoid warning under 5.5
                eval 'binmode($out, ":crlf")';
            }
        }
        else {
            $err = $merge ? '' : IO::Handle->new;
            eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
            die "Could not execute (@command): $@" if $@;
            $sel = $merge ? undef : IO::Select->new( $out, $err );
        }
    }
    else {
        $err = '';
        my $command
          = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
        open( $out, "$command|" )
          or die "Could not execute ($command): $!";
    }

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

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

    return $self;
}


sub handle_unicode {
    my $self = shift;

    if ( $self->{sel} ) {
        if ( _get_unicode() ) {

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

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

}

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

sub wait { shift->{wait} }
sub exit { shift->{exit} }

sub _next {
    my $self = shift;

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

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

                        if ( $got == 0 ) {
                            $sel->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->_finish;
                return;
            };
        }
        else {
            return sub {
                if ( defined( my $line = <$out> ) ) {
                    chomp $line;
                    return $line;
                }
                $self->_finish;
                return;
            };
        }
    }
    else {
        return sub {
            $self->_finish;
            return;
        };
    }
}

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

sub _finish {
    my $self = shift;

    my $status = $?;

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

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

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

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

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

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

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

    return $self;
}


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

1;