File Coverage

blib/lib/Test/Stream/Plugin/Subtest.pm

Criterion	Covered	Total	%
statement	86	86	100.0
branch	24	28	85.7
condition	14	23	60.8
subroutine	15	15	100.0
pod	2	3	66.6
total	141	155	90.9

package Test::Stream::Plugin::Subtest;
use strict;
use warnings;

use Test::Stream::Context qw/context/;
use Test::Stream::Util qw/try/;

use Test::Stream::Event::Subtest;
use Test::Stream::Hub::Subtest;
use Test::Stream::Plugin;

sub load_ts_plugin {
    my $class = shift;
    my $caller = shift;

    if (!@_ || (@_ == 1 && $_[0] =~ m/^(streamed|buffered)$/)) {
        my $name = $1 || $_[0] || 'buffered';
        no strict 'refs';
        *{"$caller->[0]\::subtest"} = $class->can("subtest_$name");
        return;
    }

    for my $arg (@_) {
        my $ok = $arg =~ m/^subtest_(streamed|buffered)$/;
        my $sub = $ok ? $class->can($arg) : undef;
        die "$class does not export '$arg' at $caller->[1] line $caller->[2].\n"
            unless $sub;

        no strict 'refs';
        *{"$caller->[0]\::$arg"} = $sub;
    }
}

sub subtest_streamed {
    my ($name, $code, @args) = @_;
    my $ctx = context();
    my $pass = _subtest("Subtest: $name", $code, 0, @args);
    $ctx->release;
    return $pass;
}

sub subtest_buffered {
    my ($name, $code, @args) = @_;
    my $ctx = context();
    my $pass = _subtest($name, $code, 1, @args);
    $ctx->release;
    return $pass;
}

sub _subtest {
    my ($name, $code, $buffered, @args) = @_;

    my $ctx = context();

    $ctx->note($name) unless $buffered;

    my $parent = $ctx->hub;

    my $stack = $ctx->stack || Test::Stream::Sync->stack;
    my $hub = $stack->new_hub(
        class => 'Test::Stream::Hub::Subtest',
    );

    my @events;
    $hub->set_nested( $parent->isa('Test::Stream::Hub::Subtest') ? $parent->nested + 1 : 1 );
    $hub->listen(sub { push @events => $_[1] });
    $hub->format(undef) if $buffered;

    my $no_diag = $ctx->debug->no_diag;
    $hub->set_parent_todo($no_diag) if $no_diag;

    my ($ok, $err, $finished);
    TS_SUBTEST_WRAPPER: {
        ($ok, $err) = try { $code->(@args) };

        # They might have done 'BEGIN { skip_all => "whatever" }'
        if (!$ok && $err =~ m/Label not found for "last TS_SUBTEST_WRAPPER"/) {
            $ok  = undef;
            $err = undef;
        }
        else {
            $finished = 1;
        }
    }
    $stack->pop($hub);

    my $dbg = $ctx->debug;

    if (!$finished) {
        if(my $bailed = $hub->bailed_out) {
            $ctx->bail($bailed->reason);
        }
        my $code = $hub->exit_code;
        $ok = !$code;
        $err = "Subtest ended with exit code $code" if $code;
    }

    $hub->finalize($dbg, 1)
        if $ok
        && !$hub->no_ending
        && !$hub->state->ended;

    my $pass = $ok && $hub->state->is_passing;
    my $e = $ctx->build_event(
        'Subtest',
        pass => $pass,
        name => $name,
        buffered  => $buffered,
        subevents => \@events,
    );

    $e->set_diag([
        $e->default_diag,
        $ok ? () : ("Caught exception in subtest: $err"),
    ]) unless $pass;

    $ctx->hub->send($e);

    $ctx->release;
    return $hub->state->is_passing;
}

1;

__END__