File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 239 561 42.6
branch 60 278 21.5
condition 10 69 14.4
subroutine 47 85 55.2
pod 42 42 100.0
total 398 1035 38.4


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 1     1   33  
  1         4  
  1         75  
5 1     1   7 use 5.006;
  1         2  
  1         39  
6 1     1   9 use strict;
  1         2  
  1         95  
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 1     1   5 BEGIN {
  1         2  
  1         382  
14             use Config;
15             # Load threads::shared when threads are turned on.
16 1 50 33 1   32 # 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 1     4   7 else {
  4         20  
61 1     1   1842 *share = sub { return $_[0] };
  1         2  
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 3     3 1 7  
116 3   66     22 $self->{Todo} = undef;
117 3         9 $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 1     1 1 2 if $self->{Have_Plan};
136              
137 1         4 if( $cmd eq 'no_plan' ) {
138 1         5 $self->carp("no_plan takes no arguments") if $arg;
139             $self->no_plan;
140 1         4 }
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 1     1 1 2 else {
157             my @args = grep { defined } ( $cmd, $arg );
158             $self->croak("plan() doesn't understand @args");
159             }
160 1         2  
161             return 1;
162 1         11 }
163 1         3  
164 1         17 #line 257
165              
166 1         6 sub expected_tests {
167 1         3 my $self = shift;
168 1         4 my($max) = @_;
169              
170 1         3 if(@_) {
171 1         3 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
172             unless $max =~ /^\+?\d+$/;
173 1         2  
174             $self->{Expected_Tests} = $max;
175 1         2 $self->{Have_Plan} = 1;
176              
177 1         3 $self->_print("1..$max\n") unless $self->no_header;
178 1         2 }
179             return $self->{Expected_Tests};
180 1         2 }
181 1         2  
182 1         3 #line 281
183              
184 1         2 sub no_plan {
185             my $self = shift;
186 1         1  
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 1     1 1 2 $self->{Skip_All} = 1;
213              
214 1 50       4 $self->_print($out) unless $self->no_header;
215             exit(0);
216 1         3 }
217              
218 1 50       5 #line 341
219              
220             sub exported_to {
221 1 50       8 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 1 50       6 #line 371
    0          
230 1         2  
231 1         5 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 1     1 1 2 my $out;
260 1         2 my $result = &share( {} );
261              
262 1 50       4 unless($test) {
263 1 50       9 $out .= "not ";
264             @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
265             }
266 1         2 else {
267 1         3 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
268             }
269 1 50       4  
270             $out .= "ok";
271 1         6 $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 } ) || return;
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 1     1 1 2 sub _unoverload_num {
344             my $self = shift;
345 1 50       16  
346 1         3 $self->_unoverload( '0+', @_ );
347              
348 1         5 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 1     1 1 3 if( !defined $got || !defined $expect ) {
374             # undef only matches undef and nothing else
375             my $test = !defined $got && !defined $expect;
376              
377 1 50       4 $self->ok( $test, $name );
378             $self->_is_diag( $got, 'eq', $expect ) unless $test;
379 1         6 return $test;
380             }
381 1         5  
382 1         2 return $self->cmp_ok( $got, 'eq', $expect, $name );
383             }
384              
385 1         10 sub is_num {
386             my( $self, $got, $expect, $name ) = @_;
387 1 50 33     13 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 1         6  
395 1         4 $self->ok( $test, $name );
396 1 50       3 $self->_is_diag( $got, '==', $expect ) unless $test;
397             return $test;
398 1         3 }
399              
400 1         2 return $self->cmp_ok( $got, '==', $expect, $name );
401 1         3 }
402              
403 1 50       3 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 1         4 # quote and force string context
409             $$val = "'$$val'";
410             }
411 1         2 else {
412 1 50       3 # force numeric context
413             $self->_unoverload_num($val);
414 1 50       5 }
415 1         2 }
416 1         3 else {
417 1         2 $$val = 'undef';
418             }
419              
420 0         0 return;
421             }
422              
423 1 50       2 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 1         3 return $self->diag(<<"DIAGNOSTIC");
430 1         2 got: $got
431             expected: $expect
432             DIAGNOSTIC
433 1         4  
434 1         1 }
435              
436 1         4 sub _isnt_diag {
437             my( $self, $got, $type ) = @_;
438 1 50       4  
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 1 50       4 local $Level = $Level + 1;
453              
454             if( !defined $got || !defined $dont_expect ) {
455             # undef only matches undef and nothing else
456 2     2   3 my $test = defined $got || defined $dont_expect;
457 2         3  
458             $self->ok( $test, $name );
459 2 50   2   12 $self->_isnt_diag( $got, 'ne' ) unless $test;
  2         13  
460             return $test;
461 2         7 }
462 2 50       6  
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 2         4  
470             if( !defined $got || !defined $dont_expect ) {
471             # undef only matches undef and nothing else
472             my $test = defined $got || defined $dont_expect;
473 2     2   5  
474             $self->ok( $test, $name );
475 2 50   2   8 $self->_isnt_diag( $got, '!=' ) unless $test;
  2 50       12  
476             return $test;
477             }
478              
479 2     2   4 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
480             }
481 2         7  
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 1     1   6  
  1         2  
  1         3068  
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 0     0 1 0 # directive.
524 0         0 # Don't ask me, man, I just work here.
525             $test = eval "
526 0         0 $code" . "\$got $type \$expect;";
527              
528 0 0 0     0 }
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 0         0 $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 0     0 1 0 my $test;
698             my $code = $self->_caller_context;
699              
700             local( $@, $!, $SIG{__DIE__} ); # isolate eval
701 0 0       0  
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 0         0 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
707              
708 0         0 $test = !$test if $cmp eq '!~';
709              
710             local $Level = $Level + 1;
711             $ok = $self->ok( $test, $name );
712 0         0 }
  0         0  
