File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 341 689 49.4
branch 94 344 27.3
condition 20 86 23.2
subroutine 61 99 61.6
pod 49 49 100.0
total 565 1267 44.5


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 10     10   171  
  10         32  
  10         408  
4 10     10   43 use 5.006;
  10         19  
  10         255  
5 10     10   47 use strict;
  10         17  
  10         725  
6             use warnings;
7              
8             our $VERSION = '0.94';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 10 50   10   417 BEGIN {
12 0         0 if( $] < 5.008 ) {
13             require Test::Builder::IO::Scalar;
14             }
15             }
16              
17              
18             # Make Test::Builder thread-safe for ithreads.
19 10     10   46 BEGIN {
  10         15  
  10         3695  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 10 50 33 10   569 # 5.8.0's threads are so busted we no longer support them.
      33        
23 0         0 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
24             require threads::shared;
25              
26             # Hack around YET ANOTHER threads::shared bug. It would
27             # occassionally forget the contents of the variable when sharing it.
28             # So we first copy the data, then share, then put our copy back.
29 0         0 *share = sub (\[$@%]) {
30 0         0 my $type = ref $_[0];
31             my $data;
32 0 0       0  
    0          
    0          
33 0         0 if( $type eq 'HASH' ) {
  0         0  
34             %$data = %{ $_[0] };
35             }
36 0         0 elsif( $type eq 'ARRAY' ) {
  0         0  
37             @$data = @{ $_[0] };
38             }
39 0         0 elsif( $type eq 'SCALAR' ) {
  0         0  
40             $$data = ${ $_[0] };
41             }
42 0         0 else {
43             die( "Unknown type: " . $type );
44             }
45 0         0  
46             $_[0] = &threads::shared::share( $_[0] );
47 0 0       0  
    0          
    0          
48 0         0 if( $type eq 'HASH' ) {
  0         0  
49             %{ $_[0] } = %$data;
50             }
51 0         0 elsif( $type eq 'ARRAY' ) {
  0         0  
52             @{ $_[0] } = @$data;
53             }
54 0         0 elsif( $type eq 'SCALAR' ) {
  0         0  
55             ${ $_[0] } = $$data;
56             }
57 0         0 else {
58             die( "Unknown type: " . $type );
59             }
60 0         0  
61 0         0 return $_[0];
62             };
63             }
64             # 5.8.0's threads::shared is busted when threads are off
65             # and earlier Perls just don't have that module at all.
66 10     81   57 else {
  81         163  
67 10     51   32646 *share = sub { return $_[0] };
  51         68  
68             *lock = sub { 0 };
69             }
70             }
71              
72             #line 117
73              
74             our $Test = Test::Builder->new;
75              
76             sub new {
77             my($class) = shift;
78             $Test ||= $class->create;
79             return $Test;
80             }
81              
82             #line 139
83              
84             sub create {
85             my $class = shift;
86              
87             my $self = bless {}, $class;
88             $self->reset;
89              
90             return $self;
91             }
92              
93             #line 168
94              
95             sub child {
96             my( $self, $name ) = @_;
97              
98             if( $self->{Child_Name} ) {
99             $self->croak("You already have a child named ($self->{Child_Name}) running");
100             }
101              
102             my $child = bless {}, ref $self;
103             $child->reset;
104              
105             # Add to our indentation
106             $child->_indent( $self->_indent . ' ' );
107             $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
108              
109             # This will be reset in finalize. We do this here lest one child failure
110             # cause all children to fail.
111             $child->{Child_Error} = $?;
112             $? = 0;
113             $child->{Parent} = $self;
114             $child->{Name} = $name || "Child of " . $self->name;
115             $self->{Child_Name} = $child->name;
116             return $child;
117             }
118              
119              
120             #line 201
121 73     73 1 145  
122 73   66     602 sub subtest {
123 73         266 my $self = shift;
124             my($name, $subtests) = @_;
125              
126             if ('CODE' ne ref $subtests) {
127             $self->croak("subtest()'s second argument must be a code ref");
128             }
129              
130             # Turn the child into the parent so anyone who has stored a copy of
131             # the Test::Builder singleton will get the child.
132             my $child = $self->child($name);
133             my %parent = %$self;
134             %$self = %$child;
135              
136             my $error;
137             if( !eval { $subtests->(); 1 } ) {
138             $error = $@;
139             }
140              
141 10     10 1 28 # Restore the parent and the copied child.
142             %$child = %$self;
143 10         43 %$self = %parent;
144 10         49  
145             # Die *after* we restore the parent.
146 10         33 die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
147              
148             return $child->finalize;
149             }
150              
151              
152             #line 250
153              
154             sub finalize {
155             my $self = shift;
156              
157             return unless $self->parent;
158             if( $self->{Child_Name} ) {
159             $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
160             }
161             $self->_ending;
162              
163             # XXX This will only be necessary for TAP envelopes (we think)
164             #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
165              
166             my $ok = 1;
167             $self->parent->{Child_Name} = undef;
168             if ( $self->{Skip_All} ) {
169             $self->parent->skip($self->{Skip_All});
170 0     0 1 0 }
171             elsif ( not @{ $self->{Test_Results} } ) {
172 0 0       0 $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
173 0         0 }
174             else {
175             $self->parent->ok( $self->is_passing, $self->name );
176 0         0 }
177 0         0 $? = $self->{Child_Error};
178             delete $self->{Parent};
179              
180 0         0 return $self->is_passing;
181 0         0 }
182              
183             sub _indent {
184             my $self = shift;
185 0         0  
186 0         0 if( @_ ) {
187 0         0 $self->{Indent} = shift;
188 0   0     0 }
189 0         0  
190 0         0 return $self->{Indent};
191             }
192              
193             #line 300
194              
195             sub parent { shift->{Parent} }
196              
197             #line 312
198              
199             sub name { shift->{Name} }
200              
201             sub DESTROY {
202             my $self = shift;
203 0     0 1 0 if ( $self->parent ) {
204 0         0 my $name = $self->name;
205             $self->diag(<<"FAIL");
206 0 0       0 Child ($name) exited without calling finalize()
207 0         0 FAIL
208             $self->parent->{In_Destroy} = 1;
209             $self->parent->ok(0, $name);
210             }
211             }
212 0         0  
213 0         0 #line 336
214 0         0  
215             our $Level;
216 0         0  
217 0 0       0 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
  0         0  
  0         0  
