File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 312 689 45.2
branch 93 344 27.0
condition 15 86 17.4
subroutine 57 99 57.5
pod 49 49 100.0
total 526 1267 41.5


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 2     2   47  
  2         7  
  2         94  
4 2     2   11 use 5.006;
  2         3  
  2         76  
5 2     2   10 use strict;
  2         7  
  2         331  
6             use warnings;
7              
8             our $VERSION = '0.94';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 2 50   2   63 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 2     2   11 BEGIN {
  2         3  
  2         955  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 2 50 33 2   79 # 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 2     6   13 else {
  6         15  
67 2     1   6776 *share = sub { return $_[0] };
  1         3  
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 6     6 1 15  
122 6   66     47 sub subtest {
123 6         19 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 2     2 1 10 # Restore the parent and the copied child.
142             %$child = %$self;
143 2         6 %$self = %parent;
144 2         9  
145             # Die *after* we restore the parent.
146 2         8 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 8     8   12 my @args = grep { defined } ( $cmd, $arg );
282             $self->croak("plan() doesn't understand @args");
283 8 50       33 }
284 0         0  
285             return 1;
286             }
287 8         856  
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 2     2 1 12 }
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 2     2 1 4  
341             sub _output_plan {
342             my($self, $max, $directive, $reason) = @_;
343              
344 2         5 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
345              
346 2         25 my $plan = "1..$max";
347 2         30 $plan .= " # $directive" if defined $directive;
348 2         5 $plan .= " $reason" if defined $reason;
349 2         4  
350 2         5 $self->_print("$plan\n");
351 2         4  
352             $self->{Have_Output_Plan} = 1;
353 2         33  
354 2         8 return;
355 2   50     17 }
356              
357 2         12 #line 579
358 2         7  
359 2         11 sub done_testing {
360             my($self, $num_tests) = @_;
361 2         7  
362 2         13 # If done_testing() specified the number of tests, shut off no_plan.
363             if( defined $num_tests ) {
364 2         6 $self->{No_Plan} = 0;
365             }
366 2         4 else {
367             $num_tests = $self->current_test;
368 2         7 }
369 2         4  
370             if( $self->{Done_Testing} ) {
371 2         4 my($file, $line) = @{$self->{Done_Testing}}[1,2];
372 2         5 $self->ok(0, "done_testing() was already called at $file line $line");
373 2         5 return;
374 2         3 }
375              
376 2         8 $self->{Done_Testing} = [caller];
377              
378 2         2 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 2     2 1 31 }
423              
424 2 100       10 #line 672
425              
426 1         3 sub exported_to {
427             my( $self, $pack ) = @_;
428 1 50       4  
429             if( defined $pack ) {
430 1 50       4 $self->{Exported_To} = $pack;
431 1         2 }
432 1         4 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 1         4  
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 1     1   3 }
445             # $test might contain an object which we don't want to accidentally
446 1 50       3 # store, so we turn it into a boolean.
    0          
