File Coverage

blib/lib/Test2/API.pm
Criterion Covered Total %
statement 255 275 92.7
branch 73 92 79.3
condition 52 81 64.2
subroutine 67 75 89.3
pod 33 37 89.1
total 480 560 85.7


line stmt bran cond sub pod time code
1             package Test2::API;
2 54     54   15200 use strict;
  54         58  
  54         1188  
3 54     54   143 use warnings;
  54         56  
  54         2553  
4              
5             our $VERSION = '0.000042';
6              
7             my $INST;
8             my $ENDING = 0;
9 166     166   1164 sub _set_is_end { $ENDING = 1 }
10              
11 54     54   12445 use Test2::API::Instance(\$INST);
  54         73  
  54         758  
12             # Set the exit status
13             END {
14 54     54   305 _set_is_end(); # See gh #16
15 54         245 $INST->set_exit();
16             }
17              
18             # See gh #16
19             {
20 54     54   658 no warnings;
  54         58  
  54         2860  
21 53 50   53   76648 INIT { eval 'END { _set_is_end() }; 1' or die $@ }
  51     51   243  
22             }
23              
24             BEGIN {
25 54     54   197 no warnings 'once';
  54         54  
  54         3977  
26 54 50 33 54   255 if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) {
      0        
27 54         705 *DO_DEPTH_CHECK = sub() { 1 };
28             }
29             else {
30 0         0 *DO_DEPTH_CHECK = sub() { 0 };
31             }
32             }
33              
34 54     54   193 use Test2::Util::Trace();
  54         47  
  54         531  
35              
36 54     54   16794 use Test2::Hub::Subtest();
  54         71  
  54         804  
37 54     54   16514 use Test2::Hub::Interceptor();
  54         81  
  54         730  
38 54     54   209 use Test2::Hub::Interceptor::Terminator();
  54         51  
  54         577  
39              
40 54     54   15863 use Test2::Event::Ok();
  54         73  
  54         729  
41 54     54   15912 use Test2::Event::Diag();
  54         80  
  54         718  
42 54     54   15957 use Test2::Event::Note();
  54         81  
  54         695  
43 54     54   15760 use Test2::Event::Plan();
  54         70  
  54         764  
44 54     54   16174 use Test2::Event::Bail();
  54         90  
  54         698  
45 54     54   15536 use Test2::Event::Exception();
  54         78  
  54         752  
46 54     54   15254 use Test2::Event::Waiting();
  54         114  
  54         692  
47 54     54   14940 use Test2::Event::Skip();
  54         86  
  54         692  
48 54     54   15701 use Test2::Event::Subtest();
  54         86  
  54         1013  
49              
50 54     54   190 use Carp qw/carp croak confess longmess/;
  54         44  
  54         2514  
51 54     54   175 use Scalar::Util qw/blessed weaken/;
  54         49  
  54         1904  
52 54     54   164 use Test2::Util qw/get_tid/;
  54         52  
  54         3441  
53              
54             our @EXPORT_OK = qw{
55             context release
56             context_do
57             no_context
58             intercept
59             run_subtest
60              
61             test2_init_done
62             test2_load_done
63              
64             test2_pid
65             test2_tid
66             test2_stack
67             test2_no_wait
68              
69             test2_add_callback_context_aquire
70             test2_add_callback_context_acquire
71             test2_add_callback_context_init
72             test2_add_callback_context_release
73             test2_add_callback_exit
74             test2_add_callback_post_load
75             test2_list_context_aquire_callbacks
76             test2_list_context_acquire_callbacks
77             test2_list_context_init_callbacks
78             test2_list_context_release_callbacks
79             test2_list_exit_callbacks
80             test2_list_post_load_callbacks
81              
82             test2_ipc
83             test2_ipc_drivers
84             test2_ipc_add_driver
85             test2_ipc_polling
86             test2_ipc_disable_polling
87             test2_ipc_enable_polling
88             test2_ipc_get_pending
89             test2_ipc_set_pending
90             test2_ipc_enable_shm
91              
92             test2_formatter
93             test2_formatters
94             test2_formatter_add
95             test2_formatter_set
96             };
97 54     54   1681 use base 'Exporter';
  54         70  
  54         3889  
