File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 421 715 58.8
branch 122 352 34.6
condition 26 92 28.2
subroutine 72 102 70.5
pod 49 49 100.0
total 690 1310 52.6


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 21     21   357  
  21         66  
  21         810  
4 21     21   101 use 5.006;
  21         36  
  21         640  
5 21     21   93 use strict;
  21         34  
  21         1497  
6             use warnings;
7              
8             our $VERSION = '0.98';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 21 50   21   641 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 21     21   95 BEGIN {
  21         38  
  21         7017  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 21 50 33 21   674 # 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 21     208   130 else {
  208         452  
67 21     139   76114 *share = sub { return $_[0] };
  139         221  
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 305     305 1 222712 $? = 0;
122 305   66     1475 $child->{Parent} = $self;
123 305         1249 $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 21     21 1 45 # the Test::Builder singleton will get the child.
142             my($error, $child, %parent);
143 21         78 {
144 21         485 # 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 21         76 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 5     5 1 8 # Die *after* we restore the parent.
171             die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
172 5 50       21  
173 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
174             return $child->finalize;
175             }
176 5         21  
177             #line 281
178              
179 5         17 sub _plan_handled {
180             my $self = shift;
181 5         18 return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
182 5         32 }
183              
184              
185 5         19 #line 306
186              
187 5         33 sub finalize {
188 5 50       17 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 5         15  
195 5         81 local $? = 0; # don't fail if $subtests happened to set $? nonzero
196 5         13 $self->_ending;
197 5         10  
198 5   33     17 # XXX This will only be necessary for TAP envelopes (we think)
199 5         17 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
200 5         13  
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 5     5 1 18 $? = $self->{Child_Error};
214 5         13 delete $self->{Parent};
215              
216 5 50       24 return $self->is_passing;
217 0         0 }
218              
219             sub _indent {
220             my $self = shift;
221              
222 5         7 if( @_ ) {
223             $self->{Indent} = shift;
224             }
225              
226 5         10 return $self->{Indent};
  5         11  
227             }
228 5         19  
229 5         77 #line 359
230 5         101  
231             sub parent { shift->{Parent} }
232              
233 5     5   18 #line 371
234 5 100       168  
235 5         43 sub name { shift->{Name} }
236 5         44  
237             sub DESTROY {
238 5 50       10 my $self = shift;
  5         14  
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 5         146 $self->parent->{In_Destroy} = 1;
245 5         120 $self->parent->ok(0, $name);
246             }
247             }
248 5         40  
249             #line 395
250              
251 5 50 33     20 our $Level;
  0         0  
252              
253 5         12 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
254 5         18 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 5     5   12 $self->{No_Header} = 0;
284 5   66     55 $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 5     5 1 13  
309             local $Level = $Level + 1;
310 5 50       15  
311 5 50       27 $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 5         21 $self->$method($arg);
316 5         20 }
317             else {
318             my @args = grep { defined } ( $cmd, $arg );
319             $self->croak("plan() doesn't understand @args");
320             }
321 5         17  
322 5         8 return 1;
323 5         18 }
324 5 50       18  
  5 50       25  
325 0         0  
326             sub _plan_tests {
327             my($self, $arg) = @_;
328 0         0  
329             if($arg) {
330             local $Level = $Level + 1;
331 5         14 return $self->expected_tests($arg);
332             }
333 5         15 elsif( !defined $arg ) {
334 5         14 $self->croak("Got an undefined number of tests");
335             }
336 5         18 else {
337             $self->croak("You said to run 0 tests");
338             }
339              
340 166     166   374 return;
341             }
342 166 100       514  
343 5         12 #line 529
344              
345             sub expected_tests {
346 166         502 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 19     19 1 222  
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 10     10 1 31 }
373              
374             #line 586
375 4     4   8  
376 4 50 33     12 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 26     26 1 237 if( defined $num_tests ) {
400             $self->{No_Plan} = 0;
401             }
402             else {
403 26         53 $num_tests = $self->current_test;
404             }
405 26         491  
406 26         101 if( $self->{Done_Testing} ) {
407 26         50 my($file, $line) = @{$self->{Done_Testing}}[1,2];
408 26         57 $self->ok(0, "done_testing() was already called at $file line $line");
409 26         58 return;
410 26         960 }
411 26         58  
412             $self->{Done_Testing} = [caller];
413 26         546  
414 26         68 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
415 26   50     187 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
416             "but done_testing() expects $num_tests");
417 26         131 }
418 26         74 else {
419 26         84 $self->{Expected_Tests} = $num_tests;
420             }
421 26         83  
422 26         52 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
423              
424 26         53 $self->{Have_Plan} = 1;
425              
426 26         83 # The wrong number of tests were run
427             $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
428 26         57  
429 26         59 # No tests were run
430             $self->is_passing(0) if $self->{Curr_Test} == 0;
431 26         53  
432 26         53 return 1;
433 26         54 }
434 26         48  
435              
436 26         89 #line 689
437              
438 26         41 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 4     4 1 11 # store, so we turn it into a boolean.
483             $test = $test ? 1 : 0;
484 4 100       15  
485             lock $self->{Curr_Test};
486 3         7 $self->{Curr_Test}++;
487              
488 3 50       12 # In case $name is a string overloaded object, force it to stringify.
489             $self->_unoverload_str( \$name );
490 3 50       13  
491 3         7 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
492 3         19 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 3         10 my $in_todo = $self->in_todo;
500             local $self->{Todo} = $todo if $in_todo;
501              
502             $self->_unoverload_str( \$todo );
503              
504 18     18   53 my $out;
505             my $result = &share( {} );
506 18 50       77  
    0          
