File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 295 911 32.3
branch 71 428 16.5
condition 25 252 9.9
subroutine 55 114 48.2
pod 48 53 90.5
total 494 1758 28.1


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 6     6   97  
  6         18  
4 6     6   26 use 5.006;
  6         8  
  6         126  
5 6     6   25 use strict;
  6         9  
  6         457  
6             use warnings;
7              
8             our $VERSION = '1.302170';
9              
10 6 50   6   204 BEGIN {
11 0         0 if( $] < 5.008 ) {
12             require Test::Builder::IO::Scalar;
13             }
14             }
15 6     6   35  
  6         8  
  6         701  
16             use Scalar::Util qw/blessed reftype weaken/;
17 6     6   2626  
  6         58542  
  6         411  
18 6     6   3203 use Test2::Util qw/USE_THREADS try get_tid/;
  6         68190  
  6         840  
19             use Test2::API qw/context release/;
20             # Make Test::Builder thread-safe for ithreads.
21 6 50 33 6   33 BEGIN {
22             warn "Test::Builder was loaded after Test2 initialization, this is not recommended."
23             if Test2::API::test2_init_done() || Test2::API::test2_load_done();
24 6         192  
25             if (USE_THREADS && ! Test2::API::test2_ipc_disabled()) {
26             require Test2::IPC;
27             require Test2::IPC::Driver::Files;
28             Test2::IPC::Driver::Files->import;
29             Test2::API::test2_ipc_enable_polling();
30             Test2::API::test2_no_wait(1);
31             }
32             }
33 6     6   43  
  6         12  
  6         130  
34 6     6   29 use Test2::Event::Subtest;
  6         10  
  6         313  
35             use Test2::Hub::Subtest;
36 6     6   2742  
  6         30461  
  6         44  
37 6     6   2848 use Test::Builder::Formatter;
  6         1164  
  6         597  
38             use Test::Builder::TodoDiag;
39              
40             our $Level = 1;
41             our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new;
42              
43 6     6   13 sub _add_ts_hooks {
44             my $self = shift;
45 6         23  
46             my $hub = $self->{Stack}->top;
47              
48             # Take a reference to the hash key, we do this to avoid closing over $self
49             # which is the singleton. We use a reference because the value could change
50 6         38 # in rare cases.
51             my $epkgr = \$self->{Exported_To};
52              
53             #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1});
54              
55 22     22   3792 $hub->pre_filter(sub {
56             my ($active_hub, $e) = @_;
57 22         52  
58 22 50       75 my $epkg = $$epkgr;
59             my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef;
60 6     6   36  
  6         11  
  6         185  
61 6     6   26 no strict 'refs';
  6         11  
  6         1311  
62 22         31 no warnings 'once';
63 22 50       58 my $todo;
  22         142  
64 22 50 33     111 $todo = ${"$cpkg\::TODO"} if $cpkg;
  22         69  
65             $todo = ${"$epkg\::TODO"} if $epkg && !$todo;
66 22 50       76  
67 0 0       0 return $e unless defined($todo);
68             return $e unless length($todo);
69              
70 0 0       0 # Turn a diag into a todo diag
71             return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
72 0 0       0  
73 0         0 $e->set_todo($todo) if $e->can('set_todo');
74             $e->add_amnesty({tag => 'TODO', details => $todo});
75              
76 0 0       0 # Set todo on ok's
77 0         0 if ($e->isa('Test2::Event::Ok')) {
78             $e->set_effective_pass(1);
79 0 0       0  
80 0   0     0 if (my $result = $e->get_meta(__PACKAGE__)) {
81 0   0     0 $result->{reason} ||= $todo;
82 0         0 $result->{type} ||= 'todo';
83             $result->{ok} = 1;
84             }
85             }
86 0         0  
87 6         127 return $e;
88             }, inherit => 1);
89             }
90              
91 6     6   39 {
  6         12  
  6         269  
92             no warnings;
93 6     6   30 INIT {
  6         16  
  6         18628  
94 6 50   6   487 use warnings;
95             Test2::API::test2_load() unless Test2::API::test2_in_preload();
96             }
97             }
98              
99 36     36 1 178 sub new {
100 36 100       124 my($class) = shift;
101 6         19 unless($Test) {
102             $Test = $class->create(singleton => 1);
103              
104             Test2::API::test2_add_callback_post_load(
105 6 50 33 6   807 sub {
106 6         26 $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0;
107 6         99 $Test->reset(singleton => 1);
108             $Test->_add_ts_hooks;
109 6         40 }
110             );
111              
112             # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So
113             # we only want the level to change if $Level != 1.
114 6     73   149 # TB->ctx compensates for this later.
  73         4439  
115             Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 });
116 6     6   109  
  6         3320  
117             Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) });
118 6 50       99  
119             Test2::API::test2_ipc()->set_no_fatal(1) if Test2::API::test2_has_ipc();
120 36         206 }
121             return $Test;
122             }
123              
124 6     6 1 12 sub create {
125 6         20 my $class = shift;
126             my %params = @_;
127 6         19  
128 6 50       30 my $self = bless {}, $class;
129 6         38 if ($params{singleton}) {
130             $self->{Stack} = Test2::API::test2_stack();
131             }
132 0         0 else {
133             $self->{Stack} = Test2::API::Stack->new;
134 0         0 $self->{Stack}->new_hub(
135             formatter => Test::Builder::Formatter->new,
136             ipc => Test2::API::test2_ipc(),
137             );
138 0         0  
139 0         0 $self->reset(%params);
140             $self->_add_ts_hooks;
141             }
142 6         101  
143             return $self;
144             }
145              
146 73     73 0 135 sub ctx {
147             my $self = shift;
148             context(
149             # 1 for our frame, another for the -1 off of $Level in our hook at the top.
150             level => 2,
151             fudge => 1,
152             stack => $self->{Stack},
153 73         355 hub => $self->{Hub},
154             wrapped => 1,
155             @_
156             );
157             }
158              
159 0     0 0 0 sub parent {
160 0         0 my $self = shift;
161 0   0     0 my $ctx = $self->ctx;
162 0         0 my $chub = $self->{Hub} || $ctx->hub;
163             $ctx->release;
164 0         0  
165 0         0 my $meta = $chub->meta(__PACKAGE__, {});
166             my $parent = $meta->{parent};
167 0 0       0  
168             return undef unless $parent;
169              
170             return bless {
171             Original_Pid => $$,
172 0         0 Stack => $self->{Stack},
173             Hub => $parent,
174             }, blessed($self);
175             }
176              
177 0     0 0 0 sub child {
178             my( $self, $name ) = @_;
179 0   0     0  
180 0         0 $name ||= "Child of " . $self->name;
181             my $ctx = $self->ctx;
182 0         0  
183 0         0 my $parent = $ctx->hub;
184             my $pmeta = $parent->meta(__PACKAGE__, {});
185 0 0       0 $self->croak("You already have a child named ($pmeta->{child}) running")
186             if $pmeta->{child};
187 0         0  
188             $pmeta->{child} = $name;
189              
190 0         0 # Clear $TODO for the child.
191             my $orig_TODO = $self->find_TODO(undef, 1, undef);
192 0         0  
193             my $subevents = [];
194 0         0  
195             my $hub = $ctx->stack->new_hub(
196             class => 'Test2::Hub::Subtest',
197             );
198              
199 0     0   0 $hub->pre_filter(sub {
200             my ($active_hub, $e) = @_;
201              
202 0 0       0 # Turn a diag into a todo diag
203             return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
204 0         0  
205 0 0       0 return $e;
206             }, inherit => 1) if $orig_TODO;
207 0     0   0  
  0         0  
208             $hub->listen(sub { push @$subevents => $_[1] });
209 0         0  
210             $hub->set_nested( $parent->nested + 1 );
211 0         0  
212 0         0 my $meta = $hub->meta(__PACKAGE__, {});
213 0         0 $meta->{Name} = $name;
214 0         0 $meta->{TODO} = $orig_TODO;
215 0         0 $meta->{TODO_PKG} = $ctx->trace->package;
216 0         0 $meta->{parent} = $parent;
217 0         0 $meta->{Test_Results} = [];
218 0         0 $meta->{subevents} = $subevents;
219 0         0 $meta->{subtest_id} = $hub->id;
220 0 0       0 $meta->{subtest_uuid} = $hub->uuid;
221             $meta->{subtest_buffered} = $parent->format ? 0 : 1;
222 0         0  
223             $self->_add_ts_hooks;
224 0         0  
225 0         0 $ctx->release;
226             return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self);
227             }
228              
229 0     0 0 0 sub finalize {
230 0         0 my $self = shift;
231 0 0       0 my $ok = 1;
232             ($ok) = @_ if @_;
233 0         0  
234 0   0     0 my $st_ctx = $self->ctx;
235             my $chub = $self->{Hub} || return $st_ctx->release;
236 0         0  
237 0 0       0 my $meta = $chub->meta(__PACKAGE__, {});
238 0         0 if ($meta->{child}) {
239             $self->croak("Can't call finalize() with child ($meta->{child}) active");
240             }
241 0         0  
242             local $? = 0; # don't fail if $subtests happened to set $? nonzero
243 0         0  
244             $self->{Stack}->pop($chub);
245 0         0  
246             $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO});
247 0         0  
248 0         0 my $parent = $self->parent;
249 0         0 my $ctx = $parent->ctx;
250 0         0 my $trace = $ctx->trace;
251             delete $ctx->hub->meta(__PACKAGE__, {})->{child};
252 0 0 0     0  
      0        
      0        