218 0         0 my($self) = @_;
219              
220             # We leave this a global because it has to be localized and localizing
221             # hash keys is just asking for pain. Also, it was documented.
222 0         0 $Level = 1;
223 0         0  
224             $self->{Name} = $0;
225             $self->is_passing(1);
226 0 0 0     0 $self->{Ending} = 0;
  0         0  
227             $self->{Have_Plan} = 0;
228 0         0 $self->{No_Plan} = 0;
229             $self->{Have_Output_Plan} = 0;
230              
231             $self->{Original_Pid} = $$;
232             $self->{Child_Name} = undef;
233             $self->{Indent} ||= '';
234              
235             share( $self->{Curr_Test} );
236             $self->{Curr_Test} = 0;
237             $self->{Test_Results} = &share( [] );
238              
239             $self->{Exported_To} = undef;
240             $self->{Expected_Tests} = 0;
241              
242             $self->{Skip_All} = 0;
243              
244             $self->{Use_Nums} = 1;
245              
246             $self->{No_Header} = 0;
247             $self->{No_Ending} = 0;
248              
249             $self->{Todo} = undef;
250             $self->{Todo_Stack} = [];
251             $self->{Start_Todo} = 0;
252 0     0 1 0 $self->{Opened_Testhandles} = 0;
253              
254 0 0       0 $self->_dup_stdhandles;
255 0 0       0  
256 0         0 return;
257             }
258 0         0  
259             #line 414
260              
261             my %plan_cmds = (
262             no_plan => \&no_plan,
263 0         0 skip_all => \&skip_all,
264 0         0 tests => \&_plan_tests,
265 0 0       0 );
  0 0       0  
266 0         0  
267             sub plan {
268             my( $self, $cmd, $arg ) = @_;
269 0         0  
270             return unless $cmd;
271              
272 0         0 local $Level = $Level + 1;
273              
274 0         0 $self->croak("You tried to plan twice") if $self->{Have_Plan};
275 0         0  
276             if( my $method = $plan_cmds{$cmd} ) {
277 0         0 local $Level = $Level + 1;
278             $self->$method($arg);
279             }
280             else {
281 61     61   75 my @args = grep { defined } ( $cmd, $arg );
282             $self->croak("plan() doesn't understand @args");
283 61 50       150 }
284 0         0  
285             return 1;
286             }
287 61         9478  
288              
289             sub _plan_tests {
290             my($self, $arg) = @_;
291              
292             if($arg) {
293             local $Level = $Level + 1;
294             return $self->expected_tests($arg);
295             }
296             elsif( !defined $arg ) {
297             $self->croak("Got an undefined number of tests");
298             }
299             else {
300             $self->croak("You said to run 0 tests");
301 0     0 1 0 }
302              
303             return;
304             }
305              
306              
307             #line 470
308              
309             sub expected_tests {
310             my $self = shift;
311             my($max) = @_;
312              
313 0     0 1 0 if(@_) {
314             $self->croak("Number of tests must be a positive integer. You gave it '$max'")
315             unless $max =~ /^\+?\d+$/;
316 0     0   0  
317 0 0       0 $self->{Expected_Tests} = $max;
318 0         0 $self->{Have_Plan} = 1;
319 0         0  
320             $self->_output_plan($max) unless $self->no_header;
321             }
322 0         0 return $self->{Expected_Tests};
323 0         0 }
324              
325             #line 494
326              
327             sub no_plan {
328             my($self, $arg) = @_;
329              
330             $self->carp("no_plan takes no arguments") if $arg;
331              
332             $self->{No_Plan} = 1;
333             $self->{Have_Plan} = 1;
334              
335             return 1;
336             }
337              
338              
339             #line 528
340 10     10 1 18  
341             sub _output_plan {
342             my($self, $max, $directive, $reason) = @_;
343              
344 10         20 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
345              
346 10         112 my $plan = "1..$max";
347 10         38 $plan .= " # $directive" if defined $directive;
348 10         20 $plan .= " $reason" if defined $reason;
349 10         19  
350 10         23 $self->_print("$plan\n");
351 10         21  
352             $self->{Have_Output_Plan} = 1;
353 10         114  
354 10         36 return;
355 10   50     82 }
356              
357 10         51 #line 579
358 10         28  
359 10         35 sub done_testing {
360             my($self, $num_tests) = @_;
361 10         26  
362 10         24 # If done_testing() specified the number of tests, shut off no_plan.
363             if( defined $num_tests ) {
364 10         88 $self->{No_Plan} = 0;
365             }
366 10         21 else {
367             $num_tests = $self->current_test;
368 10         730 }
369 10         22  
370             if( $self->{Done_Testing} ) {
371 10         23 my($file, $line) = @{$self->{Done_Testing}}[1,2];
372 10         22 $self->ok(0, "done_testing() was already called at $file line $line");
373 10         20 return;
374 10         34 }
375              
376 10         55 $self->{Done_Testing} = [caller];
377              
378 10         18 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
379             $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
380             "but done_testing() expects $num_tests");
381             }
382             else {
383             $self->{Expected_Tests} = $num_tests;
384             }
385              
386             $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
387              
388             $self->{Have_Plan} = 1;
389              
390             # The wrong number of tests were run
391             $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
392              
393             # No tests were run
394             $self->is_passing(0) if $self->{Curr_Test} == 0;
395              
396             return 1;
397             }
398              
399              
400             #line 630
401              
402             sub has_plan {
403             my $self = shift;
404              
405             return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
406             return('no_plan') if $self->{No_Plan};
407             return(undef);
408             }
409              
410             #line 647
411              
412             sub skip_all {
413             my( $self, $reason ) = @_;
414              
415             $self->{Skip_All} = $self->parent ? $reason : 1;
416              
417             $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
418             if ( $self->parent ) {
419             die bless {} => 'Test::Builder::Exception';
420             }
421             exit(0);
422 10     10 1 30 }
423              
424 10 50       41 #line 672
425              
426 10         49 sub exported_to {
427             my( $self, $pack ) = @_;
428 10 50       46  
429             if( defined $pack ) {
430 10 50       45 $self->{Exported_To} = $pack;
431 10         22 }
432 10         39 return $self->{Exported_To};
433             }
434              
435 0         0 #line 702
  0         0  
