File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 300 572 52.4
branch 99 282 35.1
condition 15 72 20.8
subroutine 52 86 60.4
pod 42 42 100.0
total 508 1054 48.2


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3             # $Id$
4 46     46   608  
  46         101  
5 46     46   139 use 5.006;
  46         56  
  46         714  
6 46     46   133 use strict;
  46         238  
  46         3097  
7             use warnings;
8              
9             our $VERSION = '0.86';
10             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
11              
12             # Make Test::Builder thread-safe for ithreads.
13 46     46   155 BEGIN {
  46         44  
  46         11912  
14             use Config;
15             # Load threads::shared when threads are turned on.
16 46 50 33 46   774 # 5.8.0's threads are so busted we no longer support them.
      33        
17 0         0 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
18             require threads::shared;
19              
20             # Hack around YET ANOTHER threads::shared bug. It would
21             # occassionally forget the contents of the variable when sharing it.
22             # So we first copy the data, then share, then put our copy back.
23 0         0 *share = sub (\[$@%]) {
24 0         0 my $type = ref $_[0];
25             my $data;
26 0 0       0  
    0          
    0          
27 0         0 if( $type eq 'HASH' ) {
  0         0  
28             %$data = %{ $_[0] };
29             }
30 0         0 elsif( $type eq 'ARRAY' ) {
  0         0  
31             @$data = @{ $_[0] };
32             }
33 0         0 elsif( $type eq 'SCALAR' ) {
  0         0  
34             $$data = ${ $_[0] };
35             }
36 0         0 else {
37             die( "Unknown type: " . $type );
38             }
39 0         0  
40             $_[0] = &threads::shared::share( $_[0] );
41 0 0       0  
    0          
    0          
42 0         0 if( $type eq 'HASH' ) {
  0         0  
43             %{ $_[0] } = %$data;
44             }
45 0         0 elsif( $type eq 'ARRAY' ) {
  0         0  
46             @{ $_[0] } = @$data;
47             }
48 0         0 elsif( $type eq 'SCALAR' ) {
  0         0  
49             ${ $_[0] } = $$data;
50             }
51 0         0 else {
52             die( "Unknown type: " . $type );
53             }
54 0         0  
55 0         0 return $_[0];
56             };
57             }
58             # 5.8.0's threads::shared is busted when threads are off
59             # and earlier Perls just don't have that module at all.
60 46     126   397 else {
  126         167  
61 46     23   57477 *share = sub { return $_[0] };
  23         22  
62             *lock = sub { 0 };
63             }
64             }
65              
66             #line 111
67              
68             my $Test = Test::Builder->new;
69              
70             sub new {
71             my($class) = shift;
72             $Test ||= $class->create;
73             return $Test;
74             }
75              
76             #line 133
77              
78             sub create {
79             my $class = shift;
80              
81             my $self = bless {}, $class;
82             $self->reset;
83              
84             return $self;
85             }
86              
87             #line 152
88              
89             our $Level;
90              
91             sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
92             my($self) = @_;
93              
94             # We leave this a global because it has to be localized and localizing
95             # hash keys is just asking for pain. Also, it was documented.
96             $Level = 1;
97              
98             $self->{Have_Plan} = 0;
99             $self->{No_Plan} = 0;
100             $self->{Original_Pid} = $$;
101              
102             share( $self->{Curr_Test} );
103             $self->{Curr_Test} = 0;
104             $self->{Test_Results} = &share( [] );
105              
106             $self->{Exported_To} = undef;
107             $self->{Expected_Tests} = 0;
108              
109             $self->{Skip_All} = 0;
110              
111             $self->{Use_Nums} = 1;
112              
113             $self->{No_Header} = 0;
114             $self->{No_Ending} = 0;
115 117     117 1 165  
116 117   66     529 $self->{Todo} = undef;
117 117         215 $self->{Todo_Stack} = [];
118             $self->{Start_Todo} = 0;
119              
120             $self->_dup_stdhandles;
121              
122             return;
123             }
124              
125             #line 210
126              
127             sub plan {
128             my( $self, $cmd, $arg ) = @_;
129              
130             return unless $cmd;
131              
132             local $Level = $Level + 1;
133              
134             $self->croak("You tried to plan twice")
135 46     46 1 62 if $self->{Have_Plan};
136              
137 46         101 if( $cmd eq 'no_plan' ) {
138 46         108 $self->carp("no_plan takes no arguments") if $arg;
139             $self->no_plan;
140 46         213 }
141             elsif( $cmd eq 'skip_all' ) {
142             return $self->skip_all($arg);
143             }
144             elsif( $cmd eq 'tests' ) {
145             if($arg) {
146             local $Level = $Level + 1;
147             return $self->expected_tests($arg);
148             }
149             elsif( !defined $arg ) {
150             $self->croak("Got an undefined number of tests");
151             }
152             else {
153             $self->croak("You said to run 0 tests");
154             }
155             }
156 46     46 1 73 else {
157             my @args = grep { defined } ( $cmd, $arg );
158             $self->croak("plan() doesn't understand @args");
159             }
160 46         53  
161             return 1;
162 46         274 }
163 46         71  
164 46         289 #line 257
165              
166 46         136 sub expected_tests {
167 46         74 my $self = shift;
168 46         85 my($max) = @_;
169              
170 46         70 if(@_) {
171 46         56 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
172             unless $max =~ /^\+?\d+$/;
173 46         79  
174             $self->{Expected_Tests} = $max;
175 46         54 $self->{Have_Plan} = 1;
176              
177 46         46 $self->_print("1..$max\n") unless $self->no_header;
178 46         47 }
179             return $self->{Expected_Tests};
180 46         52 }
181 46         61  
182 46         56 #line 281
183              
184 46         85 sub no_plan {
185             my $self = shift;
186 46         57  
187             $self->{No_Plan} = 1;
188             $self->{Have_Plan} = 1;
189              
190             return 1;
191             }
192              
193             #line 298
194              
195             sub has_plan {
196             my $self = shift;
197              
198             return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
199             return('no_plan') if $self->{No_Plan};
200             return(undef);
201             }
202              
203             #line 315
204              
205             sub skip_all {
206             my( $self, $reason ) = @_;
207              
208             my $out = "1..0";
209             $out .= " # Skip $reason" if $reason;
210             $out .= "\n";
211              
212 37     37 1 59 $self->{Skip_All} = 1;
213              
214 37 100       135 $self->_print($out) unless $self->no_header;
215             exit(0);
216 28         41 }
217              
218             #line 341
219 28 50       710  
220             sub exported_to {
221 28 50       833 my( $self, $pack ) = @_;
    50          
    50          
222 0 0       0  
223 0         0 if( defined $pack ) {
224             $self->{Exported_To} = $pack;
225             }
226 0         0 return $self->{Exported_To};
227             }
228              
229 28 50       78 #line 371
    0          
