File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 159 352 45.1
branch 50 194 25.7
condition 11 50 22.0
subroutine 33 52 63.4
pod 31 32 96.8
total 284 680 41.7


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