253             $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1)
254             if $ok
255             && $chub->count
256             && !$chub->no_ending
257             && !$chub->ended;
258 0   0     0  
259 0         0 my $plan = $chub->plan || 0;
260 0         0 my $count = $chub->count;
261 0         0 my $failed = $chub->failed;
262             my $passed = $chub->is_passing;
263 0 0       0  
264 0 0 0     0 my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan;
265 0 0       0 if ($count && $num_extra != 0) {
266 0         0 my $s = $plan == 1 ? '' : 's';
267             $st_ctx->diag(<<"FAIL");
268             Looks like you planned $plan test$s but ran $count.
269             FAIL
270             }
271 0 0       0  
272 0 0       0 if ($failed) {
273             my $s = $failed == 1 ? '' : 's';
274 0 0       0  
275             my $qualifier = $num_extra == 0 ? '' : ' run';
276 0         0  
277             $st_ctx->diag(<<"FAIL");
278             Looks like you failed $failed test$s of $count$qualifier.
279             FAIL
280             }
281 0 0 0     0  
      0        
      0        
282 0         0 if (!$passed && !$failed && $count && !$num_extra) {
283             $st_ctx->diag(<<"FAIL");
284             All assertions inside the subtest passed, but errors were encountered.
285             FAIL
286             }
287 0         0  
288             $st_ctx->release;
289 0 0       0  
290 0         0 unless ($chub->bailed_out) {
291 0 0 0     0 my $plan = $chub->plan;
    0          
292 0         0 if ( $plan && $plan eq 'SKIP' ) {
293             $parent->skip($chub->skip_reason, $meta->{Name});
294             }
295 0         0 elsif ( !$chub->count ) {
296             $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} );
297             }
298 0         0 else {
299 0         0 $parent->{subevents} = $meta->{subevents};
300 0         0 $parent->{subtest_id} = $meta->{subtest_id};
301 0         0 $parent->{subtest_uuid} = $meta->{subtest_uuid};
302 0         0 $parent->{subtest_buffered} = $meta->{subtest_buffered};
303             $parent->ok( $chub->is_passing, $meta->{Name} );
304             }
305             }
306 0         0  
307 0         0 $ctx->release;
308             return $chub->is_passing;
309             }
310              
311 0     0 1 0 sub subtest {
312 0         0 my $self = shift;
313 0         0 my ($name, $code, @args) = @_;
314 0 0 0     0 my $ctx = $self->ctx;
315             $ctx->throw("subtest()'s second argument must be a code ref")
316             unless $code && reftype($code) eq 'CODE';
317 0   0     0  
318             $name ||= "Child of " . $self->name;
319              
320              
321 0         0 $_->($name,$code,@args)
322             for Test2::API::test2_list_pre_subtest_callbacks();
323 0         0  
324             $ctx->note("Subtest: $name");
325 0         0  
326             my $child = $self->child($name);
327 0         0  
328 0         0 my $start_pid = $$;
329 0         0 my $st_ctx;
330             my ($ok, $err, $finished, $child_error);
331 0         0 T2_SUBTEST_WRAPPER: {
  0         0  
332 0         0 my $ctx = $self->ctx;
333 0         0 $st_ctx = $ctx->snapshot;
334 0         0 $ctx->release;
  0         0  
  0         0  
  0         0  
335 0         0 $ok = eval { local $Level = 1; $code->(@args); 1 };
336             ($err, $child_error) = ($@, $?);
337              
338 0 0 0     0 # They might have done 'BEGIN { skip_all => "whatever" }'
      0        
      0        
339 0         0 if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
340 0         0 $ok = undef;
341             $err = undef;
342             }
343 0         0 else {
344             $finished = 1;
345             }
346             }
347 0 0 0     0  
348 0 0       0 if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) {
349 0         0 warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
350             exit 255;
351             }
352 0         0  
353             my $trace = $ctx->trace;
354 0 0       0  
355 0 0       0 if (!$finished) {
356 0         0 if(my $bailed = $st_ctx->hub->bailed_out) {
357 0         0 my $chub = $child->{Hub};
358 0         0 $self->{Stack}->pop($chub);
359             $ctx->bail($bailed->reason);
360 0         0 }
361 0         0 my $code = $st_ctx->hub->exit_code;
362 0 0       0 $ok = !$code;
363             $err = "Subtest ended with exit code $code" if $code;
364             }
365 0         0  
366 0         0 my $st_hub = $st_ctx->hub;
367 0         0 my $plan = $st_hub->plan;
368             my $count = $st_hub->count;
369 0 0 0     0  
      0        
370 0 0       0 if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) {
371 0         0 $st_ctx->plan(0) unless defined $plan;
372             $st_ctx->diag('No tests run!');
373             }
374 0         0  
375             $child->finalize($st_ctx->trace);
376 0         0  
377             $ctx->release;
378 0 0       0  
379             die $err unless $ok;
380 0 0       0  
381             $? = $child_error if defined $child_error;
382 0         0  
383             return $st_hub->is_passing;
384             }
385              
386 0     0 1 0 sub name {
387 0         0 my $self = shift;
388 0         0 my $ctx = $self->ctx;
389             release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name};
390             }
391              
392 6     6 1 18 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
393             my ($self, %params) = @_;
394 6         24  
395             Test2::API::test2_unset_is_end();
396              
397             # We leave this a global because it has to be localized and localizing
398 6         22 # hash keys is just asking for pain. Also, it was documented.
399             $Level = 1;
400              
401 6 0       19 $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0
    50          
