File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 388 715 54.2
branch 119 352 33.8
condition 22 92 23.9
subroutine 69 102 67.6
pod 49 49 100.0
total 647 1310 49.3


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