File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 349 689 50.6
branch 116 344 33.7
condition 20 86 23.2
subroutine 60 99 60.6
pod 49 49 100.0
total 594 1267 46.8


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 9     9   253  
  9         33  
  9         388  
4 9     9   182 use 5.006;
  9         17  
  9         293  
5 9     9   49 use strict;
  9         19  
  9         861  
6             use warnings;
7              
8             our $VERSION = '0.94';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 9 50   9   303 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 9     9   51 BEGIN {
  9         16  
  9         5969  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 9 50 33 9   471 # 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 9     65   50 else {
  65         144  
67 9     44   47016 *share = sub { return $_[0] };
  44         227  
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 76     76 1 180  
122 76   66     339 sub subtest {
123 76         230 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 9     9 1 24 # Restore the parent and the copied child.
142             %$child = %$self;
143 9         34 %$self = %parent;
144 9         50  
145             # Die *after* we restore the parent.
146 9         34 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 52     52   72 my @args = grep { defined } ( $cmd, $arg );
282             $self->croak("plan() doesn't understand @args");
283 52 50       132 }
284 0         0  
285             return 1;
286             }
287 52         18348  
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 9     9 1 22  
341             sub _output_plan {
342             my($self, $max, $directive, $reason) = @_;
343              
344 9         17 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
345              
346 9         102 my $plan = "1..$max";
347 9         42 $plan .= " # $directive" if defined $directive;
348 9         23 $plan .= " $reason" if defined $reason;
349 9         21  
350 9         19 $self->_print("$plan\n");
351 9         21  
352             $self->{Have_Output_Plan} = 1;
353 9         106  
354 9         41 return;
355 9   50     79 }
356              
357 9         46 #line 579
358 9         27  
359 9         40 sub done_testing {
360             my($self, $num_tests) = @_;
361 9         28  
362 9         21 # If done_testing() specified the number of tests, shut off no_plan.
363             if( defined $num_tests ) {
364 9         20 $self->{No_Plan} = 0;
365             }
366 9         20 else {
367             $num_tests = $self->current_test;
368 9         31 }
369 9         20  
370             if( $self->{Done_Testing} ) {
371 9         20 my($file, $line) = @{$self->{Done_Testing}}[1,2];
372 9         22 $self->ok(0, "done_testing() was already called at $file line $line");
373 9         22 return;
374 9         19 }
375              
376 9         35 $self->{Done_Testing} = [caller];
377              
378 9         14 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 7     7 1 17 }
423              
424 7 100       31 #line 672
425              
426 4         12 sub exported_to {
427             my( $self, $pack ) = @_;
428 4 50       24  
429             if( defined $pack ) {
430 4 50       24 $self->{Exported_To} = $pack;
431 4         9 }
432 4         16 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 4         15  
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 5     5   107 }
445             # $test might contain an object which we don't want to accidentally
446 5 50       19 # store, so we turn it into a boolean.
    0          
