File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 335 689 48.6
branch 92 344 26.7
condition 20 86 23.2
subroutine 60 99 60.6
pod 49 49 100.0
total 556 1267 43.8


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 47     47   858  
  47         172  
  47         2918  
4 47     47   272 use 5.006;
  47         99  
  47         1696  
5 47     47   253 use strict;
  47         136  
  47         3839  
6             use warnings;
7              
8             our $VERSION = '0.94';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 47 50   47   1379 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 47     47   289 BEGIN {
  47         88  
  47         17537  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 47 50 33 47   1274 # 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 47     608   243 else {
  608         1624  
67 47     467   179061 *share = sub { return $_[0] };
  467         714  
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 931     931 1 2122  
122 931   66     7092 sub subtest {
123 931         2691 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 47     47 1 133 # Restore the parent and the copied child.
142             %$child = %$self;
143 47         206 %$self = %parent;
144 47         300  
145             # Die *after* we restore the parent.
146 47         178 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 514     514   748 my @args = grep { defined } ( $cmd, $arg );
282             $self->croak("plan() doesn't understand @args");
283 514 50       1346 }
284 0         0  
285             return 1;
286             }
287 514         169302  
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 47     47 1 127  
341             sub _output_plan {
342             my($self, $max, $directive, $reason) = @_;
343              
344 47         128 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
345              
346 47         578 my $plan = "1..$max";
347 47         223 $plan .= " # $directive" if defined $directive;
348 47         132 $plan .= " $reason" if defined $reason;
349 47         140  
350 47         132 $self->_print("$plan\n");
351 47         122  
352             $self->{Have_Output_Plan} = 1;
353 47         666  
354 47         210 return;
355 47   50     406 }
356              
357 47         274 #line 579
358 47         245  
359 47         209 sub done_testing {
360             my($self, $num_tests) = @_;
361 47         142  
362 47         134 # If done_testing() specified the number of tests, shut off no_plan.
363             if( defined $num_tests ) {
364 47         123 $self->{No_Plan} = 0;
365             }
366 47         123 else {
367             $num_tests = $self->current_test;
368 47         178 }
369 47         137  
370             if( $self->{Done_Testing} ) {
371 47         130 my($file, $line) = @{$self->{Done_Testing}}[1,2];
372 47         157 $self->ok(0, "done_testing() was already called at $file line $line");
373 47         124 return;
374 47         118 }
375              
376 47         213 $self->{Done_Testing} = [caller];
377              
378 47         86 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 50     50 1 156 }
423              
424 50 100       217 #line 672
425              
426 43         157 sub exported_to {
427             my( $self, $pack ) = @_;
428 43 50       328  
429             if( defined $pack ) {
430 43 50       253 $self->{Exported_To} = $pack;
431 43         122 }
432 43         216 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 43         154  
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 47     47   119 }
445             # $test might contain an object which we don't want to accidentally
446 47 50       223 # store, so we turn it into a boolean.
    0          