436 0         0  
437             sub ok {
438             my( $self, $test, $name ) = @_;
439 10         33  
440             if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
441             $name = 'unnamed test' unless defined $name;
442             $self->is_passing(0);
443             $self->croak("Cannot run test ($name) with active children");
444 8     8   251 }
445             # $test might contain an object which we don't want to accidentally
446 8 50       36 # store, so we turn it into a boolean.
    0          
447 8         18 $test = $test ? 1 : 0;
448 8         31  
449             lock $self->{Curr_Test};
450             $self->{Curr_Test}++;
451 0         0  
452             # In case $name is a string overloaded object, force it to stringify.
453             $self->_unoverload_str( \$name );
454 0         0  
455             $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
456             You named your test '$name'. You shouldn't use numbers for your test names.
457 0         0 Very confusing.
458             ERR
459              
460             # Capture the value of $TODO for the rest of this ok() call
461             # so it can more easily be found by other routines.
462             my $todo = $self->todo();
463             my $in_todo = $self->in_todo;
464             local $self->{Todo} = $todo if $in_todo;
465              
466             $self->_unoverload_str( \$todo );
467              
468             my $out;
469             my $result = &share( {} );
470              
471             unless($test) {
472 8     8 1 16 $out .= "not ";
473 8         17 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
474             }
475 8 50       29 else {
476 8 50       55 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
477             }
478              
479 8         19 $out .= "ok";
480 8         14 $out .= " $self->{Curr_Test}" if $self->use_numbers;
481              
482 8 50       27 if( defined $name ) {
483             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
484 8         26 $out .= " - $name";
485             $result->{name} = $name;
486             }
487             else {
488             $result->{name} = '';
489             }
490              
491             if( $self->in_todo ) {
492             $out .= " # TODO $todo";
493             $result->{reason} = $todo;
494             $result->{type} = 'todo';
495             }
496 2     2 1 69 else {
497             $result->{reason} = '';
498 2 50       9 $result->{type} = '';
499             }
500 2         6  
501 2         4 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
502             $out .= "\n";
503 2         5  
504             $self->_print($out);
505              
506             unless($test) {
507             my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
508             $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
509              
510             my( undef, $file, $line ) = $self->caller;
511             if( defined $name ) {
512             $self->diag(qq[ $msg test '$name'\n]);
513             $self->diag(qq[ at $file line $line.\n]);
514             }
515             else {
516             $self->diag(qq[ $msg test at $file line $line.\n]);
517             }
518             }
519              
520             $self->is_passing(0) unless $test || $self->in_todo;
521              
522             # Check that we haven't violated the plan
523             $self->_check_is_passing_plan();
524              
525             return $test ? 1 : 0;
526             }
527              
528              
529             # Check that we haven't yet violated the plan and set
530 10     10   25 # is_passing() accordingly
531             sub _check_is_passing_plan {
532 10 50       51 my $self = shift;
533              
534 10         31 my $plan = $self->has_plan;
535 10 50       34 return unless defined $plan; # no plan yet defined
536 10 50       28 return unless $plan !~ /\D/; # no numeric plan
537             $self->is_passing(0) if $plan < $self->{Curr_Test};
538 10         46 }
539              
540 10         27  
541             sub _unoverload {
542 10         28 my $self = shift;
543             my $type = shift;
544              
545             $self->_try(sub { require overload; }, die_on_fail => 1);
546              
547             foreach my $thing (@_) {
548             if( $self->_is_object($$thing) ) {
549             if( my $string_meth = overload::Method( $$thing, $type ) ) {
550             $$thing = $$thing->$string_meth();
551             }
552             }
553             }
554              
555             return;
556             }
557              
558             sub _is_object {
559             my( $self, $thing ) = @_;
560              
561             return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
562             }
563              
564             sub _unoverload_str {
565             my $self = shift;
566              
567             return $self->_unoverload( q[""], @_ );
568             }
569              
570             sub _unoverload_num {
571             my $self = shift;
572              
573             $self->_unoverload( '0+', @_ );
574              
575             for my $val (@_) {
576             next unless $self->_is_dualvar($$val);
577             $$val = $$val + 0;
578             }
579              
580             return;
581 0     0 1 0 }
582              
583             # This is a hack to detect a dualvar such as $!
584 0 0       0 sub _is_dualvar {
585 0         0 my( $self, $val ) = @_;
586              
587             # Objects are not dualvars.
588 0         0 return 0 if ref $val;
589              
590             no warnings 'numeric';
591 0 0       0 my $numval = $val + 0;
592 0         0 return $numval != 0 and $numval ne $val ? 1 : 0;
  0         0  
593 0         0 }
594 0         0  
595             #line 876
596              
597 0         0 sub is_eq {
598             my( $self, $got, $expect, $name ) = @_;
599 0 0 0     0 local $Level = $Level + 1;
600 0         0  
  0         0  
601             $self->_unoverload_str( \$got, \$expect );
602              
603             if( !defined $got || !defined $expect ) {
604 0         0 # undef only matches undef and nothing else
605             my $test = !defined $got && !defined $expect;
606              
607 0 0       0 $self->ok( $test, $name );
608             $self->_is_diag( $got, 'eq', $expect ) unless $test;
609 0         0 return $test;
610             }
611              
612 0 0       0 return $self->cmp_ok( $got, 'eq', $expect, $name );
613             }
614              
615 0 0       0 sub is_num {
616             my( $self, $got, $expect, $name ) = @_;
617 0         0 local $Level = $Level + 1;
618              
619             $self->_unoverload_num( \$got, \$expect );
620              
621             if( !defined $got || !defined $expect ) {
622             # undef only matches undef and nothing else
623             my $test = !defined $got && !defined $expect;
624              
625             $self->ok( $test, $name );
626             $self->_is_diag( $got, '==', $expect ) unless $test;
627             return $test;
628             }
629              
630             return $self->cmp_ok( $got, '==', $expect, $name );
631             }
632 51     51 1 61  
633             sub _diag_fmt {
634 51 100       171 my( $self, $type, $val ) = @_;
635 26 50       88  
636 0         0 if( defined $$val ) {
637             if( $type eq 'eq' or $type eq 'ne' ) {
638             # quote and force string context
639             $$val = "'$$val'";
640             }
641             else {
642             # force numeric context
643             $self->_unoverload_num($val);
644             }
645             }
646             else {
647             $$val = 'undef';
648             }
649 0     0 1 0  
650             return;
651 0 0       0 }
652              
653 0 0       0 sub _is_diag {
654 0 0       0 my( $self, $got, $type, $expect ) = @_;
655 0         0  
656             $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
657 0         0  
658             local $Level = $Level + 1;
659             return $self->diag(<<"DIAGNOSTIC");
660             got: $got
661             expected: $expect
662             DIAGNOSTIC
663              
664             }
665              
666             sub _isnt_diag {
667             my( $self, $got, $type ) = @_;
668              
669             $self->_diag_fmt( $type, \$got );
670              
671             local $Level = $Level + 1;
672             return $self->diag(<<"DIAGNOSTIC");
673             got: $got
674 10     10 1 24 expected: anything else
675             DIAGNOSTIC
676 10 50       44 }
677 10         28  
678             #line 973
679 10         32  
680             sub isnt_eq {
681             my( $self, $got, $dont_expect, $name ) = @_;
682             local $Level = $Level + 1;
683              
684             if( !defined $got || !defined $dont_expect ) {
685             # undef only matches undef and nothing else
686             my $test = defined $got || defined $dont_expect;
687              
688             $self->ok( $test, $name );
689             $self->_isnt_diag( $got, 'ne' ) unless $test;
690             return $test;
691             }
692              
693             return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
694             }
695              
696             sub isnt_num {
697             my( $self, $got, $dont_expect, $name ) = @_;
698             local $Level = $Level + 1;
699              
700             if( !defined $got || !defined $dont_expect ) {
701             # undef only matches undef and nothing else
702             my $test = defined $got || defined $dont_expect;
703              
704 51     51 1 103 $self->ok( $test, $name );
705             $self->_isnt_diag( $got, '!=' ) unless $test;
706 51 50 33     214 return $test;
707 0 0       0 }
708 0         0  
709 0         0 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
710             }
711              
712             #line 1022
713 51 50       119  
714             sub like {
715 51         143 my( $self, $this, $regex, $name ) = @_;
716 51         76  
717             local $Level = $Level + 1;
718             return $self->_regex_ok( $this, $regex, '=~', $name );
719 51         145 }
720              
721 51 50 66     341 sub unlike {
722             my( $self, $this, $regex, $name ) = @_;
723              
724             local $Level = $Level + 1;
725             return $self->_regex_ok( $this, $regex, '!~', $name );
726             }
727              
728 51         150 #line 1046
729 51         137  
730 51 50       208 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
731              
732 51         125 sub cmp_ok {
733             my( $self, $got, $type, $expect, $name ) = @_;
734 51         67  
735 51         341 my $test;
736             my $error;
737 51 50       291 {
738 0         0 ## no critic (BuiltinFunctions::ProhibitStringyEval)
739 0 0       0  
740             local( $@, $!, $SIG{__DIE__} ); # isolate eval
741              
742 51         401 my($pack, $file, $line) = $self->caller();
743              
744             $test = eval qq[
745 51         1532 #line 1 "cmp_ok [from $file line $line]"
746 51 50       135 \$got $type \$expect;
747             ];
748 51 100       371 $error = $@;
749 31         62 }
750 31         127 local $Level = $Level + 1;
751 31         288 my $ok = $self->ok( $test, $name );
752              
753             # Treat overloaded objects as numbers if we're asked to do a
754 20         45 # numeric comparison.
755             my $unoverload
756             = $numeric_cmps{$type}
757 51 50       109 ? '_unoverload_num'
758 0         0 : '_unoverload_str';
759 0         0  
760 0         0 $self->diag(<<"END") if $error;
761             An error occurred while using $type:
762             ------------------------------------
763 51         109 $error
764 51         128 ------------------------------------
765             END
766              
767 51         160 unless($ok) {
768 51         70 $self->$unoverload( \$got, \$expect );
769              
770 51         137 if( $type =~ /^(eq|==)$/ ) {
771             $self->_is_diag( $got, $type, $expect );
772 51 50       192 }
773 0 0       0 elsif( $type =~ /^(ne|!=)$/ ) {
774 0 0       0 $self->_isnt_diag( $got, $type );
775             }
776 0         0 else {
777 0 0       0 $self->_cmp_diag( $got, $type, $expect );
778 0         0 }
779 0         0 }
780             return $ok;
781             }
782 0         0  
783             sub _cmp_diag {
784             my( $self, $got, $type, $expect ) = @_;
785              
786 51 50 33     147 $got = defined $got ? "'$got'" : 'undef';
787             $expect = defined $expect ? "'$expect'" : 'undef';
788              
789 51         380 local $Level = $Level + 1;
790             return $self->diag(<<"DIAGNOSTIC");
791 51 50       197 $got
792             $type
793             $expect
794             DIAGNOSTIC
795             }
796              
797             sub _caller_context {
798 51     51   77 my $self = shift;
799              
800 51         121 my( $pack, $file, $line ) = $self->caller(1);
801 51 50       129  
802 51 100       180 my $code = '';
803 25 50       99 $code .= "#line $line $file\n" if defined $file and defined $line;
804              
805             return $code;
806             }
807              
808 129     129   152 #line 1145
809 129         152  
810             sub BAIL_OUT {
811 129     129   550 my( $self, $reason ) = @_;
  129         2578  
812              
813 129         550 $self->{Bailed_Out} = 1;
814 156 50       523 $self->_print("Bail out! $reason");
815 0 0       0 exit 255;
816 0         0 }
817              
818             #line 1158
819              
820             {
821 129         270 no warnings 'once';
822             *BAILOUT = \&BAIL_OUT;
823             }
824              
825 156     156   246 #line 1172
826              
827 156 100   156   4827 sub skip {
  156 50       720  
828             my( $self, $why ) = @_;
829             $why ||= '';
830             $self->_unoverload_str( \$why );
831 129     129   162  
832             lock( $self->{Curr_Test} );
833 129         293 $self->{Curr_Test}++;
834              
835             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
836             {
837 0     0   0 'ok' => 1,
838             actual_ok => 1,
839 0         0 name => '',
840             type => 'skip',
841 0         0 reason => $why,
842 0 0       0 }
843 0         0 );
844              
845             my $out = "ok";
846 0         0 $out .= " $self->{Curr_Test}" if $self->use_numbers;
847             $out .= " # skip";
848             $out .= " $why" if length $why;
849             $out .= "\n";
850              
851 0     0   0 $self->_print($out);
852              
853             return 1;
854 0 0       0 }
855              
856 10     10   97 #line 1213
  10         22  
  10         17193  