98              
99             # There is a use-cycle between API and API/Context. Context needs to use some
100             # API functions as the package is compiling. Test2::API::context() needs
101             # Test2::API::Context to be loaded, but we cannot 'require' the module there as
102             # it causes a very noticable performance impact with how often context() is
103             # called.
104             #
105             # This will make sure that Context.pm is loaded the first time this module is
106             # imported, then the regular import method is swapped into place.
107             sub import {
108             require Test2::API::Context unless $INC{'Test2/API/Context.pm'};
109              
110             {
111 54     54   201 no warnings 'redefine';
  54         44  
  54         96452  
112             *import = \&Exporter::import;
113             }
114              
115             goto &import;
116             }
117              
118             my $STACK = $INST->stack;
119             my $CONTEXTS = $INST->contexts;
120             my $INIT_CBS = $INST->context_init_callbacks;
121             my $ACQUIRE_CBS = $INST->context_acquire_callbacks;
122              
123 22     22 1 60 sub test2_init_done { $INST->finalized }
124 3     3 1 9 sub test2_load_done { $INST->loaded }
125              
126 1     1 0 4 sub test2_pid { $INST->pid }
127 1     1 0 3 sub test2_tid { $INST->tid }
128 41     41 1 2616 sub test2_stack { $INST->stack }
129             sub test2_no_wait {
130 5 100   5 1 21 $INST->set_no_wait(@_) if @_;
131 5         8 $INST->no_wait;
132             }
133              
134 3     3 1 22 sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) }
135 0     0 0 0 sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) }
136 3     3 1 13 sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) }
137 4     4 1 22 sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) }
138 3     3 1 9 sub test2_add_callback_exit { $INST->add_exit_callback(@_) }
139 3     3 1 9 sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) }
140 0     0 0 0 sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} }
  0         0  
141 2     2 1 6 sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} }
  2         6  
142 2     2 1 5 sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} }
  2         5  
143 2     2 1 5 sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} }
  2         6  
144 2     2 1 7 sub test2_list_exit_callbacks { @{$INST->exit_callbacks} }
  2         5  
145 2     2 1 6 sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} }
  2         6  
146              
147 91     91 1 284 sub test2_ipc { $INST->ipc }
148 2     2 1 19 sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) }
149 6     6 1 20 sub test2_ipc_drivers { @{$INST->ipc_drivers} }
  6         18  
150 3     3 1 8 sub test2_ipc_polling { $INST->ipc_polling }
151 1     1 1 2 sub test2_ipc_enable_polling { $INST->enable_ipc_polling }
152 1     1 1 3 sub test2_ipc_disable_polling { $INST->disable_ipc_polling }
153 0     0 1 0 sub test2_ipc_get_pending { $INST->get_ipc_pending }
154 32     32 1 181 sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) }
155 0     0 1 0 sub test2_ipc_enable_shm { $INST->ipc_enable_shm }
156              
157 76     76 1 220 sub test2_formatter { $INST->formatter }
158 0     0 1 0 sub test2_formatters { @{$INST->formatters} }
  0         0  
