File Coverage

blib/lib/Test2/Formatter/TAP.pm

Criterion	Covered	Total	%
statement	154	165	93.3
branch	56	86	65.1
condition	18	31	58.0
subroutine	24	24	100.0
pod	12	15	80.0
total	264	321	82.2

package Test2::Formatter::TAP;
use strict;
use warnings;

our $VERSION = '0.000044';

use Test2::Util::HashBase qw{
    no_numbers handles _encoding
};

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

use Carp qw/croak/;

use base 'Test2::Formatter';

my %CONVERTERS = (
    'Test2::Event::Ok'        => 'event_ok',
    'Test2::Event::Skip'      => 'event_skip',
    'Test2::Event::Note'      => 'event_note',
    'Test2::Event::Diag'      => 'event_diag',
    'Test2::Event::Bail'      => 'event_bail',
    'Test2::Event::Exception' => 'event_exception',
    'Test2::Event::Subtest'   => 'event_subtest',
    'Test2::Event::Plan'      => 'event_plan',
);

# Initial list of converters are safe for direct hash access cause we control them.
my %SAFE_TO_ACCESS_HASH = %CONVERTERS;

sub register_event {
    my $class = shift;
    my ($type, $convert) = @_;
    croak "Event type is a required argument" unless $type;
    croak "Event type '$type' already registered" if $CONVERTERS{$type};
    croak "The second argument to register_event() must be a code reference or method name"
        unless $convert && (ref($convert) eq 'CODE' || $class->can($convert));
    $CONVERTERS{$type} = $convert;
}

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

sub init {
    my $self = shift;

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

sub hide_buffered { 1 }

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) = @_;

    my $type = ref($e);

    my $converter = $CONVERTERS{$type} || 'event_other';
    my @tap = $self->$converter($e, $self->{+NO_NUMBERS} ? undef : $num) or return;

    my $handles = $self->{+HANDLES};
    my $nesting = ($SAFE_TO_ACCESS_HASH{$type} ? $e->{nested} : $e->nested) || 0;
    my $indent = '    ' x $nesting;

    # Local is expensive! Only do it if we really need to.
    local($\, $,) = (undef, '') if $\ || $,;
    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];
}

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

sub event_tap {
    my $self = shift;
    my ($e, $num) = @_;

    my $converter = $CONVERTERS{ref($e)} or return;

    $num = undef if $self->{+NO_NUMBERS};

    return $self->$converter($e, $num);
}

sub event_ok {
    my $self = shift;
    my ($e, $num) = @_;

    # We use direct hash access for performance. OK events are so common we
    # need this to be fast.
    my ($name, $todo) = @{$e}{qw/name todo/};
    my $in_todo = defined($todo);

    my $out = "";
    $out .= "not " unless $e->{pass};
    $out .= "ok";
    $out .= " $num" if defined($num);
    $out .= " - $name" if defined $name;
    $out .= " # TODO" if $in_todo;
    $out .= " $todo" if defined($todo) && length($todo);

    # The primary line of TAP, if the test passed this is all we need.
    return([OUT_STD, "$out\n"]);
}

sub event_skip {
    my $self = shift;
    my ($e, $num) = @_;

    my $name   = $e->name;
    my $reason = $e->reason;
    my $todo   = $e->todo;

    my $out = "";
    $out .= "not " unless $e->{pass};
    $out .= "ok";
    $out .= " $num" if defined $num;
    $out .= " - $name" if $name;
    if (defined($todo)) {
        $out .= " # TODO & SKIP"
    }
    else {
        $out .= " # skip";
    }
    $out .= " $reason" if defined($reason) && length($reason);

    return([OUT_STD, "$out\n"]);
}

sub event_note {
    my $self = shift;
    my ($e, $num) = @_;

    chomp(my $msg = $e->message);
    $msg =~ s/^/# /;
    $msg =~ s/\n/\n# /g;

    return [OUT_STD, "$msg\n"];
}

sub event_diag {
    my $self = shift;
    my ($e, $num) = @_;

    chomp(my $msg = $e->message);
    $msg =~ s/^/# /;
    $msg =~ s/\n/\n# /g;

    return [OUT_ERR, "$msg\n"];
}

sub event_bail {
    my $self = shift;
    my ($e, $num) = @_;

    return if $e->nested;

    return [
        OUT_STD,
        "Bail out!  " . $e->reason . "\n",
    ];
}

sub event_exception {
    my $self = shift;
    my ($e, $num) = @_;
    return [ OUT_ERR, $e->error ];
}

sub event_subtest {
    my $self = shift;
    my ($e, $num) = @_;

    # A 'subtest' is a subclass of 'ok'. Let the code that renders 'ok' render
    # this event.
    my ($ok, @diag) = $self->event_ok($e, $num);

    # If the subtest is not buffered then the sub-events have already been
    # rendered, we can go ahead and return.
    return ($ok, @diag) unless $e->buffered;

    # In a verbose harness we indent the diagnostics from the 'Ok' event since
    # they will appear inside the subtest braces. This helps readability. In a
    # non-verbose harness we do nto do this because it is less readable.
    if ($ENV{HARNESS_IS_VERBOSE}) {
        # index 0 is the filehandle, index 1 is the message we want to indent.
        $_->[1] =~ s/^(.*\S.*)$/    $1/mg for @diag;
    }

    # Add the trailing ' {' to the 'ok' line of TAP output.
    $ok->[1] =~ s/\n/ {\n/;

    # Render the sub-events, we use our own counter for these.
    my $count = 0;
    my @subs = map {
        # Bump the count for any event that should bump it.
        $count++ if $_->increments_count;

        # This indents all output lines generated for the sub-events.
        # index 0 is the filehandle, index 1 is the message we want to indent.
        map { $_->[1] =~ s/^(.*\S.*)$/    $1/mg; $_ } $self->event_tap($_, $count);
    } @{$e->subevents};

    return (
        $ok,                # opening ok - name {
        @diag,              #   diagnostics if the subtest failed
        @subs,              #   All the inner-event lines
        [OUT_STD(), "}\n"], # } (closing brace)
    );
}

sub event_plan {
    my $self = shift;
    my ($e, $num) = @_;

    my $directive = $e->directive;
    return if $directive && $directive eq 'NO PLAN';

    my $reason = $e->reason;
    $reason =~ s/\n/\n# /g if $reason;

    my $plan = "1.." . $e->max;
    if ($directive) {
        $plan .= " # $directive";
        $plan .= " $reason" if defined $reason;
    }

    return [OUT_STD, "$plan\n"];
}

sub event_other {
    my $self = shift;
    my ($e, $num) = @_;
    return if $e->no_display;

    my @out;

    if (my ($max, $directive, $reason) = $e->sets_plan) {
        my $plan = "1..$max";
        $plan .= " # $directive" if $directive;
        $plan .= " $reason" if defined $reason;
        push @out => [OUT_STD, "$plan\n"];
    }

    if ($e->increments_count) {
        my $ok = "";
        $ok .= "not " if $e->causes_fail;
        $ok .= "ok";
        $ok .= " $num" if defined($num);
        $ok .= " - " . $e->summary if $e->summary;

        push @out => [OUT_STD, "$ok\n"];
    }
    else { # Comment
        my $handle =  ($e->causes_fail || $e->diagnostics) ? OUT_ERR : OUT_STD;
        my $summary = $e->summary || ref($e);
        chomp($summary);
        $summary =~ s/^/# /smg;
        push @out => [$handle, "$summary\n"];
    }

    return @out;
}

1;

__END__