File Coverage

blib/lib/Test/Stream/Formatter/TAP.pm

Criterion	Covered	Total	%
statement	62	63	98.4
branch	19	24	79.1
condition	13	14	92.8
subroutine	13	13	100.0
pod	2	3	66.6
total	109	117	93.1

package Test::Stream::Formatter::TAP;
use strict;
use warnings;

use Test::Stream::Util qw/protect/;
use Test::Stream::HashBase(
    accessors => [qw/no_numbers no_header no_diag handles _encoding/],
);

sub OUT_STD()  { 0 }
sub OUT_ERR()  { 1 }
sub OUT_TODO() { 2 }

use Test::Stream::Exporter qw/import exports/;
exports qw/OUT_STD OUT_ERR OUT_TODO/;
no Test::Stream::Exporter;

_autoflush(\*STDOUT);
_autoflush(\*STDERR);

sub init {
    my $self = shift;

    $self->{+HANDLES} ||= $self->_open_handles;
    if(my $enc = delete $self->{encoding}) {
        $self->encoding($enc);
    }
}

sub encoding {
    my $self = shift;

    if (@_) {
        my ($enc) = @_;
        my $handles = $self->{+HANDLES};

        # https://rt.perl.org/Public/Bug/Display.html?id=31923
        # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
        # order to avoid the thread segfault.
        if ($enc =~ m/^utf-?8$/i) {
            binmode($_, ":utf8") for @$handles;
        }
        else {
            binmode($_, ":encoding($enc)") for @$handles;
        }
        $self->{+_ENCODING} = $enc;
    }

    return $self->{+_ENCODING};
}

if ($^C) {
    no warnings 'redefine';
    *write = sub {};
}
sub write {
    my ($self, $e, $num) = @_;

    return if $self->{+NO_DIAG}   && $e->isa('Test::Stream::Event::Diag');
    return if $self->{+NO_HEADER} && $e->isa('Test::Stream::Event::Plan');

    $num = undef if $self->{+NO_NUMBERS};
    my @tap = $e->to_tap($num);

    my $handles = $self->{+HANDLES};
    my $nesting = $e->nested || 0;
    my $indent = '    ' x $nesting;

    return if $nesting && $e->isa('Test::Stream::Event::Bail');

    local($\, $", $,) = (undef, ' ', '');
    for my $set (@tap) {
        no warnings 'uninitialized';
        my ($hid, $msg) = @$set;
        next unless $msg;
        my $io = $handles->[$hid] or next;

        $msg =~ s/^/$indent/mg if $nesting;
        print $io $msg;
    }
}

sub _open_handles {
    my $self = shift;

    open( my $out, ">&STDOUT" ) or die "Can't dup STDOUT:  $!";
    open( my $err, ">&STDERR" ) or die "Can't dup STDERR:  $!";

    _autoflush($out);
    _autoflush($err);

    return [$out, $err, $out];
}

sub _autoflush {
    my($fh) = pop;
    my $old_fh = select $fh;
    $| = 1;
    select $old_fh;
}

1;

__END__