File Coverage

blib/lib/TAPx/Parser/Source.pm

Criterion	Covered	Total	%
statement	57	73	78.0
branch	7	16	43.7
condition			n/a
subroutine	15	18	83.3
pod	6	6	100.0
total	85	113	75.2

package TAPx::Parser::Source;

use strict;
use vars qw($VERSION);

use IPC::Open3;
use IO::Select;
use IO::Handle;

use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant IS_MACOS => ( $^O eq 'MacOS' );
use constant IS_VMS   => ( $^O eq 'VMS' );

use TAPx::Parser::Iterator;

# Causes problem on MacOS and shouldn't be necessary anyway
#$SIG{CHLD} = sub { wait };

=head1 NAME

TAPx::Parser::Source - Stream output from some source

=head1 VERSION

Version 0.50_07

=cut

$VERSION = '0.50_07';

=head1 DESCRIPTION

Takes a command and hopefully returns a stream from it.

=head1 SYNOPSIS

 use TAPx::Parser::Source;
 my $source = TAPx::Parser::Source->new;
 my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;

=head1 METHODS

=head2 Class methods

=head3 C

 my $source = TAPx::Parser::Source->new;

Returns a new C object.

=cut

sub new {
    my $class = shift;
    _autoflush( \*STDOUT );
    _autoflush( \*STDERR );
    bless { switches => [] }, $class;
}

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

=head2 Instance methods

=head3 C

 my $source = $source->source;
 $source->source(['./some_prog some_test_file']);

 # or
 $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);

Getter/setter for the source.  The source should generally consist of an array
reference of strings which, when executed via C<&IPC::Open3::open3>, should
return a filehandle which returns successive rows of TAP.

=cut

sub source {
    my $self = shift;
    return $self->{source} unless @_;
    unless ( 'ARRAY' eq ref $_[0] ) {
        $self->_croak("Argument to &source must be an array reference");
    }
    $self->{source} = shift;
    return $self;
}

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

=head3 C

 my $stream = $source->get_stream;

Returns a stream of the output generated by executing C.

=cut

sub get_stream {
    my ($self) = @_;
    my @command = $self->_get_command
      or $self->_croak("No command found!");

    my $stdout_handle = IO::Handle->new();

    my $pid;
    eval { $pid = open3( undef, $stdout_handle, undef, @command ); };

    if ($@) {

        # TODO: Need to do something better with the error info here.
        $self->exit( $? >> 8 );
        $self->error("Could not execute (@command): $!");
        return;
    }
    else {
        if (IS_WIN32) {

            # open3 defaults to raw mode, need this for Windows. Maybe
            # other platforms too?
            # TODO: What was the first perl version that supports this?
            binmode $stdout_handle, ':crlf';
        }

        my $iter = TAPx::Parser::Iterator->new($stdout_handle);
        $iter->pid($pid);
        return $iter;
    }
}

sub _get_command { @{ shift->source } }

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

=head3 C

 unless ( my $stream = $source->get_stream ) {
     die $source->error;
 }

If a stream cannot be created, this method will return the error.

=cut

sub error {
    my $self = shift;
    return $self->{error} unless @_;
    $self->{error} = shift;
    return $self;
}

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

=head3 C

  my $exit = $source->exit;

Returns the exit status of the process I an error occurs in
opening the file.

=cut

sub exit {
    my $self = shift;
    return $self->{exit} unless @_;
    $self->{exit} = shift;
    return $self;
}

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

=head3 C

  my $pid = $source->pid;

Returns the pid of the command being used to execute the tests.

=cut

sub pid {
    my $self = shift;
    return $self->{pid} unless @_;
    $self->{pid} = shift;
    return $self;
}

# Turns on autoflush for the handle passed
sub _autoflush {
    my $flushed = shift;
    my $old_fh  = select $flushed;
    $| = 1;
    select $old_fh;
}

sub _croak {
    my $self = shift;
    require Carp;
    Carp::croak(@_);
}

1;