File Coverage

blib/lib/Archive/TAP/Peek.pm

Criterion	Covered	Total	%
statement	43	43	100.0
branch	13	18	72.2
condition			n/a
subroutine	7	7	100.0
pod	1	2	50.0
total	64	70	91.4

# ABSTRACT: Look into TAP-Archives

package Archive::TAP::Peek;
{
  $Archive::TAP::Peek::VERSION = '0.002';
}

use strict;
use warnings;

use Archive::Extract;
use File::Temp qw( tempdir );
use TAP::Parser;

sub new {
    my $class = shift;

    my %args = @_;

    my $self = { error_found => 0 };

    die "Parameter 'archive' needed" unless exists $args{archive};

    die "$args{archive} not found" unless -f $args{archive};

    my $ae = Archive::Extract->new( archive => $args{archive},
                                    type => 'tgz'
                                  );

    die "$args{archive} is not of type 'tgz'" unless $ae->is_tgz;

    my $tmpdir = tempdir( CLEANUP => 1 );

    $ae->extract( to => $tmpdir ) or die $ae->error;

    my $files = $ae->files;

    my $outdir = $ae->extract_path;

    foreach my $f (@{$files}) {

        next unless ( $f =~ /.*\.t$/);

        # code from here:
        # http://stackoverflow.com/questions/13781443/capture-and-split-tap-output-result
        my $tap_file = $outdir . '/' . $f;
        open my $tap_fh, $tap_file or die $!;

        # Can't just pass in the .t file, it will try to execute it.
        my $parser = TAP::Parser->new({
            source => $tap_fh
        });

        while ( my $result = $parser->next ) {
            # do whatever you like with the $result, like print it back out
            my $line = $result->as_string;

            if ($line =~ /^ok/) {
                # everything is fine... keep going on
            }
            elsif ($line =~ /^not ok/) {
                # oops! error.
                $self->{error_found} = 1;

                # we break here... since we already know there are failures
                last;
            }
            else {
                # some other lines we don't need
            }
        }

    }

    bless ($self, $class);

    return $self;
}

sub all_ok {
    my $self = shift;

    if( $self->{error_found} ) {
        return;
    }
    else {
        return 1;
    }
}

1;

__END__