230 28         34  
231 28         722 sub ok {
232             my( $self, $test, $name ) = @_;
233              
234 0         0 # $test might contain an object which we don't want to accidentally
235             # store, so we turn it into a boolean.
236             $test = $test ? 1 : 0;
237 0         0  
238             $self->_plan_check;
239              
240             lock $self->{Curr_Test};
241 0         0 $self->{Curr_Test}++;
  0         0  
242 0         0  
243             # In case $name is a string overloaded object, force it to stringify.
244             $self->_unoverload_str( \$name );
245 0         0  
246             $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
247             You named your test '$name'. You shouldn't use numbers for your test names.
248             Very confusing.
249             ERR
250              
251             # Capture the value of $TODO for the rest of this ok() call
252             # so it can more easily be found by other routines.
253             my $todo = $self->todo();
254             my $in_todo = $self->in_todo;
255             local $self->{Todo} = $todo if $in_todo;
256              
257             $self->_unoverload_str( \$todo );
258              
259 30     30 1 1383 my $out;
260 30         723 my $result = &share( {} );
261              
262 30 50       825 unless($test) {
263 30 50       175 $out .= "not ";
264             @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
265             }
266 30         735 else {
267 30         44 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
268             }
269 30 50       1948  
270             $out .= "ok";
271 30         827 $out .= " $self->{Curr_Test}" if $self->use_numbers;
272              
273             if( defined $name ) {
274             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
275             $out .= " - $name";
276             $result->{name} = $name;
277             }
278             else {
279             $result->{name} = '';
280             }
281              
282             if( $self->in_todo ) {
283 0     0 1 0 $out .= " # TODO $todo";
284             $result->{reason} = $todo;
285 0         0 $result->{type} = 'todo';
286 0         0 }
287             else {
288 0         0 $result->{reason} = '';
289             $result->{type} = '';
290             }
291              
292             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
293             $out .= "\n";
294              
295             $self->_print($out);
296              
297             unless($test) {
298             my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
299             $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
300 0     0 1 0  
301             my( undef, $file, $line ) = $self->caller;
302 0 0       0 if( defined $name ) {
303 0 0       0 $self->diag(qq[ $msg test '$name'\n]);
304 0         0 $self->diag(qq[ at $file line $line.\n]);
305             }
306             else {
307             $self->diag(qq[ $msg test at $file line $line.\n]);
308             }
309             }
310              
311             return $test ? 1 : 0;
312             }
313              
314             sub _unoverload {
315             my $self = shift;
316             my $type = shift;
317 0     0 1 0  
318             $self->_try(sub { require overload; }, die_on_fail => 1);
319 0         0  
320 0 0       0 foreach my $thing (@_) {
321 0         0 if( $self->_is_object($$thing) ) {
322             if( my $string_meth = overload::Method( $$thing, $type ) ) {
323 0         0 $$thing = $$thing->$string_meth();
324             }
325 0 0       0 }
326 0         0 }
327              
328             return;
329             }
330              
331             sub _is_object {
332             my( $self, $thing ) = @_;
333              
334             return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
335             }
336              
337             sub _unoverload_str {
338             my $self = shift;
339              
340             return $self->_unoverload( q[""], @_ );
341             }
342              
343 46     46 1 69 sub _unoverload_num {
344             my $self = shift;
345 46 50       125  
346 46         105 $self->_unoverload( '0+', @_ );
347              
348 46         89 for my $val (@_) {
349             next unless $self->_is_dualvar($$val);
350             $$val = $$val + 0;
351             }
352              
353             return;
354             }
355              
356             # This is a hack to detect a dualvar such as $!
357             sub _is_dualvar {
358             my( $self, $val ) = @_;
359              
360             # Objects are not dualvars.
361             return 0 if ref $val;
362              
363             no warnings 'numeric';
364             my $numval = $val + 0;
365             return $numval != 0 and $numval ne $val ? 1 : 0;
366             }
367              
368             #line 524
369              
370             sub is_eq {
371             my( $self, $got, $expect, $name ) = @_;
372             local $Level = $Level + 1;
373 23     23 1 35  
374             $self->_unoverload_str( \$got, \$expect );
375              
376             if( !defined $got || !defined $expect ) {
377 23 100       52 # undef only matches undef and nothing else
378             my $test = !defined $got && !defined $expect;
379 23         56  
380             $self->ok( $test, $name );
381 23         63 $self->_is_diag( $got, 'eq', $expect ) unless $test;
382 23         26 return $test;
383             }
384              
385 23         58 return $self->cmp_ok( $got, 'eq', $expect, $name );
386             }
387 23 50 66     120  
388             sub is_num {
389             my( $self, $got, $expect, $name ) = @_;
390             local $Level = $Level + 1;
391              
392             $self->_unoverload_num( \$got, \$expect );
393              
394 23         61 if( !defined $got || !defined $expect ) {
395 23         51 # undef only matches undef and nothing else
396 23 50       43 my $test = !defined $got && !defined $expect;
397              
398 23         46 $self->ok( $test, $name );
399             $self->_is_diag( $got, '==', $expect ) unless $test;
400 23         28 return $test;
401 23         49 }
402              
403 23 100       49 return $self->cmp_ok( $got, '==', $expect, $name );
404 5         8 }
405 5 50       9  
406             sub _diag_fmt {
407             my( $self, $type, $val ) = @_;
408 18         47  
409             if( defined $$val ) {
410             if( $type eq 'eq' or $type eq 'ne' ) {
411 23         33 # quote and force string context
412 23 50       50 $$val = "'$$val'";
413             }
414 23 100       58 else {
415 12         25 # force numeric context
416 12         22 $self->_unoverload_num($val);
417 12         19 }
418             }
419             else {
420 11         16 $$val = 'undef';
421             }
422              
423 23 50       35 return;
424 0         0 }
425 0         0  
426 0         0 sub _is_diag {
427             my( $self, $got, $type, $expect ) = @_;
428              
429 23         36 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
430 23         38  
431             local $Level = $Level + 1;
432             return $self->diag(<<"DIAGNOSTIC");
433 23         54 got: $got
434 23         120 expected: $expect
435             DIAGNOSTIC
436 23         50  
437             }
438 23 100       73  
439 5 50       14 sub _isnt_diag {
440 5 50       30 my( $self, $got, $type ) = @_;
441              
442 5         16 $self->_diag_fmt( $type, \$got );
443 5 50       15  
444 5         22 local $Level = $Level + 1;
445 5         26 return $self->diag(<<"DIAGNOSTIC");
446             got: $got
447             expected: anything else
448 0         0 DIAGNOSTIC
449             }
450              
451             #line 621
452 23 100       86  
453             sub isnt_eq {
454             my( $self, $got, $dont_expect, $name ) = @_;
455             local $Level = $Level + 1;
456 59     59   51  
457 59         92 if( !defined $got || !defined $dont_expect ) {
458             # undef only matches undef and nothing else
459 59     59   197 my $test = defined $got || defined $dont_expect;
  59         242  
460              
461 59         131 $self->ok( $test, $name );
462 72 50       114 $self->_isnt_diag( $got, 'ne' ) unless $test;
463 0 0       0 return $test;
464 0         0 }
465              
466             return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
467             }
468              
469 59         58 sub isnt_num {
470             my( $self, $got, $dont_expect, $name ) = @_;
471             local $Level = $Level + 1;
472              
473 72     72   70 if( !defined $got || !defined $dont_expect ) {
474             # undef only matches undef and nothing else
475 72 50   72   167 my $test = defined $got || defined $dont_expect;
  72 50       155  
476              
477             $self->ok( $test, $name );
478             $self->_isnt_diag( $got, '!=' ) unless $test;
479 59     59   51 return $test;
480             }
481 59         113  
482             return $self->cmp_ok( $got, '!=', $dont_expect, $name );
483             }
484              
485 0     0   0 #line 672
486              
487 0         0 sub like {
488             my( $self, $this, $regex, $name ) = @_;
489 0         0  
490 0 0       0 local $Level = $Level + 1;
491 0         0 return $self->_regex_ok( $this, $regex, '=~', $name );
492             }
493              
494 0         0 sub unlike {
495             my( $self, $this, $regex, $name ) = @_;
496              
497             local $Level = $Level + 1;
498             return $self->_regex_ok( $this, $regex, '!~', $name );
499 0     0   0 }
500              
501             #line 696
502 0 0       0  
503             my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
504 46     46   241  
  46         82  
  46         89322  