857 0         0  
858 0 0       0 sub todo_skip {
    0          
859             my( $self, $why ) = @_;
860             $why ||= '';
861              
862             lock( $self->{Curr_Test} );
863             $self->{Curr_Test}++;
864              
865             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
866             {
867             'ok' => 1,
868             actual_ok => 0,
869             name => '',
870             type => 'todo_skip',
871             reason => $why,
872             }
873             );
874              
875             my $out = "not ok";
876             $out .= " $self->{Curr_Test}" if $self->use_numbers;
877             $out .= " # TODO & SKIP $why\n";
878 24     24 1 60  
879 24         117 $self->_print($out);
880              
881 24         88 return 1;
882             }
883 24 100 66     316  
884             #line 1293
885 1   33     8  
886             sub maybe_regex {
887 1         4 my( $self, $regex ) = @_;
888 1 50       4 my $usable_regex = undef;
889 1         2  
890             return $usable_regex unless defined $regex;
891              
892 23         106 my( $re, $opts );
893              
894             # Check for qr/foo/
895             if( _is_qr($regex) ) {
896 0     0 1 0 $usable_regex = $regex;
897 0         0 }
898             # Check for '/foo/' or 'm,foo,'
899 0         0 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
900             ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
901 0 0 0     0 )
902             {
903 0   0     0 $usable_regex = length $opts ? "(?$opts)$re" : $re;
904             }
905 0         0  
906 0 0       0 return $usable_regex;
907 0         0 }
908              
909             sub _is_qr {
910 0         0 my $regex = shift;
911              
912             # is_regexp() checks for regexes in a robust manner, say if they're
913             # blessed.
914 0     0   0 return re::is_regexp($regex) if defined &re::is_regexp;
915             return ref $regex eq 'Regexp';
916 0 0       0 }
917 0 0 0     0  
918             sub _regex_ok {
919 0         0 my( $self, $this, $regex, $cmp, $name ) = @_;
920              
921             my $ok = 0;
922             my $usable_regex = $self->maybe_regex($regex);
923 0         0 unless( defined $usable_regex ) {
924             local $Level = $Level + 1;
925             $ok = $self->ok( 0, $name );
926             $self->diag(" '$regex' doesn't look much like a regex to me.");
927 0         0 return $ok;
928             }
929              
930 0         0 {
931             ## no critic (BuiltinFunctions::ProhibitStringyEval)
932              
933             my $test;
934 0     0   0 my $context = $self->_caller_context;
935              
936 0         0 local( $@, $!, $SIG{__DIE__} ); # isolate eval
937              
938 0         0 $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
939 0         0  
940             $test = !$test if $cmp eq '!~';
941              
942             local $Level = $Level + 1;
943             $ok = $self->ok( $test, $name );
944             }
945              
946             unless($ok) {
947 0     0   0 $this = defined $this ? "'$this'" : 'undef';
948             my $match = $cmp eq '=~' ? "doesn't match" : "matches";
949 0         0  
950             local $Level = $Level + 1;
951 0         0 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
952 0         0 %s
953             %13s '%s'
954             DIAGNOSTIC
955              
956             }
957              
958             return $ok;
959             }
960              
961             # I'm not ready to publish this. It doesn't deal with array return
962             # values from the code or context.
963              
964             #line 1389
965              
966             sub _try {
967             my( $self, $code, %opts ) = @_;
968              
969             my $error;
970             my $return;
971             {
972             local $!; # eval can mess up $!
973             local $@; # don't set $@ in the test
974             local $SIG{__DIE__}; # don't trip an outside DIE handler.
975 0     0 1 0 $return = eval { $code->() };
976 0         0 $error = $@;
977             }
978 0 0 0     0  
979             die $error if $error and $opts{die_on_fail};
980 0   0     0  
981             return wantarray ? ( $return, $error ) : $return;
982 0         0 }
983 0 0       0  
984 0         0 #line 1418
985              
986             sub is_fh {
987 0         0 my $self = shift;
988             my $maybe_fh = shift;
989             return 0 unless defined $maybe_fh;
990              
991 0     0 1 0 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
992 0         0 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
993              
994 0 0 0     0 return eval { $maybe_fh->isa("IO::Handle") } ||
995             eval { tied($maybe_fh)->can('TIEHANDLE') };
996 0   0     0 }
997              
998 0         0 #line 1461
999 0 0       0  
1000 0         0 sub level {
1001             my( $self, $level ) = @_;
1002              
1003 0         0 if( defined $level ) {
1004             $Level = $level;
1005             }
1006             return $Level;
1007             }
1008              
1009             #line 1493
1010              
1011             sub use_numbers {
1012             my( $self, $use_nums ) = @_;
1013              
1014             if( defined $use_nums ) {
1015             $self->{Use_Nums} = $use_nums;
1016             }
1017             return $self->{Use_Nums};
1018             }
1019              
1020             #line 1526
1021              
1022             foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1023             my $method = lc $attribute;
1024 5     5 1 13  
1025             my $code = sub {
1026 5         11 my( $self, $no ) = @_;
1027 5         18  
1028             if( defined $no ) {
1029             $self->{$attribute} = $no;
1030             }
1031 1     1 1 4 return $self->{$attribute};
1032             };
1033 1         2  
1034 1         4 no strict 'refs'; ## no critic
1035             *{ __PACKAGE__ . '::' . $method } = $code;
1036             }
1037              
1038             #line 1579
1039              
1040             sub diag {
1041             my $self = shift;
1042              
1043             $self->_print_comment( $self->_diag_fh, @_ );
1044             }
1045              
1046             #line 1594
1047              
1048             sub note {
1049             my $self = shift;
1050 23     23 1 48  
1051             $self->_print_comment( $self->output, @_ );
1052 23         286 }
1053              
1054             sub _diag_fh {
1055             my $self = shift;
1056              
1057 23         32 local $Level = $Level + 1;
  23         102  
1058             return $self->in_todo ? $self->todo_output : $self->failure_output;
1059 23         80 }
1060              
1061 23         1533 sub _print_comment {
1062             my( $self, $fh, @msgs ) = @_;
1063              
1064             return if $self->no_diag;
1065 23         297 return unless @msgs;
1066              
1067 23         41 # Prevent printing headers when compiling (i.e. -c)
1068 23         67 return if $^C;
1069              
1070             # Smash args together like print does.
1071             # Convert undef to 'undef' so its readable.
1072 23 50       71 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1073              
1074             # Escape the beginning, _print will take care of the rest.
1075             $msg =~ s/^/# /;
1076              
1077 23 50       52 local $Level = $Level + 1;
1078             $self->_print_to_fh( $fh, $msg );
1079              
1080             return 0;
1081             }
1082              
1083             #line 1644
1084 23 50       53  
1085 0         0 sub explain {
1086             my $self = shift;
1087 0 0       0  
    0          
1088 0         0 return map {
1089             ref $_
1090             ? do {
1091 0         0 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1092              
1093             my $dumper = Data::Dumper->new( [$_] );
1094 0         0 $dumper->Indent(1)->Terse(1);
1095             $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1096             $dumper->Dump;
1097 23         660 }
1098             : $_
1099             } @_;
1100             }
1101 0     0   0  
1102             #line 1673
1103 0 0       0  
1104 0 0       0 sub _print {
1105             my $self = shift;
1106 0         0 return $self->_print_to_fh( $self->output, @_ );
1107 0         0 }
1108              
1109             sub _print_to_fh {
1110             my( $self, $fh, @msgs ) = @_;
1111              
1112             # Prevent printing headers when only compiling. Mostly for when
1113             # tests are deparsed with B::Deparse
1114             return if $^C;
1115 6     6   9  
1116             my $msg = join '', @msgs;
1117 6         17  
1118             local( $\, $", $, ) = ( undef, ' ', '' );
1119 6         15  
1120 6 50 33     54 # Escape each line after the first with a # so we don't
1121             # confuse Test::Harness.
1122 6         15 $msg =~ s{\n(?!\z)}{\n# }sg;
1123              
1124             # Stick a newline on the end if it needs it.
1125             $msg .= "\n" unless $msg =~ /\n\z/;
1126              
1127             return print $fh $self->_indent, $msg;
1128             }
1129              
1130             #line 1732
1131              
1132             sub output {
1133             my( $self, $fh ) = @_;
1134              
1135             if( defined $fh ) {
1136             $self->{Out_FH} = $self->_new_fh($fh);
1137             }
1138             return $self->{Out_FH};
1139             }
1140              
1141             sub failure_output {
1142             my( $self, $fh ) = @_;
1143              
1144             if( defined $fh ) {
1145             $self->{Fail_FH} = $self->_new_fh($fh);
1146             }
1147 0     0 1 0 return $self->{Fail_FH};
1148             }
1149 0         0  
1150 0         0 sub todo_output {
1151 0         0 my( $self, $fh ) = @_;
1152              
1153             if( defined $fh ) {
1154             $self->{Todo_FH} = $self->_new_fh($fh);
1155             }
1156             return $self->{Todo_FH};
1157             }
1158              
1159             sub _new_fh {
1160 10     10   132 my $self = shift;
  10         16  
  10         12914  
1161             my($file_or_fh) = shift;
1162              
1163             my $fh;
1164             if( $self->is_fh($file_or_fh) ) {
1165             $fh = $file_or_fh;
1166             }
1167             elsif( ref $file_or_fh eq 'SCALAR' ) {
1168             # Scalar refs as filehandles was added in 5.8.
1169             if( $] >= 5.008 ) {
1170             open $fh, ">>", $file_or_fh
1171             or $self->croak("Can't open scalar ref $file_or_fh: $!");
1172             }
1173             # Emulate scalar ref filehandles with a tie.
1174 0     0 1 0 else {
1175 0   0     0 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1176 0         0 or $self->croak("Can't tie scalar ref $file_or_fh");
1177             }
1178 0         0 }
1179 0         0 else {
1180             open $fh, ">", $file_or_fh
1181 0         0 or $self->croak("Can't open test output log $file_or_fh: $!");
1182             _autoflush($fh);
1183             }
1184              
1185             return $fh;
1186             }
1187              
1188             sub _autoflush {
1189             my($fh) = shift;
1190             my $old_fh = select $fh;
1191 0         0 $| = 1;
1192 0 0       0 select $old_fh;
1193 0         0  
1194 0 0       0 return;
1195 0         0 }
1196              
1197 0         0 my( $Testout, $Testerr );
1198              
1199 0         0 sub _dup_stdhandles {
1200             my $self = shift;
1201              
1202             $self->_open_testhandles;
1203              
1204             # Set everything to unbuffered else plain prints to STDOUT will
1205             # come out in the wrong order from our own prints.
1206             _autoflush($Testout);
1207             _autoflush( \*STDOUT );
1208             _autoflush($Testerr);
1209             _autoflush( \*STDERR );
1210              
1211             $self->reset_outputs;
1212              
1213             return;
1214             }
1215 0     0 1 0  
1216 0   0     0 sub _open_testhandles {
1217             my $self = shift;
1218 0         0  
1219 0         0 return if $self->{Opened_Testhandles};
1220              
1221 0         0 # We dup STDOUT and STDERR so people can change them in their
1222             # test suites while still getting normal test output.
1223             open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
1224             open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
1225              
1226             # $self->_copy_io_layers( \*STDOUT, $Testout );
1227             # $self->_copy_io_layers( \*STDERR, $Testerr );
1228              
1229             $self->{Opened_Testhandles} = 1;
1230              
1231 0         0 return;
1232 0 0       0 }
1233 0         0  
1234             sub _copy_io_layers {
1235 0         0 my( $self, $src, $dst ) = @_;
1236              
1237 0         0 $self->_try(
1238             sub {
1239             require PerlIO;
1240             my @src_layers = PerlIO::get_layers($src);
1241              
1242             binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
1243             }
1244             );
1245              
1246             return;
1247             }
1248              
1249             #line 1857
1250              
1251             sub reset_outputs {
1252             my $self = shift;
1253              
1254             $self->output ($Testout);
1255             $self->failure_output($Testerr);
1256             $self->todo_output ($Testout);
1257              
1258             return;
1259             }
1260              
1261             #line 1883
1262              
1263             sub _message_at_caller {
1264             my $self = shift;
1265              
1266             local $Level = $Level + 1;
1267             my( $pack, $file, $line ) = $self->caller;
1268             return join( "", @_ ) . " at $file line $line.\n";
1269             }
1270              
1271             sub carp {
1272             my $self = shift;
1273             return warn $self->_message_at_caller(@_);
1274             }
1275              
1276             sub croak {
1277             my $self = shift;
1278             return die $self->_message_at_caller(@_);
1279             }
1280              
1281              
1282             #line 1923
1283              
1284             sub current_test {
1285             my( $self, $num ) = @_;
1286              
1287             lock( $self->{Curr_Test} );
1288             if( defined $num ) {
1289             $self->{Curr_Test} = $num;
1290              
1291             # If the test counter is being pushed forward fill in the details.
1292             my $test_results = $self->{Test_Results};
1293             if( $num > @$test_results ) {
1294             my $start = @$test_results ? @$test_results : 0;
1295 6     6 1 10 for( $start .. $num - 1 ) {
1296 6         8 $test_results->[$_] = &share(
1297             {
1298 6 50       19 'ok' => 1,
1299             actual_ok => undef,
1300 6         6 reason => 'incrementing test number',
1301             type => 'unknown',
1302             name => undef
1303 6 50 0     17 }
    0          
1304 6         11 );
1305             }
1306             }
1307             # If backward, wipe history. Its their funeral.
1308             elsif( $num < @$test_results ) {
1309             $#{$test_results} = $num - 1;
1310             }
1311 0 0       0 }
1312             return $self->{Curr_Test};
1313             }
1314 6         13  
1315             #line 1971
1316              
1317             sub is_passing {
1318 6     6   10 my $self = shift;
1319              
1320             if( @_ ) {
1321             $self->{Is_Passing} = shift;
1322 6 50       56 }
1323 0         0  
1324             return $self->{Is_Passing};
1325             }
1326              
1327 6     6   19  
1328             #line 1993
1329 6         9  
1330 6         31 sub summary {
1331 6 50       17 my($self) = shift;
1332 0         0  
1333 0         0 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1334 0         0 }
1335 0         0  
1336             #line 2048
1337              
1338             sub details {
1339             my $self = shift;
1340             return @{ $self->{Test_Results} };
1341 6         10 }
  6         10  
1342 6         25  
1343             #line 2077
1344 6         30  
1345             sub todo {
1346 6         331 my( $self, $pack ) = @_;
1347              
1348 6 100       112 return $self->{Todo} if defined $self->{Todo};
1349              
1350 6         13 local $Level = $Level + 1;
1351 6         20 my $todo = $self->find_TODO($pack);
1352             return $todo if defined $todo;
1353              
1354 6 50       20 return '';
1355 0 0       0 }
1356 0 0       0  
1357             #line 2099
1358 0         0  
1359 0         0 sub find_TODO {
1360             my( $self, $pack ) = @_;
1361              
1362             $pack = $pack || $self->caller(1) || $self->exported_to;
1363             return unless $pack;
1364              
1365             no strict 'refs'; ## no critic
1366 6         355 return ${ $pack . '::TODO' };
1367             }
1368              
1369             #line 2117
1370              
1371             sub in_todo {
1372             my $self = shift;
1373              
1374             local $Level = $Level + 1;
1375             return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
1376             }
1377              
1378             #line 2167
1379              
1380             sub todo_start {
1381             my $self = shift;
1382             my $message = @_ ? shift : '';
1383              
1384             $self->{Start_Todo}++;
1385             if( $self->in_todo ) {
1386             push @{ $self->{Todo_Stack} } => $self->todo;
1387             }
1388             $self->{Todo} = $message;
1389              
1390             return;
1391 285     285   902 }
1392              
1393 285         298 #line 2189
1394              
1395             sub todo_end {
1396 285         286 my $self = shift;
  285         821  
1397 285         290  
1398 285         940 if( !$self->{Start_Todo} ) {
1399 285         404 $self->croak('todo_end() called without todo_start()');
  285         800  
1400 285         2753 }
1401              
1402             $self->{Start_Todo}--;
1403 285 50 66     2885  
1404             if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1405 285 50       1930 $self->{Todo} = pop @{ $self->{Todo_Stack} };
1406             }
1407             else {
1408             delete $self->{Todo};
1409             }
1410              
1411             return;
1412             }
1413              
1414             #line 2222
1415              
1416             sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1417             my( $self, $height ) = @_;
1418             $height ||= 0;
1419              
1420 30     30 1 32 my $level = $self->level + $height + 1;
1421 30         33 my @caller;
1422 30 50       81 do {
1423             @caller = CORE::caller( $level );
1424 30 50       127 $level--;
1425 0 0       0 } until @caller;
1426             return wantarray ? @caller : $caller[0];
1427             }
1428 0   0     0  
1429             #line 2239
1430              
1431             #line 2253
1432              
1433             #'#
1434             sub _sanity_check {
1435             my $self = shift;
1436              
1437             $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1438             $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1439             'Somehow you got a different number of results than tests ran!' );
1440              
1441             return;
1442             }
1443              
1444             #line 2274
1445              
1446             sub _whoa {
1447             my( $self, $check, $desc ) = @_;
1448             if($check) {
1449             local $Level = $Level + 1;
1450             $self->croak(<<"WHOA");
1451             WHOA! $desc
1452             This should never happen! Please contact the author immediately!
1453             WHOA
1454             }
1455              
1456             return;
1457             }
1458              
1459             #line 2298
1460              
1461             sub _my_exit {
1462             $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
1463 182     182 1 267  
1464             return 1;
1465 182 50       400 }
1466 0         0  
1467             #line 2310
1468 182         357  
1469             sub _ending {
1470             my $self = shift;
1471             return if $self->no_ending;
1472             return if $self->{Ending}++;
1473              
1474             my $real_exit_code = $?;
1475              
1476             # Don't bother with an ending if this is a forked copy. Only the parent
1477             # should do the ending.
1478             if( $self->{Original_Pid} != $$ ) {
1479             return;
1480             }
1481              
1482             # Ran tests but never declared a plan or hit done_testing
1483             if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
1484             $self->is_passing(0);
1485             $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
1486             }
1487              
1488             # Exit if plan() was never called. This is so "require Test::Simple"
1489             # doesn't puke.
1490             if( !$self->{Have_Plan} ) {
1491             return;
1492             }
1493              
1494             # Don't do an ending if we bailed out.
1495 51     51 1 79 if( $self->{Bailed_Out} ) {
1496             $self->is_passing(0);
1497 51 50       294 return;
1498 0         0 }
1499             # Figure out if we passed or failed and print helpful messages.
1500 51         205 my $test_results = $self->{Test_Results};
1501             if(@$test_results) {
1502             # The plan? We have no plan.
1503             if( $self->{No_Plan} ) {
1504             $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
1505             $self->{Expected_Tests} = $self->{Curr_Test};
1506             }
1507              
1508             # Auto-extended arrays and elements which aren't explicitly
1509             # filled in with a shared reference will puke under 5.8.0
1510             # ithreads. So we have to fill them in by hand. :(
1511             my $empty_result = &share( {} );
1512             for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1513             $test_results->[$idx] = $empty_result
1514             unless defined $test_results->[$idx];
1515             }
1516              
1517             my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
1518              
1519             my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1520              
1521             if( $num_extra != 0 ) {
1522             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1523             $self->diag(<<"FAIL");
1524             Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
1525             FAIL
1526             $self->is_passing(0);
1527             }
1528              
1529             if($num_failed) {
1530             my $num_tests = $self->{Curr_Test};
1531 20     20   40 my $s = $num_failed == 1 ? '' : 's';
1532              
1533 20 50       104 my $qualifier = $num_extra == 0 ? '' : ' run';
1534 0         0  
1535             $self->diag(<<"FAIL");
1536 20         119 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1537             FAIL
1538             $self->is_passing(0);
1539 10     10   74 }
  10         19  
  10         21933  
