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


line stmt bran cond sub pod time code
1             package Test::Stream::Plugin::Subtest;
2 31     31   149 use strict;
  31         60  
  31         767  
3 31     31   154 use warnings;
  31         54  
  31         847  
4              
5 31     31   157 use Test::Stream::Context qw/context/;
  31         58  
  31         250  
6 31     31   163 use Test::Stream::Util qw/try/;
  31         54  
  31         225  
7              
8 31     31   18138 use Test::Stream::Event::Subtest;
  31         79  
  31         223  
9 31     31   17881 use Test::Stream::Hub::Subtest;
  31         87  
  31         762  
10 31     31   168 use Test::Stream::Plugin;
  31         61  
  31         224  
11              
12             sub load_ts_plugin {
13 31     31 0 72 my $class = shift;
14 31         63 my $caller = shift;
15              
16 31 100 66     422 if (!@_ || (@_ == 1 && $_[0] =~ m/^(streamed|buffered)$/)) {
      66        
17 2   50     19 my $name = $1 || $_[0] || 'buffered';
18 31     31   157 no strict 'refs';
  31         63  
  31         5080  
19 2         12 *{"$caller->[0]\::subtest"} = $class->can("subtest_$name");
  2         16  
20 2         11 return;
21             }
22              
23 29         76 for my $arg (@_) {
24 30         144 my $ok = $arg =~ m/^subtest_(streamed|buffered)$/;
25 30 50       311 my $sub = $ok ? $class->can($arg) : undef;
26 30 50       141 die "$class does not export '$arg' at $caller->[1] line $caller->[2].\n"
27             unless $sub;
28              
29 31     31   167 no strict 'refs';
  31         66  
  31         20456  
30 30         64 *{"$caller->[0]\::$arg"} = $sub;
  30         962  
31             }
32             }
33              
34             sub subtest_streamed {
35 10     10 1 151 my ($name, $code, @args) = @_;
36 10         27 my $ctx = context();
37 10         41 my $pass = _subtest("Subtest: $name", $code, 0, @args);
38 9         58 $ctx->release;
39 9         32 return $pass;
40             }
41              
42             sub subtest_buffered {
43 212     212 1 504 my ($name, $code, @args) = @_;
44 212         628 my $ctx = context();
45 212         774 my $pass = _subtest($name, $code, 1, @args);
46 210         1173 $ctx->release;
47 210         638 return $pass;
48             }
49              
50             sub _subtest {
51 222     222   500 my ($name, $code, $buffered, @args) = @_;
52              
53 222         589 my $ctx = context();
54              
55 222 100       608 $ctx->note($name) unless $buffered;
56              
57 222         757 my $parent = $ctx->hub;
58              
59 222   66     1131 my $stack = $ctx->stack || Test::Stream::Sync->stack;
60 222         1486 my $hub = $stack->new_hub(
61             class => 'Test::Stream::Hub::Subtest',
62             );
63              
64 222         364 my @events;
65 222 100       2349 $hub->set_nested( $parent->isa('Test::Stream::Hub::Subtest') ? $parent->nested + 1 : 1 );
66 222     1554   2036 $hub->listen(sub { push @events => $_[1] });
  1554         6714  
67 222 100       1095 $hub->format(undef) if $buffered;
68              
69 222         736 my $no_diag = $ctx->debug->no_diag;
70 222 100       616 $hub->set_parent_todo($no_diag) if $no_diag;
71              
72 222         330 my ($ok, $err, $finished);
73             TS_SUBTEST_WRAPPER: {
74 222     222   311 ($ok, $err) = try { $code->(@args) };
  222         1176  
  222         693  
75              
76             # They might have done 'BEGIN { skip_all => "whatever" }'
77 217 100 66     1273 if (!$ok && $err =~ m/Label not found for "last TS_SUBTEST_WRAPPER"/) {
78 1         2 $ok = undef;
79 1         2 $err = undef;
80             }
81             else {
82 216         396 $finished = 1;
83             }
84             }
85 221         936 $stack->pop($hub);
86              
87 221         782 my $dbg = $ctx->debug;
88              
89 221 100       1114 if (!$finished) {
90 5 100       18 if(my $bailed = $hub->bailed_out) {
91 2         15 $ctx->bail($bailed->reason);
92             }
93 3         21 my $code = $hub->exit_code;
94 3         12 $ok = !$code;
95 3 50       10 $err = "Subtest ended with exit code $code" if $code;
96             }
97              
98 219 100 33     1154 $hub->finalize($dbg, 1)
      66        
99             if $ok
100             && !$hub->no_ending
101             && !$hub->state->ended;
102              
103 219   66     1046 my $pass = $ok && $hub->state->is_passing;
104 219         1044 my $e = $ctx->build_event(
105             'Subtest',
106             pass => $pass,
107             name => $name,
108             buffered => $buffered,
109             subevents => \@events,
110             );
111              
112 219 50       882 $e->set_diag([
    100          
113             $e->default_diag,
114             $ok ? () : ("Caught exception in subtest: $err"),
115             ]) unless $pass;
116              
117 219         858 $ctx->hub->send($e);
118              
119 219         782 $ctx->release;
120 219         803 return $hub->state->is_passing;
121             }
122              
123             1;
124              
125             __END__