File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 370 752 49.2
branch 107 372 28.7
condition 21 95 22.1
subroutine 69 105 65.7
pod 49 49 100.0
total 616 1373 44.8


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