159 1     1 1 3 sub test2_formatter_add { $INST->add_formatter(@_) }
160             sub test2_formatter_set {
161 2     2 1 27 my ($formatter) = @_;
162 2 100       77 croak "No formatter specified" unless $formatter;
163 1 50       4 croak "Global Formatter already set" if $INST->formatter_set;
164 0         0 $INST->set_formatter($formatter);
165             }
166              
167             # Private, for use in Test2::API::Context
168 54     54   115 sub _contexts_ref { $INST->contexts }
169 1     1   4 sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks }
170 1     1   5 sub _context_init_callbacks_ref { $INST->context_init_callbacks }
171 55     55   178 sub _context_release_callbacks_ref { $INST->context_release_callbacks }
172              
173             # Private, for use in Test2::IPC
174 0     0   0 sub _set_ipc { $INST->set_ipc(@_) }
175              
176             sub context_do(&;@) {
177 4     4 1 20 my $code = shift;
178 4         5 my @args = @_;
179              
180 4         6 my $ctx = context(level => 1);
181              
182 4         7 my $want = wantarray;
183              
184 4         3 my @out;
185 4         5 my $ok = eval {
186 4 100       15 $want ? @out = $code->($ctx, @args) :
    100          
187             defined($want) ? $out[0] = $code->($ctx, @args) :
188             $code->($ctx, @args) ;
189 3         13 1;
190             };
191 4         12 my $err = $@;
192              
193 4         8 $ctx->release;
194              
195 4 100       10 die $err unless $ok;
196              
197 3 100       7 return @out if $want;
198 2 100       5 return $out[0] if defined $want;
199 1         2 return;
200             }
201              
202             sub no_context(&;$) {
203 3     3 1 4 my ($code, $hid) = @_;
204 3   66     7 $hid ||= $STACK->top->hid;
205              
206 3         10 my $ctx = $CONTEXTS->{$hid};
207 3         4 delete $CONTEXTS->{$hid};
208 3         3 my $ok = eval { $code->(); 1 };
  3         4  
  3         5  
209 3         3 my $err = $@;
210              
211 3         5 $CONTEXTS->{$hid} = $ctx;
212 3         4 weaken($CONTEXTS->{$hid});
213              
214 3 50       6 die $err unless $ok;
215              
216 3         4 return;
217             };
218              
219             sub context {
220             # We need to grab these before anything else to ensure they are not
221             # changed.
222 1173     1173 1 3734965 my ($errno, $eval_error, $child_error) = (0 + $!, $@, $?);
223              
224 1173         2407 my %params = (level => 0, wrapped => 0, @_);
225              
226             # If something is getting a context then the sync system needs to be
227             # considered loaded...
228 1173 100       2650 $INST->load unless $INST->{loaded};
229              
230 1173 100       1947 croak "context() called, but return value is ignored"
231             unless defined wantarray;
232              
233 1172   33     3481 my $stack = $params{stack} || $STACK;
234 1172 100 100     3939 my $hub = $params{hub} || @$stack ? $stack->[-1] : $stack->top;
235 1172         1221 my $hid = $hub->{hid};
236 1172         1040 my $current = $CONTEXTS->{$hid};
237              
238 1172         1938 $_->(\%params) for @$ACQUIRE_CBS;
239 1172 100       1709 map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire};
  72         88  
240              
241             # This is for https://github.com/Test-More/Test2/issues/16
242             # and https://rt.perl.org/Public/Bug/Display.html?id=127774
243 1172   50     2615 my $phase = ${^GLOBAL_PHASE} || 'NA';
244 1172   66     4808 my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT';
245              
246 1172         1063 my $level = 1 + $params{level};
247 1172 100       5816 my ($pkg, $file, $line, $sub) = $end_phase ? caller(0) : caller($level);
248 1172 100 66     2477 unless ($pkg || $end_phase) {
249 2 100       145 confess "Could not find context at depth $level" unless $params{fudge};
250 1   66     40 ($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg);
251             }
252              
253 1171         910 my $depth = $level;
254 1171   100     9351 $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1);
      66        
      100        