447 5         12 $test = $test ? 1 : 0;
448 5         23  
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 14     14 1 22 $out .= "not ";
473 14         28 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
474             }
475 14 100       57 else {
476 5 50       37 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
477             }
478              
479 5         15 $out .= "ok";
480 5         10 $out .= " $self->{Curr_Test}" if $self->use_numbers;
481              
482 5 50       21 if( defined $name ) {
483             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
484 14         71 $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 1     1 1 4 else {
497             $result->{reason} = '';
498 1 50       3 $result->{type} = '';
499             }
500 1         3  
501 1         3 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
502             $out .= "\n";
503 1         3  
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 9     9   23 # is_passing() accordingly
531             sub _check_is_passing_plan {
532 9 50       45 my $self = shift;
533              
534 9         28 my $plan = $self->has_plan;
535 9 50       31 return unless defined $plan; # no plan yet defined
536 9 50       31 return unless $plan !~ /\D/; # no numeric plan
537             $self->is_passing(0) if $plan < $self->{Curr_Test};
538 9         49 }
539              
540 9         30  
541             sub _unoverload {
542 9         29 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 6     6 1 13 }
582              
583             # This is a hack to detect a dualvar such as $!
584 6 50       22 sub _is_dualvar {
585 0         0 my( $self, $val ) = @_;
586              
587             # Objects are not dualvars.
588 6         29 return 0 if ref $val;
589              
590             no warnings 'numeric';
591 6 50       25 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 6         30 sub is_eq {
598             my( $self, $got, $expect, $name ) = @_;
599 6 50 66     34 local $Level = $Level + 1;
600 0         0  
  0         0  
601             $self->_unoverload_str( \$got, \$expect );
602              
603             if( !defined $got || !defined $expect ) {
604 6         17 # undef only matches undef and nothing else
605             my $test = !defined $got && !defined $expect;
606              
607 6 100       36 $self->ok( $test, $name );
608             $self->_is_diag( $got, 'eq', $expect ) unless $test;
609 6         14 return $test;
610             }
611              
612 6 50       30 return $self->cmp_ok( $got, 'eq', $expect, $name );
613             }
614              
615 6 50       25 sub is_num {
616             my( $self, $got, $expect, $name ) = @_;
617 6         802 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 38     38 1 105  
633             sub _diag_fmt {
634 38 100       124 my( $self, $type, $val ) = @_;
635 30 100       105  
636 4         8 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 8     8 1 18 expected: anything else
675             DIAGNOSTIC
676 8 50       32 }
677 8         26  
678             #line 973
679 8         26  
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 38     38 1 83 $self->ok( $test, $name );
705             $self->_isnt_diag( $got, '!=' ) unless $test;
706 38 50 33     163 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 38 100       105  
714             sub like {
715 38         228 my( $self, $this, $regex, $name ) = @_;
716 38         72  
717             local $Level = $Level + 1;
718             return $self->_regex_ok( $this, $regex, '=~', $name );
719 38         135 }
720              
721 38 50 66     290 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 38         151 #line 1046
729 38         116  
730 38 50       97 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
731              
732 38         89 sub cmp_ok {
733             my( $self, $got, $type, $expect, $name ) = @_;
734 38         51  
735 38         122 my $test;
736             my $error;
737 38 100       111 {
738 1         3 ## no critic (BuiltinFunctions::ProhibitStringyEval)
739 1 50       5  
740             local( $@, $!, $SIG{__DIE__} ); # isolate eval
741              
742 37         145 my($pack, $file, $line) = $self->caller();
743              
744             $test = eval qq[
745 38         75 #line 1 "cmp_ok [from $file line $line]"
746 38 50       104 \$got $type \$expect;
747             ];
748 38 100       89 $error = $@;
749 33         66 }
750 33         134 local $Level = $Level + 1;
751 33         81 my $ok = $self->ok( $test, $name );
752              
753             # Treat overloaded objects as numbers if we're asked to do a
754 5         14 # numeric comparison.
755             my $unoverload
756             = $numeric_cmps{$type}
757 38 50       113 ? '_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 38         95 $error
764 38         213 ------------------------------------
765             END
766              
767 38         135 unless($ok) {
768 38         62 $self->$unoverload( \$got, \$expect );
769              
770 38         118 if( $type =~ /^(eq|==)$/ ) {
771             $self->_is_diag( $got, $type, $expect );
772 38 100       147 }
773 1 50       4 elsif( $type =~ /^(ne|!=)$/ ) {
774 1 50       10 $self->_isnt_diag( $got, $type );
775             }
776 1         8 else {
777 1 50       6 $self->_cmp_diag( $got, $type, $expect );
778 1         9 }
779 1         7 }
780             return $ok;
781             }
782 0         0  
783             sub _cmp_diag {
784             my( $self, $got, $type, $expect ) = @_;
785              
786 38 100 66     144 $got = defined $got ? "'$got'" : 'undef';
787             $expect = defined $expect ? "'$expect'" : 'undef';
788              
789 38         142 local $Level = $Level + 1;
790             return $self->diag(<<"DIAGNOSTIC");
791 38 100       197 $got
792             $type
793             $expect
794             DIAGNOSTIC
795             }
796              
797             sub _caller_context {
798 38     38   78 my $self = shift;
799              
800 38         130 my( $pack, $file, $line ) = $self->caller(1);
801 38 100       111  
802 34 100       150 my $code = '';
803 8 50       29 $code .= "#line $line $file\n" if defined $file and defined $line;
804              
805             return $code;
806             }
807              
808 93     93   189 #line 1145
809 93         124  
810             sub BAIL_OUT {
811 93     93   518 my( $self, $reason ) = @_;
  93         671  
812              
813 93         328 $self->{Bailed_Out} = 1;
814 110 50       274 $self->_print("Bail out! $reason");
815 0 0       0 exit 255;
816 0         0 }
817              
818             #line 1158
819              
820             {
821 93         220 no warnings 'once';
822             *BAILOUT = \&BAIL_OUT;
823             }
824              
825 110     110   185 #line 1172
826              
827 110 100   110   2158 sub skip {
  110 50       441  
828             my( $self, $why ) = @_;
829             $why ||= '';
830             $self->_unoverload_str( \$why );
831 93     93   155  
832             lock( $self->{Curr_Test} );
833 93         245 $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 9     9   98 #line 1213
  9         25  
  9         24159  
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 2     2 1 4  
879 2         3 $self->_print($out);
880              
881 2         6 return 1;
882             }
883 2 50 33     9  
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 2         20 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 0     0 1 0  
1025             my $code = sub {
1026 0         0 my( $self, $no ) = @_;
1027 0         0  
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 2     2 1 4  
1051             $self->_print_comment( $self->output, @_ );
1052 2         3 }
1053              
1054             sub _diag_fh {
1055             my $self = shift;
1056              
1057 2         2 local $Level = $Level + 1;
  2         8  
1058             return $self->in_todo ? $self->todo_output : $self->failure_output;
1059 2         6 }
1060              
1061 2         107 sub _print_comment {
1062             my( $self, $fh, @msgs ) = @_;
1063              
1064             return if $self->no_diag;
1065 2         24 return unless @msgs;
1066              
1067 2         4 # Prevent printing headers when compiling (i.e. -c)
1068 2         7 return if $^C;
1069              
1070             # Smash args together like print does.
1071             # Convert undef to 'undef' so its readable.
1072 2 50       6 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1073              
1074             # Escape the beginning, _print will take care of the rest.
1075             $msg =~ s/^/# /;
1076              
1077 2 50       5 local $Level = $Level + 1;
1078             $self->_print_to_fh( $fh, $msg );
1079              
1080             return 0;
1081             }
1082              
1083             #line 1644
1084 2 50       4  
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 2         116 }
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 0     0   0  
1116             my $msg = join '', @msgs;
1117 0         0  
1118             local( $\, $", $, ) = ( undef, ' ', '' );
1119 0         0  
1120 0 0 0     0 # Escape each line after the first with a # so we don't
1121             # confuse Test::Harness.
1122 0         0 $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 9     9   82 my $self = shift;
  9         30  
  9         13068  
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 0     0 1 0 for( $start .. $num - 1 ) {
1296 0         0 $test_results->[$_] = &share(
1297             {
1298 0 0       0 'ok' => 1,
1299             actual_ok => undef,
1300 0         0 reason => 'incrementing test number',
1301             type => 'unknown',
1302             name => undef
1303 0 0 0     0 }
    0          
1304 0         0 );
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 0         0  
1315             #line 1971
1316              
1317             sub is_passing {
1318 0     0   0 my $self = shift;
1319              
1320             if( @_ ) {
1321             $self->{Is_Passing} = shift;
1322 0 0       0 }
1323 0         0  
1324             return $self->{Is_Passing};
1325             }
1326              
1327 0     0   0  
1328             #line 1993
1329 0         0  
1330 0         0 sub summary {
1331 0 0       0 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 0         0 }
  0         0  
1342 0         0  
1343             #line 2077
1344 0         0  
1345             sub todo {
1346 0         0 my( $self, $pack ) = @_;
1347              
1348 0 0       0 return $self->{Todo} if defined $self->{Todo};
1349              
1350 0         0 local $Level = $Level + 1;
1351 0         0 my $todo = $self->find_TODO($pack);
1352             return $todo if defined $todo;
1353              
1354 0 0       0 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 0         0 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 203     203   603 }
1392              
1393 203         244 #line 2189
1394              
1395             sub todo_end {
1396 203         205 my $self = shift;
  203         681  
1397 203         231  
1398 203         609 if( !$self->{Start_Todo} ) {
1399 203         306 $self->croak('todo_end() called without todo_start()');
  203         402  
1400 203         737 }
1401              
1402             $self->{Start_Todo}--;
1403 203 50 66     512  
1404             if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1405 203 50       1049 $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 27     27 1 489 my $level = $self->level + $height + 1;
1421 27         34 my @caller;
1422 27 50       81 do {
1423             @caller = CORE::caller( $level );
1424 27 50       129 $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 125     125 1 161  
1464             return 1;
1465 125 50       264 }
1466 0         0  
1467             #line 2310
1468 125         249  
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 38     38 1 66 if( $self->{Bailed_Out} ) {
1496             $self->is_passing(0);
1497 38 50       129 return;
1498 0         0 }
1499             # Figure out if we passed or failed and print helpful messages.
1500 38         427 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 19     19   42 my $s = $num_failed == 1 ? '' : 's';
1532              
1533 19 50       63 my $qualifier = $num_extra == 0 ? '' : ' run';
1534 0         0  
1535             $self->diag(<<"FAIL");
1536 19         130 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1537             FAIL
1538             $self->is_passing(0);
1539 9     9   143 }
  9         20  
  9         36884  
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 4     4 1 8  
1582             END {
1583 4         12 $Test->_ending if defined $Test;
1584             }
1585              
1586             #line 2498
1587              
1588             1;
1589