File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 330 715 46.1
branch 98 352 27.8
condition 20 92 21.7
subroutine 60 102 58.8
pod 49 49 100.0
total 557 1310 42.5


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 15     15   280  
  15         53  
  15         594  
4 15     15   79 use 5.006;
  15         18  
  15         468  
5 15     15   69 use strict;
  15         169  
  15         1284  
6             use warnings;
7              
8             our $VERSION = '0.98';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 15 50   15   561 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 15     15   83 BEGIN {
  15         26  
  15         7709  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 15 50 33 15   559 # 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 15     4146   122 else {
  4146         6597  
67 15     4102   101566 *share = sub { return $_[0] };
  4102         5370  
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 4156     4156 1 6070 $? = 0;
122 4156   66     9857 $child->{Parent} = $self;
123 4156         11380 $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 15     15 1 38 # the Test::Builder singleton will get the child.
142             my($error, $child, %parent);
143 15         62 {
144 15         75 # 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 15         61 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 4117     4117   4906 return;
341             }
342 4117 50       8391  
343 0         0 #line 529
344              
345             sub expected_tests {
346 4117         8211 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 2     2 1 13  
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 15     15 1 38 if( defined $num_tests ) {
400             $self->{No_Plan} = 0;
401             }
402             else {
403 15         36 $num_tests = $self->current_test;
404             }
405 15         195  
406 15         67 if( $self->{Done_Testing} ) {
407 15         39 my($file, $line) = @{$self->{Done_Testing}}[1,2];
408 15         39 $self->ok(0, "done_testing() was already called at $file line $line");
409 15         37 return;
410 15         33 }
411 15         38  
412             $self->{Done_Testing} = [caller];
413 15         222  
414 15         134 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
415 15   50     132 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
416             "but done_testing() expects $num_tests");
417 15         83 }
418 15         46 else {
419 15         53 $self->{Expected_Tests} = $num_tests;
420             }
421 15         42  
422 15         40 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
423              
424 15         38 $self->{Have_Plan} = 1;
425              
426 15         57 # The wrong number of tests were run
427             $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
428 15         41  
429 15         38 # No tests were run
430             $self->is_passing(0) if $self->{Curr_Test} == 0;
431 15         33  
432 15         39 return 1;
433 15         31 }
434 15         36  
435              
436 15         53 #line 689
437              
438 15         21 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 13     13 1 38 # store, so we turn it into a boolean.
483             $test = $test ? 1 : 0;
484 13 100       54  
485             lock $self->{Curr_Test};
486 12         36 $self->{Curr_Test}++;
487              
488 12 50       54 # In case $name is a string overloaded object, force it to stringify.
489             $self->_unoverload_str( \$name );
490 12 50       79  
491 12         48 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
492 12         82 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 11         39 my $in_todo = $self->in_todo;
500             local $self->{Todo} = $todo if $in_todo;
501              
502             $self->_unoverload_str( \$todo );
503              
504 11     11   43 my $out;
505             my $result = &share( {} );
506 11 50       44  
    0          