447 1         3 $test = $test ? 1 : 0;
448 1         5  
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 1     1 1 2 $out .= "not ";
473 1         3 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
474             }
475 1 50       4 else {
476 1 50       8 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
477             }
478              
479 1         3 $out .= "ok";
480 1         2 $out .= " $self->{Curr_Test}" if $self->use_numbers;
481              
482 1 50       4 if( defined $name ) {
483             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
484 1         5 $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 0     0 1 0 else {
497             $result->{reason} = '';
498 0 0       0 $result->{type} = '';
499             }
500 0         0  
501 0         0 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
502             $out .= "\n";
503 0         0  
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 2     2   6 # is_passing() accordingly
531             sub _check_is_passing_plan {
532 2 50       53 my $self = shift;
533              
534 2         32 my $plan = $self->has_plan;
535 2 100       10 return unless defined $plan; # no plan yet defined
536 2 100       9 return unless $plan !~ /\D/; # no numeric plan
537             $self->is_passing(0) if $plan < $self->{Curr_Test};
538 2         13 }
539              
540 2         6  
541             sub _unoverload {
542 2         6 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 2     2 1 9  
633             sub _diag_fmt {
634 2 100       19 my( $self, $type, $val ) = @_;
635 1 50       4  
636 1         4 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 1     1 1 28  
650             return;
651 1 50       6 }
652              
653 1 50       6 sub _is_diag {
654 1 50       3 my( $self, $got, $type, $expect ) = @_;
655 0         0  
656             $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
657 1         1771  
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 2     2 1 6 expected: anything else
675             DIAGNOSTIC
676 2 50       13 }
677 2         6  
678             #line 973
679 2         7  
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 1     1 1 4 $self->ok( $test, $name );
705             $self->_isnt_diag( $got, '!=' ) unless $test;
706 1 50 33     8 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 1 50       7  
714             sub like {
715 1         53 my( $self, $this, $regex, $name ) = @_;
716 1         2  
717             local $Level = $Level + 1;
718             return $self->_regex_ok( $this, $regex, '=~', $name );
719 1         8 }
720              
721 1 50 33     16 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 1         7 #line 1046
729 1         6  
730 1 50       4 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
731              
732 1         4 sub cmp_ok {
733             my( $self, $got, $type, $expect, $name ) = @_;
734 1         3  
735 1         4 my $test;
736             my $error;
737 1 50       4 {
738 1         3 ## no critic (BuiltinFunctions::ProhibitStringyEval)
739 1 50       3  
740             local( $@, $!, $SIG{__DIE__} ); # isolate eval
741              
742 0         0 my($pack, $file, $line) = $self->caller();
743              
744             $test = eval qq[
745 1         2 #line 1 "cmp_ok [from $file line $line]"
746 1 50       5 \$got $type \$expect;
747             ];
748 1 50       5 $error = $@;
749 1         4 }
750 1         4 local $Level = $Level + 1;
751 1         3 my $ok = $self->ok( $test, $name );
752              
753             # Treat overloaded objects as numbers if we're asked to do a
754 0         0 # numeric comparison.
755             my $unoverload
756             = $numeric_cmps{$type}
757 1 50       4 ? '_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 1         4 $error
764 1         3 ------------------------------------
765             END
766              
767 1         4 unless($ok) {
768 1         3 $self->$unoverload( \$got, \$expect );
769              
770 1         5 if( $type =~ /^(eq|==)$/ ) {
771             $self->_is_diag( $got, $type, $expect );
772 1 50       5 }
773 1 50       5 elsif( $type =~ /^(ne|!=)$/ ) {
774 1 50       9 $self->_isnt_diag( $got, $type );
775             }
776 1         4 else {
777 1 50       5 $self->_cmp_diag( $got, $type, $expect );
778 1         7 }
779 1         7 }
780             return $ok;
781             }
782 0         0  
783             sub _cmp_diag {
784             my( $self, $got, $type, $expect ) = @_;
785              
786 1 50 33     7 $got = defined $got ? "'$got'" : 'undef';
787             $expect = defined $expect ? "'$expect'" : 'undef';
788              
789 1         16 local $Level = $Level + 1;
790             return $self->diag(<<"DIAGNOSTIC");
791 1 50       6 $got
792             $type
793             $expect
794             DIAGNOSTIC
795             }
796              
797             sub _caller_context {
798 1     1   2 my $self = shift;
799              
800 1         4 my( $pack, $file, $line ) = $self->caller(1);
801 1 50       4  
802 1 50       6 my $code = '';
803 1 50       5 $code .= "#line $line $file\n" if defined $file and defined $line;
804              
805             return $code;
806             }
807              
808 2     2   3 #line 1145
809 2         4  
810             sub BAIL_OUT {
811 2     2   16 my( $self, $reason ) = @_;
  2         16  
812              
813 2         9 $self->{Bailed_Out} = 1;
814 2 50       9 $self->_print("Bail out! $reason");
815 0 0       0 exit 255;
816 0         0 }
817              
818             #line 1158
819              
820             {
821 2         5 no warnings 'once';
822             *BAILOUT = \&BAIL_OUT;
823             }
824              
825 2     2   5 #line 1172
826              
827 2 50   2   11 sub skip {
  2 50       11  
828             my( $self, $why ) = @_;
829             $why ||= '';
830             $self->_unoverload_str( \$why );
831 2     2   5  
832             lock( $self->{Curr_Test} );
833 2         9 $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 2     2   21 #line 1213
  2         4  
  2         3228  
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 0     0 1 0  
879 0         0 $self->_print($out);
880              
881 0         0 return 1;
882             }
883 0 0 0     0  
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 0         0 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 0     0 1 0  
1051             $self->_print_comment( $self->output, @_ );
1052 0         0 }
1053              
1054             sub _diag_fh {
1055             my $self = shift;
1056              
1057 0         0 local $Level = $Level + 1;
  0         0  
1058             return $self->in_todo ? $self->todo_output : $self->failure_output;
1059 0         0 }
1060              
1061 0         0 sub _print_comment {
1062             my( $self, $fh, @msgs ) = @_;
1063              
1064             return if $self->no_diag;
1065 0         0 return unless @msgs;
1066              
1067 0         0 # Prevent printing headers when compiling (i.e. -c)
1068 0         0 return if $^C;
1069              
1070             # Smash args together like print does.
1071             # Convert undef to 'undef' so its readable.
1072 0 0       0 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1073              
1074             # Escape the beginning, _print will take care of the rest.
1075             $msg =~ s/^/# /;
1076              
1077 0 0       0 local $Level = $Level + 1;
1078             $self->_print_to_fh( $fh, $msg );
1079              
1080             return 0;
1081             }
1082              
1083             #line 1644
1084 0 0       0  
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 0         0 }
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 2     2   14 my $self = shift;
  2         3  
  2         2356  
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 4     4   11 }
1392              
1393 4         7 #line 2189
1394              
1395             sub todo_end {
1396 4         6 my $self = shift;
  4         11  
1397 4         8  
1398 4         14 if( !$self->{Start_Todo} ) {
1399 4         8 $self->croak('todo_end() called without todo_start()');
  4         9  
1400 4         18 }
1401              
1402             $self->{Start_Todo}--;
1403 4 50 33     13  
1404             if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1405 4 50       27 $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 6     6 1 11 my $level = $self->level + $height + 1;
1421 6         9 my @caller;
1422 6 50       15 do {
1423             @caller = CORE::caller( $level );
1424 6 50       32 $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 12     12 1 18  
1464             return 1;
1465 12 50       31 }
1466 0         0  
1467             #line 2310
1468 12         28  
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 1     1 1 4 if( $self->{Bailed_Out} ) {
1496             $self->is_passing(0);
1497 1 50       4 return;
1498 0         0 }
1499             # Figure out if we passed or failed and print helpful messages.
1500 1         8 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 8     8   19 my $s = $num_failed == 1 ? '' : 's';
1532              
1533 8 50       64 my $qualifier = $num_extra == 0 ? '' : ' run';
1534 0         0  
1535             $self->diag(<<"FAIL");
1536 8         57 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1537             FAIL
1538             $self->is_passing(0);
1539 2     2   12 }
  2         5  
  2         4080  
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 9  
1582             END {
1583 4         12 $Test->_ending if defined $Test;
1584             }
1585              
1586             #line 2498
1587              
1588             1;
1589