File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 344 707 48.6
branch 98 350 28.0
condition 19 92 20.6
subroutine 64 101 63.3
pod 49 49 100.0
total 574 1299 44.1


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 14     14   6280  
  14         485  
  14         826  
4 14     14   64 use 5.006;
  14         27  
  14         347  
5 14     14   61 use strict;
  14         20  
  14         996  
6             use warnings;
7              
8             our $VERSION = '0.96';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 14 50   14   381 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 14     14   63 BEGIN {
  14         31  
  14         5211  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 14 50 33 14   480 # 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 14     63   73 else {
  63         132  
67 14     24   57948 *share = sub { return $_[0] };
  24         41  
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 58     58 1 140 $? = 0;
122 58   66     465 $child->{Parent} = $self;
123 58         163 $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 14     14 1 35 # the Test::Builder singleton will get the child.
142             my($error, $child, %parent);
143 14         57 {
144 14         63 # 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 14         49 local $Test::Builder::Level = $Test::Builder::Level + 1;
147              
148             $child = $self->child($name);
149             %parent = %$self;
150             %$self = %$child;
151              
152             my $run_the_subtests = sub {
153             $subtests->();
154             $self->done_testing unless $self->_plan_handled;
155             1;
156             };
157              
158             if( !eval { $run_the_subtests->() } ) {
159             $error = $@;
160             }
161             }
162              
163             # Restore the parent and the copied child.
164             %$child = %$self;
165             %$self = %parent;
166              
167             # Restore the parent's $TODO
168             $self->find_TODO(undef, 1, $child->{Parent_TODO});
169              
170 0     0 1 0 # Die *after* we restore the parent.
171             die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
172 0 0       0  
173 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
174             return $child->finalize;
175             }
176 0         0  
177             #line 281
178              
179 0         0 sub _plan_handled {
180             my $self = shift;
181 0         0 return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
182 0         0 }
183              
184              
185 0         0 #line 306
186              
187 0         0 sub finalize {
188 0 0       0 my $self = shift;
189 0         0  
190             return unless $self->parent;
191             if( $self->{Child_Name} ) {
192             $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
193             }
194 0         0 $self->_ending;
195 0         0  
196 0         0 # XXX This will only be necessary for TAP envelopes (we think)
197 0         0 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
198 0   0     0  
199 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
200 0         0 my $ok = 1;
201             $self->parent->{Child_Name} = undef;
202             if ( $self->{Skip_All} ) {
203             $self->parent->skip($self->{Skip_All});
204             }
205             elsif ( not @{ $self->{Test_Results} } ) {
206             $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
207             }
208             else {
209             $self->parent->ok( $self->is_passing, $self->name );
210             }
211             $? = $self->{Child_Error};
212             delete $self->{Parent};
213 0     0 1 0  
214 0         0 return $self->is_passing;
215             }
216 0 0       0  
217 0         0 sub _indent {
218             my $self = shift;
219              
220             if( @_ ) {
221             $self->{Indent} = shift;
222 0         0 }
223              
224             return $self->{Indent};
225             }
226 0         0  
  0         0  
227             #line 357
228 0         0  
229 0         0 sub parent { shift->{Parent} }
230 0         0  
231             #line 369
232              
233 0     0   0 sub name { shift->{Name} }
234 0 0       0  
235 0         0 sub DESTROY {
236 0         0 my $self = shift;
237             if ( $self->parent and $$ == $self->{Original_Pid} ) {
238 0 0       0 my $name = $self->name;
  0         0  
239 0         0 $self->diag(<<"FAIL");
240             Child ($name) exited without calling finalize()
241             FAIL
242             $self->parent->{In_Destroy} = 1;
243             $self->parent->ok(0, $name);
244 0         0 }
245 0         0 }
246              
247             #line 393
248 0         0  
249             our $Level;
250              
251 0 0 0     0 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
  0         0  
252             my($self) = @_;
253 0         0  
254 0         0 # We leave this a global because it has to be localized and localizing
255             # hash keys is just asking for pain. Also, it was documented.
256             $Level = 1;
257              
258             $self->{Name} = $0;
259             $self->is_passing(1);
260             $self->{Ending} = 0;
261             $self->{Have_Plan} = 0;
262             $self->{No_Plan} = 0;
263             $self->{Have_Output_Plan} = 0;
264             $self->{Done_Testing} = 0;
265              
266             $self->{Original_Pid} = $$;
267             $self->{Child_Name} = undef;
268             $self->{Indent} ||= '';
269              
270             share( $self->{Curr_Test} );
271             $self->{Curr_Test} = 0;
272             $self->{Test_Results} = &share( [] );
273              
274             $self->{Exported_To} = undef;
275             $self->{Expected_Tests} = 0;
276              
277             $self->{Skip_All} = 0;
278              
279             $self->{Use_Nums} = 1;
280              
281             $self->{No_Header} = 0;
282             $self->{No_Ending} = 0;
283 0     0   0  
284 0   0     0 $self->{Todo} = undef;
285             $self->{Todo_Stack} = [];
286             $self->{Start_Todo} = 0;
287             $self->{Opened_Testhandles} = 0;
288              
289             $self->_dup_stdhandles;
290              
291             return;
292             }
293              
294             #line 472
295              
296             my %plan_cmds = (
297             no_plan => \&no_plan,
298             skip_all => \&skip_all,
299             tests => \&_plan_tests,
300             );
301              
302             sub plan {
303             my( $self, $cmd, $arg ) = @_;
304              
305             return unless $cmd;
306              
307             local $Level = $Level + 1;
308 0     0 1 0  
309             $self->croak("You tried to plan twice") if $self->{Have_Plan};
310 0 0       0  
311 0 0       0 if( my $method = $plan_cmds{$cmd} ) {
312 0         0 local $Level = $Level + 1;
313             $self->$method($arg);
314 0         0 }
315             else {
316             my @args = grep { defined } ( $cmd, $arg );
317             $self->croak("plan() doesn't understand @args");
318             }
319 0         0  
320 0         0 return 1;
321 0         0 }
322 0 0       0  
  0 0       0  
