File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 421 752 55.9
branch 141 372 37.9
condition 29 95 30.5
subroutine 73 105 69.5
pod 49 49 100.0
total 713 1373 51.9


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 32     32   480  
  32         75  
  32         1121  
4 32     32   127 use 5.006;
  32         41  
  32         931  
5 32     32   124 use strict;
  32         42  
  32         2448  
6             use warnings;
7              
8             our $VERSION = '1.001009';
9             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
10              
11 32 50   32   871 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 32     32   144 BEGIN {
  32         45  
  32         9171  
20             use Config;
21             # Load threads::shared when threads are turned on.
22 32 50 33 32   898 # 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 32     724   205 else {
  724         982  
67 32     628   86664 *share = sub { return $_[0] };
  628         604  
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 745     745 1 1170 my $class = ref $self;
122 745   66     1949 my $child = $class->create;
123 745         1488  
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 32     32 1 46 $child->{Parent} = $self;
142             $child->{Parent_TODO} = $orig_TODO;
143 32         105 $child->{Name} = $name || "Child of " . $self->name;
144 32         107 $self->{Child_Name} = $child->name;
145             return $child;
146 32         110 }
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 799     799   696 local $Level = $Level + 1;
374             return $self->expected_tests($arg);
375 799 50       1388 }
376 0         0 elsif( !defined $arg ) {
377             $self->croak("Got an undefined number of tests");
378             }
379 799         1182 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 0     0 1 0 $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 32     32 1 47 return;
433             }
434              
435              
436 32         56 #line 684
437              
438 32         326 sub done_testing {
439 32         105 my($self, $num_tests) = @_;
440 32         50  
441 32         60 # If done_testing() specified the number of tests, shut off no_plan.
442 32         92 if( defined $num_tests ) {
443 32         62 $self->{No_Plan} = 0;
444 32         52 }
445             else {
446 32         350 $num_tests = $self->current_test;
447 32         59 }
448 32   50     211  
449             if( $self->{Done_Testing} ) {
450 32         52 my($file, $line) = @{$self->{Done_Testing}}[1,2];
451 32         124 $self->ok(0, "done_testing() was already called at $file line $line");
452             return;
453 32         59 }
454 32         55  
455             $self->{Done_Testing} = [caller];
456 32         54  
457             if( $self->expected_tests && $num_tests != $self->expected_tests ) {
458 32         76 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
459             "but done_testing() expects $num_tests");
460 32         56 }
461 32         52 else {
462             $self->{Expected_Tests} = $num_tests;
463 32         43 }
464 32         57  
465 32         48 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
466 32         50  
467             $self->{Have_Plan} = 1;
468 32         97  
469 32         80 # The wrong number of tests were run
470             $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
471 32         35  
472             # No tests were run
473             $self->is_passing(0) if $self->{Curr_Test} == 0;
474              
475             return 1;
476             }
477              
478              
479 32     32   46 #line 735
480              
481 32         78 sub has_plan {
482             my $self = shift;
483 32         41  
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 57     57 1 111 lock $self->{Curr_Test};
529             $self->{Curr_Test}++;
530 57 100       160  
531             # In case $name is a string overloaded object, force it to stringify.
532 32         161 $self->_unoverload_str( \$name );
533              
534 32 50       152 $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 32 50       139 Very confusing.
537 32         70 ERR
538 32         107  
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 32         94 $self->_unoverload_str( \$todo );
546              
547             my $out;
548             my $result = &share( {} );
549              
550 31     31   57 unless($test) {
551             $out .= "not ";
552 31 50       93 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
    0          
553 31         71 }
554 31         125 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 31     31 1 61 $result->{type} = '';
578 31         54 }
579              
580 31 50       116 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
581 31 50       274 $out .= "\n";
582              
583             $self->_print($out);
584 31         82  
585 31         68 unless($test) {
586             my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
587 31 50       112 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
588              
589 31         94 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 1     1 1 1 # Check that we haven't violated the plan
602             $self->_check_is_passing_plan();
603 1 50       3  
604             return $test ? 1 : 0;
605 1         2 }
606 1         2  
607              
608 1         2 # 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 32     32   65 return;
635             }
636 32 50       118  
637             sub _is_object {
638 32         86 my( $self, $thing ) = @_;
639 32 50       94  
640 32 50       159 return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
641             }
642 32         203  
643             sub _unoverload_str {
644 32         138 my $self = shift;
645              
646 32         84 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 628     628 1 575 DIAGNOSTIC
738              
739 628 100       2120 }
740 1 50       4  
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 0     0 1 0  
755             sub isnt_eq {
756 0 0       0 my( $self, $got, $dont_expect, $name ) = @_;
757             local $Level = $Level + 1;
758 0 0       0  
759 0 0       0 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 0         0  
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 44     44 1 82 $self->ok( $test, $name );
780             $self->_isnt_diag( $got, '!=' ) unless $test;
781 44 50       151 return $test;
782 44         114 }
783              
784 44         118 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 628     628 1 897  
810             sub cmp_ok {
811 628 50 33     1706 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 628 100       1021 my $error;
819             {
820 628         1240 ## no critic (BuiltinFunctions::ProhibitStringyEval)
821 628         708  
822             local( $@, $!, $SIG{__DIE__} ); # isolate eval
823              
824 628         1157 my($pack, $file, $line) = $self->caller();
825              
826 628 50 66     3474 # 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 628         1168 }
834 628         1080 local $Level = $Level + 1;
835 628 100       1121 my $ok = $self->ok( $test, $name );
836              
837 628         998 # Treat overloaded objects as numbers if we're asked to do a
838             # numeric comparison.
839 628         536 my $unoverload
840 628         1163 = $numeric_cmps{$type}
841             ? '_unoverload_num'
842 628 100       966 : '_unoverload_str';
843 35         48  
844 35 100       56 $self->diag(<<"END") unless $succ;
845             An error occurred while using $type:
846             ------------------------------------
847 593         1487 $error
848             ------------------------------------
849             END
850 628         744  
851 628 50       1038 unless($ok) {
852             $self->$unoverload( \$got, \$expect );
853 628 100       943  
854 442         939 if( $type =~ /^(eq|==)$/ ) {
855 442         585 $self->_is_diag( $got, $type, $expect );
856 442         668 }
857             elsif( $type =~ /^(ne|!=)$/ ) {
858             $self->_isnt_diag( $got, $type );
859 186         282 }
860             else {
861             $self->_cmp_diag( $got, $type, $expect );
862 628 100       905 }
863 42         56 }
864 42         55 return $ok;
865 42         57 }
866              
867             sub _cmp_diag {
868 586         821 my( $self, $got, $type, $expect ) = @_;
869 586         830  
870             $got = defined $got ? "'$got'" : 'undef';
871             $expect = defined $expect ? "'$expect'" : 'undef';
872 628         1298  
873 628         592 local $Level = $Level + 1;
874             return $self->diag(<<"DIAGNOSTIC");
875 628         1044 $got
876             $type
877 628 100       1639 $expect
878 35 100       76 DIAGNOSTIC
879 35 50       137 }
880              
881 35         83 sub _caller_context {
882 35 100       83 my $self = shift;
883 33         115  
884 33         111 my( $pack, $file, $line ) = $self->caller(1);
885              
886             my $code = '';
887 2         9 $code .= "#line $line $file\n" if defined $file and defined $line;
888              
889             return $code;
890             }
891 628 100 100     1265  
892             #line 1259
893              
894 628         1548 sub BAIL_OUT {
895             my( $self, $reason ) = @_;
896 628 100       1591  
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 628     628   737 }
904              
905 628         1091 $self->_print("Bail out! $reason");
906 628 50       1110 exit 255;
907 628 100       1879 }
908 627 50       1352  
909             #line 1279
910              
911             {
912             no warnings 'once';
913 1322     1322   1049 *BAILOUT = \&BAIL_OUT;
914 1322         1114 }
915              
916 1322     1322   4521 #line 1293
  1322         5964  