505 0         0 sub cmp_ok {
506 0 0       0 my( $self, $got, $type, $expect, $name ) = @_;
    0          
507              
508             my $test;
509             my $error;
510             {
511             ## no critic (BuiltinFunctions::ProhibitStringyEval)
512              
513             local( $@, $!, $SIG{__DIE__} ); # isolate eval
514              
515             my($pack, $file, $line) = $self->caller();
516              
517             $test = eval qq[
518             #line 1 "cmp_ok [from $file line $line]"
519             \$got $type \$expect;
520             ];
521             $error = $@;
522             }
523             local $Level = $Level + 1;
524             my $ok = $self->ok( $test, $name );
525              
526 13     13 1 16 # Treat overloaded objects as numbers if we're asked to do a
527 13         17 # numeric comparison.
528             my $unoverload
529 13         25 = $numeric_cmps{$type}
530             ? '_unoverload_num'
531 13 50 33     44 : '_unoverload_str';
532              
533 0   0     0 $self->diag(<<"END") if $error;
534             An error occurred while using $type:
535 0         0 ------------------------------------
536 0 0       0 $error
537 0         0 ------------------------------------
538             END
539              
540 13         29 unless($ok) {
541             $self->$unoverload( \$got, \$expect );
542              
543             if( $type =~ /^(eq|==)$/ ) {
544 0     0 1 0 $self->_is_diag( $got, $type, $expect );
545 0         0 }
546             elsif( $type =~ /^(ne|!=)$/ ) {
547 0         0 $self->_isnt_diag( $got, $type );
548             }
549 0 0 0     0 else {
550             $self->_cmp_diag( $got, $type, $expect );
551 0   0     0 }
552             }
553 0         0 return $ok;
554 0 0       0 }
555 0         0  
556             sub _cmp_diag {
557             my( $self, $got, $type, $expect ) = @_;
558 0         0  
559             $got = defined $got ? "'$got'" : 'undef';
560             $expect = defined $expect ? "'$expect'" : 'undef';
561              
562 0     0   0 local $Level = $Level + 1;
563             return $self->diag(<<"DIAGNOSTIC");
564 0 0       0 $got
565 0 0 0     0 $type
566             $expect
567 0         0 DIAGNOSTIC
568             }
569              
570             sub _caller_context {
571 0         0 my $self = shift;
572              
573             my( $pack, $file, $line ) = $self->caller(1);
574              
575 0         0 my $code = '';
576             $code .= "#line $line $file\n" if defined $file and defined $line;
577              
578 0         0 return $code;
579             }
580              
581             #line 795
582 0     0   0  
583             sub BAIL_OUT {
584 0         0 my( $self, $reason ) = @_;
585              
586 0         0 $self->{Bailed_Out} = 1;
587 0         0 $self->_print("Bail out! $reason");
588             exit 255;
589             }
590              
591             #line 808
592              
593             *BAILOUT = \&BAIL_OUT;
594              
595 0     0   0 #line 819
596              
597 0         0 sub skip {
598             my( $self, $why ) = @_;
599 0         0 $why ||= '';
600 0         0 $self->_unoverload_str( \$why );
601              
602             $self->_plan_check;
603              
604             lock( $self->{Curr_Test} );
605             $self->{Curr_Test}++;
606              
607             $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
608             {
609             'ok' => 1,
610             actual_ok => 1,
611             name => '',
612             type => 'skip',
613             reason => $why,
614             }
615             );
616              
617             my $out = "ok";
618             $out .= " $self->{Curr_Test}" if $self->use_numbers;
619             $out .= " # skip";
620             $out .= " $why" if length $why;
621             $out .= "\n";
622              
623 0     0 1 0 $self->_print($out);
624 0         0  
625             return 1;
626 0 0 0     0 }
627              
628 0   0     0 #line 862
629              
630 0         0 sub todo_skip {
631 0 0       0 my( $self, $why ) = @_;
632 0         0 $why ||= '';
633              
634             $self->_plan_check;
635 0         0  
636             lock( $self->{Curr_Test} );
637             $self->{Curr_Test}++;
638              
639 0     0 1 0 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
640 0         0 {
641             'ok' => 1,
642 0 0 0     0 actual_ok => 0,
643             name => '',
644 0   0     0 type => 'todo_skip',
645             reason => $why,
646 0         0 }
647 0 0       0 );
648 0         0  
649             my $out = "not ok";
650             $out .= " $self->{Curr_Test}" if $self->use_numbers;
651 0         0 $out .= " # TODO & SKIP $why\n";
652              
653             $self->_print($out);
654              
655             return 1;
656             }
657              
658             #line 941
659              
660             sub maybe_regex {
661             my( $self, $regex ) = @_;
662             my $usable_regex = undef;
663              
664             return $usable_regex unless defined $regex;
665              
666             my( $re, $opts );
667              
668             # Check for qr/foo/
669             if( _is_qr($regex) ) {
670             $usable_regex = $regex;
671             }
672             # Check for '/foo/' or 'm,foo,'
673             elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
674 0     0 1 0 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
675             )
676 0         0 {
677 0         0 $usable_regex = length $opts ? "(?$opts)$re" : $re;
678             }
679              
680             return $usable_regex;
681 0     0 1 0 }
682              
683 0         0 sub _is_qr {
684 0         0 my $regex = shift;
685              
686             # is_regexp() checks for regexes in a robust manner, say if they're
687             # blessed.
688             return re::is_regexp($regex) if defined &re::is_regexp;
689             return ref $regex eq 'Regexp';
690             }
691              
692             sub _regex_ok {
693             my( $self, $this, $regex, $cmp, $name ) = @_;
694              
695             my $ok = 0;
696             my $usable_regex = $self->maybe_regex($regex);
697             unless( defined $usable_regex ) {
698             local $Level = $Level + 1;
699             $ok = $self->ok( 0, $name );
700 13     13 1 20 $self->diag(" '$regex' doesn't look much like a regex to me.");
701             return $ok;
702 13         10 }
703              
704             {
705             ## no critic (BuiltinFunctions::ProhibitStringyEval)
706              
707 13         13 my $test;
  13         31  
708             my $code = $self->_caller_context;
709 13         23  
710             local( $@, $!, $SIG{__DIE__} ); # isolate eval
711 13         696  
712             # Yes, it has to look like this or 5.4.5 won't see the #line
713             # directive.
714             # Don't ask me, man, I just work here.
715 13         137 $test = eval "
716             $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
717 13         16  
718 13         28 $test = !$test if $cmp eq '!~';
719              
720             local $Level = $Level + 1;
721             $ok = $self->ok( $test, $name );
722             }
723 13 50       31  
724             unless($ok) {
725             $this = defined $this ? "'$this'" : 'undef';
726             my $match = $cmp eq '=~' ? "doesn't match" : "matches";
727 13 50       26  
728             local $Level = $Level + 1;
729             $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
730             %s
731             %13s '%s'
732             DIAGNOSTIC
733              
734 13 50       24 }
735 0         0  
736             return $ok;
737 0 0       0 }
    0          