713              
714 0         0 unless($ok) {
715             $this = defined $this ? "'$this'" : 'undef';
716             my $match = $cmp eq '=~' ? "doesn't match" : "matches";
717              
718             local $Level = $Level + 1;
719 0         0 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
720             %s
721             %13s '%s'
722             DIAGNOSTIC
723 0         0  
724 0         0 }
725              
726 0 0       0 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 0         0 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 0     0   0 return eval { $maybe_fh->isa("IO::Handle") } ||
756             # 5.5.4's tied() and can() doesn't like getting undef
757 0         0 eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
758             }
759 0         0  
760 0 0 0     0 #line 1097
761              
762 0         0 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 4     4   5 sub _plan_check {
1034             my $self = shift;
1035 4         8  
1036 4         4 unless( $self->{Have_Plan} ) {
1037 4         10 local $Level = $Level + 2;
1038 4         6 $self->croak("You tried to run a test without a plan");
  4         7  
1039             }
1040 4 50       27  
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 3     3 1 4  
1056 3         4 # If the test counter is being pushed forward fill in the details.
1057 3 50       7 my $test_results = $self->{Test_Results};
1058             if( $num > @$test_results ) {
1059 3 50       15 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 3     3 1 4  
1100             return $self->{Todo} if defined $self->{Todo};
1101 3 50       5  
1102 0         0 local $Level = $Level + 1;
1103             my $todo = $self->find_TODO($pack);
1104 3         20 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 1     1 1 1  
1132             sub todo_start {
1133 1 50       4 my $self = shift;
1134 0         0 my $message = @_ ? shift : '';
1135              
1136 1         5 $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 2     2   5  
1168             sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1169 2 50       8 my( $self, $height ) = @_;
1170 0         0 $height ||= 0;
1171              
1172 2         37 my @caller = CORE::caller( $self->level + $height + 1 );
1173             return wantarray ? @caller : $caller[0];
1174             }
1175 1     1   8  
  1         2  
  1         3868  
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 0     0 1 0  
1218             sub _ending {
1219 0         0 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 0     0   0 return;
1239             }
1240 0         0  
1241 0 0       0 # 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 0     0   0 if( $self->{No_Plan} ) {
1246             $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1247 0 0       0 $self->{Expected_Tests} = $self->{Curr_Test};
1248 0 0       0 }
1249              
1250             # Auto-extended arrays and elements which aren't explicitly
1251 0 0       0 # 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 0 0       0 $test_results->[$idx] = $empty_result
  0         0  
1256             unless defined $test_results->[$idx];
1257             }
1258 0         0  
1259             my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
1260 0         0  
1261 0         0 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1262              
1263 0         0 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 2     2   4 else {
1312 2         8 $self->diag("No tests run!\n");
1313             _my_exit(255) && return;
1314             }
1315              
1316 2     2   5 $self->_whoa( 1, "We fell off the end of _ending()" );
1317             }
1318              
1319             END {
1320 2 50       9 $Test->_ending if defined $Test and !$Test->no_ending;
1321             }
1322 2         6  
1323             #line 2074
1324 2         11  
1325             1;
1326