File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 376 689 54.5
branch 124 344 36.0
condition 19 86 22.0
subroutine 65 99 65.6
pod 49 49 100.0
total 633 1267 49.9


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 30     30   412  
  30         76  
  30         1006  
4 30     30   113 use 5.006;
  30         33  
  30         729  
5 30     30   107 use strict;
  30         591  
  30         1889  
6             use warnings;
7              
8             our $VERSION = '0.94';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 30 50   30   853 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 30     30   128 BEGIN {
  30         36  
  30         7509  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 30 50 33 30   623 # 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 30     169   129 else {
  169         388  
67 30     105   65466 *share = sub { return $_[0] };
  105         136  
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 195     195 1 472  
122 195   66     944 sub subtest {
123 195         585 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 30     30 1 58 # Restore the parent and the copied child.
142             %$child = %$self;
143 30         72 %$self = %parent;
144 30         79  
145             # Die *after* we restore the parent.
146 30         79 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 160     160   209 my @args = grep { defined } ( $cmd, $arg );
282             $self->croak("plan() doesn't understand @args");
283 160 50       388 }
284 0         0  
285             return 1;
286             }
287 160         26971  
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 14     14 1 52 }
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 30     30 1 44  
341             sub _output_plan {
342             my($self, $max, $directive, $reason) = @_;
343              
344 30         42 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
345              
346 30         232 my $plan = "1..$max";
347 30         78 $plan .= " # $directive" if defined $directive;
348 30         38 $plan .= " $reason" if defined $reason;
349 30         42  
350 30         46 $self->_print("$plan\n");
351 30         40  
352             $self->{Have_Output_Plan} = 1;
353 30         213  
354 30         141 return;
355 30   50     153 }
356              
357 30         88 #line 579
358 30         51  
359 30         128 sub done_testing {
360             my($self, $num_tests) = @_;
361 30         56  
362 30         46 # If done_testing() specified the number of tests, shut off no_plan.
363             if( defined $num_tests ) {
364 30         42 $self->{No_Plan} = 0;
365             }
366 30         47 else {
367             $num_tests = $self->current_test;
368 30         67 }
369 30         46  
370             if( $self->{Done_Testing} ) {
371 30         41 my($file, $line) = @{$self->{Done_Testing}}[1,2];
372 30         49 $self->ok(0, "done_testing() was already called at $file line $line");
373 30         42 return;
374 30         45 }
375              
376 30         96 $self->{Done_Testing} = [caller];
377              
378 30         29 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 18     18 1 29 }
423              
424 18 100       45 #line 672
425              
426 9         34 sub exported_to {
427             my( $self, $pack ) = @_;
428 9 50       38  
429             if( defined $pack ) {
430 9 50       35 $self->{Exported_To} = $pack;
431 9         19 }
432 9         31 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 2         5  
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 20     20   39 }
445             # $test might contain an object which we don't want to accidentally
446 20 50       83 # store, so we turn it into a boolean.
    0          
