File Coverage

blib/lib/Test/ParallelSubtest/Capture.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	7	12	58.3
condition	3	9	33.3
subroutine	11	11	100.0
pod	4	4	100.0
total	75	86	87.2

package Test::ParallelSubtest::Capture;
use strict;
use warnings;

our $VERSION = '0.05';
$VERSION = eval $VERSION;

{
    package Test::ParallelSubtest::CaptureFH;
    use IO::WrapTie;
    use Tie::FileHandle::Base;
    our @ISA = qw(IO::WrapTie::Slave Tie::FileHandle::Base);

    sub TIEHANDLE {
        my ($pkg, $bufref, $prefix) = @_;

        return bless {
            BufRef => $bufref,
            Prefix => $prefix,
        }, ref($pkg)||$pkg;
    }

    sub PRINT {
        my $self = shift;

        my $text = join '', @_;
        if (length $text) {
            # Append to the buffer the prefix that identifies this
            # filehandle, followed by the data length and then the data.
            ${ $self->{BufRef} } .= $self->{Prefix}
                                        . pack('N', length $text) . $text;
        }
    }
}

use Carp;

sub new {
    my ($pkg, $bufref) = @_;

    if ($bufref) {
        ref $bufref eq 'SCALAR' or croak 'new() arg must be a scalar ref';
    }
    else {
        my $buf = '';
        $bufref = \$buf;
    }

    return bless {
        BufRef => $bufref,
    }, ref($pkg)||$pkg;
}

sub install {
    my ($self, $builder) = @_;

    my %fh;
    foreach my $prefix (qw( o f t )) {
        $fh{$prefix} = Test::ParallelSubtest::CaptureFH->new_tie(
                                                   $self->{BufRef}, $prefix);
    }

    $builder->output(        $fh{'o'});
    $builder->failure_output($fh{'f'});
    $builder->todo_output(   $fh{'t'});
}

sub as_string_ref {
    my $self = shift;

    return $self->{BufRef};
}

sub replay_writes {
    my ($self, $out_dest, $fail_dest, $todo_dest) = @_;

    my %fh = (
        'o' => $out_dest,
        'f' => $fail_dest,
        't' => $todo_dest,
    );

    my $buf = ${ $self->{BufRef} };
    while (length $buf) {
        $buf =~ s/^([oft])// or return;
        my $fh = $fh{$1};
        my $packed_len = substr $buf, 0, 4, '';
        return if length($packed_len) != 4;
        my $len = unpack 'N', $packed_len;
        return if $len < 1 or $len > length $buf;
        print $fh substr $buf, 0, $len, '';
    }

    return 1;
}

1;

__END__