File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 211 473 44.6
branch 60 256 23.4
condition 18 75 24.0
subroutine 40 64 62.5
pod 32 32 100.0
total 361 900 40.1


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