File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 296 573 51.6
branch 72 282 25.5
condition 14 72 19.4
subroutine 54 86 62.7
pod 42 42 100.0
total 478 1055 45.3


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3             # $Id$
4 4     4   74  
  4         14  
  4         164  
5 4     4   20 use 5.006;
  4         8  
  4         134  
6 4     4   24 use strict;
  4         49  
  4         296  
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 4     4   22 BEGIN {
  4         6  
  4         1566  
14             use Config;
15             # Load threads::shared when threads are turned on.
16 4 50 33 4   126 # 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 4     23   42 else {
  23         50  
61 4     11   7305 *share = sub { return $_[0] };
  11         18  
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 21     21 1 56  
116 21   66     117 $self->{Todo} = undef;
117 21         60 $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 4     4 1 11 if $self->{Have_Plan};
136              
137 4         16 if( $cmd eq 'no_plan' ) {
138 4         18 $self->carp("no_plan takes no arguments") if $arg;
139             $self->no_plan;
140 4         18 }
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 4     4 1 9 else {
157             my @args = grep { defined } ( $cmd, $arg );
158             $self->croak("plan() doesn't understand @args");
159             }
160 4         12  
161             return 1;
162 4         34 }
163 4         16  
164 4         50 #line 257
165              
166 4         21 sub expected_tests {
167 4         12 my $self = shift;
168 4         13 my($max) = @_;
169              
170 4         12 if(@_) {
171 4         8 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
172             unless $max =~ /^\+?\d+$/;
173 4         13  
174             $self->{Expected_Tests} = $max;
175 4         8 $self->{Have_Plan} = 1;
176              
177 4         9 $self->_print("1..$max\n") unless $self->no_header;
178 4         10 }
179             return $self->{Expected_Tests};
180 4         8 }
181 4         9  
182 4         9 #line 281
183              
184 4         17 sub no_plan {
185             my $self = shift;
186 4         7  
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 2     2 1 6 $self->{Skip_All} = 1;
213              
214 2 50       25 $self->_print($out) unless $self->no_header;
215             exit(0);
216 2         7 }
217              
218 2 50       12 #line 341
219              
220             sub exported_to {
221 2 50       26 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 2 50       8 #line 371
    0          
230 2         12  
231 2         11 sub ok {
232             my( $self, $test, $name ) = @_;
233              
234 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            
238             $self->_plan_check;
239              
240             lock $self->{Curr_Test};
241 0           $self->{Curr_Test}++;
  0            
242 0            
243             # In case $name is a string overloaded object, force it to stringify.
244             $self->_unoverload_str( \$name );
245 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 4     4 1 8 my $out;
260 4         9 my $result = &share( {} );
261              
262 4 50       18 unless($test) {
263 4 50       31 $out .= "not ";
264             @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
265             }
266 4         13 else {
267 4         10 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
268             }
269 4 50       17  
270             $out .= "ok";
271 4         27 $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 4     4 1 12 sub _unoverload_num {
344             my $self = shift;
345 4 50       17  
346 4         13 $self->_unoverload( '0+', @_ );
347              
348 4         15 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 11     11 1 27  
374             $self->_unoverload_str( \$got, \$expect );
375              
376             if( !defined $got || !defined $expect ) {
377 11 50       35 # undef only matches undef and nothing else
378             my $test = !defined $got && !defined $expect;
379 11         42  
380             $self->ok( $test, $name );
381 11         42 $self->_is_diag( $got, 'eq', $expect ) unless $test;
382 11         20 return $test;
383             }
384              
385 11         51 return $self->cmp_ok( $got, 'eq', $expect, $name );
386             }
387 11 50 33     110  
388             sub is_num {
389             my( $self, $got, $expect, $name ) = @_;
390             local $Level = $Level + 1;
391              
392             $self->_unoverload_num( \$got, \$expect );
393              
394 11         63 if( !defined $got || !defined $expect ) {
395 11         38 # undef only matches undef and nothing else
396 11 50       31 my $test = !defined $got && !defined $expect;
397              
398 11         31 $self->ok( $test, $name );
399             $self->_is_diag( $got, '==', $expect ) unless $test;
400 11         18 return $test;
401 11         37 }
402              
403 11 50       30 return $self->cmp_ok( $got, '==', $expect, $name );
404 0         0 }
405 0 0       0  
406             sub _diag_fmt {
407             my( $self, $type, $val ) = @_;
408 11         48  
409             if( defined $$val ) {
410             if( $type eq 'eq' or $type eq 'ne' ) {
411 11         21 # quote and force string context
412 11 50       34 $$val = "'$$val'";
413             }
414 11 50       31 else {
415 11         25 # force numeric context
416 11         33 $self->_unoverload_num($val);
417 11         27 }
418             }
419             else {
420 0         0 $$val = 'undef';
421             }
422              
423 11 50       28 return;
424 0         0 }
425 0         0  
426 0         0 sub _is_diag {
427             my( $self, $got, $type, $expect ) = @_;
428              
429 11         24 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
430 11         27  
431             local $Level = $Level + 1;
432             return $self->diag(<<"DIAGNOSTIC");
433 11         41 got: $got
434 11         19 expected: $expect
435             DIAGNOSTIC
436 11         38  
437             }
438 11 50       46  
439 0 0       0 sub _isnt_diag {
440 0 0       0 my( $self, $got, $type ) = @_;
441              
442 0         0 $self->_diag_fmt( $type, \$got );
443 0 0       0  
444 0         0 local $Level = $Level + 1;
445 0         0 return $self->diag(<<"DIAGNOSTIC");
446             got: $got
447             expected: anything else
448 0         0 DIAGNOSTIC
449             }
450              
451             #line 621
452 11 50       74  
453             sub isnt_eq {
454             my( $self, $got, $dont_expect, $name ) = @_;
455             local $Level = $Level + 1;
456 30     30   39  
457 30         47 if( !defined $got || !defined $dont_expect ) {
458             # undef only matches undef and nothing else
459 30     30   152 my $test = defined $got || defined $dont_expect;
  30         2053  
460              
461 30         116 $self->ok( $test, $name );
462 38 50       101 $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 30         69 sub isnt_num {
470             my( $self, $got, $dont_expect, $name ) = @_;
471             local $Level = $Level + 1;
472              
473 38     38   56 if( !defined $got || !defined $dont_expect ) {
474             # undef only matches undef and nothing else
475 38 50   38   176 my $test = defined $got || defined $dont_expect;
  38 50       127  
476              
477             $self->ok( $test, $name );
478             $self->_isnt_diag( $got, '!=' ) unless $test;
479 30     30   52 return $test;
480             }
481 30         79  
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 4     4   30  
  4         13  
  4         12783  
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 8     8 1 19 # Treat overloaded objects as numbers if we're asked to do a
527 8         14 # numeric comparison.
528             my $unoverload
529 8         32 = $numeric_cmps{$type}
530             ? '_unoverload_num'
531 8 50 33     43 : '_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 8         34 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 1     1 1 3 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
675             )
676 1         3 {
677 1         4 $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 8     8 1 22 $self->diag(" '$regex' doesn't look much like a regex to me.");
701             return $ok;
702 8         13 }
703              
704             {
705             ## no critic (BuiltinFunctions::ProhibitStringyEval)
706              
707 8         11 my $test;
  8         34  
708             my $code = $self->_caller_context;
709 8         27  
710             local( $@, $!, $SIG{__DIE__} ); # isolate eval
711 8         435  
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 8         108 $test = eval "
716             $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
717 8         176  
718 8         27 $test = !$test if $cmp eq '!~';
719              
720             local $Level = $Level + 1;
721             $ok = $self->ok( $test, $name );
722 8 50       28 }
723              
724             unless($ok) {
725             $this = defined $this ? "'$this'" : 'undef';
726             my $match = $cmp eq '=~' ? "doesn't match" : "matches";
727 8 50       21  
728             local $Level = $Level + 1;
729             $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
730             %s
731             %13s '%s'
732             DIAGNOSTIC
733              
734 8 50       20 }
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 8         1011 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 1     1   1 my $self = shift;
766             my $maybe_fh = shift;
767 1         14 return 0 unless defined $maybe_fh;
768              
769 1         2 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
770 1 50 33     10 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
771              
772 1         3 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 1     1 1 2 if( $self->is_fh($file_or_fh) ) {
944 1         2 $fh = $file_or_fh;
945             }
946 1 50       4 else {
947             open $fh, ">", $file_or_fh
948 1         2 or $self->croak("Can't open test output log $file_or_fh: $!");
949             _autoflush($fh);
950             }
951 1 50 0     4  
    0          
952 1         2 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 1         3 }
963              
964             my( $Testout, $Testerr );
965              
966 1     1   2 sub _dup_stdhandles {
967             my $self = shift;
968              
969             $self->_open_testhandles;
970 1 50       14  
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 1     1   3 _autoflush($Testerr);
976             _autoflush( \*STDERR );
977 1         2  
978 1         13 $self->reset_outputs;
979 1 50       4  
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 1         2  
  1         1  
990 1         6 # We dup STDOUT and STDERR so people can change them in their
991             # test suites while still getting normal test output.
992 1         7 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 1         74  
998             $Opened_Testhandles = 1;
999              
1000 1 50       20 return;
1001             }
1002 1         2  
1003 1         4 sub _copy_io_layers {
1004             my( $self, $src, $dst ) = @_;
1005              
1006 1 50       4 $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 1         127 #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 68     68   151 }
1044              
1045 68         71 sub croak {
1046             my $self = shift;
1047             return die $self->_message_at_caller(@_);
1048 68         77 }
  68         168  
1049 68         74  
1050 68         197 sub _plan_check {
1051 68         104 my $self = shift;
  68         114  
1052 68         1362  
1053             unless( $self->{Have_Plan} ) {
1054             local $Level = $Level + 2;
1055 68 50 33     188 $self->croak("You tried to run a test without a plan");
1056             }
1057 68 50       365  
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 12     12 1 18  
1073 12         13 # If the test counter is being pushed forward fill in the details.
1074 12 50       107 my $test_results = $self->{Test_Results};
1075             if( $num > @$test_results ) {
1076 12 50       57 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 42     42 1 51  
1117             return $self->{Todo} if defined $self->{Todo};
1118 42 50       119  
1119 0         0 local $Level = $Level + 1;
1120             my $todo = $self->find_TODO($pack);
1121 42         263 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 11     11 1 20  
1149             sub todo_start {
1150 11 50       30 my $self = shift;
1151 0         0 my $message = @_ ? shift : '';
1152              
1153 11         89 $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 8     8   23  
1185             sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1186 8 50       43 my( $self, $height ) = @_;
1187 0         0 $height ||= 0;
1188              
1189 8         90 my $level = $self->level + $height + 1;
1190             my @caller;
1191             do {
1192 4     4   40 @caller = CORE::caller( $level );
  4         69  
  4         8378  
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 0     0 1 0  
1235             return 1;
1236 0         0 }
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 0     0   0 return;
1256             }
1257 0         0  
1258 0 0       0 # Don't do an ending if we bailed out.
1259             if( $self->{Bailed_Out} ) {
1260             return;
1261             }
1262 0     0   0  
1263             # Figure out if we passed or failed and print helpful messages.
1264 0 0       0 my $test_results = $self->{Test_Results};
1265 0 0       0 if(@$test_results) {
1266             # The plan? We have no plan.
1267             if( $self->{No_Plan} ) {
1268 0 0       0 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1269             $self->{Expected_Tests} = $self->{Curr_Test};
1270             }
1271              
1272 0 0       0 # Auto-extended arrays and elements which aren't explicitly
  0         0  
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 0         0 my $empty_result = &share( {} );
1276             for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1277 0         0 $test_results->[$idx] = $empty_result
1278 0         0 unless defined $test_results->[$idx];
1279             }
1280 0         0  
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 15     15   28 $self->diag(<<"FAIL");
1329 15         54 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 15     15   36 else {
1334             $self->diag("No tests run!\n");
1335             _my_exit(255) && return;
1336             }
1337 15 50       66  
1338             $self->_whoa( 1, "We fell off the end of _ending()" );
1339 15         48 }
1340              
1341 15         84 END {
1342             $Test->_ending if defined $Test and !$Test->no_ending;
1343             }
1344              
1345 15         195 #line 2098
1346              
1347             1;
1348 15 50       74