255 1171         1160 $depth -= $params{wrapped};
256 1171   100     3548 my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth;
257              
258 1171 100 66     1685 if ($current && $params{on_release} && $depth_ok) {
      66        
259 1   50     3 $current->{_on_release} ||= [];
260 1         1 push @{$current->{_on_release}} => $params{on_release};
  1         1  
261             }
262              
263             # I know this is ugly....
264 1171 100 50     2640 ($!, $@, $?) = ($errno, $eval_error, $child_error) and return bless(
      100        
265             {
266             %$current,
267             _is_canon => undef,
268             errno => $errno,
269             eval_error => $eval_error,
270             child_error => $child_error,
271             _is_spawn => [$pkg, $file, $line, $sub],
272             },
273             'Test2::API::Context'
274             ) if $current && $depth_ok;
275              
276             # Handle error condition of bad level
277 1082 100       1394 if ($current) {
278 2 50       2 unless (${$current->{_aborted}}) {
  2         12  
279             _canon_error($current, [$pkg, $file, $line, $sub, $depth])
280 2 50       5 unless $current->{_is_canon};
281              
282 2 50       7 _depth_error($current, [$pkg, $file, $line, $sub, $depth])
283             unless $depth_ok;
284             }
285              
286 2 50       19 $current->release if $current->{_is_canon};
287              
288 2         2 delete $CONTEXTS->{$hid};
289             }
290              
291             # Directly bless the object here, calling new is a noticable performance
292             # hit with how often this needs to be called.
293 1082         4334 my $trace = bless(
294             {
295             frame => [$pkg, $file, $line, $sub],
296             pid => $$,
297             tid => get_tid(),
298             },
299             'Test2::Util::Trace'
300             );
301              
302             # Directly bless the object here, calling new is a noticable performance
303             # hit with how often this needs to be called.
304 1082         925 my $aborted = 0;
305             $current = bless(
306             {
307             _aborted => \$aborted,
308             stack => $stack,
309             hub => $hub,
310             trace => $trace,
311             _is_canon => 1,
312             _depth => $depth,
313             errno => $errno,
314             eval_error => $eval_error,
315             child_error => $child_error,
316 1082 100       5571 $params{on_release} ? (_on_release => [$params{on_release}]) : (),
317             },
318             'Test2::API::Context'
319             );
320              
321 1082         1449 $CONTEXTS->{$hid} = $current;
322 1082         2414 weaken($CONTEXTS->{$hid});
323              
324 1082         2184 $_->($current) for @$INIT_CBS;
325 1082 100       1774 map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init};
  37         42  
326              
327 1082 100       1551 $params{on_init}->($current) if $params{on_init};
328              
329 1082         2152 ($!, $@, $?) = ($errno, $eval_error, $child_error);
330              
331 1082         3083 return $current;
332             }
333              
334             sub _depth_error {
335 2     2   6 _existing_error(@_, <<" EOT");
336             context() was called to retrieve an existing context, however the existing
337             context was created in a stack frame at the same, or deeper level. This usually
338             means that a tool failed to release the context when it was finished.
339             EOT
340             }
341              
342             sub _canon_error {
343 0     0   0 _existing_error(@_, <<" EOT");
344             context() was called to retrieve an existing context, however the existing
345             context has an invalid internal state (!_canon_count). This should not normally
346             happen unless something is mucking about with internals...
347             EOT
348             }
349              
350             sub _existing_error {
351 2     2   4 my ($ctx, $details, $msg) = @_;
352 2         4 my ($pkg, $file, $line, $sub, $depth) = @$details;
353              
354 2         6 my $oldframe = $ctx->{trace}->frame;
355 2         3 my $olddepth = $ctx->{_depth};
356              
357 2         153 my $mess = longmess();
358              
359 2         336 warn <<" EOT";
360             $msg
361             Old context details:
362             File: $oldframe->[1]
363             Line: $oldframe->[2]
364             Tool: $oldframe->[3]
365             Depth: $olddepth
366              
367             New context details:
368             File: $file
369             Line: $line
370             Tool: $sub
371             Depth: $depth
372              
373             Trace: $mess
374              
375             Removing the old context and creating a new one...
376             EOT
377             }
378              
379             sub release($;$) {
380 0     0 1 0 $_[0]->release;
381 0         0 return $_[1];
382             }
383              
384             sub intercept(&) {
385 13     13 1 82 my $code = shift;
386              
387 13         25 my $ctx = context();
388              
389 13         13 my $ipc;
390 13 100       34 if (my $global_ipc = test2_ipc()) {
391 10         26 my $driver = blessed($global_ipc);
392 10         50 $ipc = $driver->new;
393             }
394              
395 13         79 my $hub = Test2::Hub::Interceptor->new(
396             ipc => $ipc,
397             no_ending => 1,
398             );
399              
400 13         15 my @events;
401 13     78   85 $hub->listen(sub { push @events => $_[1] });
  78         155  
402              
403 13         35 $ctx->stack->top; # Make sure there is a top hub before we begin.
404 13         28 $ctx->stack->push($hub);
405              
406             # Do not use 'try' cause it localizes __DIE__
407 13         12 my ($ok, $err);
408             {
409 13         11 $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 };
  13         14  
  13         34  
  10         19  
410 13         27 $err = $@;
411             }
412              
413 13         40 $hub->cull;
414 13         31 $ctx->stack->pop($hub);
415              
416 13         26 my $trace = $ctx->trace;
417 13         26 $ctx->release;
418              
419 13 100 66     49 die $err unless $ok
      66        
