File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 293 714 41.0
branch 74 352 21.0
condition 14 92 15.2
subroutine 55 102 53.9
pod 49 49 100.0
total 485 1309 37.0


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 1     1   17  
  1         3  
4 1     1   5 use 5.006;
  1         1  
  1         19  
5 1     1   5 use strict;
  1         2  
  1         73  
6             use warnings;
7              
8             our $VERSION = '0.98';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 1 50   1   41 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 1     1   6 BEGIN {
  1         2  
  1         373  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 1 50 33 1   23 # 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 1     126   5 else {
  126         209  
67 1     123   3169 *share = sub { return $_[0] };
  123         186  
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 125     125 1 235 $? = 0;
122 125   66     322 $child->{Parent} = $self;
123 125         342 $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 1     1 1 2 # the Test::Builder singleton will get the child.
142             my($error, $child, %parent);
143 1         2 {
144 1         4 # 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 1         4 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          
325 0         0  
326             sub _plan_tests {
327 0         0 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 124     124   163 return;
341             }
342 124 50       270  
343 0         0 #line 529
344              
345             sub expected_tests {
346 124         269 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 0     0 1 0  
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 1     1 1 1 if( defined $num_tests ) {
400             $self->{No_Plan} = 0;
401             }
402             else {
403 1         3 $num_tests = $self->current_test;
404             }
405 1         9  
406 1         3 if( $self->{Done_Testing} ) {
407 1         1 my($file, $line) = @{$self->{Done_Testing}}[1,2];
408 1         2 $self->ok(0, "done_testing() was already called at $file line $line");
409 1         2 return;
410 1         1 }
411 1         2  
412             $self->{Done_Testing} = [caller];
413 1         9  
414 1         3 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
415 1   50     7 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
416             "but done_testing() expects $num_tests");
417 1         4 }
418 1         3 else {
419 1         2 $self->{Expected_Tests} = $num_tests;
420             }
421 1         3  
422 1         2 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
423              
424 1         2 $self->{Have_Plan} = 1;
425              
426 1         2 # The wrong number of tests were run
427             $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
428 1         2  
429 1         2 # No tests were run
430             $self->is_passing(0) if $self->{Curr_Test} == 0;
431 1         2  
432 1         2 return 1;
433 1         2 }
434 1         2  
435              
436 1         4 #line 689
437              
438 1         1 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 1     1 1 3 # store, so we turn it into a boolean.
483             $test = $test ? 1 : 0;
484 1 50       6  
485             lock $self->{Curr_Test};
486 1         3 $self->{Curr_Test}++;
487              
488 1 50       5 # In case $name is a string overloaded object, force it to stringify.
489             $self->_unoverload_str( \$name );
490 1 50       6  
491 1         2 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
492 1         5 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 1         16 my $in_todo = $self->in_todo;
500             local $self->{Todo} = $todo if $in_todo;
501              
502             $self->_unoverload_str( \$todo );
503              
504 1     1   3 my $out;
505             my $result = &share( {} );
506 1 50       4  
    0          