917              
918 1322         3233 sub skip {
919 1388 100       3480 my( $self, $why, $name ) = @_;
920 6 50       15 $why ||= '';
921 0         0 $name = '' unless defined $name;
922             $self->_unoverload_str( \$why );
923              
924             lock( $self->{Curr_Test} );
925             $self->{Curr_Test}++;
926 1322         1965  
927             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
928             {
929             'ok' => 1,
930 1388     1388   1500 actual_ok => 1,
931             name => $name,
932 1388 100   1388   3501 type => 'skip',
  1388 100       3401  
933             reason => $why,
934             }
935             );
936 1322     1322   1268  
937             my $out = "ok";
938 1322         2105 $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 32     32   247 name => '',
  32         44  
  32         40701  
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 584     584 1 818 if( _is_qr($regex) ) {
988 584         815 $usable_regex = $regex;
989             }
990 584 100 66     1881 # Check for '/foo/' or 'm,foo,'
991             elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
992 14   100     108 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
993             )
994 14         30 {
995 14 100       37 $usable_regex = length $opts ? "(?$opts)$re" : $re;
996 14         129 }
997              
998             return $usable_regex;
999 570         1039 }
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 65     65   73 return $ok;
1020             }
1021 65 100       93  
1022 62 50 66     156 {
1023             my $test;
1024 62         100 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 3         4 no warnings 'uninitialized';
1033              
1034             $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
1035 65         105 }
1036              
1037             $test = !$test if $cmp eq '!~';
1038              
1039 31     31   45 local $Level = $Level + 1;
1040             $ok = $self->ok( $test, $name );
1041 31         93 }
1042              
1043 31         55 unless($ok) {
1044 31         97 $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 3     3   5  
1053             }
1054 3         9  
1055             return $ok;
1056 3         5 }
1057 3         15  
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 3     3 1 6  
1081 3         6 #line 1545
1082              
1083 3 50 33     13 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 3         8 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 15     15 1 37 };
1130              
1131 15         27 no strict 'refs'; ## no critic
1132 15         64 *{ __PACKAGE__ . '::' . $method } = $code;
1133             }
1134              
1135             #line 1706
1136 3     3 1 6  
1137             sub diag {
1138 3         7 my $self = shift;
1139 3         12  
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 573     573 1 740 sub _print_comment {
1159             my( $self, $fh, @msgs ) = @_;
1160 573 50       1132  
1161 0         0 return if $self->no_diag;
1162             return unless @msgs;
1163              
1164 573         502 # 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 573         491 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
  573         2789  
1170              
1171 573         1054 # Escape the beginning, _print will take care of the rest.
1172             $msg =~ s/^/# /;
1173              
1174 573         29724 local $Level = $Level + 1;
1175             $self->_print_to_fh( $fh, $msg );
1176              
1177             return 0;
1178             }
1179 573         6855  
1180             #line 1771
1181 573         780  
1182 573         1285 sub explain {
1183             my $self = shift;
1184              
1185             return map {
1186 573 50       1133 ref $_
1187             ? do {
1188             $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1189              
1190             my $dumper = Data::Dumper->new( [$_] );
1191 573 50       906 $dumper->Indent(1)->Terse(1);
1192             $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1193             $dumper->Dump;
1194             }
1195             : $_
1196             } @_;
1197             }
1198 573 100       847  
1199 31         92 #line 1800
1200              
1201 31 100       132 sub _print {
    50          
1202 28         62 my $self = shift;
1203             return $self->_print_to_fh( $self->output, @_ );
1204             }
1205 3         10  
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 573         2572 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 18     18   23  
1230             sub output {
1231 18         52 my( $self, $fh ) = @_;
1232              
1233 18         36 if( defined $fh ) {
1234 18 50 33     129 $self->{Out_FH} = $self->_new_fh($fh);
1235             }
1236 18         36 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 32     32   217 }
  32         57  
  32         19383  
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 18     18 1 30 }
1418 18         26 return $self->{Curr_Test};
1419             }
1420 18 50       50  
1421             #line 2107
1422 18         22  
1423             sub is_passing {
1424             my $self = shift;
1425 18 50 0     100  
    0          
1426 18         27 if( @_ ) {
1427             $self->{Is_Passing} = shift;
1428             }
1429              
1430             return $self->{Is_Passing};
1431             }
1432              
1433 0 0       0  
1434             #line 2129
1435              
1436 18         39 sub summary {
1437             my($self) = shift;
1438              
1439             return map { $_->{'ok'} } @{ $self->{Test_Results} };
1440 18     18   26 }
1441              
1442             #line 2184
1443              
1444 18 50       105 sub details {
1445 0         0 my $self = shift;
1446             return @{ $self->{Test_Results} };
1447             }
1448              
1449 18     18   117 #line 2213
1450              
1451 18         25 sub todo {
1452 18         63 my( $self, $pack ) = @_;
1453 18 50       47  
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 18         23 }
  18         21  