323 0         0  
324             sub _plan_tests {
325             my($self, $arg) = @_;
326 0         0  
327             if($arg) {
328             local $Level = $Level + 1;
329 0         0 return $self->expected_tests($arg);
330             }
331 0         0 elsif( !defined $arg ) {
332 0         0 $self->croak("Got an undefined number of tests");
333             }
334 0         0 else {
335             $self->croak("You said to run 0 tests");
336             }
337              
338 38     38   75 return;
339             }
340 38 50       121  
341 0         0 #line 527
342              
343             sub expected_tests {
344 38         105 my $self = shift;
345             my($max) = @_;
346              
347             if(@_) {
348             $self->croak("Number of tests must be a positive integer. You gave it '$max'")
349             unless $max =~ /^\+?\d+$/;
350              
351             $self->{Expected_Tests} = $max;
352             $self->{Have_Plan} = 1;
353              
354             $self->_output_plan($max) unless $self->no_header;
355             }
356             return $self->{Expected_Tests};
357             }
358 6     6 1 32  
359             #line 551
360              
361             sub no_plan {
362             my($self, $arg) = @_;
363              
364             $self->carp("no_plan takes no arguments") if $arg;
365              
366             $self->{No_Plan} = 1;
367             $self->{Have_Plan} = 1;
368              
369             return 1;
370 0     0 1 0 }
371              
372             #line 584
373 0     0   0  
374 0 0 0     0 sub _output_plan {
375 0         0 my($self, $max, $directive, $reason) = @_;
376 0         0  
377             $self->carp("The plan was already output") if $self->{Have_Output_Plan};
378              
379 0         0 my $plan = "1..$max";
380 0         0 $plan .= " # $directive" if defined $directive;
381             $plan .= " $reason" if defined $reason;
382              
383             $self->_print("$plan\n");
384              
385             $self->{Have_Output_Plan} = 1;
386              
387             return;
388             }
389              
390              
391             #line 636
392              
393             sub done_testing {
394             my($self, $num_tests) = @_;
395              
396             # If done_testing() specified the number of tests, shut off no_plan.
397 14     14 1 31 if( defined $num_tests ) {
398             $self->{No_Plan} = 0;
399             }
400             else {
401 14         36 $num_tests = $self->current_test;
402             }
403 14         216  
404 14         74 if( $self->{Done_Testing} ) {
405 14         31 my($file, $line) = @{$self->{Done_Testing}}[1,2];
406 14         30 $self->ok(0, "done_testing() was already called at $file line $line");
407 14         109 return;
408 14         32 }
409 14         35  
410             $self->{Done_Testing} = [caller];
411 14         229  
412 14         40 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
413 14   50     119 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
414             "but done_testing() expects $num_tests");
415 14         73 }
416 14         38 else {
417 14         49 $self->{Expected_Tests} = $num_tests;
418             }
419 14         33  
420 14         28 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
421              
422 14         189 $self->{Have_Plan} = 1;
423              
424 14         53 # The wrong number of tests were run
425             $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
426 14         30  
427 14         28 # No tests were run
428             $self->is_passing(0) if $self->{Curr_Test} == 0;
429 14         31  
430 14         35 return 1;
431 14         29 }
432 14         32  
433              
434 14         48 #line 687
435              
436 14         23 sub has_plan {
437             my $self = shift;
438              
439             return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
440             return('no_plan') if $self->{No_Plan};
441             return(undef);
442             }
443              
444             #line 704
445              
446             sub skip_all {
447             my( $self, $reason ) = @_;
448              
449             $self->{Skip_All} = $self->parent ? $reason : 1;
450              
451             $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
452             if ( $self->parent ) {
453             die bless {} => 'Test::Builder::Exception';
454             }
455             exit(0);
456             }
457              
458             #line 729
459              
460             sub exported_to {
461             my( $self, $pack ) = @_;
462              
463             if( defined $pack ) {
464             $self->{Exported_To} = $pack;
465             }
466             return $self->{Exported_To};
467             }
468              
469             #line 759
470              
471             sub ok {
472             my( $self, $test, $name ) = @_;
473              
474             if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
475             $name = 'unnamed test' unless defined $name;
476             $self->is_passing(0);
477             $self->croak("Cannot run test ($name) with active children");
478             }
479             # $test might contain an object which we don't want to accidentally
480 17     17 1 45 # store, so we turn it into a boolean.
481             $test = $test ? 1 : 0;
482 17 100       63  
483             lock $self->{Curr_Test};
484 14         44 $self->{Curr_Test}++;
485              
486 14 50       68 # In case $name is a string overloaded object, force it to stringify.
487             $self->_unoverload_str( \$name );
488 14 50       70  
489 14         33 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
490 14         286 You named your test '$name'. You shouldn't use numbers for your test names.
491             Very confusing.
492             ERR
493 0         0  
  0         0  
494 0         0 # Capture the value of $TODO for the rest of this ok() call
495             # so it can more easily be found by other routines.
496             my $todo = $self->todo();
497 11         36 my $in_todo = $self->in_todo;
498             local $self->{Todo} = $todo if $in_todo;
499              
500             $self->_unoverload_str( \$todo );
501              
502 11     11   25 my $out;
503             my $result = &share( {} );
504 11 50       39  
    0          