507 11         27 unless($test) {
508 11         51 $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 11     11 1 25 }
532 11         24 else {
533             $result->{reason} = '';
534 11 50       162 $result->{type} = '';
535 11 50       97 }
536              
537             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
538 11         36 $out .= "\n";
539 11         25  
540             $self->_print($out);
541 11 50       44  
542             unless($test) {
543 11         45 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 3     3 1 7  
556             $self->is_passing(0) unless $test || $self->in_todo;
557 3 50       14  
558             # Check that we haven't violated the plan
559 3         11 $self->_check_is_passing_plan();
560 3         9  
561             return $test ? 1 : 0;
562 3         9 }
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 15     15   42 }
589             }
590 15 50       128  
591             return;
592 15         52 }
593 15 100       65  
594 15 100       86 sub _is_object {
595             my( $self, $thing ) = @_;
596 15         84  
597             return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
598 15         48 }
599              
600 15         56 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 4102     4102 1 5049 return $self->diag(<<"DIAGNOSTIC");
692             got: $got
693 4102 100       13990 expected: $expect
694 12 50       48 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 1     1 1 3 }
709              
710 1 50       5 #line 1032
711              
712 1 50       5 sub isnt_eq {
713 1 50       12 my( $self, $got, $dont_expect, $name ) = @_;
714 0         0 local $Level = $Level + 1;
715              
716 1         102 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 15     15 1 43 # undef only matches undef and nothing else
734             my $test = defined $got || defined $dont_expect;
735 15 50       68  
736 15         55 $self->ok( $test, $name );
737             $self->_isnt_diag( $got, '!=' ) unless $test;
738 15         51 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 4102     4102 1 8924  
764             sub cmp_ok {
765 4102 50 33     11323 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 4102 50       7068 local( $@, $!, $SIG{__DIE__} ); # isolate eval
773              
774 4102         9236 my($pack, $file, $line) = $self->caller();
775 4102         5152  
776             # This is so that warnings come out at the caller's level
777             $test = eval qq[
778 4102         9046 #line $line "(eval in cmp_ok) $file"
779             \$got $type \$expect;
780 4102 50 66     15305 ];
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 4102         8251 # numeric comparison.
788 4102         8019 my $unoverload
789 4102 50       7983 = $numeric_cmps{$type}
790             ? '_unoverload_num'
791 4102         9190 : '_unoverload_str';
792              
793 4102         5421 $self->diag(<<"END") if $error;
794 4102         8816 An error occurred while using $type:
795             ------------------------------------
796 4102 50       8818 $error
797 0         0 ------------------------------------
798 0 0       0 END
799              
800             unless($ok) {
801 4102         13571 $self->$unoverload( \$got, \$expect );
802              
803             if( $type =~ /^(eq|==)$/ ) {
804 4102         6603 $self->_is_diag( $got, $type, $expect );
805 4102 50       8837 }
806             elsif( $type =~ /^(ne|!=)$/ ) {
807 4102 100       7514 $self->_isnt_diag( $got, $type );
808 1204         2345 }
809 1204         1778 else {
810 1204         2711 $self->_cmp_diag( $got, $type, $expect );
811             }
812             }
813 2898         7554 return $ok;
814             }
815              
816 4102 50       8545 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 4102         7666 local $Level = $Level + 1;
823 4102         13763 return $self->diag(<<"DIAGNOSTIC");
824             $got
825             $type
826 4102         25156 $expect
827 4102         4937 DIAGNOSTIC
828             }
829 4102         13154  
830             sub _caller_context {
831 4102 50       10547 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 4102 50 33     9870  
846             $self->{Bailed_Out} = 1;
847             $self->_print("Bail out! $reason");
848 4102         8963 exit 255;
849             }
850 4102 50       16830  
851             #line 1218
852              
853             {
854             no warnings 'once';
855             *BAILOUT = \&BAIL_OUT;
856             }
857 4102     4102   5316  
858             #line 1232
859 4102         7931  
860 4102 50       10164 sub skip {
861 4102 100       11255 my( $self, $why ) = @_;
862 4090 50       10421 $why ||= '';
863             $self->_unoverload_str( \$why );
864              
865             lock( $self->{Curr_Test} );
866             $self->{Curr_Test}++;
867 8244     8244   8462  
868 8244         9181 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
869             {
870 8244     8244   36456 'ok' => 1,
  8244         63708  
871             actual_ok => 1,
872 8244         33194 name => '',
873 8284 50       18384 type => 'skip',
874 0 0       0 reason => $why,
875 0         0 }
876             );
877              
878             my $out = "ok";
879             $out .= " $self->{Curr_Test}" if $self->use_numbers;
880 8244         17045 $out .= " # skip";
881             $out .= " $why" if length $why;
882             $out .= "\n";
883              
884 8284     8284   15277 $self->_print($out);
885              
886 8284 100   8284   32566 return 1;
  8284 50       29220  
887             }
888              
889             #line 1273
890 8244     8244   9924  
891             sub todo_skip {
892 8244         16924 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 15     15   3651 }
  15         32  
  15         38968  
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 1496     1496 1 2929  
942 1496         2401 sub _is_qr {
943             my $regex = shift;
944 1496 100 66     8596  
945             # is_regexp() checks for regexes in a robust manner, say if they're
946 560   33     2352 # blessed.
947             return re::is_regexp($regex) if defined &re::is_regexp;
948 560         1165 return ref $regex eq 'Regexp';
949 560 50       1156 }
950 560         2631  
951             sub _regex_ok {
952             my( $self, $this, $regex, $cmp, $name ) = @_;
953 936         2243  
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 0     0   0 $test = !$test if $cmp eq '!~';
974              
975 0 0       0 local $Level = $Level + 1;
976 0 0 0     0 $ok = $self->ok( $test, $name );
977             }
978 0         0  
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 0         0 }
990              
991             return $ok;
992             }
993 0     0   0  
994             # I'm not ready to publish this. It doesn't deal with array return
995 0         0 # values from the code or context.
996              
997 0         0 #line 1449
998 0         0  
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 0     0 1 0  
1084             $self->_print_comment( $self->output, @_ );
1085 0         0 }
1086 0         0  
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 936     936 1 1828  
1110             local $Level = $Level + 1;
1111 936         1285 $self->_print_to_fh( $fh, $msg );
1112              
1113             return 0;
1114             }
1115              
1116 936         1094 #line 1704
  936         5008  