420             || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'));
421              
422 12 100 100     56 $hub->finalize($trace, 1)
      100        
423             if $ok
424             && !$hub->no_ending
425             && !$hub->ended;
426              
427 12         43 return \@events;
428             }
429              
430             sub run_subtest {
431 40     40 1 216 my ($name, $code, $params, @args) = @_;
432              
433 40 50       100 $params = { buffered => $params } unless ref $params;
434 40         53 my $buffered = delete $params->{buffered};
435              
436 40         49 my $ctx = context();
437              
438 40 100       95 $ctx->note($name) unless $buffered;
439              
440 40         101 my $parent = $ctx->hub;
441              
442 40   33     77 my $stack = $ctx->stack || $STACK;
443 40         109 my $hub = $stack->new_hub(
444             class => 'Test2::Hub::Subtest',
445             %$params,
446             );
447              
448 40         33 my @events;
449 40 50       225 $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 );
450 40     193   199 $hub->listen(sub { push @events => $_[1] });
  193         367  
451              
452 40 100       65 if ($buffered) {
453 36 100       86 if (my $format = $hub->format) {
454 34 100       169 my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1;
455 34 100       87 $hub->format(undef) if $hide;
456             }
457             }
458              
459 40         29 my ($ok, $err, $finished);
460             T2_SUBTEST_WRAPPER: {
461             # Do not use 'try' cause it localizes __DIE__
462 40         42 $ok = eval { $code->(@args); 1 };
  40         43  
  40         74  
  39         101  
463 39         41 $err = $@;
464              
465             # They might have done 'BEGIN { skip_all => "whatever" }'
466 39 50 33     98 if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/) {
467 0         0 $ok = undef;
468 0         0 $err = undef;
469             }
470             else {
471 39         41 $finished = 1;
472             }
473             }
474 39         93 $stack->pop($hub);
475              
476 39         68 my $trace = $ctx->trace;
477              
478 39 50       64 if (!$finished) {
479 0 0       0 if(my $bailed = $hub->bailed_out) {
480 0         0 $ctx->bail($bailed->reason);
481             }
482 0         0 my $code = $hub->exit_code;
483 0         0 $ok = !$code;
484 0 0       0 $err = "Subtest ended with exit code $code" if $code;
485             }
486              
487 39 50 33     142 $hub->finalize($trace, 1)
      33        
488             if $ok
489             && !$hub->no_ending
490             && !$hub->ended;
491              
492 39   66     98 my $pass = $ok && $hub->is_passing;
493 39         85 my $e = $ctx->build_event(
494             'Subtest',
495             pass => $pass,
496             name => $name,
497             subtest_id => $hub->id,
498             buffered => $buffered,
499             subevents => \@events,
500             );
501              
502 39         115 my $plan_ok = $hub->check_plan;
503              
504 39         73 $ctx->hub->send($e);
505              
506 39 100       92 $ctx->failure_diag($e) unless $e->pass;
507              
508 39 50       62 $ctx->diag("Caught exception in subtest: $err") unless $ok;
509              
510 39 50 66     115 $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count)
511             if defined($plan_ok) && !$plan_ok;
512              
513 39         72 $ctx->release;
514 39         271 return $pass;
515             }
516              
517             1;
518              
519             __END__