File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 285 561 50.8
branch 77 278 27.7
condition 13 69 18.8
subroutine 54 85 63.5
pod 42 42 100.0
total 471 1035 45.5


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