1117              
1118 936         2104 sub explain {
1119             my $self = shift;
1120              
1121 936         63059 return map {
1122             ref $_
1123             ? do {
1124             $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1125 936         35765  
1126             my $dumper = Data::Dumper->new( [$_] );
1127 936         1577 $dumper->Indent(1)->Terse(1);
1128 936         2159 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1129             $dumper->Dump;
1130             }
1131             : $_
1132 936 50       2712 } @_;
1133             }
1134              
1135             #line 1733
1136              
1137 936 50       1957 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 936 50       1781  
1145 0         0 # Prevent printing headers when only compiling. Mostly for when
1146             # tests are deparsed with B::Deparse
1147 0 0       0 return if $^C;
    0          
1148 0         0  
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 936         3973  
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 0     0   0 sub failure_output {
1176             my( $self, $fh ) = @_;
1177 0         0  
1178             if( defined $fh ) {
1179 0         0 $self->{Fail_FH} = $self->_new_fh($fh);
1180 0 0 0     0 }
1181             return $self->{Fail_FH};
1182 0         0 }
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 15     15   141 }
  15         32  
  15         23509  
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 0     0 1 0 }
1356 0         0  
1357             #line 2040
1358 0 0       0  
1359             sub is_passing {
1360 0         0 my $self = shift;
1361              
1362             if( @_ ) {
1363 0 0 0     0 $self->{Is_Passing} = shift;
    0          
1364 0         0 }
1365              
1366             return $self->{Is_Passing};
1367             }
1368              
1369              
1370             #line 2062
1371 0 0       0  
1372             sub summary {
1373             my($self) = shift;
1374 0         0  
1375             return map { $_->{'ok'} } @{ $self->{Test_Results} };
1376             }
1377              
1378 0     0   0 #line 2117
1379              
1380             sub details {
1381             my $self = shift;
1382 0 0       0 return @{ $self->{Test_Results} };
1383 0         0 }
1384              
1385             #line 2146
1386              
1387 0     0   0 sub todo {
1388             my( $self, $pack ) = @_;
1389 0         0  
1390 0         0 return $self->{Todo} if defined $self->{Todo};
1391 0 0       0  
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 0         0 sub find_TODO {
  0         0  
1402 0         0 my( $self, $pack, $set, $new_value ) = @_;
1403              
1404 0         0 $pack = $pack || $self->caller(1) || $self->exported_to;
1405             return unless $pack;
1406 0         0  
1407             no strict 'refs'; ## no critic
1408 0 0       0 my $old_value = ${ $pack . '::TODO' };
1409             $set and ${ $pack . '::TODO' } = $new_value;
1410 0         0 return $old_value;
1411 0         0 }
1412              
1413             #line 2193
1414 0 0       0  
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 0         0 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 17207     17207   33717 else {
1452             delete $self->{Todo};
1453 17207         19563 }
1454              
1455             return;
1456 17207         18346 }
  17207         42986  
1457 17207         21148  
1458 17207         49955 #line 2298
1459 17207         24757  
  17207         30899  
1460 17207         72201 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1461             my( $self, $height ) = @_;
1462             $height ||= 0;
1463 17207 50 66     41066  
1464             my $level = $self->level + $height + 1;
1465 17207 100       86671 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 45     45 1 62  
1481 45         50 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1482 45 50       130 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1483             'Somehow you got a different number of results than tests ran!' );
1484 45 50       201  
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 13242     13242 1 15988 return;
1524             }
1525 13242 50       24713  
1526 0         0 # Ran tests but never declared a plan or hit done_testing
1527             if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
1528 13242         25042 $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 4102     4102 1 5372 my $empty_result = &share( {} );
1556             for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1557 4102 50       7384 $test_results->[$idx] = $empty_result
1558 0         0 unless defined $test_results->[$idx];
1559             }
1560 4102         15429  
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 30     30   124 }
1592              
1593 30 50       105 my $exit_code;
1594 0         0 if($num_failed) {
1595             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1596 30         267 }
1597             elsif( $num_extra != 0 ) {
1598             $exit_code = 255;
1599 15     15   116 }
  15         39  
  15         42062  
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