447 47         139 $test = $test ? 1 : 0;
448 47         310  
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 47     47 1 131 $out .= "not ";
473 47         274 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
474             }
475 47 50       237 else {
476 47 50       581 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
477             }
478              
479 47         163 $out .= "ok";
480 47         122 $out .= " $self->{Curr_Test}" if $self->use_numbers;
481              
482 47 50       282 if( defined $name ) {
483             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
484 47         359 $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 47     47   132 # is_passing() accordingly
531             sub _check_is_passing_plan {
532 47 50       264 my $self = shift;
533              
534 47         173 my $plan = $self->has_plan;
535 47 50       191 return unless defined $plan; # no plan yet defined
536 47 50       290 return unless $plan !~ /\D/; # no numeric plan
537             $self->is_passing(0) if $plan < $self->{Curr_Test};
538 47         316 }
539              
540 47         251  
541             sub _unoverload {
542 47         169 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 467     467 1 685  
633             sub _diag_fmt {
634 467 50       2063 my( $self, $type, $val ) = @_;
635 0 0       0  
636 0         0 if( defined $$val ) {
637             if( $type eq 'eq' or $type eq 'ne' ) {
638             # quote and force string context
639             $$val = "'$$val'";
640             }
641             else {
642             # force numeric context
643             $self->_unoverload_num($val);
644             }
645             }
646             else {
647             $$val = 'undef';
648             }
649 0     0 1 0  
650             return;
651 0 0       0 }
652              
653 0 0       0 sub _is_diag {
654 0 0       0 my( $self, $got, $type, $expect ) = @_;
655 0         0  
656             $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
657 0         0  
658             local $Level = $Level + 1;
659             return $self->diag(<<"DIAGNOSTIC");
660             got: $got
661             expected: $expect
662             DIAGNOSTIC
663              
664             }
665              
666             sub _isnt_diag {
667             my( $self, $got, $type ) = @_;
668              
669             $self->_diag_fmt( $type, \$got );
670              
671             local $Level = $Level + 1;
672             return $self->diag(<<"DIAGNOSTIC");
673             got: $got
674 48     48 1 138 expected: anything else
675             DIAGNOSTIC
676 48 50       534 }
677 48         537  
678             #line 973
679 48         182  
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 467     467 1 1145 $self->ok( $test, $name );
705             $self->_isnt_diag( $got, '!=' ) unless $test;
706 467 50 33     1974 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 467 50       1324  
714             sub like {
715 467         1623 my( $self, $this, $regex, $name ) = @_;
716 467         784  
717             local $Level = $Level + 1;
718             return $self->_regex_ok( $this, $regex, '=~', $name );
719 467         1738 }
720              
721 467 50 66     2334 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 467         1511 #line 1046
729 467         1302  
730 467 50       1190 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
731              
732 467         1567 sub cmp_ok {
733             my( $self, $got, $type, $expect, $name ) = @_;
734 467         1027  
735 467         2072 my $test;
736             my $error;
737 467 50       1350 {
738 0         0 ## no critic (BuiltinFunctions::ProhibitStringyEval)
739 0 0       0  
740             local( $@, $!, $SIG{__DIE__} ); # isolate eval
741              
742 467         2028 my($pack, $file, $line) = $self->caller();
743              
744             $test = eval qq[
745 467         882 #line 1 "cmp_ok [from $file line $line]"
746 467 50       1608 \$got $type \$expect;
747             ];
748 467 100       2408 $error = $@;
749 67         129 }
750 67         113 local $Level = $Level + 1;
751 67         136 my $ok = $self->ok( $test, $name );
752              
753             # Treat overloaded objects as numbers if we're asked to do a
754 400         1073 # numeric comparison.
755             my $unoverload
756             = $numeric_cmps{$type}
757 467 50       1010 ? '_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 467         1732 $error
764 467         1190 ------------------------------------
765             END
766              
767 467         2547 unless($ok) {
768 467         789 $self->$unoverload( \$got, \$expect );
769              
770 467         1336 if( $type =~ /^(eq|==)$/ ) {
771             $self->_is_diag( $got, $type, $expect );
772 467 50       1976 }
773 0 0       0 elsif( $type =~ /^(ne|!=)$/ ) {
774 0 0       0 $self->_isnt_diag( $got, $type );
775             }
776 0         0 else {
777 0 0       0 $self->_cmp_diag( $got, $type, $expect );
778 0         0 }
779 0         0 }
780             return $ok;
781             }
782 0         0  
783             sub _cmp_diag {
784             my( $self, $got, $type, $expect ) = @_;
785              
786 467 50 33     1435 $got = defined $got ? "'$got'" : 'undef';
787             $expect = defined $expect ? "'$expect'" : 'undef';
788              
789 467         1460 local $Level = $Level + 1;
790             return $self->diag(<<"DIAGNOSTIC");
791 467 50       4328 $got
792             $type
793             $expect
794             DIAGNOSTIC
795             }
796              
797             sub _caller_context {
798 467     467   817 my $self = shift;
799              
800 467         1486 my( $pack, $file, $line ) = $self->caller(1);
801 467 50       1632  
802 467 50       1804 my $code = '';
803 467 50       1675 $code .= "#line $line $file\n" if defined $file and defined $line;
804              
805             return $code;
806             }
807              
808 1427     1427   1784 #line 1145
809 1427         2028  
810             sub BAIL_OUT {
811 1427     1427   7953 my( $self, $reason ) = @_;
  1427         10240  
812              
813 1427         6139 $self->{Bailed_Out} = 1;
814 1920 100       6149 $self->_print("Bail out! $reason");
815 12 50       53 exit 255;
816 12         6461 }
817              
818             #line 1158
819              
820             {
821 1427         3992 no warnings 'once';
822             *BAILOUT = \&BAIL_OUT;
823             }
824              
825 1920     1920   3063 #line 1172
826              
827 1920 100   1920   8603 sub skip {
  1920 100       9735  
828             my( $self, $why ) = @_;
829             $why ||= '';
830             $self->_unoverload_str( \$why );
831 1427     1427   2096  
832             lock( $self->{Curr_Test} );
833 1427         16241 $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 47     47   487 #line 1213
  47         108  
  47         101065  
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 65     65 1 183  
879 65         161 $self->_print($out);
880              
881 65         286 return 1;
882             }
883 65 100 66     382  
884             #line 1293
885 1   33     8  
886             sub maybe_regex {
887 1         5 my( $self, $regex ) = @_;
888 1 50       4 my $usable_regex = undef;
889 1         4  
890             return $usable_regex unless defined $regex;
891              
892 64         1027 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 106     106 1 259  
1025             my $code = sub {
1026 106         312 my( $self, $no ) = @_;
1027 106         489  
1028             if( defined $no ) {
1029             $self->{$attribute} = $no;
1030             }
1031 10     10 1 28 return $self->{$attribute};
1032             };
1033 10         22  
1034 10         43 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 64     64 1 175  
1051             $self->_print_comment( $self->output, @_ );
1052 64         112 }
1053              
1054             sub _diag_fh {
1055             my $self = shift;
1056              
1057 64         110 local $Level = $Level + 1;
  64         327  
1058             return $self->in_todo ? $self->todo_output : $self->failure_output;
1059 64         243 }
1060              
1061 64         4815 sub _print_comment {
1062             my( $self, $fh, @msgs ) = @_;
1063              
1064             return if $self->no_diag;
1065 64         914 return unless @msgs;
1066              
1067 64         148 # Prevent printing headers when compiling (i.e. -c)
1068 64         281 return if $^C;
1069              
1070             # Smash args together like print does.
1071             # Convert undef to 'undef' so its readable.
1072 64 50       388 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1073              
1074             # Escape the beginning, _print will take care of the rest.
1075             $msg =~ s/^/# /;
1076              
1077 64 50       174 local $Level = $Level + 1;
1078             $self->_print_to_fh( $fh, $msg );
1079              
1080             return 0;
1081             }
1082              
1083             #line 1644
1084 64 50       290  
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 64         852 }
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 116     116   361  
1116             my $msg = join '', @msgs;
1117 116         400  
1118             local( $\, $", $, ) = ( undef, ' ', '' );
1119 116         320  
1120 116 50 33     1047 # Escape each line after the first with a # so we don't
1121             # confuse Test::Harness.
1122 116         329 $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 47     47   401 my $self = shift;
  47         151  
  47         95777  
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 116     116 1 224 for( $start .. $num - 1 ) {
1296 116         478 $test_results->[$_] = &share(
1297             {
1298 116 50       545 'ok' => 1,
1299             actual_ok => undef,
1300 116         185 reason => 'incrementing test number',
1301             type => 'unknown',
1302             name => undef
1303 116 50 0     356 }
    0          
1304 116         248 );
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 116         315  
1315             #line 1971
1316              
1317             sub is_passing {
1318 116     116   204 my $self = shift;
1319              
1320             if( @_ ) {
1321             $self->{Is_Passing} = shift;
1322 116 50       13275 }
1323 0         0  
1324             return $self->{Is_Passing};
1325             }
1326              
1327 116     116   290  
1328             #line 1993
1329 116         214  
1330 116         653 sub summary {
1331 116 50       383 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 116         176 }
  116         168  
1342 116         618  
1343             #line 2077
1344 116         820  
1345             sub todo {
1346 116         7318 my( $self, $pack ) = @_;
1347              
1348 116 100       2268 return $self->{Todo} if defined $self->{Todo};
1349              
1350 116         269 local $Level = $Level + 1;
1351 116         447 my $todo = $self->find_TODO($pack);
1352             return $todo if defined $todo;
1353              
1354 116 50       374 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 116         2720 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 3347     3347   7086 }
1392              
1393 3347         4078 #line 2189
1394              
1395             sub todo_end {
1396 3347         4436 my $self = shift;
  3347         10085  
1397 3347         3804  
1398 3347         18855 if( !$self->{Start_Todo} ) {
1399 3347         6625 $self->croak('todo_end() called without todo_start()');
  3347         6130  
1400 3347         14859 }
1401              
1402             $self->{Start_Todo}--;
1403 3347 50 66     17074  
1404             if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1405 3347 50       20807 $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 141     141 1 201 my $level = $self->level + $height + 1;
1421 141         273 my @caller;
1422 141 50       497 do {
1423             @caller = CORE::caller( $level );
1424 141 50       688 $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 1581     1581 1 2297  
1464             return 1;
1465 1581 50       3477 }
1466 0         0  
1467             #line 2310
1468 1581         5810  
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 467     467 1 886 if( $self->{Bailed_Out} ) {
1496             $self->is_passing(0);
1497 467 50       1513 return;
1498 0         0 }
1499             # Figure out if we passed or failed and print helpful messages.
1500 467         2101 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 94     94   251 my $s = $num_failed == 1 ? '' : 's';
1532              
1533 94 50       417 my $qualifier = $num_extra == 0 ? '' : ' run';
1534 0         0  
1535             $self->diag(<<"FAIL");
1536 94         859 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1537             FAIL
1538             $self->is_passing(0);
1539 47     47   550 }
  47         167  
  47         107711  
1540              
1541             if($real_exit_code) {
1542             $self->diag(<<"FAIL");
1543             Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
1544             FAIL
1545             $self->is_passing(0);
1546             _my_exit($real_exit_code) && return;
1547             }
1548              
1549             my $exit_code;
1550             if($num_failed) {
1551             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1552             }
1553             elsif( $num_extra != 0 ) {
1554             $exit_code = 255;
1555             }
1556             else {
1557             $exit_code = 0;
1558             }
1559              
1560             _my_exit($exit_code) && return;
1561             }
1562             elsif( $self->{Skip_All} ) {
1563             _my_exit(0) && return;
1564             }
1565             elsif($real_exit_code) {
1566             $self->diag(<<"FAIL");
1567             Looks like your test exited with $real_exit_code before it could output anything.
1568             FAIL
1569             $self->is_passing(0);
1570             _my_exit($real_exit_code) && return;
1571             }
1572             else {
1573             $self->diag("No tests run!\n");
1574             $self->is_passing(0);
1575             _my_exit(255) && return;
1576             }
1577              
1578             $self->is_passing(0);
1579             $self->_whoa( 1, "We fell off the end of _ending()" );
1580             }
1581 0     0 1 0  
1582             END {
1583 0         0 $Test->_ending if defined $Test;
1584             }
1585              
1586             #line 2498
1587              
1588             1;
1589