1540              
1541             if($real_exit_code) {
1542             $self->diag(<<"FAIL");
1543             Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
1544             FAIL
1545             $self->is_passing(0);
1546             _my_exit($real_exit_code) && return;
1547             }
1548              
1549             my $exit_code;
1550             if($num_failed) {
1551             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1552             }
1553             elsif( $num_extra != 0 ) {
1554             $exit_code = 255;
1555             }
1556             else {
1557             $exit_code = 0;
1558             }
1559              
1560             _my_exit($exit_code) && return;
1561             }
1562             elsif( $self->{Skip_All} ) {
1563             _my_exit(0) && return;
1564             }
1565             elsif($real_exit_code) {
1566             $self->diag(<<"FAIL");
1567             Looks like your test exited with $real_exit_code before it could output anything.
1568             FAIL
1569             $self->is_passing(0);
1570             _my_exit($real_exit_code) && return;
1571             }
1572             else {
1573             $self->diag("No tests run!\n");
1574             $self->is_passing(0);
1575             _my_exit(255) && return;
1576             }
1577              
1578             $self->is_passing(0);
1579             $self->_whoa( 1, "We fell off the end of _ending()" );
1580             }
1581 0     0 1 0  
1582             END {
1583 0         0 $Test->_ending if defined $Test;
1584             }
1585              
1586             #line 2498
1587              
1588             1;
1589