738 0         0  
739             # I'm not ready to publish this. It doesn't deal with array return
740             # values from the code or context.
741 0         0  
742             #line 1041
743              
744 0         0 sub _try {
745             my( $self, $code, %opts ) = @_;
746              
747 13         217 my $error;
748             my $return;
749             {
750             local $!; # eval can mess up $!
751 0     0   0 local $@; # don't set $@ in the test
752             local $SIG{__DIE__}; # don't trip an outside DIE handler.
753 0 0       0 $return = eval { $code->() };
754 0 0       0 $error = $@;
755             }
756 0         0  
757 0         0 die $error if $error and $opts{die_on_fail};
758              
759             return wantarray ? ( $return, $error ) : $return;
760             }
761              
762             #line 1070
763              
764             sub is_fh {
765 0     0   0 my $self = shift;
766             my $maybe_fh = shift;
767 0         0 return 0 unless defined $maybe_fh;
768              
769 0         0 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
770 0 0 0     0 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
771              
772 0         0 return eval { $maybe_fh->isa("IO::Handle") } ||
773             # 5.5.4's tied() and can() doesn't like getting undef
774             eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
775             }
776              
777             #line 1114
778              
779             sub level {
780             my( $self, $level ) = @_;
781              
782             if( defined $level ) {
783             $Level = $level;
784             }
785             return $Level;
786             }
787              
788             #line 1146
789              
790             sub use_numbers {
791             my( $self, $use_nums ) = @_;
792              
793             if( defined $use_nums ) {
794             $self->{Use_Nums} = $use_nums;
795             }
796             return $self->{Use_Nums};
797 0     0 1 0 }
798              
799 0         0 #line 1179
800 0         0  
801 0         0 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
802             my $method = lc $attribute;
803              
804             my $code = sub {
805             my( $self, $no ) = @_;
806              
807             if( defined $no ) {
808             $self->{$attribute} = $no;
809             }
810             return $self->{$attribute};
811             };
812              
813             no strict 'refs'; ## no critic
814             *{ __PACKAGE__ . '::' . $method } = $code;
815             }
816              
817             #line 1232
818              
819             sub diag {
820             my $self = shift;
821 0     0 1 0  
822 0   0     0 $self->_print_comment( $self->_diag_fh, @_ );
823 0         0 }
824              
825 0         0 #line 1247
826              
827 0         0 sub note {
828 0         0 my $self = shift;
829              
830 0         0 $self->_print_comment( $self->output, @_ );
831             }
832              
833             sub _diag_fh {
834             my $self = shift;
835              
836             local $Level = $Level + 1;
837             return $self->in_todo ? $self->todo_output : $self->failure_output;
838             }
839              
840 0         0 sub _print_comment {
841 0 0       0 my( $self, $fh, @msgs ) = @_;
842 0         0  
843 0 0       0 return if $self->no_diag;
844 0         0 return unless @msgs;
845              
846 0         0 # Prevent printing headers when compiling (i.e. -c)
847             return if $^C;
848 0         0  
849             # Smash args together like print does.
850             # Convert undef to 'undef' so its readable.
851             my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
852              
853             # Escape the beginning, _print will take care of the rest.
854             $msg =~ s/^/# /;
855              
856             local $Level = $Level + 1;
857             $self->_print_to_fh( $fh, $msg );
858              
859             return 0;
860             }
861              
862             #line 1297
863              
864 0     0 1 0 sub explain {
865 0   0     0 my $self = shift;
866              
867 0         0 return map {
868             ref $_
869 0         0 ? do {
870 0         0 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
871              
872 0         0 my $dumper = Data::Dumper->new( [$_] );
873             $dumper->Indent(1)->Terse(1);
874             $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
875             $dumper->Dump;
876             }
877             : $_
878             } @_;
879             }
880              
881             #line 1326
882 0         0  
883 0 0       0 sub _print {
884 0         0 my $self = shift;
885             return $self->_print_to_fh( $self->output, @_ );
886 0         0 }
887              
888 0         0 sub _print_to_fh {
889             my( $self, $fh, @msgs ) = @_;
890              
891             # Prevent printing headers when only compiling. Mostly for when
892             # tests are deparsed with B::Deparse
893             return if $^C;
894              
895             my $msg = join '', @msgs;
896              
897             local( $\, $", $, ) = ( undef, ' ', '' );
898              
899             # Escape each line after the first with a # so we don't
900             # confuse Test::Harness.
901             $msg =~ s{\n(?!\z)}{\n# }sg;
902              
903             # Stick a newline on the end if it needs it.
904             $msg .= "\n" unless $msg =~ /\n\z/;
905              
906             return print $fh $msg;
907             }
908              
909             #line 1381
910              
911             sub output {
912             my( $self, $fh ) = @_;
913              
914             if( defined $fh ) {
915             $self->{Out_FH} = $self->_new_fh($fh);
916             }
917             return $self->{Out_FH};
918             }
919              
920             sub failure_output {
921             my( $self, $fh ) = @_;
922              
923             if( defined $fh ) {
924             $self->{Fail_FH} = $self->_new_fh($fh);
925             }
926             return $self->{Fail_FH};
927             }
928              
929             sub todo_output {
930             my( $self, $fh ) = @_;
931              
932             if( defined $fh ) {
933             $self->{Todo_FH} = $self->_new_fh($fh);
934             }
935             return $self->{Todo_FH};
936             }
937              
938             sub _new_fh {
939             my $self = shift;
940             my($file_or_fh) = shift;
941              
942             my $fh;
943 0     0 1 0 if( $self->is_fh($file_or_fh) ) {
944 0         0 $fh = $file_or_fh;
945             }
946 0 0       0 else {
947             open $fh, ">", $file_or_fh
948 0         0 or $self->croak("Can't open test output log $file_or_fh: $!");
949             _autoflush($fh);
950             }
951 0 0 0     0  
    0          
952 0         0 return $fh;
953             }
954              
955             sub _autoflush {
956             my($fh) = shift;
957             my $old_fh = select $fh;
958             $| = 1;
959 0 0       0 select $old_fh;
960              
961             return;
962 0         0 }
963              
964             my( $Testout, $Testerr );
965              
966 0     0   0 sub _dup_stdhandles {
967             my $self = shift;
968              
969             $self->_open_testhandles;
970 0 0       0  
971 0         0 # Set everything to unbuffered else plain prints to STDOUT will
972             # come out in the wrong order from our own prints.
973             _autoflush($Testout);
974             _autoflush( \*STDOUT );
975 0     0   0 _autoflush($Testerr);
976             _autoflush( \*STDERR );
977 0         0  
978 0         0 $self->reset_outputs;
979 0 0       0  
980 0         0 return;
981 0         0 }
982 0         0  
983 0         0 my $Opened_Testhandles = 0;
984              
985             sub _open_testhandles {
986             my $self = shift;
987              
988             return if $Opened_Testhandles;
989 0         0  
  0         0  
990 0         0 # We dup STDOUT and STDERR so people can change them in their
991             # test suites while still getting normal test output.
992 0         0 open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
993             open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
994              
995             # $self->_copy_io_layers( \*STDOUT, $Testout );
996             # $self->_copy_io_layers( \*STDERR, $Testerr );
997 0         0  
998             $Opened_Testhandles = 1;
999              
1000 0 0       0 return;
1001             }
1002 0         0  
1003 0         0 sub _copy_io_layers {
1004             my( $self, $src, $dst ) = @_;
1005              
1006 0 0       0 $self->_try(
1007 0 0       0 sub {
1008 0 0       0 require PerlIO;
1009             my @src_layers = PerlIO::get_layers($src);
1010 0         0  
1011 0         0 binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
1012             }
1013             );
1014              
1015             return;
1016             }
1017              
1018 0         0 #line 1496
1019              
1020             sub reset_outputs {
1021             my $self = shift;
1022              
1023             $self->output ($Testout);
1024             $self->failure_output($Testerr);
1025             $self->todo_output ($Testout);
1026              
1027             return;
1028             }
1029              
1030             #line 1522
1031              
1032             sub _message_at_caller {
1033             my $self = shift;
1034              
1035             local $Level = $Level + 1;
1036             my( $pack, $file, $line ) = $self->caller;
1037             return join( "", @_ ) . " at $file line $line.\n";
1038             }
1039              
1040             sub carp {
1041             my $self = shift;
1042             return warn $self->_message_at_caller(@_);
1043 180     180   218 }
1044              
1045 180         124 sub croak {
1046             my $self = shift;
1047             return die $self->_message_at_caller(@_);
1048 180         110 }
  180         273  
1049 180         109  
1050 180         265 sub _plan_check {
1051 180         155 my $self = shift;
  180         193  
1052 180         358  
1053             unless( $self->{Have_Plan} ) {
1054             local $Level = $Level + 2;
1055 180 0 33     242 $self->croak("You tried to run a test without a plan");
1056             }
1057 180 100       556  
1058             return;
1059             }
1060              
1061             #line 1572
1062              
1063             sub current_test {
1064             my( $self, $num ) = @_;
1065              
1066             lock( $self->{Curr_Test} );
1067             if( defined $num ) {
1068             $self->croak("Can't change the current test number without a plan!")
1069             unless $self->{Have_Plan};
1070              
1071             $self->{Curr_Test} = $num;
1072 138     138 1 123  
1073 138         103 # If the test counter is being pushed forward fill in the details.
1074 138 50       241 my $test_results = $self->{Test_Results};
1075             if( $num > @$test_results ) {
1076 138 50       446 my $start = @$test_results ? @$test_results : 0;
1077 0 0       0 for( $start .. $num - 1 ) {
1078             $test_results->[$_] = &share(
1079             {
1080             'ok' => 1,
1081 0   0     0 actual_ok => undef,
1082             reason => 'incrementing test number',
1083             type => 'unknown',
1084             name => undef
1085             }
1086             );
1087             }
1088             }
1089             # If backward, wipe history. Its their funeral.
1090             elsif( $num < @$test_results ) {
1091             $#{$test_results} = $num - 1;
1092             }
1093             }
1094             return $self->{Curr_Test};
1095             }
1096              
1097             #line 1617
1098              
1099             sub summary {
1100             my($self) = shift;
1101              
1102             return map { $_->{'ok'} } @{ $self->{Test_Results} };
1103             }
1104              
1105             #line 1672
1106              
1107             sub details {
1108             my $self = shift;
1109             return @{ $self->{Test_Results} };
1110             }
1111              
1112             #line 1701
1113              
1114             sub todo {
1115             my( $self, $pack ) = @_;
1116 143     143 1 130  
1117             return $self->{Todo} if defined $self->{Todo};
1118 143 50       225  
1119 0         0 local $Level = $Level + 1;
1120             my $todo = $self->find_TODO($pack);
1121 143         183 return $todo if defined $todo;
1122              
1123             return '';
1124             }
1125              
1126             #line 1723
1127              
1128             sub find_TODO {
1129             my( $self, $pack ) = @_;
1130              
1131             $pack = $pack || $self->caller(1) || $self->exported_to;
1132             return unless $pack;
1133              
1134             no strict 'refs'; ## no critic
1135             return ${ $pack . '::TODO' };
1136             }
1137              
1138             #line 1741
1139              
1140             sub in_todo {
1141             my $self = shift;
1142              
1143             local $Level = $Level + 1;
1144             return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
1145             }
1146              
1147             #line 1791
1148 23     23 1 24  
1149             sub todo_start {
1150 23 50       53 my $self = shift;
1151 0         0 my $message = @_ ? shift : '';
1152              
1153 23         85 $self->{Start_Todo}++;
1154             if( $self->in_todo ) {
1155             push @{ $self->{Todo_Stack} } => $self->todo;
1156             }
1157             $self->{Todo} = $message;
1158              
1159             return;
1160             }
1161              
1162             #line 1813
1163              
1164             sub todo_end {
1165             my $self = shift;
1166              
1167             if( !$self->{Start_Todo} ) {
1168             $self->croak('todo_end() called without todo_start()');
1169             }
1170              
1171             $self->{Start_Todo}--;
1172              
1173             if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1174             $self->{Todo} = pop @{ $self->{Todo_Stack} };
1175             }
1176             else {
1177             delete $self->{Todo};
1178             }
1179              
1180             return;
1181             }
1182              
1183             #line 1846
1184 117     117   171  
1185             sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1186 117 50       917 my( $self, $height ) = @_;
1187 0         0 $height ||= 0;
1188              
1189 117         1447 my $level = $self->level + $height + 1;
1190             my @caller;
1191             do {
1192 46     46   918 @caller = CORE::caller( $level );
  46         71  
  46         58648  
1193             $level--;
1194             } until @caller;
1195             return wantarray ? @caller : $caller[0];
1196             }
1197              
1198             #line 1863
1199              
1200             #line 1877
1201              
1202             #'#
1203             sub _sanity_check {
1204             my $self = shift;
1205              
1206             $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1207             $self->_whoa( !$self->{Have_Plan} and $self->{Curr_Test},
1208             'Somehow your tests ran without a plan!' );
1209             $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1210             'Somehow you got a different number of results than tests ran!' );
1211              
1212             return;
1213             }
1214              
1215             #line 1900
1216              
1217             sub _whoa {
1218             my( $self, $check, $desc ) = @_;
1219             if($check) {
1220             local $Level = $Level + 1;
1221             $self->croak(<<"WHOA");
1222             WHOA! $desc
1223             This should never happen! Please contact the author immediately!
1224             WHOA
1225             }
1226              
1227             return;
1228             }
1229              
1230             #line 1924
1231              
1232             sub _my_exit {
1233             $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
1234 41     41 1 55  
1235             return 1;
1236 41         103 }
1237              
1238             #line 1936
1239              
1240             sub _ending {
1241             my $self = shift;
1242              
1243             my $real_exit_code = $?;
1244             $self->_sanity_check();
1245              
1246             # Don't bother with an ending if this is a forked copy. Only the parent
1247             # should do the ending.
1248             if( $self->{Original_Pid} != $$ ) {
1249 0     0 1 0 return;
1250             }
1251 0         0  
1252             # Exit if plan() was never called. This is so "require Test::Simple"
1253             # doesn't puke.
1254             if( !$self->{Have_Plan} ) {
1255 46     46   61 return;
1256             }
1257 46         79  
1258 46 50       99 # Don't do an ending if we bailed out.
1259             if( $self->{Bailed_Out} ) {
1260             return;
1261             }
1262 41     41   71  
1263             # Figure out if we passed or failed and print helpful messages.
1264 41 50       89 my $test_results = $self->{Test_Results};
1265 41 100       105 if(@$test_results) {
1266             # The plan? We have no plan.
1267             if( $self->{No_Plan} ) {
1268 40 50       113 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1269             $self->{Expected_Tests} = $self->{Curr_Test};
1270             }
1271              
1272 40 50       71 # Auto-extended arrays and elements which aren't explicitly
  75         239  
1273             # filled in with a shared reference will puke under 5.8.0
1274             # ithreads. So we have to fill them in by hand. :(
1275 40         180 my $empty_result = &share( {} );
1276             for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1277 40         69 $test_results->[$idx] = $empty_result
1278 40         84 unless defined $test_results->[$idx];
1279             }
1280 40         90  
1281             my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
1282              
1283             my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1284              
1285             if( $num_extra != 0 ) {
1286             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1287             $self->diag(<<"FAIL");
1288             Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
1289             FAIL
1290             }
1291              
1292             if($num_failed) {
1293             my $num_tests = $self->{Curr_Test};
1294             my $s = $num_failed == 1 ? '' : 's';
1295              
1296             my $qualifier = $num_extra == 0 ? '' : ' run';
1297              
1298             $self->diag(<<"FAIL");
1299 0     0 1 0 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1300             FAIL
1301             }
1302 0         0  
1303 0 0       0 if($real_exit_code) {
1304 0     0   0 $self->diag(<<"FAIL");
  0         0  
1305             Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
1306 0         0 FAIL
1307 0         0  
1308 0 0       0 _my_exit($real_exit_code) && return;
1309 0         0 }
1310              
1311             my $exit_code;
1312             if($num_failed) {
1313             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1314             }
1315             elsif( $num_extra != 0 ) {
1316             $exit_code = 255;
1317             }
1318             else {
1319             $exit_code = 0;
1320             }
1321              
1322             _my_exit($exit_code) && return;
1323             }
1324             elsif( $self->{Skip_All} ) {
1325             _my_exit(0) && return;
1326             }
1327             elsif($real_exit_code) {
1328 53     53   682 $self->diag(<<"FAIL");
1329 53         115 Looks like your test exited with $real_exit_code before it could output anything.
1330             FAIL
1331             _my_exit($real_exit_code) && return;
1332             }
1333 98     98   146 else {
1334             $self->diag("No tests run!\n");
1335             _my_exit(255) && return;
1336             }
1337 98 50       916  
1338             $self->_whoa( 1, "We fell off the end of _ending()" );
1339 98         971 }
1340              
1341 98         369 END {
1342             $Test->_ending if defined $Test and !$Test->no_ending;
1343             }
1344              
1345 98         859 #line 2098
1346              
1347             1;
1348 98 50       1102