507 1         2 unless($test) {
508 1         5 $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 1     1 1 3 }
532 1         3 else {
533             $result->{reason} = '';
534 1 50       5 $result->{type} = '';
535 1 50       10 }
536              
537             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
538 1         3 $out .= "\n";
539 1         2  
540             $self->_print($out);
541 1 50       4  
542             unless($test) {
543 1         5 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 1     1   5 }
589             }
590 1 50       6  
591             return;
592 1         3 }
593 1 50       5  
594 1 50       7 sub _is_object {
595             my( $self, $thing ) = @_;
596 1         6  
597             return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
598 1         3 }
599              
600 1         4 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 123     123 1 155 return $self->diag(<<"DIAGNOSTIC");
692             got: $got
693 123 50       448 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 0     0 1 0 }
709              
710 0 0       0 #line 1032
711              
712 0 0       0 sub isnt_eq {
713 0 0       0 my( $self, $got, $dont_expect, $name ) = @_;
714 0         0 local $Level = $Level + 1;
715              
716 0         0 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 1     1 1 2 # undef only matches undef and nothing else
734             my $test = defined $got || defined $dont_expect;
735 1 50       5  
736 1         9 $self->ok( $test, $name );
737             $self->_isnt_diag( $got, '!=' ) unless $test;
738 1         5 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 123     123 1 249  
764             sub cmp_ok {
765 123 50 33     463 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 123 50       331 local( $@, $!, $SIG{__DIE__} ); # isolate eval
773              
774 123         348 my($pack, $file, $line) = $self->caller();
775 123         209  
776             # This is so that warnings come out at the caller's level
777             $test = eval qq[
778 123         328 #line $line "(eval in cmp_ok) $file"
779             \$got $type \$expect;
780 123 50 66     381 ];
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 123         328 # numeric comparison.
788 123         306 my $unoverload
789 123 50       263 = $numeric_cmps{$type}
790             ? '_unoverload_num'
791 123         256 : '_unoverload_str';
792              
793 123         192 $self->diag(<<"END") if $error;
794 123         288 An error occurred while using $type:
795             ------------------------------------
796 123 50       287 $error
797 0         0 ------------------------------------
798 0 0       0 END
799              
800             unless($ok) {
801 123         424 $self->$unoverload( \$got, \$expect );
802              
803             if( $type =~ /^(eq|==)$/ ) {
804 123         213 $self->_is_diag( $got, $type, $expect );
805 123 50       316 }
806             elsif( $type =~ /^(ne|!=)$/ ) {
807 123 100       242 $self->_isnt_diag( $got, $type );
808 1         3 }
809 1         5 else {
810 1         3 $self->_cmp_diag( $got, $type, $expect );
811             }
812             }
813 122         288 return $ok;
814             }
815              
816 123 50       230 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 123         307 local $Level = $Level + 1;
823 123         224 return $self->diag(<<"DIAGNOSTIC");
824             $got
825             $type
826 123         334 $expect
827 123         182 DIAGNOSTIC
828             }
829 123         330  
830             sub _caller_context {
831 123 50       374 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 123 50 33     402  
846             $self->{Bailed_Out} = 1;
847             $self->_print("Bail out! $reason");
848 123         335 exit 255;
849             }
850 123 50       474  
851             #line 1218
852              
853             {
854             no warnings 'once';
855             *BAILOUT = \&BAIL_OUT;
856             }
857 123     123   162  
858             #line 1232
859 123         300  
860 123 50       374 sub skip {
861 123 50       593 my( $self, $why ) = @_;
862 123 50       334 $why ||= '';
863             $self->_unoverload_str( \$why );
864              
865             lock( $self->{Curr_Test} );
866             $self->{Curr_Test}++;
867 246     246   324  
868 246         360 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
869             {
870 246     246   1248 'ok' => 1,
  246         3098  
871             actual_ok => 1,
872 246         902 name => '',
873 246 50       589 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 246         451 $out .= " # skip";
881             $out .= " $why" if length $why;
882             $out .= "\n";
883              
884 246     246   416 $self->_print($out);
885              
886 246 50   246   937 return 1;
  246 50       823  
887             }
888              
889             #line 1273
890 246     246   298  
891             sub todo_skip {
892 246         563 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 1     1   6 }
  1         1  
  1         1349  
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 0     0 1 0  
942 0         0 sub _is_qr {
943             my $regex = shift;
944 0 0 0     0  
945             # is_regexp() checks for regexes in a robust manner, say if they're
946 0   0     0 # blessed.
947             return re::is_regexp($regex) if defined &re::is_regexp;
948 0         0 return ref $regex eq 'Regexp';
949 0 0       0 }
950 0         0  
951             sub _regex_ok {
952             my( $self, $this, $regex, $cmp, $name ) = @_;
953 0         0  
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 0     0 1 0  
1110             local $Level = $Level + 1;
1111 0         0 $self->_print_to_fh( $fh, $msg );
1112              
1113             return 0;
1114             }
1115              
1116 0         0 #line 1704
  0         0  
1117              
1118 0         0 sub explain {
1119             my $self = shift;
1120              
1121 0         0 return map {
1122             ref $_
1123             ? do {
1124             $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1125 0         0  
1126             my $dumper = Data::Dumper->new( [$_] );
1127 0         0 $dumper->Indent(1)->Terse(1);
1128 0         0 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1129             $dumper->Dump;
1130             }
1131             : $_
1132             } @_;
1133 0 0       0 }
1134              
1135             #line 1733
1136              
1137 0 0       0 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 0 0       0  
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 0         0  
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 1     1   6 }
  1         2  
  1         1183  
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 494     494   1067 else {
1452             delete $self->{Todo};
1453 494         773 }
1454              
1455             return;
1456 494         555 }
  494         2072  
1457 494         594  
1458 494         1472 #line 2298
1459 494         868  
  494         906  
1460 494         2873 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1461             my( $self, $height ) = @_;
1462             $height ||= 0;
1463 494 0 33     1029  
1464             my $level = $self->level + $height + 1;
1465 494 50       2299 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 3     3 1 5  
1481 3         4 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1482 3 50       8 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1483             'Somehow you got a different number of results than tests ran!' );
1484 3 50       12  
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 369     369 1 516 return;
1524             }
1525 369 50       679  
1526 0         0 # Ran tests but never declared a plan or hit done_testing
1527             if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
1528 369         662 $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 123     123 1 177 my $empty_result = &share( {} );
1556             for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1557 123 50       234 $test_results->[$idx] = $empty_result
1558 0         0 unless defined $test_results->[$idx];
1559             }
1560 123         478  
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 2     2   5 }
1592              
1593 2 50       8 my $exit_code;
1594 0         0 if($num_failed) {
1595             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1596 2         13 }
1597             elsif( $num_extra != 0 ) {
1598             $exit_code = 255;
1599 1     1   5 }
  1         2  
  1         2123  
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