File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 233 482 48.3
branch 71 252 28.1
condition 14 75 18.6
subroutine 42 68 61.7
pod 34 34 100.0
total 394 911 43.2


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