505 11         26 unless($test) {
506 11         47 $out .= "not ";
507             @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
508             }
509 0         0 else {
510             @$result{ 'ok', 'actual_ok' } = ( 1, $test );
511             }
512 0         0  
513             $out .= "ok";
514             $out .= " $self->{Curr_Test}" if $self->use_numbers;
515 0         0  
516             if( defined $name ) {
517             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
518             $out .= " - $name";
519             $result->{name} = $name;
520             }
521             else {
522             $result->{name} = '';
523             }
524              
525             if( $self->in_todo ) {
526             $out .= " # TODO $todo";
527             $result->{reason} = $todo;
528             $result->{type} = 'todo';
529 11     11 1 23 }
530 11         22 else {
531             $result->{reason} = '';
532 11 50       49 $result->{type} = '';
533 11 50       96 }
534              
535             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
536 11         34 $out .= "\n";
537 11         22  
538             $self->_print($out);
539 11 50       43  
540             unless($test) {
541 11         40 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
542             $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
543              
544             my( undef, $file, $line ) = $self->caller;
545             if( defined $name ) {
546             $self->diag(qq[ $msg test '$name'\n]);
547             $self->diag(qq[ at $file line $line.\n]);
548             }
549             else {
550             $self->diag(qq[ $msg test at $file line $line.\n]);
551             }
552             }
553 0     0 1 0  
554             $self->is_passing(0) unless $test || $self->in_todo;
555 0 0       0  
556             # Check that we haven't violated the plan
557 0         0 $self->_check_is_passing_plan();
558 0         0  
559             return $test ? 1 : 0;
560 0         0 }
561              
562              
563             # Check that we haven't yet violated the plan and set
564             # is_passing() accordingly
565             sub _check_is_passing_plan {
566             my $self = shift;
567              
568             my $plan = $self->has_plan;
569             return unless defined $plan; # no plan yet defined
570             return unless $plan !~ /\D/; # no numeric plan
571             $self->is_passing(0) if $plan < $self->{Curr_Test};
572             }
573              
574              
575             sub _unoverload {
576             my $self = shift;
577             my $type = shift;
578              
579             $self->_try(sub { require overload; }, die_on_fail => 1);
580              
581             foreach my $thing (@_) {
582             if( $self->_is_object($$thing) ) {
583             if( my $string_meth = overload::Method( $$thing, $type ) ) {
584             $$thing = $$thing->$string_meth();
585             }
586 14     14   105 }
587             }
588 14 50       86  
589             return;
590 14         46 }
591 14 100       94  
592 14 100       48 sub _is_object {
593             my( $self, $thing ) = @_;
594 14         148  
595             return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
596 14         43 }
597              
598 14         46 sub _unoverload_str {
599             my $self = shift;
600              
601             return $self->_unoverload( q[""], @_ );
602             }
603              
604             sub _unoverload_num {
605             my $self = shift;
606              
607             $self->_unoverload( '0+', @_ );
608              
609             for my $val (@_) {
610             next unless $self->_is_dualvar($$val);
611             $$val = $$val + 0;
612             }
613              
614             return;
615             }
616              
617             # This is a hack to detect a dualvar such as $!
618             sub _is_dualvar {
619             my( $self, $val ) = @_;
620              
621             # Objects are not dualvars.
622             return 0 if ref $val;
623              
624             no warnings 'numeric';
625             my $numval = $val + 0;
626             return $numval != 0 and $numval ne $val ? 1 : 0;
627             }
628              
629             #line 933
630              
631             sub is_eq {
632             my( $self, $got, $expect, $name ) = @_;
633             local $Level = $Level + 1;
634              
635             if( !defined $got || !defined $expect ) {
636             # undef only matches undef and nothing else
637             my $test = !defined $got && !defined $expect;
638 0     0 1 0  
639             $self->ok( $test, $name );
640             $self->_is_diag( $got, 'eq', $expect ) unless $test;
641 0 0       0 return $test;
642 0         0 }
643              
644             return $self->cmp_ok( $got, 'eq', $expect, $name );
645 0         0 }
646              
647             sub is_num {
648 0 0       0 my( $self, $got, $expect, $name ) = @_;
649 0         0 local $Level = $Level + 1;
  0         0  
650 0         0  
651 0         0 if( !defined $got || !defined $expect ) {
652             # undef only matches undef and nothing else
653             my $test = !defined $got && !defined $expect;
654 0         0  
655             $self->ok( $test, $name );
656 0 0 0     0 $self->_is_diag( $got, '==', $expect ) unless $test;
657 0         0 return $test;
  0         0  
658             }
659              
660             return $self->cmp_ok( $got, '==', $expect, $name );
661 0         0 }
662              
663             sub _diag_fmt {
664 0 0       0 my( $self, $type, $val ) = @_;
665              
666 0         0 if( defined $$val ) {
667             if( $type eq 'eq' or $type eq 'ne' ) {
668             # quote and force string context
669 0 0       0 $$val = "'$$val'";
670             }
671             else {
672 0 0       0 # force numeric context
673             $self->_unoverload_num($val);
674 0         0 }
675             }
676             else {
677             $$val = 'undef';
678             }
679              
680             return;
681             }
682              
683             sub _is_diag {
684             my( $self, $got, $type, $expect ) = @_;
685              
686             $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
687              
688             local $Level = $Level + 1;
689 24     24 1 35 return $self->diag(<<"DIAGNOSTIC");
690             got: $got
691 24 50       128 expected: $expect
692 0 0       0 DIAGNOSTIC
693 0         0  
694             }
695              
696             sub _isnt_diag {
697             my( $self, $got, $type ) = @_;
698              
699             $self->_diag_fmt( $type, \$got );
700              
701             local $Level = $Level + 1;
702             return $self->diag(<<"DIAGNOSTIC");
703             got: $got
704             expected: anything else
705             DIAGNOSTIC
706 3     3 1 9 }
707              
708 3 50       18 #line 1026
709              
710 3 50       16 sub isnt_eq {
711 3 50       10 my( $self, $got, $dont_expect, $name ) = @_;
712 0         0 local $Level = $Level + 1;
713              
714 3         1844 if( !defined $got || !defined $dont_expect ) {
715             # undef only matches undef and nothing else
716             my $test = defined $got || defined $dont_expect;
717              
718             $self->ok( $test, $name );
719             $self->_isnt_diag( $got, 'ne' ) unless $test;
720             return $test;
721             }
722              
723             return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
724             }
725              
726             sub isnt_num {
727             my( $self, $got, $dont_expect, $name ) = @_;
728             local $Level = $Level + 1;
729              
730             if( !defined $got || !defined $dont_expect ) {
731 14     14 1 34 # undef only matches undef and nothing else
732             my $test = defined $got || defined $dont_expect;
733 14 50       65  
734 14         42 $self->ok( $test, $name );
735             $self->_isnt_diag( $got, '!=' ) unless $test;
736 14         46 return $test;
737             }
738              
739             return $self->cmp_ok( $got, '!=', $dont_expect, $name );
740             }
741              
742             #line 1075
743              
744             sub like {
745             my( $self, $this, $regex, $name ) = @_;
746              
747             local $Level = $Level + 1;
748             return $self->_regex_ok( $this, $regex, '=~', $name );
749             }
750              
751             sub unlike {
752             my( $self, $this, $regex, $name ) = @_;
753              
754             local $Level = $Level + 1;
755             return $self->_regex_ok( $this, $regex, '!~', $name );
756             }
757              
758             #line 1099
759              
760             my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
761 24     24 1 58  
762             sub cmp_ok {
763 24 50 33     113 my( $self, $got, $type, $expect, $name ) = @_;
764 0 0       0  
765 0         0 my $test;
766 0         0 my $error;
767             {
768             ## no critic (BuiltinFunctions::ProhibitStringyEval)
769              
770 24 50       96 local( $@, $!, $SIG{__DIE__} ); # isolate eval
771              
772 24         95 my($pack, $file, $line) = $self->caller();
773 24         50  
774             # This is so that warnings come out at the caller's level
775             $test = eval qq[
776 24         88 #line $line "(eval in cmp_ok) $file"
777             \$got $type \$expect;
778 24 50 66     202 ];
779             $error = $@;
780             }
781             local $Level = $Level + 1;
782             my $ok = $self->ok( $test, $name );
783              
784             # Treat overloaded objects as numbers if we're asked to do a
785 24         88 # numeric comparison.
786 24         88 my $unoverload
787 24 50       64 = $numeric_cmps{$type}
788             ? '_unoverload_num'
789 24         68 : '_unoverload_str';
790              
791 24         32 $self->diag(<<"END") if $error;
792 24         83 An error occurred while using $type:
793             ------------------------------------
794 24 50       68 $error
795 0         0 ------------------------------------
796 0 0       0 END
797              
798             unless($ok) {
799 24         95 $self->$unoverload( \$got, \$expect );
800              
801             if( $type =~ /^(eq|==)$/ ) {
802 24         1429 $self->_is_diag( $got, $type, $expect );
803 24 50       75 }
804             elsif( $type =~ /^(ne|!=)$/ ) {
805 24 100       94 $self->_isnt_diag( $got, $type );
806 14         35 }
807 14         34 else {
808 14         31 $self->_cmp_diag( $got, $type, $expect );
809             }
810             }
811 10         35 return $ok;
812             }
813              
814 24 50       62 sub _cmp_diag {
815 0         0 my( $self, $got, $type, $expect ) = @_;
816 0         0  
817 0         0 $got = defined $got ? "'$got'" : 'undef';
818             $expect = defined $expect ? "'$expect'" : 'undef';
819              
820 24         64 local $Level = $Level + 1;
821 24         54 return $self->diag(<<"DIAGNOSTIC");
822             $got
823             $type
824 24         89 $expect
825 24         41 DIAGNOSTIC
826             }
827 24         74  
828             sub _caller_context {
829 24 50       98 my $self = shift;
830 0 0       0  
831 0 0       0 my( $pack, $file, $line ) = $self->caller(1);
832              
833 0         0 my $code = '';
834 0 0       0 $code .= "#line $line $file\n" if defined $file and defined $line;
835 0         0  
836 0         0 return $code;
837             }
838              
839 0         0 #line 1199
840              
841             sub BAIL_OUT {
842             my( $self, $reason ) = @_;
843 24 50 33     91  
844             $self->{Bailed_Out} = 1;
845             $self->_print("Bail out! $reason");
846 24         92 exit 255;
847             }
848 24 50       314  
849             #line 1212
850              
851             {
852             no warnings 'once';
853             *BAILOUT = \&BAIL_OUT;
854             }
855 24     24   44  
856             #line 1226
857 24         73  
858 24 50       74 sub skip {
859 24 50       105 my( $self, $why ) = @_;
860 24 50       91 $why ||= '';
861             $self->_unoverload_str( \$why );
862              
863             lock( $self->{Curr_Test} );
864             $self->{Curr_Test}++;
865 54     54   91  
866 54         71 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
867             {
868 54     54   265 'ok' => 1,
  54         359  
869             actual_ok => 1,
870 54         185 name => '',
871 60 50       156 type => 'skip',
872 0 0       0 reason => $why,
873 0         0 }
874             );
875              
876             my $out = "ok";
877             $out .= " $self->{Curr_Test}" if $self->use_numbers;
878 54         126 $out .= " # skip";
879             $out .= " $why" if length $why;
880             $out .= "\n";
881              
882 60     60   120 $self->_print($out);
883              
884 60 100   60   220 return 1;
  60 50       312  
