File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 159 352 45.2
branch 49 192 25.5
condition 11 50 22.0
subroutine 32 51 62.7
pod 31 32 96.9
total 282 677 41.7


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 8     8   154  
  8         74  
  8         76  
4             use 5.004;
5              
6             # $^C was only introduced in 5.005-ish. We do this to prevent
7             # use of uninitialized value warnings in older perls.
8             $^C ||= 0;
9 8     8   115  
  8         70  
  8         109  
10 8     8   120 use strict;
  8         76  
  8         109  
11             use vars qw($VERSION $CLASS);
12             $VERSION = '0.17';
13             $CLASS = __PACKAGE__;
14              
15             my $IsVMS = $^O eq 'VMS';
16              
17             # Make Test::Builder thread-safe for ithreads.
18 8     8   257 BEGIN {
  8         73  
  8         113  
19 8 50 33 8   103     use Config;
20 0         0     if( $] >= 5.008 && $Config{useithreads} ) {
21 0         0         require threads;
22 0         0         require threads::shared;
23                     threads::shared->import;
24                 }
25 8     147   139     else {
  147         1390  
26 8     115   91         *share = sub { 0 };
  115         1205  
27                     *lock = sub { 0 };
28                 }
29             }
30 8     8   119  
  8         70  
  8         135  