402             unless $params{singleton};
403 6 50       14  
404             $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$;
405 6         48  
406 6         577 my $ctx = $self->ctx;
407 6         62 my $hub = $ctx->hub;
408 6 50       168 $ctx->release;
409 0         0 unless ($params{singleton}) {
410 0         0 $hub->reset_state();
411             $hub->_tb_reset();
412             }
413 6         36  
414             $ctx = $self->ctx;
415 6         557  
416             my $meta = $ctx->hub->meta(__PACKAGE__, {});
417             %$meta = (
418             Name => $0,
419             Ending => 0,
420             Done_Testing => undef,
421             Skip_All => 0,
422             Test_Results => [],
423 6         187 parent => $meta->{parent},
424             );
425 6 50       20  
426             $self->{Exported_To} = undef unless $params{singleton};
427 6   33     26  
428 6         15 $self->{Orig_Handles} ||= do {
429 6         64 my $format = $ctx->hub->format;
430 6 50 33     78 my $out;
431 6         52 if ($format && $format->isa('Test2::Formatter::TAP')) {
432             $out = $format->handles;
433 6 50       44 }
434             $out ? [@$out] : [];
435             };
436 6         28  
437 6 50       160 $self->use_numbers(1);
438 6 50       18 $self->no_header(0) unless $params{singleton};
439 6         29 $self->no_ending(0) unless $params{singleton};
440             $self->reset_outputs;
441 6         38  
442             $ctx->release;
443 6         125  
444             return;
445             }
446              
447              
448             my %plan_cmds = (
449             no_plan => \&no_plan,
450             skip_all => \&skip_all,
451             tests => \&_plan_tests,
452             );
453              
454 1     1 1 3 sub plan {
455             my( $self, $cmd, $arg ) = @_;
456 1 50       3  
457             return unless $cmd;
458 1         4  
459 1         114 my $ctx = $self->ctx;
460             my $hub = $ctx->hub;
461 1 50       9  
462             $ctx->throw("You tried to plan twice") if $hub->plan;
463 1         9  
464             local $Level = $Level + 1;
465 1 50       13  
466 1         3 if( my $method = $plan_cmds{$cmd} ) {
467 1         4 local $Level = $Level + 1;
468             $self->$method($arg);
469             }
470 0         0 else {
  0         0  
471 0         0 my @args = grep { defined } ( $cmd, $arg );
472             $ctx->throw("plan() doesn't understand @args");
473             }
474 1         14  
475             release $ctx, 1;
476             }
477              
478              
479 3     3   9 sub _plan_tests {
480             my($self, $arg) = @_;
481 3         8  
482             my $ctx = $self->ctx;
483 3 50       138  
    0          
484 3         9 if($arg) {
485 3         11 local $Level = $Level + 1;
486             $self->expected_tests($arg);
487             }
488 0         0 elsif( !defined $arg ) {
489             $ctx->throw("Got an undefined number of tests");
490             }
491 0         0 else {
492             $ctx->throw("You said to run 0 tests");
493             }
494 3         26  
495             $ctx->release;
496             }
497              
498              
499 3     3 1 6 sub expected_tests {
500 3         9 my $self = shift;
501             my($max) = @_;
502 3         8  
503             my $ctx = $self->ctx;
504 3 50       100  
505 3 50       38 if(@_) {
506             $self->croak("Number of tests must be a positive integer. You gave it '$max'")
507             unless $max =~ /^\+?\d+$/;
508 3         20  
509             $ctx->plan($max);
510             }
511 3         1742  
512             my $hub = $ctx->hub;
513 3         26  
514             $ctx->release;
515 3         47  
516 3 50       20 my $plan = $hub->plan;
517 3 50       24 return 0 unless $plan;
518 3         19 return 0 if $plan =~ m/\D/;
519             return $plan;
520             }
521              
522              
523 0     0 1 0 sub no_plan {
524             my($self, $arg) = @_;
525 0         0  
526             my $ctx = $self->ctx;
527 0 0       0  
528 0         0 if (defined $ctx->hub->plan) {
529 0         0 warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future.";
530 0         0 $ctx->release;
531             return;
532             }
533 0 0       0  
534             $ctx->alert("no_plan takes no arguments") if $arg;
535 0         0  
536             $ctx->hub->plan('NO PLAN');
537 0         0  
538             release $ctx, 1;
539             }
540              
541              
542 0     0 1 0 sub done_testing {
543             my($self, $num_tests) = @_;
544 0         0  
545             my $ctx = $self->ctx;
546 0         0  
547             my $meta = $ctx->hub->meta(__PACKAGE__, {});
548 0 0       0  
549 0         0 if ($meta->{Done_Testing}) {
  0         0  
550 0         0 my ($file, $line) = @{$meta->{Done_Testing}}[1,2];
551 0         0 local $ctx->hub->{ended}; # OMG This is awful.
552 0         0 $self->ok(0, "done_testing() was already called at $file line $line");
553 0         0 $ctx->release;
554             return;
555 0         0 }
556             $meta->{Done_Testing} = [$ctx->trace->call];
557 0         0  
558 0         0 my $plan = $ctx->hub->plan;
559             my $count = $ctx->hub->count;
560              
561 0 0 0     0 # If done_testing() specified the number of tests, shut off no_plan
    0 0        
562 0 0 0     0 if( defined $num_tests ) {
563             $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN';
564             }
565 0         0 elsif ($count && defined $num_tests && $count != $num_tests) {
  0         0  
566             $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests");
567             }
568 0         0 else {
569             $num_tests = $self->current_test;
570             }
571 0 0 0     0  
572 0         0 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
  0         0  
573             $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
574             "but done_testing() expects $num_tests");
575             }
576 0 0 0     0  
577             $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN';
578 0         0  
579             $ctx->hub->finalize($ctx->trace, 1);
580 0         0  
581             release $ctx, 1;
582             }
583              
584              
585 0     0 1 0 sub has_plan {
586             my $self = shift;
587 0         0  
588 0         0 my $ctx = $self->ctx;
589 0         0 my $plan = $ctx->hub->plan;
590             $ctx->release;
591 0 0 0     0  
592 0 0 0     0 return( $plan ) if $plan && $plan !~ m/\D/;
593 0         0 return('no_plan') if $plan && $plan eq 'NO PLAN';
594             return(undef);
595             }
596              
597              
598 3     3 1 9 sub skip_all {
599             my( $self, $reason ) = @_;
600 3         11  
601             my $ctx = $self->ctx;
602 3   50     155  
603             $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1;
604              
605 3 50       98 # Work around old perl bug
606 0         0 if ($] < 5.020000) {
607 0         0 my $begin = 0;
608 0         0 my $level = 0;
609 0 0 0     0 while (my @call = caller($level++)) {
610 0 0       0 last unless @call && $call[0];
611 0         0 next unless $call[3] =~ m/::BEGIN$/;
612 0         0 $begin++;
613             last;
614             }
615 0 0 0     0 # HACK!
616             die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent};
617             }
618 3         19  
619             $ctx->plan(0, SKIP => $reason);
620             }
621              
622              
623 12     12 1 28 sub exported_to {
624             my( $self, $pack ) = @_;
625 12 100       108  
626 6         16 if( defined $pack ) {
627             $self->{Exported_To} = $pack;
628 12         28 }
629             return $self->{Exported_To};
630             }
631              
632              
633 12     12 1 26 sub ok {
634             my( $self, $test, $name ) = @_;
635 12         39  
636             my $ctx = $self->ctx;
637              
638             # $test might contain an object which we don't want to accidentally
639 12 50       888 # store, so we turn it into a boolean.
640             $test = $test ? 1 : 0;
641              
642 6     6   62 # In case $name is a string overloaded object, force it to stringify.
  6         12  
  6         838  
643 12 50       34 no warnings qw/uninitialized numeric/;
644             $name = "$name" if defined $name;
645              
646             # Profiling showed that the regex here was a huge time waster, doing the
647 12 50 33     56 # numeric addition first cuts our profile time from ~300ms to ~50ms
648             $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/;
649             You named your test '$name'. You shouldn't use numbers for your test names.
650             Very confusing.
651 6     6   40 ERR
  6         11  
  6         5263  
652             use warnings qw/uninitialized numeric/;
653 12         47  
654 12         16 my $trace = $ctx->{trace};
655             my $hub = $ctx->{hub};
656 12 50       51  
657             my $result = {
658             ok => $test,
659             actual_ok => $test,
660             reason => '',
661             type => '',
662             (name => defined($name) ? $name : ''),
663             };
664 12 50       51  
665             $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results};
666 12         17  
667             my $orig_name = $name;
668 12         16  
669 12         21 my @attrs;
670 12         17 my $subevents = delete $self->{subevents};
671 12         16 my $subtest_id = delete $self->{subtest_id};
672 12         16 my $subtest_uuid = delete $self->{subtest_uuid};
673 12         17 my $subtest_buffered = delete $self->{subtest_buffered};
674 12 50       22 my $epkg = 'Test2::Event::Ok';
675 0         0 if ($subevents) {
676 0         0 $epkg = 'Test2::Event::Subtest';
677             push @attrs => (subevents => $subevents, subtest_id => $subtest_id, subtest_uuid => $subtest_uuid, buffered => $subtest_buffered);
678             }
679 12         125  
680             my $e = bless {
681             trace => bless( {%$trace}, 'Test2::EventFacet::Trace'),
682             pass => $test,
683             name => $name,
684             _meta => {'Test::Builder' => $result},
685             effective_pass => $test,
686             @attrs,
687 12         138 }, $epkg;
688             $hub->send($e);
689 12 50       2744  
690             $self->_ok_debug($trace, $orig_name) unless($test);
691 12         69  
692 12         241 $ctx->release;
693             return $test;
694             }
695              
696 0     0   0 sub _ok_debug {
697 0         0 my $self = shift;
698             my ($trace, $orig_name) = @_;
699 0         0  
700             my $is_todo = $self->in_todo;
701 0 0       0  
702             my $msg = $is_todo ? "Failed (TODO)" : "Failed";
703 0         0  
704 0 0       0 my (undef, $file, $line) = $trace->call;
705 0         0 if (defined $orig_name) {
706             $self->diag(qq[ $msg test '$orig_name'\n at $file line $line.\n]);
707             }
708 0         0 else {
709             $self->diag(qq[ $msg test at $file line $line.\n]);
710             }
711             }
712              
713 0     0   0 sub _diag_fh {
714 0         0 my $self = shift;
715 0 0       0 local $Level = $Level + 1;
716             return $self->in_todo ? $self->todo_output : $self->failure_output;
717             }
718              
719 8     8   1034 sub _unoverload {
720             my ($self, $type, $thing) = @_;
721 8 50       21  
722 8 0 50 0   29 return unless ref $$thing;
  0         0  
723             return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') });
724 8         13 {
  8         92  
725 8         117 local ($!, $@);
726             require overload;
727 8   50     26 }
728 8         496 my $string_meth = overload::Method( $$thing, $type ) || return;
729             $$thing = $$thing->$string_meth();
730             }
731              
732 4     4   5 sub _unoverload_str {
733             my $self = shift;
734 4         10  
735             $self->_unoverload( q[""], $_ ) for @_;
736             }
737              
738 0     0   0 sub _unoverload_num {
739             my $self = shift;
740 0         0  
741             $self->_unoverload( '0+', $_ ) for @_;
742 0         0  
743 0 0       0 for my $val (@_) {
744 0         0 next unless $self->_is_dualvar($$val);
745             $$val = $$val + 0;
746             }
747             }
748              
749             # This is a hack to detect a dualvar such as $!
750 0     0   0 sub _is_dualvar {
751             my( $self, $val ) = @_;
752              
753 0 0       0 # Objects are not dualvars.
754             return 0 if ref $val;
755 6     6   45  
  6         12  
  6         6726  
756 0         0 no warnings 'numeric';
757 0   0     0 my $numval = $val + 0;
758             return ($numval != 0 and $numval ne $val ? 1 : 0);
759             }
760              
761              
762 11     11 1 20 sub is_eq {
763             my( $self, $got, $expect, $name ) = @_;
764 11         24  
765             my $ctx = $self->ctx;
766 11         845  
767             local $Level = $Level + 1;
768 11 100 66     43  
769             if( !defined $got || !defined $expect ) {
770 1   33     8 # undef only matches undef and nothing else
771             my $test = !defined $got && !defined $expect;
772 1         3  
773 1 50       8 $self->ok( $test, $name );
774 1         4 $self->_is_diag( $got, 'eq', $expect ) unless $test;
775 1         21 $ctx->release;
776             return $test;
777             }
778 10         27  
779             release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name );
780             }
781              
782              
783 0     0 1 0 sub is_num {
784 0         0 my( $self, $got, $expect, $name ) = @_;
785 0         0 my $ctx = $self->ctx;
786             local $Level = $Level + 1;
787 0 0 0     0  
788             if( !defined $got || !defined $expect ) {
789 0   0     0 # undef only matches undef and nothing else
790             my $test = !defined $got && !defined $expect;
791 0         0  
792 0 0       0 $self->ok( $test, $name );
793 0         0 $self->_is_diag( $got, '==', $expect ) unless $test;
794 0         0 $ctx->release;
795             return $test;
796             }
797 0         0  
798             release $ctx, $self->cmp_ok( $got, '==', $expect, $name );
799             }
800              
801              
802 0     0   0 sub _diag_fmt {
803             my( $self, $type, $val ) = @_;
804 0 0       0  
805 0 0 0     0 if( defined $$val ) {
806             if( $type eq 'eq' or $type eq 'ne' ) {
807 0         0 # quote and force string context
808             $$val = "'$$val'";
809             }
810             else {
811 0         0 # force numeric context
812             $self->_unoverload_num($val);
813             }
814             }
815 0         0 else {
816             $$val = 'undef';
817             }
818 0         0  
819             return;
820             }
821              
822              
823 0     0   0 sub _is_diag {
824             my( $self, $got, $type, $expect ) = @_;
825 0         0  
826             $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
827 0         0  
828 0         0 local $Level = $Level + 1;
829             return $self->diag(<<"DIAGNOSTIC");
830             got: $got
831             expected: $expect
832             DIAGNOSTIC
833              
834             }
835              
836 0     0   0 sub _isnt_diag {
837             my( $self, $got, $type ) = @_;
838 0         0  
839             $self->_diag_fmt( $type, \$got );
840 0         0  
841 0         0 local $Level = $Level + 1;
842             return $self->diag(<<"DIAGNOSTIC");
843             got: $got
844             expected: anything else
845             DIAGNOSTIC
846             }
847              
848              
849 0     0 1 0 sub isnt_eq {
850 0         0 my( $self, $got, $dont_expect, $name ) = @_;
851 0         0 my $ctx = $self->ctx;
852             local $Level = $Level + 1;
853 0 0 0     0  
854             if( !defined $got || !defined $dont_expect ) {
855 0   0     0 # undef only matches undef and nothing else
856             my $test = defined $got || defined $dont_expect;
857 0         0  
858 0 0       0 $self->ok( $test, $name );
859 0         0 $self->_isnt_diag( $got, 'ne' ) unless $test;
860 0         0 $ctx->release;
861             return $test;
862             }
863 0         0  
864             release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name );
865             }
866              
867 0     0 1 0 sub isnt_num {
868 0         0 my( $self, $got, $dont_expect, $name ) = @_;
869 0         0 my $ctx = $self->ctx;
870             local $Level = $Level + 1;
871 0 0 0     0  
872             if( !defined $got || !defined $dont_expect ) {
873 0   0     0 # undef only matches undef and nothing else
874             my $test = defined $got || defined $dont_expect;
875 0         0  
876 0 0       0 $self->ok( $test, $name );
877 0         0 $self->_isnt_diag( $got, '!=' ) unless $test;
878 0         0 $ctx->release;
879             return $test;
880             }
881 0         0  
882             release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name );
883             }
884              
885              
886 0     0 1 0 sub like {
887 0         0 my( $self, $thing, $regex, $name ) = @_;
888             my $ctx = $self->ctx;
889 0         0  
890             local $Level = $Level + 1;
891 0         0  
892             release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name );
893             }
894              
895 0     0 1 0 sub unlike {
896 0         0 my( $self, $thing, $regex, $name ) = @_;
897             my $ctx = $self->ctx;
898 0         0  
899             local $Level = $Level + 1;
900 0         0  
901             release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name );
902             }
903              
904              
905             my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
906              
907             # Bad, these are not comparison operators. Should we include more?
908             my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
909              
910 10     10 1 21 sub cmp_ok {
911 10         19 my( $self, $got, $type, $expect, $name ) = @_;
912             my $ctx = $self->ctx;
913 10 50       357  
914 0         0 if ($cmp_ok_bl{$type}) {
915             $ctx->throw("$type is not a valid comparison operator in cmp_ok()");
916             }
917 10         22  
918 10         0 my ($test, $succ);
919             my $error;
920             {
921             ## no critic (BuiltinFunctions::ProhibitStringyEval)
922 10         12  
  10         48  
923             local( $@, $!, $SIG{__DIE__} ); # isolate eval
924 10         40  
925             my($pack, $file, $line) = $ctx->trace->call();
926              
927 10         629 # This is so that warnings come out at the caller's level
928             $succ = eval qq[
929             #line $line "(eval in cmp_ok) $file"
930             \$test = (\$got $type \$expect);
931             1;
932 10         143 ];
933             $error = $@;
934 10         16 }
935 10         29 local $Level = $Level + 1;
936             my $ok = $self->ok( $test, $name );
937              
938             # Treat overloaded objects as numbers if we're asked to do a
939             # numeric comparison.
940 10 50       68 my $unoverload
941             = $numeric_cmps{$type}
942             ? '_unoverload_num'
943             : '_unoverload_str';
944 10 50       22  
945             $self->diag(<<"END") unless $succ;
946             An error occurred while using $type:
947             ------------------------------------
948             $error
949             ------------------------------------
950             END
951 10 50       17  
952 0         0 unless($ok) {
953             $self->$unoverload( \$got, \$expect );
954 0 0       0  
    0          
955 0         0 if( $type =~ /^(eq|==)$/ ) {
956             $self->_is_diag( $got, $type, $expect );
957             }
958 6     6   45 elsif( $type =~ /^(ne|!=)$/ ) {
  6         17  
  6         489  
959 0   0     0 no warnings;
960             my $eq = ($got eq $expect || $got == $expect)
961             && (
962             (defined($got) xor defined($expect))
963             || (length($got) != length($expect))
964 6     6   39 );
  6         12  
  6         1909  
965             use warnings;
966 0 0       0  
967 0         0 if ($eq) {
968             $self->_cmp_diag( $got, $type, $expect );
969             }
970 0         0 else {
971             $self->_isnt_diag( $got, $type );
972             }
973             }
974 0         0 else {
975             $self->_cmp_diag( $got, $type, $expect );
976             }
977 10         33 }
978             return release $ctx, $ok;
979             }
980              
981 0     0   0 sub _cmp_diag {
982             my( $self, $got, $type, $expect ) = @_;
983 0 0       0  
984 0 0       0 $got = defined $got ? "'$got'" : 'undef';
985             $expect = defined $expect ? "'$expect'" : 'undef';
986 0         0  
987 0         0 local $Level = $Level + 1;
988             return $self->diag(<<"DIAGNOSTIC");
989             $got
990             $type
991             $expect
992             DIAGNOSTIC
993             }
994              
995 0     0   0 sub _caller_context {
996             my $self = shift;
997 0         0  
998             my( $pack, $file, $line ) = $self->caller(1);
999 0         0  
1000 0 0 0     0 my $code = '';
1001             $code .= "#line $line $file\n" if defined $file and defined $line;
1002 0         0  
1003             return $code;
1004             }
1005              
1006              
1007 0     0 1 0 sub BAIL_OUT {
1008             my( $self, $reason ) = @_;
1009 0         0  
1010             my $ctx = $self->ctx;
1011 0         0  
1012             $self->{Bailed_Out} = 1;
1013 0         0  
1014             $ctx->bail($reason);
1015             }
1016              
1017              
1018 6     6   40 {
  6         10  
  6         4539  
1019             no warnings 'once';
1020             *BAILOUT = \&BAIL_OUT;
1021             }
1022              
1023 0     0 1 0 sub skip {
1024 0   0     0 my( $self, $why, $name ) = @_;
1025 0 0       0 $why ||= '';
1026 0         0 $name = '' unless defined $name;
1027             $self->_unoverload_str( \$why );
1028 0         0  
1029             my $ctx = $self->ctx;
1030              
1031             $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
1032             'ok' => 1,
1033             actual_ok => 1,
1034             name => $name,
1035             type => 'skip',
1036 0 0       0 reason => $why,
1037             } unless $self->{no_log_results};
1038 0         0  
1039 0         0 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
1040 0         0 $name =~ s{\n}{\n# }sg;
1041             $why =~ s{\n}{\n# }sg;
1042 0         0  
1043 0         0 my $tctx = $ctx->snapshot;
1044             $tctx->skip('', $why);
1045 0         0  
1046             return release $ctx, 1;
1047             }
1048              
1049              
1050 0     0 1 0 sub todo_skip {
1051 0   0     0 my( $self, $why ) = @_;
1052             $why ||= '';
1053 0         0  
1054             my $ctx = $self->ctx;
1055              
1056             $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
1057             'ok' => 1,
1058             actual_ok => 0,
1059             name => '',
1060             type => 'todo_skip',
1061 0 0       0 reason => $why,
1062             } unless $self->{no_log_results};
1063 0         0  
1064 0         0 $why =~ s{\n}{\n# }sg;
1065 0         0 my $tctx = $ctx->snapshot;
1066             $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0);
1067 0         0  
1068             return release $ctx, 1;
1069             }
1070              
1071              
1072 0     0 1 0 sub maybe_regex {
1073 0         0 my( $self, $regex ) = @_;
1074             my $usable_regex = undef;
1075 0 0       0  
1076             return $usable_regex unless defined $regex;
1077 0         0  
1078             my( $re, $opts );
1079              
1080 0 0 0     0 # Check for qr/foo/
    0          
1081 0         0 if( _is_qr($regex) ) {
1082             $usable_regex = $regex;
1083             }
1084             # Check for '/foo/' or 'm,foo,'
1085             elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
1086             ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1087             )
1088 0 0       0 {
1089             $usable_regex = length $opts ? "(?$opts)$re" : $re;
1090             }
1091 0         0  
1092             return $usable_regex;
1093             }
1094              
1095 0     0   0 sub _is_qr {
1096             my $regex = shift;
1097              
1098             # is_regexp() checks for regexes in a robust manner, say if they're
1099 0 0       0 # blessed.
1100 0         0 return re::is_regexp($regex) if defined &re::is_regexp;
1101             return ref $regex eq 'Regexp';
1102             }
1103              
1104 0     0   0 sub _regex_ok {
1105             my( $self, $thing, $regex, $cmp, $name ) = @_;
1106 0         0  
1107 0         0 my $ok = 0;
1108 0 0       0 my $usable_regex = $self->maybe_regex($regex);
1109 0         0 unless( defined $usable_regex ) {
1110 0         0 local $Level = $Level + 1;
1111 0         0 $ok = $self->ok( 0, $name );
1112 0         0 $self->diag(" '$regex' doesn't look much like a regex to me.");
1113             return $ok;
1114             }
1115              
1116 0         0 {
  0         0  
1117 0         0 my $test;
1118             my $context = $self->_caller_context;
1119              
1120             {
1121             ## no critic (BuiltinFunctions::ProhibitStringyEval)
1122 0         0  
  0         0  
1123             local( $@, $!, $SIG{__DIE__} ); # isolate eval
1124              
1125 6     6   43 # No point in issuing an uninit warning, they'll see it in the diagnostics
  6         11  
  6         2950  
1126             no warnings 'uninitialized';
1127 0         0  
1128             $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
1129             }
1130 0 0       0  
1131             $test = !$test if $cmp eq '!~';
1132 0         0  
1133 0         0 local $Level = $Level + 1;
1134             $ok = $self->ok( $test, $name );
1135             }
1136 0 0       0  
1137 0 0       0 unless($ok) {
1138 0 0       0 $thing = defined $thing ? "'$thing'" : 'undef';
1139             my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1140 0         0  
1141 0         0 local $Level = $Level + 1;
1142             $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
1143             %s
1144             %13s '%s'
1145             DIAGNOSTIC
1146              
1147             }
1148 0         0  
1149             return $ok;
1150             }
1151              
1152              
1153 0     0 1 0 sub is_fh {
1154 0         0 my $self = shift;
1155 0 0       0 my $maybe_fh = shift;
1156             return 0 unless defined $maybe_fh;
1157 0 0       0  
1158 0 0       0 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1159             return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1160              
1161 0   0     0 return eval { $maybe_fh->isa("IO::Handle") } ||
1162             eval { tied($maybe_fh)->can('TIEHANDLE') };
1163             }
1164              
1165              
1166 0     0 1 0 sub level {
1167             my( $self, $level ) = @_;
1168 0 0       0  
1169 0         0 if( defined $level ) {
1170             $Level = $level;
1171 0         0 }
1172             return $Level;
1173             }
1174              
1175              
1176 6     6 1 13 sub use_numbers {
1177             my( $self, $use_nums ) = @_;
1178 6         15  
1179 6         326 my $ctx = $self->ctx;
1180 6 50 33     120 my $format = $ctx->hub->format;
      33        
1181 0 0       0 unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) {
1182 0         0 warn "The current formatter does not support 'use_numbers'" if $format;
1183             return release $ctx, 0;
1184             }
1185 6 50       77  
1186             $format->set_no_numbers(!$use_nums) if defined $use_nums;
1187 6 50       33  
1188             return release $ctx, $format->no_numbers ? 0 : 1;
1189             }
1190              
1191 6     6   29 BEGIN {
1192 12         29 for my $method (qw(no_header no_diag)) {
1193             my $set = "set_$method";
1194 0     0   0 my $code = sub {
1195             my( $self, $no ) = @_;
1196 0         0  
1197 0         0 my $ctx = $self->ctx;
1198 0 0 0     0 my $format = $ctx->hub->format;
1199 0 0       0 unless ($format && $format->can($set)) {
1200 0         0 warn "The current formatter does not support '$method'" if $format;
1201             $ctx->release;
1202 0         0 return
1203             }
1204 0 0       0  
1205             $format->$set($no) if defined $no;
1206 0 0       0  
1207 12         58 return release $ctx, $format->$method ? 1 : 0;
1208             };
1209 6     6   42  
  6         14  
  6         259  
1210 12         9167 no strict 'refs'; ## no critic
1211             *$method = $code;
1212             }
1213             }
1214              
1215 0     0 1 0 sub no_ending {
1216             my( $self, $no ) = @_;
1217 0         0  
1218             my $ctx = $self->ctx;
1219 0 0       0  
1220             $ctx->hub->set_no_ending($no) if defined $no;
1221 0         0  
1222             return release $ctx, $ctx->hub->no_ending;
1223             }
1224              
1225 1     1 1 3 sub diag {
1226 1 50       4 my $self = shift;
1227             return unless @_;
1228 1 50       3  
  1         9  
1229             my $text = join '' => map {defined($_) ? $_ : 'undef'} @_;
1230 1 50       4  
1231 0         0 if (Test2::API::test2_in_preload()) {
1232 0         0 chomp($text);
1233 0         0 $text =~ s/^/# /msg;
1234 0         0 print STDERR $text, "\n";
1235             return 0;
1236             }
1237 1         8  
1238 1         162 my $ctx = $self->ctx;
1239 1         5775 $ctx->diag($text);
1240 1         181 $ctx->release;
1241             return 0;
1242             }
1243              
1244              
1245 0     0 1 0 sub note {
1246 0 0       0 my $self = shift;
1247             return unless @_;
1248 0 0       0  
  0         0  
1249             my $text = join '' => map {defined($_) ? $_ : 'undef'} @_;
1250 0 0       0  
1251 0         0 if (Test2::API::test2_in_preload()) {
1252 0         0 chomp($text);
1253 0         0 $text =~ s/^/# /msg;
1254 0         0 print STDOUT $text, "\n";
1255             return 0;
1256             }
1257 0         0  
1258 0         0 my $ctx = $self->ctx;
1259 0         0 $ctx->note($text);
1260 0         0 $ctx->release;
1261             return 0;
1262             }
1263              
1264              
1265 0     0 1 0 sub explain {
1266             my $self = shift;
1267 0         0  
1268 0         0 local ($@, $!);
1269             require Data::Dumper;
1270              
1271 0         0 return map {
1272 0 0       0 ref $_
1273 0         0 ? do {
1274 0         0 my $dumper = Data::Dumper->new( [$_] );
1275 0 0       0 $dumper->Indent(1)->Terse(1);
1276 0         0 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1277             $dumper->Dump;
1278             }
1279             : $_
1280             } @_;
1281             }
1282              
1283              
1284 0     0 1 0 sub output {
1285             my( $self, $fh ) = @_;
1286 0         0  
1287 0         0 my $ctx = $self->ctx;
1288 0         0 my $format = $ctx->hub->format;
1289 0 0 0     0 $ctx->release;
1290             return unless $format && $format->isa('Test2::Formatter::TAP');
1291 0 0       0  
1292             $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh)
1293             if defined $fh;
1294 0         0  
1295             return $format->handles->[Test2::Formatter::TAP::OUT_STD()];
1296             }
1297              
1298 0     0 1 0 sub failure_output {
1299             my( $self, $fh ) = @_;
1300 0         0  
1301 0         0 my $ctx = $self->ctx;
1302 0         0 my $format = $ctx->hub->format;
1303 0 0 0     0 $ctx->release;
1304             return unless $format && $format->isa('Test2::Formatter::TAP');
1305 0 0       0  
1306             $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh)
1307             if defined $fh;
1308 0         0  
1309             return $format->handles->[Test2::Formatter::TAP::OUT_ERR()];
1310             }
1311              
1312 0     0 1 0 sub todo_output {
1313             my( $self, $fh ) = @_;
1314 0         0  
1315 0         0 my $ctx = $self->ctx;
1316 0         0 my $format = $ctx->hub->format;
1317 0 0 0     0 $ctx->release;
1318             return unless $format && $format->isa('Test::Builder::Formatter');
1319 0 0       0  
1320             $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh)
1321             if defined $fh;
1322 0         0  
1323             return $format->handles->[Test::Builder::Formatter::OUT_TODO()];
1324             }
1325              
1326 0     0   0 sub _new_fh {
1327 0         0 my $self = shift;
1328             my($file_or_fh) = shift;
1329 0         0  
1330 0 0       0 my $fh;
    0          
1331 0         0 if( $self->is_fh($file_or_fh) ) {
1332             $fh = $file_or_fh;
1333             }
1334             elsif( ref $file_or_fh eq 'SCALAR' ) {
1335 0 0       0 # Scalar refs as filehandles was added in 5.8.
1336 0 0       0 if( $] >= 5.008 ) {
1337             open $fh, ">>", $file_or_fh
1338             or $self->croak("Can't open scalar ref $file_or_fh: $!");
1339             }
1340             # Emulate scalar ref filehandles with a tie.
1341 0 0       0 else {
1342             $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1343             or $self->croak("Can't tie scalar ref $file_or_fh");
1344             }
1345             }
1346 0 0       0 else {
1347             open $fh, ">", $file_or_fh
1348 0         0 or $self->croak("Can't open test output log $file_or_fh: $!");
1349             _autoflush($fh);
1350             }
1351 0         0  
1352             return $fh;
1353             }
1354              
1355 0     0   0 sub _autoflush {
1356 0         0 my($fh) = shift;
1357 0         0 my $old_fh = select $fh;
1358 0         0 $| = 1;
1359             select $old_fh;
1360 0         0  
1361             return;
1362             }
1363              
1364              
1365 6     6 1 10 sub reset_outputs {
1366             my $self = shift;
1367 6         13  
1368 6         288 my $ctx = $self->ctx;
1369 6         94 my $format = $ctx->hub->format;
1370 6 50 33     82 $ctx->release;
1371 6 50       43 return unless $format && $format->isa('Test2::Formatter::TAP');
  6         71  
1372             $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles};
1373 6         37  
1374             return;
1375             }
1376              
1377              
1378 0     0 1 0 sub carp {
1379 0         0 my $self = shift;
1380 0         0 my $ctx = $self->ctx;
1381 0         0 $ctx->alert(join "", @_);
1382             $ctx->release;
1383             }
1384              
1385 0     0 1 0 sub croak {
1386 0         0 my $self = shift;
1387 0         0 my $ctx = $self->ctx;
1388 0         0 $ctx->throw(join "", @_);
1389             $ctx->release;
1390             }
1391              
1392              
1393 0     0 1 0 sub current_test {
1394             my( $self, $num ) = @_;
1395 0         0  
1396 0         0 my $ctx = $self->ctx;
1397             my $hub = $ctx->hub;
1398 0 0       0  
1399 0         0 if( defined $num ) {
1400             $hub->set_count($num);
1401 0 0       0  
1402             unless ($self->{no_log_results}) {
1403 0         0 # If the test counter is being pushed forward fill in the details.
1404 0 0       0 my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
    0          
1405 0 0       0 if ($num > @$test_results) {
1406 0         0 my $start = @$test_results ? @$test_results : 0;
1407 0         0 for ($start .. $num - 1) {
1408             $test_results->[$_] = {
1409             'ok' => 1,
1410             actual_ok => undef,
1411             reason => 'incrementing test number',
1412             type => 'unknown',
1413             name => undef
1414             };
1415             }
1416             }
1417             # If backward, wipe history. Its their funeral.
1418 0         0 elsif ($num < @$test_results) {
  0         0  
1419             $#{$test_results} = $num - 1;
1420             }
1421             }
1422 0         0 }
1423             return release $ctx, $hub->count;
1424             }
1425              
1426              
1427 0     0 1 0 sub is_passing {
1428             my $self = shift;
1429 0         0  
1430 0         0 my $ctx = $self->ctx;
1431             my $hub = $ctx->hub;
1432 0 0       0  
1433 0         0 if( @_ ) {
1434 0 0       0 my ($bool) = @_;
1435 0         0 $hub->set_failed(0) if $bool;
1436             $hub->is_passing($bool);
1437             }
1438 0         0  
1439             return release $ctx, $hub->is_passing;
1440             }
1441              
1442              
1443 0     0 1 0 sub summary {
1444             my($self) = shift;
1445 0 0       0  
1446             return if $self->{no_log_results};
1447 0         0  
1448 0         0 my $ctx = $self->ctx;
1449 0         0 my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
1450 0 0       0 $ctx->release;
  0         0  
1451             return map { $_ ? $_->{'ok'} : () } @$data;
1452             }
1453              
1454              
1455 0     0 1 0 sub details {
1456             my $self = shift;
1457 0 0       0  
1458             return if $self->{no_log_results};
1459 0         0  
1460 0         0 my $ctx = $self->ctx;
1461 0         0 my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
1462 0         0 $ctx->release;
1463             return @$data;
1464             }
1465              
1466              
1467 0     0 1 0 sub find_TODO {
1468             my( $self, $pack, $set, $new_value ) = @_;
1469 0         0  
1470             my $ctx = $self->ctx;
1471 0   0     0  
      0        
1472 0         0 $pack ||= $ctx->trace->package || $self->exported_to;
1473             $ctx->release;
1474 0 0       0  
1475             return unless $pack;
1476 6     6   49  
  6         12  
  6         196  
1477 6     6   33 no strict 'refs'; ## no critic
  6         31  
  6         1095  
1478 0         0 no warnings 'once';
  0         0  
1479 0 0       0 my $old_value = ${ $pack . '::TODO' };
  0         0  
1480 0         0 $set and ${ $pack . '::TODO' } = $new_value;
1481             return $old_value;
1482             }
1483              
1484 0     0 1 0 sub todo {
1485             my( $self, $pack ) = @_;
1486 0         0  
1487 0         0 local $Level = $Level + 1;
1488 0         0 my $ctx = $self->ctx;
1489             $ctx->release;
1490 0         0  
1491 0 0 0     0 my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
1492             return $meta->[-1]->[1] if $meta && @$meta;
1493 0   0     0  
1494             $pack ||= $ctx->trace->package;
1495 0 0       0  
1496             return unless $pack;
1497 6     6   38  
  6         11  
  6         157  
1498 6     6   27 no strict 'refs'; ## no critic
  6         10  
  6         899  
1499 0         0 no warnings 'once';
  0         0  
1500             return ${ $pack . '::TODO' };
1501             }
1502              
1503 0     0 1 0 sub in_todo {
1504             my $self = shift;
1505 0         0  
1506 0         0 local $Level = $Level + 1;
1507 0         0 my $ctx = $self->ctx;
1508             $ctx->release;
1509 0         0  
1510 0 0 0     0 my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
1511             return 1 if $meta && @$meta;
1512 0   0     0  
1513             my $pack = $ctx->trace->package || return 0;
1514 6     6   38  
  6         10  
  6         204  
1515 6     6   34 no strict 'refs'; ## no critic
  6         10  
  6         7424  
1516 0         0 no warnings 'once';
  0         0  
1517             my $todo = ${ $pack . '::TODO' };
1518 0 0       0  
1519 0 0       0 return 0 unless defined $todo;
1520 0         0 return 0 if "$todo" eq '';
1521             return 1;
1522             }
1523              
1524 0     0 1 0 sub todo_start {
1525 0 0       0 my $self = shift;
1526             my $message = @_ ? shift : '';
1527 0         0  
1528             my $ctx = $self->ctx;
1529 0         0  
1530             my $hub = $ctx->hub;
1531 0     0   0 my $filter = $hub->pre_filter(sub {
1532             my ($active_hub, $e) = @_;
1533              
1534 0 0       0 # Turn a diag into a todo diag
1535             return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
1536              
1537 0 0 0     0 # Set todo on ok's
1538 0         0 if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) {
1539 0         0 $e->set_todo($message);
1540             $e->set_effective_pass(1);
1541 0 0       0  
1542 0   0     0 if (my $result = $e->get_meta(__PACKAGE__)) {
1543 0   0     0 $result->{reason} ||= $message;
1544 0         0 $result->{type} ||= 'todo';
1545             $result->{ok} = 1;
1546             }
1547             }
1548 0         0  
1549 0         0 return $e;
1550             }, inherit => 1);
1551 0         0  
  0         0  