885             }
886              
887             #line 1267
888 54     54   77  
889             sub todo_skip {
890 54         145 my( $self, $why ) = @_;
891             $why ||= '';
892              
893             lock( $self->{Curr_Test} );
894 0     0   0 $self->{Curr_Test}++;
895              
896 0         0 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
897             {
898 0         0 'ok' => 1,
899 0 0       0 actual_ok => 0,
900 0         0 name => '',
901             type => 'todo_skip',
902             reason => $why,
903 0         0 }
904             );
905              
906             my $out = "not ok";
907             $out .= " $self->{Curr_Test}" if $self->use_numbers;
908 0     0   0 $out .= " # TODO & SKIP $why\n";
909              
910             $self->_print($out);
911 0 0       0  
912             return 1;
913 14     14   133 }
  14         36  
  14         23213  
914 0         0  
915 0 0       0 #line 1347
    0          
916              
917             sub maybe_regex {
918             my( $self, $regex ) = @_;
919             my $usable_regex = undef;
920              
921             return $usable_regex unless defined $regex;
922              
923             my( $re, $opts );
924              
925             # Check for qr/foo/
926             if( _is_qr($regex) ) {
927             $usable_regex = $regex;
928             }
929             # Check for '/foo/' or 'm,foo,'
930             elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
931             ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
932             )
933             {
934             $usable_regex = length $opts ? "(?$opts)$re" : $re;
935 8     8 1 34 }
936 8         19  
937             return $usable_regex;
938 8 50 33     73 }
939              
940 0   0     0 sub _is_qr {
941             my $regex = shift;
942 0         0  
943 0 0       0 # is_regexp() checks for regexes in a robust manner, say if they're
944 0         0 # blessed.
945             return re::is_regexp($regex) if defined &re::is_regexp;
946             return ref $regex eq 'Regexp';
947 8         33 }
948              
949             sub _regex_ok {
950             my( $self, $this, $regex, $cmp, $name ) = @_;
951 0     0 1 0  
952 0         0 my $ok = 0;
953             my $usable_regex = $self->maybe_regex($regex);
954 0 0 0     0 unless( defined $usable_regex ) {
955             local $Level = $Level + 1;
956 0   0     0 $ok = $self->ok( 0, $name );
957             $self->diag(" '$regex' doesn't look much like a regex to me.");
958 0         0 return $ok;
959 0 0       0 }
960 0         0  
961             {
962             ## no critic (BuiltinFunctions::ProhibitStringyEval)
963 0         0  
964             my $test;
965             my $context = $self->_caller_context;
966              
967 0     0   0 local( $@, $!, $SIG{__DIE__} ); # isolate eval
968              
969 0 0       0 $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
970 0 0 0     0  
971             $test = !$test if $cmp eq '!~';
972 0         0  
973             local $Level = $Level + 1;
974             $ok = $self->ok( $test, $name );
975             }
976 0         0  
977             unless($ok) {
978             $this = defined $this ? "'$this'" : 'undef';
979             my $match = $cmp eq '=~' ? "doesn't match" : "matches";
980 0         0  
981             local $Level = $Level + 1;
982             $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
983 0         0 %s
984             %13s '%s'
985             DIAGNOSTIC
986              
987 0     0   0 }
988              
989 0         0 return $ok;
990             }
991 0         0  
992 0         0 # I'm not ready to publish this. It doesn't deal with array return
993             # values from the code or context.
994              
995             #line 1443
996              
997             sub _try {
998             my( $self, $code, %opts ) = @_;
999              
1000 0     0   0 my $error;
1001             my $return;
1002 0         0 {
1003             local $!; # eval can mess up $!
1004 0         0 local $@; # don't set $@ in the test
1005 0         0 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1006             $return = eval { $code->() };
1007             $error = $@;
1008             }
1009              
1010             die $error if $error and $opts{die_on_fail};
1011              
1012             return wantarray ? ( $return, $error ) : $return;
1013             }
1014              
1015             #line 1472
1016              
1017             sub is_fh {
1018             my $self = shift;
1019             my $maybe_fh = shift;
1020             return 0 unless defined $maybe_fh;
1021              
1022             return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1023             return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1024              
1025             return eval { $maybe_fh->isa("IO::Handle") } ||
1026             eval { tied($maybe_fh)->can('TIEHANDLE') };
1027             }
1028 0     0 1 0  
1029 0         0 #line 1515
1030              
1031 0 0 0     0 sub level {
1032             my( $self, $level ) = @_;
1033 0   0     0  
1034             if( defined $level ) {
1035 0         0 $Level = $level;
1036 0 0       0 }
1037 0         0 return $Level;
1038             }
1039              
1040 0         0 #line 1547
1041              
1042             sub use_numbers {
1043             my( $self, $use_nums ) = @_;
1044 0     0 1 0  
1045 0         0 if( defined $use_nums ) {
1046             $self->{Use_Nums} = $use_nums;
1047 0 0 0     0 }
1048             return $self->{Use_Nums};
1049 0   0     0 }
1050              
1051 0         0 #line 1580
1052 0 0       0  
1053 0         0 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1054             my $method = lc $attribute;
1055              
1056 0         0 my $code = sub {
1057             my( $self, $no ) = @_;
1058              
1059             if( defined $no ) {
1060             $self->{$attribute} = $no;
1061             }
1062             return $self->{$attribute};
1063             };
1064              
1065             no strict 'refs'; ## no critic
1066             *{ __PACKAGE__ . '::' . $method } = $code;
1067             }
1068              
1069             #line 1633
1070              
1071             sub diag {
1072             my $self = shift;
1073              
1074             $self->_print_comment( $self->_diag_fh, @_ );
1075             }
1076              
1077 4     4 1 10 #line 1648
1078              
1079 4         8 sub note {
1080 4         18 my $self = shift;
1081              
1082             $self->_print_comment( $self->output, @_ );
1083             }
1084 0     0 1 0  
1085             sub _diag_fh {
1086 0         0 my $self = shift;
1087 0         0  
1088             local $Level = $Level + 1;
1089             return $self->in_todo ? $self->todo_output : $self->failure_output;
1090             }
1091              
1092             sub _print_comment {
1093             my( $self, $fh, @msgs ) = @_;
1094              
1095             return if $self->no_diag;
1096             return unless @msgs;
1097              
1098             # Prevent printing headers when compiling (i.e. -c)
1099             return if $^C;
1100              
1101             # Smash args together like print does.
1102             # Convert undef to 'undef' so its readable.
1103 8     8 1 16 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1104              
1105 8         12 # Escape the beginning, _print will take care of the rest.
1106             $msg =~ s/^/# /;
1107              
1108             local $Level = $Level + 1;
1109             $self->_print_to_fh( $fh, $msg );
1110 8         10  
  8         100  
1111             return 0;
1112 8         31 }
1113              
1114             #line 1698
1115 8         574  
1116             sub explain {
1117             my $self = shift;
1118              
1119 8         118 return map {
1120             ref $_
1121 8         16 ? do {
1122 8         30 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1123              
1124             my $dumper = Data::Dumper->new( [$_] );
1125             $dumper->Indent(1)->Terse(1);
1126 8 50       31 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1127             $dumper->Dump;
1128             }
1129             : $_
1130             } @_;
1131 8 50       17 }
1132              
1133             #line 1727
1134              
1135             sub _print {
1136             my $self = shift;
1137             return $self->_print_to_fh( $self->output, @_ );
1138 8 50       28 }
1139 0         0  
1140             sub _print_to_fh {
1141 0 0       0 my( $self, $fh, @msgs ) = @_;
    0          
1142 0         0  
1143             # Prevent printing headers when only compiling. Mostly for when
1144             # tests are deparsed with B::Deparse
1145 0         0 return if $^C;
1146              
1147             my $msg = join '', @msgs;
1148 0         0 my $indent = $self->_indent;
1149              
1150             local( $\, $", $, ) = ( undef, ' ', '' );
1151 8         452  
1152             # Escape each line after the first with a # so we don't
1153             # confuse Test::Harness.
1154             $msg =~ s{\n(?!\z)}{\n$indent# }sg;
1155 0     0   0  
1156             # Stick a newline on the end if it needs it.
1157 0 0       0 $msg .= "\n" unless $msg =~ /\n\z/;
1158 0 0       0  
1159             return print $fh $indent, $msg;
1160 0         0 }
1161 0         0  
1162             #line 1787
1163              
1164             sub output {
1165             my( $self, $fh ) = @_;
1166              
1167             if( defined $fh ) {
1168             $self->{Out_FH} = $self->_new_fh($fh);
1169 4     4   7 }
1170             return $self->{Out_FH};
1171 4         13 }
1172              
1173 4         10 sub failure_output {
1174 4 50 33     34 my( $self, $fh ) = @_;
1175              
1176 4         10 if( defined $fh ) {
1177             $self->{Fail_FH} = $self->_new_fh($fh);
1178             }
1179             return $self->{Fail_FH};
1180             }
1181              
1182             sub todo_output {
1183             my( $self, $fh ) = @_;
1184              
1185             if( defined $fh ) {
1186             $self->{Todo_FH} = $self->_new_fh($fh);
1187             }
1188             return $self->{Todo_FH};
1189             }
1190              
1191             sub _new_fh {
1192             my $self = shift;
1193             my($file_or_fh) = shift;
1194              
1195             my $fh;
1196             if( $self->is_fh($file_or_fh) ) {
1197             $fh = $file_or_fh;
1198             }
1199             elsif( ref $file_or_fh eq 'SCALAR' ) {
1200             # Scalar refs as filehandles was added in 5.8.
1201 0     0 1 0 if( $] >= 5.008 ) {
1202             open $fh, ">>", $file_or_fh
1203 0         0 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1204 0         0 }
1205 0         0 # Emulate scalar ref filehandles with a tie.
1206             else {
1207             $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1208             or $self->croak("Can't tie scalar ref $file_or_fh");
1209             }
1210             }
1211             else {
1212             open $fh, ">", $file_or_fh
1213             or $self->croak("Can't open test output log $file_or_fh: $!");
1214 14     14   104 _autoflush($fh);
  14         29  
  14         24374  
1215             }
1216              
1217             return $fh;
1218             }
1219              
1220             sub _autoflush {
1221             my($fh) = shift;
1222             my $old_fh = select $fh;
1223             $| = 1;
1224             select $old_fh;
1225              
1226             return;
1227             }
1228 0     0 1 0  
1229 0   0     0 my( $Testout, $Testerr );
1230 0         0  
1231             sub _dup_stdhandles {
1232 0         0 my $self = shift;
1233 0         0  
1234             $self->_open_testhandles;
1235 0         0  
1236             # Set everything to unbuffered else plain prints to STDOUT will
1237             # come out in the wrong order from our own prints.
1238             _autoflush($Testout);
1239             _autoflush( \*STDOUT );
1240             _autoflush($Testerr);
1241             _autoflush( \*STDERR );
1242              
1243             $self->reset_outputs;
1244              
1245 0         0 return;
1246 0 0       0 }
1247 0         0  
1248 0 0       0 sub _open_testhandles {
1249 0         0 my $self = shift;
1250              
1251 0         0 return if $self->{Opened_Testhandles};
1252              
1253 0         0 # We dup STDOUT and STDERR so people can change them in their
1254             # test suites while still getting normal test output.
1255             open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
1256             open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
1257              
1258             # $self->_copy_io_layers( \*STDOUT, $Testout );
1259             # $self->_copy_io_layers( \*STDERR, $Testerr );
1260              
1261             $self->{Opened_Testhandles} = 1;
1262              
1263             return;
1264             }
1265              
1266             sub _copy_io_layers {
1267             my( $self, $src, $dst ) = @_;
1268              
1269 0     0 1 0 $self->_try(
1270 0   0     0 sub {
1271             require PerlIO;
1272 0         0 my @src_layers = PerlIO::get_layers($src);
1273 0         0  
1274             binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
1275 0         0 }
1276             );
1277              
1278             return;
1279             }
1280              
1281             #line 1912
1282              
1283             sub reset_outputs {
1284             my $self = shift;
1285 0         0  
1286 0 0       0 $self->output ($Testout);
1287 0         0 $self->failure_output($Testerr);
1288             $self->todo_output ($Testout);
1289 0         0  
1290             return;
1291 0         0 }
1292              
1293             #line 1938
1294              
1295             sub _message_at_caller {
1296             my $self = shift;
1297              
1298             local $Level = $Level + 1;
1299             my( $pack, $file, $line ) = $self->caller;
1300             return join( "", @_ ) . " at $file line $line.\n";
1301             }
1302              
1303             sub carp {
1304             my $self = shift;
1305             return warn $self->_message_at_caller(@_);
1306             }
1307              
1308             sub croak {
1309             my $self = shift;
1310             return die $self->_message_at_caller(@_);
1311             }
1312              
1313              
1314             #line 1978
1315              
1316             sub current_test {
1317             my( $self, $num ) = @_;
1318              
1319             lock( $self->{Curr_Test} );
1320             if( defined $num ) {
1321             $self->{Curr_Test} = $num;
1322              
1323             # If the test counter is being pushed forward fill in the details.
1324             my $test_results = $self->{Test_Results};
1325             if( $num > @$test_results ) {
1326             my $start = @$test_results ? @$test_results : 0;
1327             for( $start .. $num - 1 ) {
1328             $test_results->[$_] = &share(
1329             {
1330             'ok' => 1,
1331             actual_ok => undef,
1332             reason => 'incrementing test number',
1333             type => 'unknown',
1334             name => undef
1335             }
1336             );
1337             }
1338             }
1339             # If backward, wipe history. Its their funeral.
1340             elsif( $num < @$test_results ) {
1341             $#{$test_results} = $num - 1;
1342             }
1343             }
1344             return $self->{Curr_Test};
1345             }
1346              
1347             #line 2026
1348              
1349 4     4 1 8 sub is_passing {
1350 4         5 my $self = shift;
1351              
1352 4 50       14 if( @_ ) {
1353             $self->{Is_Passing} = shift;
1354 4         7 }
1355              
1356             return $self->{Is_Passing};
1357 4 50 0     11 }
    0          
1358 4         7  
1359              
1360             #line 2048
1361              
1362             sub summary {
1363             my($self) = shift;
1364              
1365 0 0       0 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1366             }
1367              
1368 4         10 #line 2103
1369              
1370             sub details {
1371             my $self = shift;
1372 4     4   9 return @{ $self->{Test_Results} };
1373             }
1374              
1375             #line 2132
1376 4 50       34  
1377 0         0 sub todo {
1378             my( $self, $pack ) = @_;
1379              
1380             return $self->{Todo} if defined $self->{Todo};
1381 4     4   8  
1382             local $Level = $Level + 1;
1383 4         6 my $todo = $self->find_TODO($pack);
1384 4         16 return $todo if defined $todo;
1385 4 50       12  
1386 0         0 return '';
1387 0         0 }
1388 0         0  
1389 0         0 #line 2159
1390              
1391             sub find_TODO {
1392             my( $self, $pack, $set, $new_value ) = @_;
1393              
1394             $pack = $pack || $self->caller(1) || $self->exported_to;
1395 4         5 return unless $pack;
  4         5  
1396 4         22  
1397             no strict 'refs'; ## no critic
1398 4         25 my $old_value = ${ $pack . '::TODO' };
1399             $set and ${ $pack . '::TODO' } = $new_value;
1400 4         221 return $old_value;
1401             }
1402 4 50       72  
1403             #line 2179
1404 4         9  
1405 4         14 sub in_todo {
1406             my $self = shift;
1407              
1408 4 50       18 local $Level = $Level + 1;
1409 0 0       0 return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
1410 0 0       0 }
1411              
1412 0         0 #line 2229
1413 0         0  
1414             sub todo_start {
1415             my $self = shift;
1416             my $message = @_ ? shift : '';
1417              
1418             $self->{Start_Todo}++;
1419             if( $self->in_todo ) {
1420 4         224 push @{ $self->{Todo_Stack} } => $self->todo;
1421             }
1422             $self->{Todo} = $message;
1423              
1424             return;
1425             }
1426              
1427             #line 2251
1428              
1429             sub todo_end {
1430             my $self = shift;
1431              
1432             if( !$self->{Start_Todo} ) {
1433             $self->croak('todo_end() called without todo_start()');
1434             }
1435              
1436             $self->{Start_Todo}--;
1437              
1438             if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1439             $self->{Todo} = pop @{ $self->{Todo_Stack} };
1440             }
1441             else {
1442             delete $self->{Todo};
1443             }
1444              
1445 118     118   240 return;
1446             }
1447 118         133  
1448             #line 2284
1449              
1450 118         127 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
  118         402  