31             use vars qw($Level);
32             my($Test_Died) = 0;
33             my($Have_Plan) = 0;
34             my $Original_Pid = $$;
35             my $Curr_Test = 0; share($Curr_Test);
36             my @Test_Results = (); share(@Test_Results);
37             my @Test_Details = (); share(@Test_Details);
38              
39              
40             #line 93
41              
42             my $Test;
43             sub new {
44                 my($class) = shift;
45                 $Test ||= bless ['Move along, nothing to see here'], $class;
46                 return $Test;
47             }
48              
49             #line 119
50              
51             my $Exported_To;
52             sub exported_to {
53                 my($self, $pack) = @_;
54              
55                 if( defined $pack ) {
56                     $Exported_To = $pack;
57                 }
58                 return $Exported_To;
59             }
60              
61             #line 142
62              
63             sub plan {
64                 my($self, $cmd, $arg) = @_;
65              
66                 return unless $cmd;
67              
68                 if( $Have_Plan ) {
69                     die sprintf "You tried to plan twice! Second plan at %s line %d\n",
70                       ($self->caller)[1,2];
71                 }
72              
73                 if( $cmd eq 'no_plan' ) {
74                     $self->no_plan;
75                 }
76                 elsif( $cmd eq 'skip_all' ) {
77                     return $self->skip_all($arg);
78                 }
79                 elsif( $cmd eq 'tests' ) {
80                     if( $arg ) {
81                         return $self->expected_tests($arg);
82                     }
83                     elsif( !defined $arg ) {
84                         die "Got an undefined number of tests. Looks like you tried to ".
85                             "say how many tests you plan to run but made a mistake.\n";
86                     }
87                     elsif( !$arg ) {
88                         die "You said to run 0 tests! You've got to run something.\n";
89                     }
90                 }
91                 else {
92                     require Carp;
93                     my @args = grep { defined } ($cmd, $arg);
94                     Carp::croak("plan() doesn't understand @args");
95                 }
96 8     8 1 88  
97 8   50     137     return 1;
98 8         102 }
99              
100             #line 189
101              
102             my $Expected_Tests = 0;
103             sub expected_tests {
104                 my($self, $max) = @_;
105              
106                 if( defined $max ) {
107                     $Expected_Tests = $max;
108                     $Have_Plan = 1;
109              
110                     $self->_print("1..$max\n") unless $self->no_header;
111                 }
112                 return $Expected_Tests;
113             }
114              
115              
116             #line 211
117              
118             my($No_Plan) = 0;
119             sub no_plan {
120                 $No_Plan = 1;
121                 $Have_Plan = 1;
122 8     8 1 86 }
123              
124 8 50       101 #line 225
125 8         79  
126             sub has_plan {
127 8         85 return($Expected_Tests) if $Expected_Tests;
128             return('no_plan') if $No_Plan;
129             return(undef);
130             };
131              
132              
133             #line 241
134              
135             my $Skip_All = 0;
136             sub skip_all {
137                 my($self, $reason) = @_;
138              
139                 my $out = "1..0";
140                 $out .= " # Skip $reason" if $reason;
141                 $out .= "\n";
142              
143                 $Skip_All = 1;
144 8     8 1 87  
145                 $self->_print($out) unless $self->no_header;
146 8 50       96     exit(0);
147             }
148 8 50       88  
149 0         0 #line 275
150              
151             sub ok {
152                 my($self, $test, $name) = @_;
153 8 50       327  
    50          
    50          
154 0         0 # $test might contain an object which we don't want to accidentally
155             # store, so we turn it into a boolean.
156                 $test = $test ? 1 : 0;
157 0         0  
158                 unless( $Have_Plan ) {
159                     require Carp;
160 8 50       93         Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
    0          
    0          
161 8         95     }
162              
163                 lock $Curr_Test;
164 0         0     $Curr_Test++;
165              
166                 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
167             You named your test '$name'. You shouldn't use numbers for your test names.
168 0         0 Very confusing.
169             ERR
170              
171                 my($pack, $file, $line) = $self->caller;
172 0         0  
173 0         0     my $todo = $self->todo($pack);
  0         0  
174 0         0  
175                 my $out;
176                 my $result = {};
177 0         0     share($result);
178              
179                 unless( $test ) {
180                     $out .= "not ";
181                     @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
182                 }
183                 else {
184                     @$result{ 'ok', 'actual_ok' } = ( 1, $test );
185                 }
186              
187                 $out .= "ok";
188                 $out .= " $Curr_Test" if $self->use_numbers;
189              
190                 if( defined $name ) {
191                     $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
192 8     8 1 83         $out .= " - $name";
193                     $result->{name} = $name;
194 8 50       127     }
195 8         76     else {
196 8         76         $result->{name} = '';
197                 }
198 8 50       93  
199                 if( $todo ) {
200 8         102         my $what_todo = $todo;
201                     $out .= " # TODO $what_todo";
202                     $result->{reason} = $what_todo;
203                     $result->{type} = 'todo';
204                 }
205                 else {
206                     $result->{reason} = '';
207                     $result->{type} = '';
208                 }
209              
210                 $Test_Results[$Curr_Test-1] = $result;
211                 $out .= "\n";
212              
213                 $self->_print($out);
214 0     0 1 0  
215 0         0     unless( $test ) {
216                     my $msg = $todo ? "Failed (TODO)" : "Failed";
217                     $self->diag(" $msg test ($file at line $line)\n");
218                 }
219              
220                 return $test ? 1 : 0;
221             }
222              
223             #line 363
224              
225             sub is_eq {
226                 my($self, $got, $expect, $name) = @_;
227 0 0   0 1 0     local $Level = $Level + 1;
228 0 0       0  
229 0         0     if( !defined $got || !defined $expect ) {
230             # undef only matches undef and nothing else
231                     my $test = !defined $got && !defined $expect;
232              
233                     $self->ok($test, $name);
234                     $self->_is_diag($got, 'eq', $expect) unless $test;
235                     return $test;
236                 }
237              
238                 return $self->cmp_ok($got, 'eq', $expect, $name);
239             }
240              
241             sub is_num {
242                 my($self, $got, $expect, $name) = @_;
243                 local $Level = $Level + 1;
244 0     0 1 0  
245                 if( !defined $got || !defined $expect ) {
246 0         0 # undef only matches undef and nothing else
247 0 0       0         my $test = !defined $got && !defined $expect;
248 0         0  
249                     $self->ok($test, $name);
250 0         0         $self->_is_diag($got, '==', $expect) unless $test;
251                     return $test;
252 0 0       0     }
253 0         0  
254                 return $self->cmp_ok($got, '==', $expect, $name);
255             }
256              
257             sub _is_diag {
258                 my($self, $got, $type, $expect) = @_;
259              
260                 foreach my $val (\$got, \$expect) {
261                     if( defined $$val ) {
262                         if( $type eq 'eq' ) {
263             # quote and force string context
264                             $$val = "'$$val'"
265                         }
266                         else {
267             # force numeric context
268                             $$val = $$val+0;
269                         }
270                     }
271                     else {
272                         $$val = 'undef';
273                     }
274                 }
275              
276                 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
277 115     115 1 1423 got: %s
278             expected: %s
279             DIAGNOSTIC
280              
281 115 50       1129 }    
282              
283 115 50       1427 #line 437
284 0         0  
285 0         0 sub isnt_eq {
286                 my($self, $got, $dont_expect, $name) = @_;
287                 local $Level = $Level + 1;
288 115         3302  
289 115         957     if( !defined $got || !defined $dont_expect ) {
290             # undef only matches undef and nothing else
291 115 50 33     1928         my $test = defined $got || defined $dont_expect;
292              
293                     $self->ok($test, $name);
294                     $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
295                     return $test;
296 115         1214     }
297              
298 115         1556     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
299             }
300 115         992  
301 115         1232 sub isnt_num {
302 115         1322     my($self, $got, $dont_expect, $name) = @_;
303                 local $Level = $Level + 1;
304 115 50       3944  
305 0         0     if( !defined $got || !defined $dont_expect ) {
306 0 0       0 # undef only matches undef and nothing else
307                     my $test = defined $got || defined $dont_expect;
308              
309 115         1775         $self->ok($test, $name);
310                     $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
311                     return $test;
312 115         1058     }
313 115 50       1161  
314                 return $self->cmp_ok($got, '!=', $dont_expect, $name);
315 115 50       1342 }
316 115         1066  
317 115         1047  
318 115         1319 #line 489
319              
320             sub like {
321 0         0     my($self, $this, $regex, $name) = @_;
322              
323                 local $Level = $Level + 1;
324 115 50       1223     $self->_regex_ok($this, $regex, '=~', $name);
325 0         0 }
326 0         0  
327 0         0 sub unlike {
328 0         0     my($self, $this, $regex, $name) = @_;
329              
330                 local $Level = $Level + 1;
331 115         1126     $self->_regex_ok($this, $regex, '!~', $name);
332 115         1261 }
333              
334             #line 530
335 115         1424  
336 115         1040  
337             sub maybe_regex {
338 115         1188 my ($self, $regex) = @_;
339                 my $usable_regex = undef;
340 115 50       1138     if( ref $regex eq 'Regexp' ) {
341 0 0       0         $usable_regex = $regex;
342 0         0     }
343             # Check if it looks like '/foo/'
344                 elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
345 115 50       1588         $usable_regex = length $opts ? "(?$opts)$re" : $re;
346                 };
347                 return($usable_regex)
348             };
349              
350             sub _regex_ok {
351                 my($self, $this, $regex, $cmp, $name) = @_;
352              
353                 local $Level = $Level + 1;
354              
355                 my $ok = 0;
356                 my $usable_regex = $self->maybe_regex($regex);
357                 unless (defined $usable_regex) {
358                     $ok = $self->ok( 0, $name );
359                     $self->diag(" '$regex' doesn't look much like a regex to me.");
360                     return $ok;
361                 }
362              
363                 {
364                     local $^W = 0;
365 60     60 1 1274         my $test = $this =~ /$usable_regex/ ? 1 : 0;
366 60         801         $test = !$test if $cmp eq '!~';
367                     $ok = $self->ok( $test, $name );
368 60 100 66     1124     }
369              
370 2   33     42     unless( $ok ) {
371                     $this = defined $this ? "'$this'" : 'undef';
372 2         23         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
373 2 50       127         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
374 2         102 %s
375             %13s '%s'
376             DIAGNOSTIC
377 58         721  
378                 }
379              
380                 return $ok;
381 0     0 1 0 }
382 0         0  
383             #line 587
384 0 0 0     0  
385             sub cmp_ok {
386 0   0     0     my($self, $got, $type, $expect, $name) = @_;
387              
388 0         0     my $test;
389 0 0       0     {
390 0         0         local $^W = 0;
391                     local($@,$!); # don't interfere with $@
392             # eval() sometimes resets $!
393 0         0         $test = eval "\$got $type \$expect";
394                 }
395                 local $Level = $Level + 1;
396                 my $ok = $self->ok($test, $name);
397 0     0   0  
398                 unless( $ok ) {
399 0         0         if( $type =~ /^(eq|==)$/ ) {
400 0 0       0             $self->_is_diag($got, $type, $expect);
401 0 0       0         }
402                     else {
403 0         0             $self->_cmp_diag($got, $type, $expect);
404                     }
405                 }
406                 return $ok;
407 0         0 }
408              
409             sub _cmp_diag {
410                 my($self, $got, $type, $expect) = @_;
411 0         0     
412                 $got = defined $got ? "'$got'" : 'undef';
413                 $expect = defined $expect ? "'$expect'" : 'undef';
414                 return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
415 0         0 %s
416             %s
417             %s
418             DIAGNOSTIC
419             }
420              
421             #line 635
422              
423             sub BAILOUT {
424                 my($self, $reason) = @_;
425              
426                 $self->_print("Bail out! $reason");
427                 exit 255;
428             }
429              
430             #line 651
431              
432             sub skip {
433                 my($self, $why) = @_;
434                 $why ||= '';
435              
436                 unless( $Have_Plan ) {
437                     require Carp;
438                     Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
439 0     0 1 0     }
440 0         0  
441                 lock($Curr_Test);
442 0 0 0     0     $Curr_Test++;
443              
444 0   0     0     my %result;
445                 share(%result);
446 0         0     %result = (
447 0 0       0         'ok' => 1,
448 0         0         actual_ok => 1,
449                     name => '',
450                     type => 'skip',
451 0         0         reason => $why,
452                 );
453                 $Test_Results[$Curr_Test-1] = \%result;
454              
455 0     0 1 0     my $out = "ok";
456 0         0     $out .= " $Curr_Test" if $self->use_numbers;
457                 $out .= " # skip $why\n";
458 0 0 0     0  
459                 $Test->_print($out);
460 0   0     0  
461                 return 1;
462 0         0 }
463 0 0       0  
464 0         0  
465             #line 696
466              
467 0         0 sub todo_skip {
468                 my($self, $why) = @_;
469                 $why ||= '';
470              
471                 unless( $Have_Plan ) {
472                     require Carp;
473                     Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
474                 }
475              
476                 lock($Curr_Test);
477                 $Curr_Test++;
478              
479                 my %result;
480                 share(%result);
481                 %result = (
482                     'ok' => 1,
483                     actual_ok => 0,
484                     name => '',
485                     type => 'todo_skip',
486                     reason => $why,
487                 );
488              
489                 $Test_Results[$Curr_Test-1] = \%result;
490              
491 0     0 1 0     my $out = "not ok";
492                 $out .= " $Curr_Test" if $self->use_numbers;
493 0         0     $out .= " # TODO & SKIP $why\n";
494 0         0  
495                 $Test->_print($out);
496              
497                 return 1;
498 0     0 1 0 }
499              
500 0         0  
501 0         0 #line 771
502              
503             sub level {
504                 my($self, $level) = @_;
505              
506                 if( defined $level ) {
507                     $Level = $level;
508                 }
509                 return $Level;
510             }
511              
512             $CLASS->level(1);
513              
514              
515             #line 808
516              
517             my $Use_Nums = 1;
518             sub use_numbers {
519                 my($self, $use_nums) = @_;
520              
521                 if( defined $use_nums ) {
522                     $Use_Nums = $use_nums;
523                 }
524                 return $Use_Nums;
525             }
526              
527             #line 835
528              
529             my($No_Header, $No_Ending) = (0,0);
530             sub no_header {
531                 my($self, $no_header) = @_;
532              
533 0     0 1 0     if( defined $no_header ) {
534 0         0         $No_Header = $no_header;
535 0 0       0     }
    0          
536 0         0     return $No_Header;
537             }
538              
539             sub no_ending {
540 0 0       0     my($self, $no_ending) = @_;
541              
542 0         0     if( defined $no_ending ) {
543                     $No_Ending = $no_ending;
544                 }
545                 return $No_Ending;
546 0     0   0 }
547              
548 0         0  
549             #line 890
550 0         0  
551 0         0 sub diag {
552 0 0       0     my($self, @msgs) = @_;
553 0         0     return unless @msgs;
554 0         0  
555 0         0 # Prevent printing headers when compiling (i.e. -c)
556                 return if $^C;
557              
558             # Escape each line with a #.
559 0         0     foreach (@msgs) {
  0         0  
560 0 0       0         $_ = 'undef' unless defined;
561 0 0       0         s/^/# /gms;
562 0         0     }
563              
564                 push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
565 0 0       0  
566 0 0       0     local $Level = $Level + 1;
567 0 0       0     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
568 0         0     local($\, $", $,) = (undef, ' ', '');
569                 print $fh @msgs;
570              
571                 return 0;
572             }
573              
574             #line 925
575 0         0  
576             sub _print {
577                 my($self, @msgs) = @_;
578              
579             # Prevent printing headers when only compiling. Mostly for when
580             # tests are deparsed with B::Deparse
581                 return if $^C;
582              
583                 local($\, $", $,) = (undef, ' ', '');
584                 my $fh = $self->output;
585              
586             # Escape each line after the first with a # so we don't
587             # confuse Test::Harness.
588                 foreach (@msgs) {
589 58     58 1 648         s/\n(.)/\n# $1/sg;
590                 }
591 58         652  
592                 push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
593 58         598  
  58         643  
594 58         2435     print $fh @msgs;
595             }
596 58         8786  
597              
598 58         692 #line 976
599 58         728  
600             my($Out_FH, $Fail_FH, $Todo_FH);
601 58 50       667 sub output {
602 0 0       0     my($self, $fh) = @_;
603 0         0  
604                 if( defined $fh ) {
605                     $Out_FH = _new_fh($fh);
606 0         0     }
607                 return $Out_FH;
608             }
609 58         1463  
610             sub failure_output {
611                 my($self, $fh) = @_;
612              
613 0     0   0     if( defined $fh ) {
614                     $Fail_FH = _new_fh($fh);
615 0 0       0     }
616 0 0       0     return $Fail_FH;
617 0         0 }
618              
619             sub todo_output {
620                 my($self, $fh) = @_;
621              
622                 if( defined $fh ) {
623                     $Todo_FH = _new_fh($fh);
624                 }
625                 return $Todo_FH;
626             }
627              
628             sub _new_fh {
629                 my($file_or_fh) = shift;
630              
631                 my $fh;
632                 unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
633                     $fh = do { local *FH };
634                     open $fh, ">$file_or_fh" or
635                         die "Can't open test output log $file_or_fh: $!";
636                 }
637 0     0 0 0     else {
638                     $fh = $file_or_fh;
639 0         0     }
640 0         0  
641                 return $fh;
642             }
643              
644             unless( $^C ) {
645             # We dup STDOUT and STDERR so people can change them in their
646             # test suites while still getting normal test output.
647                 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
648                 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
649              
650             # Set everything to unbuffered else plain prints to STDOUT will
651             # come out in the wrong order from our own prints.
652                 _autoflush(\*TESTOUT);
653 0     0 1 0     _autoflush(\*STDOUT);
654 0   0     0     _autoflush(\*TESTERR);
655                 _autoflush(\*STDERR);
656 0 0       0  
657 0         0     $CLASS->output(\*TESTOUT);
658 0         0     $CLASS->failure_output(\*TESTERR);
659                 $CLASS->todo_output(\*TESTOUT);
660             }
661 0         0  
662 0         0 sub _autoflush {
663                 my($fh) = shift;
664 0         0     my $old_fh = select $fh;
665 0         0     $| = 1;
666 0         0     select $old_fh;
667             }
668              
669              
670             #line 1064
671              
672             sub current_test {
673 0         0     my($self, $num) = @_;
674              
675 0         0     lock($Curr_Test);
676 0 0       0     if( defined $num ) {
677 0         0         unless( $Have_Plan ) {
678                         require Carp;
679 0         0             Carp::croak("Can't change the current test number without a plan!");
680                     }
681 0         0  
682                     $Curr_Test = $num;
683                     if( $num > @Test_Results ) {
684                         my $start = @Test_Results ? $#Test_Results + 1 : 0;
685                         for ($start..$num-1) {
686                             my %result;
687                             share(%result);
688                             %result = ( ok => 1,
689                                         actual_ok => undef,
690                                         reason => 'incrementing test number',
691                                         type => 'unknown',
692                                         name => undef
693                                       );
694                             $Test_Results[$_] = \%result;
695                         }
696                     }
697                 }
698 0     0 1 0     return $Curr_Test;
699 0   0     0 }
700              
701 0 0       0  
702 0         0 #line 1105
703 0         0  
704             sub summary {
705                 my($self) = shift;
706 0         0  
707 0         0     return map { $_->{'ok'} } @Test_Results;
708             }
709 0         0  
710 0         0 #line 1160
711 0         0  
712             sub details {
713                 return @Test_Results;
714             }
715              
716             #line 1184
717              
718             sub todo {
719 0         0     my($self, $pack) = @_;
720              
721 0         0     $pack = $pack || $self->exported_to || $self->caller(1);
722 0 0       0  
723 0         0     no strict 'refs';
724                 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
725 0         0                                      : 0;
726             }
727 0         0  
728             #line 1204
729              
730             sub caller {
731                 my($self, $height) = @_;
732                 $height ||= 0;
733              
734                 my @caller = CORE::caller($self->level + $height + 1);
735                 return wantarray ? @caller : $caller[0];
736             }
737              
738             #line 1216
739              
740             #line 1230
741              
742             #'#
743             sub _sanity_check {
744                 _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
745                 _whoa(!$Have_Plan and $Curr_Test,
746                       'Somehow your tests ran without a plan!');
747                 _whoa($Curr_Test != @Test_Results,
748                       'Somehow you got a different number of results than tests ran!');
749             }
750              
751             #line 1249
752              
753             sub _whoa {
754                 my($check, $desc) = @_;
755                 if( $check ) {
756                     die <<WHOA;
757             WHOA! $desc
758             This should never happen! Please contact the author immediately!
759             WHOA
760                 }
761             }
762              
763             #line 1270
764              
765             sub _my_exit {
766                 $? = $_[0];
767              
768                 return 1;
769             }
770              
771              
772             #line 1283
773 123     123 1 1313  
774             $SIG{__DIE__} = sub {
775 123 100       1325 # We don't want to muck with death in an eval, but $^S isn't
776 8         77 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
777             # with it. Instead, we use caller. This also means it runs under
778 123         2820 # 5.004!
779                 my $in_eval = 0;
780                 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
781                     $in_eval = 1 if $sub =~ /^\(eval\)/;
782                 }
783                 $Test_Died = 1 unless $in_eval;
784             };
785              
786             sub _ending {
787                 my $self = shift;
788              
789                 _sanity_check();
790              
791             # Don't bother with an ending if this is a forked copy. Only the parent
792             # should do the ending.
793                 do{ _my_exit($?) && return } if $Original_Pid != $$;
794              
795             # Bailout if plan() was never called. This is so
796             # "require Test::Simple" doesn't puke.
797                 do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
798              
799             # Figure out if we passed or failed and print helpful messages.
800                 if( @Test_Results ) {
801             # The plan? We have no plan.
802                     if( $No_Plan ) {
803                         $self->_print("1..$Curr_Test\n") unless $self->no_header;
804                         $Expected_Tests = $Curr_Test;
805                     }
806              
807             # 5.8.0 threads bug. Shared arrays will not be auto-extended
808             # by a slice. Worse, we have to fill in every entry else
809             # we'll get an "Invalid value for shared scalar" error
810                     for my $idx ($#Test_Results..$Expected_Tests-1) {
811 115     115 1 1545             my %empty_result = ();
812                         share(%empty_result);
813 115 50       1197             $Test_Results[$idx] = \%empty_result
814 0         0               unless defined $Test_Results[$idx];
815                     }
816 115         1425  
817                     my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
818                     $num_failed += abs($Expected_Tests - @Test_Results);
819              
820                     if( $Curr_Test < $Expected_Tests ) {
821                         $self->diag(<<"FAIL");
822             Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
823             FAIL
824                     }
825                     elsif( $Curr_Test > $Expected_Tests ) {
826                         my $num_extra = $Curr_Test - $Expected_Tests;
827                         $self->diag(<<"FAIL");
828             Looks like you planned $Expected_Tests tests but ran $num_extra extra.
829             FAIL
830                     }
831                     elsif ( $num_failed ) {
832                         $self->diag(<<"FAIL");
833             Looks like you failed $num_failed tests of $Expected_Tests.
834             FAIL
835                     }
836              
837                     if( $Test_Died ) {
838 8     8 1 80             $self->diag(<<"FAIL");
839             Looks like your test died just after $Curr_Test.
840 8 50       92 FAIL
841 0         0  
842                         _my_exit( 255 ) && return;
843 8         174         }
844              
845                     _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
846                 }
847 8     8 1 80     elsif ( $Skip_All ) {
848                     _my_exit( 0 ) && return;
849 8 50       92     }
850 0         0     elsif ( $Test_Died ) {
851                     $self->diag(<<'FAIL');
852 8         202 Looks like your test died before it could output anything.
853             FAIL
854                 }
855                 else {
856                     $self->diag("No tests run!\n");
857                     _my_exit( 255 ) && return;
858                 }
859             }
860              
861             END {
862                 $Test->_ending if defined $Test and !$Test->no_ending;
863             }
864              
865             #line 1406
866              
867             1;
868