507 18         58 unless($test) {
508 18         150 $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 26     26 1 55 }
532 26         50 else {
533             $result->{reason} = '';
534 26 100       102 $result->{type} = '';
535 18 50       286 }
536              
537             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
538 18         60 $out .= "\n";
539 18         37  
540             $self->_print($out);
541 18 50       90  
542             unless($test) {
543 26         116 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 24     24   68 }
589             }
590 24 50       133  
591             return;
592 24         88 }
593 24 50       114  
594 24 50       95 sub _is_object {
595             my( $self, $thing ) = @_;
596 24         145  
597             return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
598 24         71 }
599              
600 24         70 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 7     7 1 13  
641             $self->ok( $test, $name );
642             $self->_is_diag( $got, 'eq', $expect ) unless $test;
643 7 50       27 return $test;
644 0         0 }
645              
646             return $self->cmp_ok( $got, 'eq', $expect, $name );
647 7         50 }
648              
649             sub is_num {
650 7 50       26 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 7         37  
657             $self->ok( $test, $name );
658 7 50 66     33 $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 7         20 }
664              
665             sub _diag_fmt {
666 7 100       43 my( $self, $type, $val ) = @_;
667              
668 7         16 if( defined $$val ) {
669             if( $type eq 'eq' or $type eq 'ne' ) {
670             # quote and force string context
671 7 50       30 $$val = "'$$val'";
672             }
673             else {
674 7 50       24 # force numeric context
675             $self->_unoverload_num($val);
676 7         241 }
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 132     132 1 203 return $self->diag(<<"DIAGNOSTIC");
692             got: $got
693 132 100       668 expected: $expect
694 15 50       37 DIAGNOSTIC
695 15         28  
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 43     43 1 95 # undef only matches undef and nothing else
734             my $test = defined $got || defined $dont_expect;
735 43 50       148  
736 43         125 $self->ok( $test, $name );
737             $self->_isnt_diag( $got, '!=' ) unless $test;
738 43         125 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 132     132 1 754  
764             sub cmp_ok {
765 132 50 33     666 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 132 50       353 local( $@, $!, $SIG{__DIE__} ); # isolate eval
773              
774 132         491 my($pack, $file, $line) = $self->caller();
775 132         246  
776             # This is so that warnings come out at the caller's level
777             $test = eval qq[
778 132         435 #line $line "(eval in cmp_ok) $file"
779             \$got $type \$expect;
780 132 50 66     937 ];
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 132         457 # numeric comparison.
788 132         405 my $unoverload
789 132 50       349 = $numeric_cmps{$type}
790             ? '_unoverload_num'
791 132         323 : '_unoverload_str';
792              
793 132         186 $self->diag(<<"END") if $error;
794 132         427 An error occurred while using $type:
795             ------------------------------------
796 132 50       329 $error
797 0         0 ------------------------------------
798 0 0       0 END
799              
800             unless($ok) {
801 132         563 $self->$unoverload( \$got, \$expect );
802              
803             if( $type =~ /^(eq|==)$/ ) {
804 132         257 $self->_is_diag( $got, $type, $expect );
805 132 50       443 }
806             elsif( $type =~ /^(ne|!=)$/ ) {
807 132 100       329 $self->_isnt_diag( $got, $type );
808 104         241 }
809 104         293 else {
810 104         1337 $self->_cmp_diag( $got, $type, $expect );
811             }
812             }
813 28         74 return $ok;
814             }
815              
816 132 50       305 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 132         347 local $Level = $Level + 1;
823 132         294 return $self->diag(<<"DIAGNOSTIC");
824             $got
825             $type
826 132         482 $expect
827 132         205 DIAGNOSTIC
828             }
829 132         414  
830             sub _caller_context {
831 132 50       439 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 132 50 33     396  
846             $self->{Bailed_Out} = 1;
847             $self->_print("Bail out! $reason");
848 132         432 exit 255;
849             }
850 132 50       552  
851             #line 1218
852              
853             {
854             no warnings 'once';
855             *BAILOUT = \&BAIL_OUT;
856             }
857 132     132   224  
858             #line 1232
859 132         406  
860 132 100       431 sub skip {
861 117 50       436 my( $self, $why ) = @_;
862 117 50       582 $why ||= '';
863             $self->_unoverload_str( \$why );
864              
865             lock( $self->{Curr_Test} );
866             $self->{Curr_Test}++;
867 358     358   429  
868 358         442 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
869             {
870 358     358   2840 'ok' => 1,
  358         2390  
871             actual_ok => 1,
872 358         1263 name => '',
873 452 100       2598 type => 'skip',
874 45 50       154 reason => $why,
875 0         0 }
876             );
877              
878             my $out = "ok";
879             $out .= " $self->{Curr_Test}" if $self->use_numbers;
880 358         8058 $out .= " # skip";
881             $out .= " $why" if length $why;
882             $out .= "\n";
883              
884 452     452   746 $self->_print($out);
885              
886 452 100   452   1719 return 1;
  452 100       3850  
887             }
888              
889             #line 1273
890 358     358   462  
891             sub todo_skip {
892 358         931 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 21     21   184 }
  21         41  
  21         44166  
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 12     12 1 29  
942 12         21 sub _is_qr {
943             my $regex = shift;
944 12 50 33     57  
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 12         40  
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 1     1 1 3  
1084             $self->_print_comment( $self->output, @_ );
1085 1         2 }
1086 1         6  
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 12     12 1 25  
1110             local $Level = $Level + 1;
1111 12         16 $self->_print_to_fh( $fh, $msg );
1112              
1113             return 0;
1114             }
1115              
1116 12         13 #line 1704
  12         86  