447 20         41 $test = $test ? 1 : 0;
448 20         70  
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 20     20 1 31 $out .= "not ";
473 20         36 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
474             }
475 20 50       64 else {
476 20 50       126 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
477             }
478              
479 20         51 $out .= "ok";
480 20         37 $out .= " $self->{Curr_Test}" if $self->use_numbers;
481              
482 20 50       72 if( defined $name ) {
483             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
484 20         143 $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 3     3 1 8 else {
497             $result->{reason} = '';
498 3 50       9 $result->{type} = '';
499             }
500 3         6  
501 3         5 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
502             $out .= "\n";
503 3         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 30     30   58 # is_passing() accordingly
531             sub _check_is_passing_plan {
532 30 50       108 my $self = shift;
533              
534 30         78 my $plan = $self->has_plan;
535 30 100       154 return unless defined $plan; # no plan yet defined
536 30 100       91 return unless $plan !~ /\D/; # no numeric plan
537             $self->is_passing(0) if $plan < $self->{Curr_Test};
538 30         140 }
539              
540 30         98  
541             sub _unoverload {
542 30         86 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 105     105 1 138  
633             sub _diag_fmt {
634 105 100       262 my( $self, $type, $val ) = @_;
635 104 50       359  
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 7     7 1 12  
650             return;
651 7 50       19 }
652              
653 7 50       20 sub _is_diag {
654 7 50       22 my( $self, $got, $type, $expect ) = @_;
655 0         0  
656             $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
657 7         5485  
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 50     50 1 83 expected: anything else
675             DIAGNOSTIC
676 50 50       145 }
677 50         126  
678             #line 973
679 50         118  
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 105     105 1 188 $self->ok( $test, $name );
705             $self->_isnt_diag( $got, '!=' ) unless $test;
706 105 50 33     440 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 105 100       292  
714             sub like {
715 105         326 my( $self, $this, $regex, $name ) = @_;
716 105         193  
717             local $Level = $Level + 1;
718             return $self->_regex_ok( $this, $regex, '=~', $name );
719 105         359 }
720              
721 105 50 66     342 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 105         355 #line 1046
729 105         263  
730 105 50       203 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
731              
732 105         230 sub cmp_ok {
733             my( $self, $got, $type, $expect, $name ) = @_;
734 105         129  
735 105         399 my $test;
736             my $error;
737 105 100       235 {
738 2         9 ## no critic (BuiltinFunctions::ProhibitStringyEval)
739 2 50       10  
740             local( $@, $!, $SIG{__DIE__} ); # isolate eval
741              
742 103         360 my($pack, $file, $line) = $self->caller();
743              
744             $test = eval qq[
745 105         172 #line 1 "cmp_ok [from $file line $line]"
746 105 50       306 \$got $type \$expect;
747             ];
748 105 100       222 $error = $@;
749 2         7 }
750 2         5 local $Level = $Level + 1;
751 2         4 my $ok = $self->ok( $test, $name );
752              
753             # Treat overloaded objects as numbers if we're asked to do a
754 103         263 # numeric comparison.
755             my $unoverload
756             = $numeric_cmps{$type}
757 105 50       173 ? '_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 105         221 $error
764 105         220 ------------------------------------
765             END
766              
767 105         310 unless($ok) {
768 105         128 $self->$unoverload( \$got, \$expect );
769              
770 105         547 if( $type =~ /^(eq|==)$/ ) {
771             $self->_is_diag( $got, $type, $expect );
772 105 100       323 }
773 2 50       11 elsif( $type =~ /^(ne|!=)$/ ) {
774 2 50       49 $self->_isnt_diag( $got, $type );
775             }
776 2         9 else {
777 2 50       8 $self->_cmp_diag( $got, $type, $expect );
778 0         0 }
779 0         0 }
780             return $ok;
781             }
782 2         11  
783             sub _cmp_diag {
784             my( $self, $got, $type, $expect ) = @_;
785              
786 105 100 66     261 $got = defined $got ? "'$got'" : 'undef';
787             $expect = defined $expect ? "'$expect'" : 'undef';
788              
789 105         439 local $Level = $Level + 1;
790             return $self->diag(<<"DIAGNOSTIC");
791 105 100       739 $got
792             $type
793             $expect
794             DIAGNOSTIC
795             }
796              
797             sub _caller_context {
798 105     105   151 my $self = shift;
799              
800 105         303 my( $pack, $file, $line ) = $self->caller(1);
801 105 50       254  
802 105 100       527 my $code = '';
803 1 50       4 $code .= "#line $line $file\n" if defined $file and defined $line;
804              
805             return $code;
806             }
807              
808 211     211   214 #line 1145
809 211         298  
810             sub BAIL_OUT {
811 211     211   1289 my( $self, $reason ) = @_;
  211         1486  
812              
813 211         651 $self->{Bailed_Out} = 1;
814 212 50       491 $self->_print("Bail out! $reason");
815 0 0       0 exit 255;
816 0         0 }
817              
818             #line 1158
819              
820             {
821 211         413 no warnings 'once';
822             *BAILOUT = \&BAIL_OUT;
823             }
824              
825 212     212   251 #line 1172
826              
827 212 50   212   772 sub skip {
  212 50       598  
828             my( $self, $why ) = @_;
829             $why ||= '';
830             $self->_unoverload_str( \$why );
831 211     211   220  
832             lock( $self->{Curr_Test} );
833 211         534 $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 30     30   206 #line 1213
  30         47  
  30         35599  
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 1     1 1 2  
879 1         3 $self->_print($out);
880              
881 1         3 return 1;
882             }
883 1 50 33     6  
884             #line 1293
885 0   0     0  
886             sub maybe_regex {
887 0         0 my( $self, $regex ) = @_;
888 0 0       0 my $usable_regex = undef;
889 0         0  
890             return $usable_regex unless defined $regex;
891              
892 1         6 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 53     53 1 77  
1025             my $code = sub {
1026 53         76 my( $self, $no ) = @_;
1027 53         138  
1028             if( defined $no ) {
1029             $self->{$attribute} = $no;
1030             }
1031 0     0 1 0 return $self->{$attribute};
1032             };
1033 0         0  
1034 0         0 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 1     1 1 2  
1051             $self->_print_comment( $self->output, @_ );
1052 1         2 }
1053              
1054             sub _diag_fh {
1055             my $self = shift;
1056              
1057 1         2 local $Level = $Level + 1;
  1         5  
1058             return $self->in_todo ? $self->todo_output : $self->failure_output;
1059 1         4 }
1060              
1061 1         75 sub _print_comment {
1062             my( $self, $fh, @msgs ) = @_;
1063              
1064             return if $self->no_diag;
1065 1         17 return unless @msgs;
1066              
1067 1         28 # Prevent printing headers when compiling (i.e. -c)
1068 1         8 return if $^C;
1069              
1070             # Smash args together like print does.
1071             # Convert undef to 'undef' so its readable.
1072 1 50       4 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1073              
1074             # Escape the beginning, _print will take care of the rest.
1075             $msg =~ s/^/# /;
1076              
1077 1 50       3 local $Level = $Level + 1;
1078             $self->_print_to_fh( $fh, $msg );
1079              
1080             return 0;
1081             }
1082              
1083             #line 1644
1084 1 50       3  
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 1         21 }
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 53     53   55  
1116             my $msg = join '', @msgs;
1117 53         105  
1118             local( $\, $", $, ) = ( undef, ' ', '' );
1119 53         107  
1120 53 50 33     325 # Escape each line after the first with a # so we don't
1121             # confuse Test::Harness.
1122 53         93 $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 30     30   188 my $self = shift;
  30         50  
  30         27835  
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 53     53 1 68 for( $start .. $num - 1 ) {
1296 53         65 $test_results->[$_] = &share(
1297             {
1298 53 50       90 'ok' => 1,
1299             actual_ok => undef,
1300 53         56 reason => 'incrementing test number',
1301             type => 'unknown',
1302             name => undef
1303 53 50 0     94 }
    0          
1304 53         76 );
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 53         104  
1315             #line 1971
1316              
1317             sub is_passing {
1318 53     53   50 my $self = shift;
1319              
1320             if( @_ ) {
1321             $self->{Is_Passing} = shift;
1322 53 50       252 }
1323 0         0  
1324             return $self->{Is_Passing};
1325             }
1326              
1327 53     53   88  
1328             #line 1993
1329 53         53  
1330 53         118 sub summary {
1331 53 50       103 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 53         55 }
  53         63  
1342 53         202  
1343             #line 2077
1344 53         244  
1345             sub todo {
1346 53         2492 my( $self, $pack ) = @_;
1347              
1348 53 50       3568 return $self->{Todo} if defined $self->{Todo};
1349              
1350 53         94 local $Level = $Level + 1;
1351 53         138 my $todo = $self->find_TODO($pack);
1352             return $todo if defined $todo;
1353              
1354 53 100       113 return '';
1355 1 50       46 }
1356 1 50       9  
1357             #line 2099
1358 1         4  
1359 1         81 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 53         186 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 423     423   820 }
1392              
1393 423         402 #line 2189
1394              
1395             sub todo_end {
1396 423         374 my $self = shift;
  423         1055  
1397 423         405  
1398 423         1357 if( !$self->{Start_Todo} ) {
1399 423         566 $self->croak('todo_end() called without todo_start()');
  423         589  
1400 423         1124 }
1401              
1402             $self->{Start_Todo}--;
1403 423 50 33     903  
1404             if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1405 423 50       1777 $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 90     90 1 81 my $level = $self->level + $height + 1;
1421 90         77 my @caller;
1422 90 50       153 do {
1423             @caller = CORE::caller( $level );
1424 90 50       289 $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 402     402 1 439  
1464             return 1;
1465 402 50       727 }
1466 0         0  
1467             #line 2310
1468 402         740  
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 105     105 1 130 if( $self->{Bailed_Out} ) {
1496             $self->is_passing(0);
1497 105 50       248 return;
1498 0         0 }
1499             # Figure out if we passed or failed and print helpful messages.
1500 105         419 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 83     83   142 my $s = $num_failed == 1 ? '' : 's';
1532              
1533 83 50       352 my $qualifier = $num_extra == 0 ? '' : ' run';
1534 0         0  
1535             $self->diag(<<"FAIL");
1536 83         482 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1537             FAIL
1538             $self->is_passing(0);
1539 30     30   161 }
  30         47  
  30         42536  
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 23     23 1 38  
1582             END {
1583 23         76 $Test->_ending if defined $Test;
1584             }
1585              
1586             #line 2498
1587              
1588             1;
1589