1451 118         123 my( $self, $height ) = @_;
1452 118         348 $height ||= 0;
1453 118         170  
  118         201  
1454 118         426 my $level = $self->level + $height + 1;
1455             my @caller;
1456             do {
1457 118 50 66     363 @caller = CORE::caller( $level );
1458             $level--;
1459 118 100       634 } until @caller;
1460             return wantarray ? @caller : $caller[0];
1461             }
1462              
1463             #line 2301
1464              
1465             #line 2315
1466              
1467             #'#
1468             sub _sanity_check {
1469             my $self = shift;
1470              
1471             $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1472             $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1473             'Somehow you got a different number of results than tests ran!' );
1474 42     42 1 50  
1475 42         48 return;
1476 42 50       125 }
1477              
1478 42 50       186 #line 2336
1479 0 0       0  
1480             sub _whoa {
1481             my( $self, $check, $desc ) = @_;
1482 0   0     0 if($check) {
1483             local $Level = $Level + 1;
1484             $self->croak(<<"WHOA");
1485             WHOA! $desc
1486             This should never happen! Please contact the author immediately!
1487             WHOA
1488             }
1489              
1490             return;
1491             }
1492              
1493             #line 2360
1494              
1495             sub _my_exit {
1496             $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
1497              
1498             return 1;
1499             }
1500              
1501             #line 2372
1502              
1503             sub _ending {
1504             my $self = shift;
1505             return if $self->no_ending;
1506             return if $self->{Ending}++;
1507              
1508             my $real_exit_code = $?;
1509              
1510             # Don't bother with an ending if this is a forked copy. Only the parent
1511             # should do the ending.
1512             if( $self->{Original_Pid} != $$ ) {
1513             return;
1514             }
1515              
1516             # Ran tests but never declared a plan or hit done_testing
1517 87     87 1 110 if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
1518             $self->is_passing(0);
1519 87 50       219 $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
1520 0         0 }
1521              
1522 87         205 # Exit if plan() was never called. This is so "require Test::Simple"
1523             # doesn't puke.
1524             if( !$self->{Have_Plan} ) {
1525             return;
1526             }
1527              
1528             # Don't do an ending if we bailed out.
1529             if( $self->{Bailed_Out} ) {
1530             $self->is_passing(0);
1531             return;
1532             }
1533             # Figure out if we passed or failed and print helpful messages.
1534             my $test_results = $self->{Test_Results};
1535             if(@$test_results) {
1536             # The plan? We have no plan.
1537             if( $self->{No_Plan} ) {
1538             $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
1539             $self->{Expected_Tests} = $self->{Curr_Test};
1540             }
1541              
1542             # Auto-extended arrays and elements which aren't explicitly
1543             # filled in with a shared reference will puke under 5.8.0
1544             # ithreads. So we have to fill them in by hand. :(
1545             my $empty_result = &share( {} );
1546             for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1547             $test_results->[$idx] = $empty_result
1548             unless defined $test_results->[$idx];
1549 24     24 1 39 }
1550              
1551 24 50       69 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
1552 0         0  
1553             my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1554 24         126  
1555             if( $num_extra != 0 ) {
1556             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1557             $self->diag(<<"FAIL");
1558             Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
1559             FAIL
1560             $self->is_passing(0);
1561             }
1562              
1563             if($num_failed) {
1564             my $num_tests = $self->{Curr_Test};
1565             my $s = $num_failed == 1 ? '' : 's';
1566              
1567             my $qualifier = $num_extra == 0 ? '' : ' run';
1568              
1569             $self->diag(<<"FAIL");
1570             Looks like you failed $num_failed test$s of $num_tests$qualifier.
1571             FAIL
1572             $self->is_passing(0);
1573             }
1574              
1575             if($real_exit_code) {
1576             $self->diag(<<"FAIL");
1577             Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
1578             FAIL
1579             $self->is_passing(0);
1580             _my_exit($real_exit_code) && return;
1581             }
1582              
1583             my $exit_code;
1584             if($num_failed) {
1585 31     31   64 $exit_code = $num_failed <= 254 ? $num_failed : 254;
1586             }
1587 31 50       266 elsif( $num_extra != 0 ) {
1588 0         0 $exit_code = 255;
1589             }
1590 31         214 else {
1591             $exit_code = 0;
1592             }
1593 14     14   126  
  14         118  
  14         31809  
1594             _my_exit($exit_code) && return;
1595             }
1596             elsif( $self->{Skip_All} ) {
1597             _my_exit(0) && return;
1598             }
1599             elsif($real_exit_code) {
1600             $self->diag(<<"FAIL");
1601             Looks like your test exited with $real_exit_code before it could output anything.
1602             FAIL
1603             $self->is_passing(0);
1604             _my_exit($real_exit_code) && return;
1605             }
1606             else {
1607             $self->diag("No tests run!\n");
1608             $self->is_passing(0);
1609             _my_exit(255) && return;
1610             }
1611              
1612             $self->is_passing(0);
1613             $self->_whoa( 1, "We fell off the end of _ending()" );
1614             }
1615              
1616             END {
1617             $Test->_ending if defined $Test;
1618             }
1619              
1620             #line 2560
1621              
1622             1;
1623