1552             push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message];
1553 0         0  
1554             $ctx->release;
1555 0         0  
1556             return;
1557             }
1558              
1559 0     0 1 0 sub todo_end {
1560             my $self = shift;
1561 0         0  
1562             my $ctx = $self->ctx;
1563 0         0  
  0         0  
1564             my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}};
1565 0 0       0  
1566             $ctx->throw('todo_end() called without todo_start()') unless $set;
1567 0         0  
1568             $ctx->hub->pre_unfilter($set->[0]);
1569 0         0  
1570             $ctx->release;
1571 0         0  
1572             return;
1573             }
1574              
1575              
1576 0     0 1 0 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1577             my( $self ) = @_;
1578 0         0  
1579             my $ctx = $self->ctx;
1580 0         0  
1581 0         0 my $trace = $ctx->trace;
1582 0 0       0 $ctx->release;
1583             return wantarray ? $trace->call : $trace->package;
1584             }
1585              
1586              
1587 0     0   0 sub _try {
1588             my( $self, $code, %opts ) = @_;
1589 0         0  
1590             my $error;
1591             my $return;
1592 0         0 {
  0         0  
1593 0         0 local $!; # eval can mess up $!
1594 0         0 local $@; # don't set $@ in the test
1595 0         0 local $SIG{__DIE__}; # don't trip an outside DIE handler.
  0         0  
1596 0         0 $return = eval { $code->() };
1597             $error = $@;
1598             }
1599 0 0 0     0  
1600             die $error if $error and $opts{die_on_fail};
1601 0 0       0  
1602             return wantarray ? ( $return, $error ) : $return;
1603             }
1604              
1605 6     6   15 sub _ending {
1606 6         19 my $self = shift;
1607             my ($ctx, $real_exit_code, $new) = @_;
1608 6 50       70  
1609 0         0 unless ($ctx) {
1610 0         0 my $octx = $self->ctx;
1611 0         0 $ctx = $octx->snapshot;
1612             $octx->release;
1613             }
1614 6 50       29  
1615 6 50       53 return if $ctx->hub->no_ending;
1616             return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++;
1617              
1618             # Don't bother with an ending if this is a forked copy. Only the parent
1619 6 50       218 # should do the ending.
1620             return unless $self->{Original_Pid} == $$;
1621 6         20  
1622 6 50       71 my $hub = $ctx->hub;
1623             return if $hub->bailed_out;
1624 6         40  
1625 6         45 my $plan = $hub->plan;
1626 6         31 my $count = $hub->count;
1627 6         27 my $failed = $hub->failed;
1628 6 0 33     134 my $passed = $hub->is_passing;
      33        
1629             return unless $plan || $count || $failed;
1630              
1631 6 50 33     19 # Ran tests but never declared a plan or hit done_testing
1632 0         0 if( !$hub->plan and $hub->count ) {
1633             $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
1634 0 0       0  
1635 0         0 if($real_exit_code) {
1636             $self->diag(<<"FAIL");
1637             Looks like your test exited with $real_exit_code just after $count.
1638 0   0     0 FAIL
1639 0         0 $$new ||= $real_exit_code;
1640             return;
1641             }
1642              
1643 0 0       0 # But if the tests ran, handle exit code.
1644 0 0       0 if($failed > 0) {
1645 0   0     0 my $exit_code = $failed <= 254 ? $failed : 254;
1646 0         0 $$new ||= $exit_code;
1647             return;
1648             }
1649 0   0     0  
1650 0         0 $$new ||= 254;
1651             return;
1652             }
1653 6 50 33     58  
1654 0         0 if ($real_exit_code && !$count) {
1655 0   0     0 $self->diag("Looks like your test exited with $real_exit_code before it could output anything.");
1656 0         0 $$new ||= $real_exit_code;
1657             return;
1658             }
1659 6 100 66     45  
1660             return if $plan && "$plan" eq 'SKIP';
1661 3 50       11  
1662 0         0 if (!$count) {
1663 0   0     0 $self->diag('No tests run!');
1664 0         0 $$new ||= 255;
1665             return;
1666             }
1667 3 50       10  
1668 0         0 if ($real_exit_code) {
1669             $self->diag(<<"FAIL");
1670             Looks like your test exited with $real_exit_code just after $count.
1671 0   0     0 FAIL
1672 0         0 $$new ||= $real_exit_code;
1673             return;
1674             }
1675 3 50       10  
1676 0         0 if ($plan eq 'NO PLAN') {
1677 0         0 $ctx->plan( $count );
1678             $plan = $hub->plan;
1679             }
1680              
1681 3         7 # Figure out if we passed or failed and print helpful messages.
1682             my $num_extra = $count - $plan;
1683 3 50       11  
1684 0 0       0 if ($num_extra != 0) {
1685 0         0 my $s = $plan == 1 ? '' : 's';
1686             $self->diag(<<"FAIL");
1687             Looks like you planned $plan test$s but ran $count.
1688             FAIL
1689             }
1690 3 50       11  
1691 0 0       0 if ($failed) {
1692             my $s = $failed == 1 ? '' : 's';
1693 0 0       0  
1694             my $qualifier = $num_extra == 0 ? '' : ' run';
1695 0         0  
1696             $self->diag(<<"FAIL");
1697             Looks like you failed $failed test$s of $count$qualifier.
1698             FAIL
1699             }
1700 3 0 33     16  
      33        
      33        
1701 0         0 if (!$passed && !$failed && $count && !$num_extra) {
1702             $ctx->diag(<<"FAIL");
1703             All assertions passed, but errors were encountered.
1704             FAIL
1705             }
1706 3         6  
1707 3 50       19 my $exit_code = 0;
    50          
    50          
1708 0 0       0 if ($failed) {
1709             $exit_code = $failed <= 254 ? $failed : 254;
1710             }
1711 0         0 elsif ($num_extra != 0) {
1712             $exit_code = 255;
1713             }
1714 0         0 elsif (!$passed) {
1715             $exit_code = 255;
1716             }
1717 3   33     15  
1718 3         9 $$new ||= $exit_code;
1719             return;
1720             }
1721              
1722             # Some things used this even though it was private... I am looking at you
1723             # Test::Builder::Prefix...
1724 0     0     sub _print_comment {
1725             my( $self, $fh, @msgs ) = @_;
1726 0 0          
1727 0 0         return if $self->no_diag;
1728             return unless @msgs;
1729              
1730 0 0         # Prevent printing headers when compiling (i.e. -c)
1731             return if $^C;
1732              
1733             # Smash args together like print does.
1734 0 0         # Convert undef to 'undef' so its readable.
  0            
1735             my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1736              
1737 0           # Escape the beginning, _print will take care of the rest.
1738             $msg =~ s/^/# /;
1739 0            
1740 0           local( $\, $", $, ) = ( undef, ' ', '' );
1741             print $fh $msg;
1742 0            
1743             return 0;
1744             }
1745              
1746             # This is used by Test::SharedFork to turn on IPC after the fact. Not
1747             # documenting because I do not want it used. The method name is borrowed from
1748             # Test::Builder 2
1749             # Once Test2 stuff goes stable this method will be removed and Test::SharedFork
1750             # will be made smarter.
1751 0     0 0   sub coordinate_forks {
1752             my $self = shift;
1753              
1754 0           {
  0            
1755 0           local ($@, $!);
1756             require Test2::IPC;
1757 0           }
1758 0           Test2::IPC->import;
1759 0           Test2::API::test2_ipc_enable_polling();
1760 0           Test2::API::test2_load();
1761 0           my $ipc = Test2::IPC::apply_ipc($self->{Stack});
1762 0           $ipc->set_no_fatal(1);
1763             Test2::API::test2_no_wait(1);
1764             }
1765 0     0 1    
1766             sub no_log_results { $_[0]->{no_log_results} = 1 }
1767              
1768             1;
1769              
1770             __END__
1771              
1772             #line 2121
1773              
1774