1117              
1118 12         32 sub explain {
1119             my $self = shift;
1120              
1121 12         726 return map {
1122             ref $_
1123             ? do {
1124             $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1125 12         163  
1126             my $dumper = Data::Dumper->new( [$_] );
1127 12         25 $dumper->Indent(1)->Terse(1);
1128 12         36 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1129             $dumper->Dump;
1130             }
1131             : $_
1132 12 50       37 } @_;
1133             }
1134              
1135             #line 1733
1136              
1137 12 50       31 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 12 50       25  
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 12         170  
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 1     1   1 sub failure_output {
1176             my( $self, $fh ) = @_;
1177 1         4  
1178             if( defined $fh ) {
1179 1         2 $self->{Fail_FH} = $self->_new_fh($fh);
1180 1 50 33     8 }
1181             return $self->{Fail_FH};
1182 1         3 }
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 21     21   167 }
  21         39  
  21         25990  
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 1     1 1 2 }
1356 1         1  
1357             #line 2040
1358 1 50       3  
1359             sub is_passing {
1360 1         2 my $self = shift;
1361              
1362             if( @_ ) {
1363 1 50 0     3 $self->{Is_Passing} = shift;
    0          
1364 1         2 }
1365              
1366             return $self->{Is_Passing};
1367             }
1368              
1369              
1370             #line 2062
1371 0 0       0  
1372             sub summary {
1373             my($self) = shift;
1374 1         3  
1375             return map { $_->{'ok'} } @{ $self->{Test_Results} };
1376             }
1377              
1378 1     1   2 #line 2117
1379              
1380             sub details {
1381             my $self = shift;
1382 1 50       7 return @{ $self->{Test_Results} };
1383 0         0 }
1384              
1385             #line 2146
1386              
1387 1     1   2 sub todo {
1388             my( $self, $pack ) = @_;
1389 1         1  
1390 1         4 return $self->{Todo} if defined $self->{Todo};
1391 1 50       3  
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 1         1 sub find_TODO {
  1         2  
1402 1         4 my( $self, $pack, $set, $new_value ) = @_;
1403              
1404 1         6 $pack = $pack || $self->caller(1) || $self->exported_to;
1405             return unless $pack;
1406 1         32  
1407             no strict 'refs'; ## no critic
1408 1 50       17 my $old_value = ${ $pack . '::TODO' };
1409             $set and ${ $pack . '::TODO' } = $new_value;
1410 1         1 return $old_value;
1411 1         4 }
1412              
1413             #line 2193
1414 1 50       3  
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 1         3 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 863     863   2001 else {
1452             delete $self->{Todo};
1453 863         1044 }
1454              
1455             return;
1456 863         905 }
  863         2919  
1457 863         1500  
1458 863         2819 #line 2298
1459 863         1283  
  863         1642  
1460 863         5412 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1461             my( $self, $height ) = @_;
1462             $height ||= 0;
1463 863 50 66     2626  
1464             my $level = $self->level + $height + 1;
1465 863 100       18485 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 78     78 1 97  
1481 78         91 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1482 78 50       174 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1483             'Somehow you got a different number of results than tests ran!' );
1484 78 50       401  
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 424     424 1 555 return;
1524             }
1525 424 50       870  
1526 0         0 # Ran tests but never declared a plan or hit done_testing
1527             if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
1528 424         812 $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 132     132 1 292 my $empty_result = &share( {} );
1556             for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1557 132 50       339 $test_results->[$idx] = $empty_result
1558 0         0 unless defined $test_results->[$idx];
1559             }
1560 132         610  
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 44     44   109 }
1592              
1593 44 50       330 my $exit_code;
1594 0         0 if($num_failed) {
1595             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1596 44         907 }
1597             elsif( $num_extra != 0 ) {
1598             $exit_code = 255;
1599 21     21   136 }
  21         69  
  21         43675  
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