1462 18         50  
1463             #line 2240
1464              
1465             sub find_TODO {
1466             my( $self, $pack, $set, $new_value ) = @_;
1467 18         27  
  18         113  
1468             $pack = $pack || $self->caller(1) || $self->exported_to;
1469             return unless $pack;
1470 32     32   203  
  32         48  
  32         14864  
1471             no strict 'refs'; ## no critic
1472 18         942 my $old_value = ${ $pack . '::TODO' };
1473             $set and ${ $pack . '::TODO' } = $new_value;
1474             return $old_value;
1475 18 100       383 }
1476              
1477 18         35 #line 2260
1478 18         61  
1479             sub in_todo {
1480             my $self = shift;
1481 18 50       54  
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 18         158 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 2774     2774   4065  
1519             return;
1520 2774         2010 }
1521              
1522             #line 2365
1523 2774         2087  
  2774         5074  
1524 2774         1961 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1525 2774         4915 my( $self, $height ) = @_;
1526 2774         2707 $height ||= 0;
  2774         3263  
1527 2774         6706  
1528             my $level = $self->level + $height + 1;
1529             my @caller;
1530 2774 50 66     4916 do {
1531             @caller = CORE::caller( $level );
1532 2774 50       9335 $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 96     96 1 86 'Somehow you got a different number of results than tests ran!' );
1548 96         96  
1549 96 50       167 return;
1550             }
1551 96 50       294  
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 2522     2522 1 2120 # Ran tests but never declared a plan or hit done_testing
1591             if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
1592 2522 50       3764 $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 2522         3318 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 628     628 1 619 # Don't do an ending if we bailed out.
1623             if( $self->{Bailed_Out} ) {
1624 628 50       1196 $self->is_passing(0);
1625 0         0 return;
1626             }
1627 628         1776 # 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 168     168   200 my $num_tests = $self->{Curr_Test};
1659             my $s = $num_failed == 1 ? '' : 's';
1660 168 50       353  
1661 0         0 my $qualifier = $num_extra == 0 ? '' : ' run';
1662              
1663 168         551 $self->diag(<<"FAIL");
1664             Looks like you failed $num_failed test$s of $num_tests$qualifier.
1665             FAIL
1666 32     32   199 $self->is_passing(0);
  32         87  
  32         53633  
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 104     104 1 106 }
1709              
1710 104         133 END {
1711             $Test->_ending if defined $Test;
1712             }
1713              
1714             #line 2669
1715              
1716             1;
1717