File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 212 488 43.4
branch 58 256 22.6
condition 13 75 17.3
subroutine 43 71 60.5
pod 35 35 100.0
total 361 925 39.0


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 1     1   25
  1         3  
  1         52  
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         37  
10 1     1   5 use strict;
  1         2  
  1         67  
11             use vars qw($VERSION);
12             $VERSION = '0.70';
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   5 BEGIN {
  1         2  
  1         2955  
17             use Config;
18             # Load threads::shared when threads are turned on.
19 1 50 33 1   54 # 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   7 else {
  4         9  
64 1     1   509 *share = sub { return $_[0] };
  1         2  
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     19 $self->{Exported_To} = $pack;
133 4         28 }
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         3 }
156             elsif( $cmd eq 'tests' ) {
157 1         5 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   10 $self->croak("plan() doesn't understand @args");
  1         3  
  1         4535  
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         14 if( @_ ) {
183             $self->croak("Number of tests must be a positive integer. You gave it '$max'")
184 1         4 unless $max =~ /^\+?\d+$/ and $max > 0;
185 1         5
186 1         3 $self->{Expected_Tests} = $max;
187             $self->{Have_Plan} = 1;
188 1         2
189 1         3 $self->_print("1..$max\n") unless $self->no_header;
190             }
191 1         162 return $self->{Expected_Tests};
192             }
193 1         3
194            
195 1         2 #line 315
196 1         2
197             sub no_plan {
198 1 50       6 my $self = shift;
199            
200 1         2 $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 2     2 1 4
224             $self->{Skip_All} = 1;
225 2 50       6
226 2         5 $self->_print($out) unless $self->no_header;
227             exit(0);
228 2         5 }
229            
230             #line 382
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 3 $self->_unoverload_str(\$name);
246            
247 2 100       8 $self->diag(<
248             You named your test '$name'. You shouldn't use numbers for your test names.
249 1         2 Very confusing.
250             ERR
251 1 50       5
252 0         0 my($pack, $file, $line) = $self->caller;
253            
254             my $todo = $self->todo($pack);
255 1 50       7 $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       4 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
    0          
    0          
263 1         1 }
264 1         4 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 2
293 1         6 $self->_print($out);
294            
295 1 50       4 unless( $test ) {
296 1 50 33     9 my $msg = $todo ? "Failed (TODO)" : "Failed";
297             $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
298            
299 1         2 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         6 $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             $self->_try(sub { require overload } ) || return;
317 0     0 1 0
318             foreach my $thing (@_) {
319 0         0 if( $self->_is_object($$thing) ) {
320 0         0 if( my $string_meth = overload::Method($$thing, $type) ) {
321             $$thing = $$thing->$string_meth();
322             }
323             }
324             }
325             }
326            
327            
328             sub _is_object {
329             my($self, $thing) = @_;
330            
331             return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
332 0     0 1 0 }
333            
334 0 0       0
335 0 0       0 sub _unoverload_str {
336 0         0 my $self = shift;
337            
338             $self->_unoverload(q[""], @_);
339             }
340            
341             sub _unoverload_num {
342             my $self = shift;
343            
344             $self->_unoverload('0+', @_);
345            
346             for my $val (@_) {
347             next unless $self->_is_dualvar($$val);
348             $$val = $$val+0;
349             }
350 0     0 1 0 }
351            
352 0         0
353 0 0       0 # This is a hack to detect a dualvar such as $!
354 0         0 sub _is_dualvar {
355             my($self, $val) = @_;
356 0         0
357             local $^W = 0;
358 0 0       0 my $numval = $val+0;
359 0         0 return 1 if $numval != 0 and $numval ne $val;
360             }
361            
362            
363            
364             #line 530
365            
366             sub is_eq {
367             my($self, $got, $expect, $name) = @_;
368             local $Level = $Level + 1;
369            
370             $self->_unoverload_str(\$got, \$expect);
371            
372             if( !defined $got || !defined $expect ) {
373             # undef only matches undef and nothing else
374             my $test = !defined $got && !defined $expect;
375            
376             $self->ok($test, $name);
377             $self->_is_diag($got, 'eq', $expect) unless $test;
378             return $test;
379             }
380            
381             return $self->cmp_ok($got, 'eq', $expect, $name);
382             }
383            
384 1     1 1 39 sub is_num {
385             my($self, $got, $expect, $name) = @_;
386             local $Level = $Level + 1;
387            
388 1 50       5 $self->_unoverload_num(\$got, \$expect);
389            
390 1         6 if( !defined $got || !defined $expect ) {
391             # undef only matches undef and nothing else
392 1         5 my $test = !defined $got && !defined $expect;
393 1         1
394             $self->ok($test, $name);
395             $self->_is_diag($got, '==', $expect) unless $test;
396 1         6 return $test;
397             }
398 1 50 33     17
399             return $self->cmp_ok($got, '==', $expect, $name);
400             }
401            
402             sub _is_diag {
403 1         8 my($self, $got, $type, $expect) = @_;
404            
405 1         6 foreach my $val (\$got, \$expect) {
406 1         5 if( defined $$val ) {
407             if( $type eq 'eq' ) {
408 1         3 # quote and force string context
409 1         5 $$val = "'$$val'"
410             }
411 1 50       4 else {
412 0         0 # force numeric context
413 0 0       0 $self->_unoverload_num($val);
414             }
415             }
416 1         5 else {
417             $$val = 'undef';
418             }
419 1         3 }
420 1 50       5
421             return $self->diag(sprintf <
422 1 50       13 got: %s
423 1         3 expected: %s
424 1         3 DIAGNOSTIC
425 1         3
426             }
427            
428 0         0 #line 608
429            
430             sub isnt_eq {
431 1 50       4 my($self, $got, $dont_expect, $name) = @_;
432 0         0 local $Level = $Level + 1;
433 0         0
434 0         0 if( !defined $got || !defined $dont_expect ) {
435             # undef only matches undef and nothing else
436             my $test = defined $got || defined $dont_expect;
437 1         2
438 1         3 $self->ok($test, $name);
439             $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
440             return $test;
441 1         4 }
442 1         2
443             return $self->cmp_ok($got, 'ne', $dont_expect, $name);
444 1         5 }
445            
446 1 50       5 sub isnt_num {
447 0 0       0 my($self, $got, $dont_expect, $name) = @_;
448 0 0       0 local $Level = $Level + 1;
449            
450 0 0       0 if( !defined $got || !defined $dont_expect ) {
451 0         0 # undef only matches undef and nothing else
452 0         0 my $test = defined $got || defined $dont_expect;
453            
454             $self->ok($test, $name);
455 0         0 $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
456             return $test;
457             }
458            
459 1 50       7 return $self->cmp_ok($got, '!=', $dont_expect, $name);
460             }
461            
462            
463             #line 660
464 2     2   3
465 2         4 sub like {
466             my($self, $this, $regex, $name) = @_;
467 2 50   2   12
  2         2033  
468             local $Level = $Level + 1;
469 2         10 $self->_regex_ok($this, $regex, '=~', $name);
470 2 50       10 }
471 0 0       0
472 0         0 sub unlike {
473             my($self, $this, $regex, $name) = @_;
474            
475             local $Level = $Level + 1;
476             $self->_regex_ok($this, $regex, '!~', $name);
477             }
478            
479            
480 2     2   4 #line 685
481            
482 2 50   2   11
  2 50       13  
483             my %numeric_cmps = map { ($_, 1) }
484             ("<", "<=", ">", ">=", "==", "!=", "<=>");
485            
486             sub cmp_ok {
487 2     2   3 my($self, $got, $type, $expect, $name) = @_;
488            
489 2         8 # Treat overloaded objects as numbers if we're asked to do a
490             # numeric comparison.
491             my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
492             : '_unoverload_str';
493 0     0   0
494             $self->$unoverload(\$got, \$expect);
495 0         0
496            
497 0         0 my $test;
498 0 0       0 {
499 0         0 local($@,$!,$SIG{__DIE__}); # isolate eval
500            
501             my $code = $self->_caller_context;
502            
503             # Yes, it has to look like this or 5.4.5 won't see the #line directive.
504             # Don't ask me, man, I just work here.
505             $test = eval "
506 0     0   0 $code" . "\$got $type \$expect;";
507            
508 0         0 }
509 0         0 local $Level = $Level + 1;
510 0 0 0     0 my $ok = $self->ok($test, $name);
511            
512             unless( $ok ) {
513             if( $type =~ /^(eq|==)$/ ) {
514             $self->_is_diag($got, $type, $expect);
515             }
516             else {
517             $self->_cmp_diag($got, $type, $expect);
518             }
519             }
520             return $ok;
521             }
522            
523             sub _cmp_diag {
524             my($self, $got, $type, $expect) = @_;
525            
526             $got = defined $got ? "'$got'" : 'undef';
527             $expect = defined $expect ? "'$expect'" : 'undef';
528             return $self->diag(sprintf <
529             %s
530             %s
531             %s
532 0     0 1 0 DIAGNOSTIC
533 0         0 }
534            
535 0         0
536             sub _caller_context {
537 0 0 0     0 my $self = shift;
538            
539 0   0     0 my($pack, $file, $line) = $self->caller(1);
540            
541 0         0 my $code = '';
542 0 0       0 $code .= "#line $line $file\n" if defined $file and defined $line;
543 0         0
544             return $code;
545             }
546 0         0
547             #line 771
548            
549             sub BAIL_OUT {
550 0     0 1 0 my($self, $reason) = @_;
551 0         0
552             $self->{Bailed_Out} = 1;
553 0         0 $self->_print("Bail out! $reason");
554             exit 255;
555 0 0 0     0 }
556            
557 0   0     0 #line 784
558            
559 0         0 *BAILOUT = \&BAIL_OUT;
560 0 0       0
561 0         0
562             #line 796
563            
564 0         0 sub skip {
565             my($self, $why) = @_;
566             $why ||= '';
567             $self->_unoverload_str(\$why);
568 0     0   0
569             $self->_plan_check;
570 0         0
571 0 0       0 lock($self->{Curr_Test});
572 0 0       0 $self->{Curr_Test}++;
573            
574 0         0 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
575             'ok' => 1,
576             actual_ok => 1,
577             name => '',
578 0         0 type => 'skip',
579             reason => $why,
580             });
581            
582 0         0 my $out = "ok";
583             $out .= " $self->{Curr_Test}" if $self->use_numbers;
584             $out .= " # skip";
585             $out .= " $why" if length $why;
586 0         0 $out .= "\n";
587            
588             $self->_print($out);
589            
590             return 1;
591             }
592            
593            
594             #line 838
595            
596             sub todo_skip {
597             my($self, $why) = @_;
598             $why ||= '';
599            
600             $self->_plan_check;
601            
602             lock($self->{Curr_Test});
603             $self->{Curr_Test}++;
604            
605             $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
606             'ok' => 1,
607             actual_ok => 0,
608             name => '',
609             type => 'todo_skip',
610 0     0 1 0 reason => $why,
611 0         0 });
612            
613 0 0 0     0 my $out = "not ok";
614             $out .= " $self->{Curr_Test}" if $self->use_numbers;
615 0   0     0 $out .= " # TODO & SKIP $why\n";
616            
617 0         0 $self->_print($out);
618 0 0       0
619 0         0 return 1;
620             }
621            
622 0         0
623             #line 916
624            
625            
626 0     0 1 0 sub maybe_regex {
627 0         0 my ($self, $regex) = @_;
628             my $usable_regex = undef;
629 0 0 0     0
630             return $usable_regex unless defined $regex;
631 0   0     0
632             my($re, $opts);
633 0         0
634 0 0       0 # Check for qr/foo/
635 0         0 if( ref $regex eq 'Regexp' ) {
636             $usable_regex = $regex;
637             }
638 0         0 # Check for '/foo/' or 'm,foo,'
639             elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
640             (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
641             )
642             {
643             $usable_regex = length $opts ? "(?$opts)$re" : $re;
644             }
645            
646             return $usable_regex;
647             };
648            
649             sub _regex_ok {
650             my($self, $this, $regex, $cmp, $name) = @_;
651            
652             my $ok = 0;
653             my $usable_regex = $self->maybe_regex($regex);
654             unless (defined $usable_regex) {
655             $ok = $self->ok( 0, $name );
656             $self->diag(" '$regex' doesn't look much like a regex to me.");
657             return $ok;
658             }
659            
660             {
661             my $test;
662 0     0 1 0 my $code = $self->_caller_context;
663            
664 0         0 local($@, $!, $SIG{__DIE__}); # isolate eval
665 0         0
666             # Yes, it has to look like this or 5.4.5 won't see the #line directive.
667             # Don't ask me, man, I just work here.
668             $test = eval "
669 0     0 1 0 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
670            
671 0         0 $test = !$test if $cmp eq '!~';
672 0         0
673             local $Level = $Level + 1;
674             $ok = $self->ok( $test, $name );
675             }
676            
677             unless( $ok ) {
678             $this = defined $this ? "'$this'" : 'undef';
679             my $match = $cmp eq '=~' ? "doesn't match" : "matches";
680             $self->diag(sprintf <
681             %s
682             %13s '%s'
683             DIAGNOSTIC
684            
685             }
686            
687             return $ok;
688             }
689            
690            
691 0     0 1 0 # I'm not ready to publish this. It doesn't deal with array return
692             # values from the code or context.
693             #line 999
694            
695 0 0       0 sub _try {
696             my($self, $code) = @_;
697            
698 0         0 local $!; # eval can mess up $!
699             local $@; # don't set $@ in the test
700             local $SIG{__DIE__}; # don't trip an outside DIE handler.
701 0         0 my $return = eval { $code->() };
702            
703 0         0 return wantarray ? ($return, $@) : $return;
  0         0  
704             }
705 0         0
706             #line 1021
707            
708             sub is_fh {
709 0         0 my $self = shift;
710             my $maybe_fh = shift;
711             return 0 unless defined $maybe_fh;
712            
713 0         0 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob
714 0         0 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob ref
715            
716 0 0       0 return eval { $maybe_fh->isa("IO::Handle") } ||
717 0 0       0 # 5.5.4's tied() and can() doesn't like getting undef
718 0         0 eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
719             }
720            
721 0         0
722             #line 1066
723            
724 0         0 sub level {
725             my($self, $level) = @_;
726            
727             if( defined $level ) {
728 0     0   0 $Level = $level;
729             }
730 0 0       0 return $Level;
731 0 0       0 }
732 0         0
733            
734             #line 1099
735            
736             sub use_numbers {
737             my($self, $use_nums) = @_;
738            
739             if( defined $use_nums ) {
740             $self->{Use_Nums} = $use_nums;
741 0     0   0 }
742             return $self->{Use_Nums};
743 0         0 }
744            
745 0         0
746 0 0 0     0 #line 1133
747            
748 0         0 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
749             my $method = lc $attribute;
750            
751             my $code = sub {
752             my($self, $no) = @_;
753            
754             if( defined $no ) {
755             $self->{$attribute} = $no;
756             }
757             return $self->{$attribute};
758             };
759            
760             no strict 'refs';
761             *{__PACKAGE__.'::'.$method} = $code;
762             }
763            
764            
765             #line 1187
766            
767             sub diag {
768             my($self, @msgs) = @_;
769            
770             return if $self->no_diag;
771             return unless @msgs;
772            
773 0     0 1 0 # Prevent printing headers when compiling (i.e. -c)
774             return if $^C;
775 0         0
776 0         0 # Smash args together like print does.
777 0         0 # Convert undef to 'undef' so its readable.
778             my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
779            
780             # Escape each line with a #.
781             $msg =~ s/^/# /gm;
782            
783             # Stick a newline on the end if it needs it.
784             $msg .= "\n" unless $msg =~ /\n\Z/;
785            
786             local $Level = $Level + 1;
787             $self->_print_diag($msg);
788            
789             return 0;
790             }
791            
792             #line 1224
793            
794             sub _print {
795             my($self, @msgs) = @_;
796            
797             # Prevent printing headers when only compiling. Mostly for when
798 0     0 1 0 # tests are deparsed with B::Deparse
799 0   0     0 return if $^C;
800 0         0
801             my $msg = join '', @msgs;
802 0         0
803             local($\, $", $,) = (undef, ' ', '');
804 0         0 my $fh = $self->output;
805 0         0
806             # Escape each line after the first with a # so we don't
807 0         0 # confuse Test::Harness.
808             $msg =~ s/\n(.)/\n# $1/sg;
809            
810             # Stick a newline on the end if it needs it.
811             $msg .= "\n" unless $msg =~ /\n\Z/;
812            
813             print $fh $msg;
814             }
815 0         0
816 0 0       0 #line 1258
817 0         0
818 0 0       0 sub _print_diag {
819 0         0 my $self = shift;
820            
821 0         0 local($\, $", $,) = (undef, ' ', '');
822             my $fh = $self->todo ? $self->todo_output : $self->failure_output;
823 0         0 print $fh @_;
824             }
825            
826             #line 1295
827            
828             sub output {
829             my($self, $fh) = @_;
830            
831             if( defined $fh ) {
832             $self->{Out_FH} = $self->_new_fh($fh);
833             }
834             return $self->{Out_FH};
835             }
836            
837             sub failure_output {
838             my($self, $fh) = @_;
839            
840 0     0 1 0 if( defined $fh ) {
841 0   0     0 $self->{Fail_FH} = $self->_new_fh($fh);
842             }
843 0         0 return $self->{Fail_FH};
844             }
845 0         0
846 0         0 sub todo_output {
847             my($self, $fh) = @_;
848 0         0
849             if( defined $fh ) {
850             $self->{Todo_FH} = $self->_new_fh($fh);
851             }
852             return $self->{Todo_FH};
853             }
854            
855            
856 0         0 sub _new_fh {
857 0 0       0 my $self = shift;
858 0         0 my($file_or_fh) = shift;
859            
860 0         0 my $fh;
861             if( $self->is_fh($file_or_fh) ) {
862 0         0 $fh = $file_or_fh;
863             }
864             else {
865             $fh = do { local *FH };
866             open $fh, ">$file_or_fh" or
867             $self->croak("Can't open test output log $file_or_fh: $!");
868             _autoflush($fh);
869             }
870            
871             return $fh;
872             }
873            
874            
875             sub _autoflush {
876             my($fh) = shift;
877             my $old_fh = select $fh;
878             $| = 1;
879             select $old_fh;
880             }
881            
882            
883             sub _dup_stdhandles {
884             my $self = shift;
885            
886             $self->_open_testhandles;
887            
888             # Set everything to unbuffered else plain prints to STDOUT will
889             # come out in the wrong order from our own prints.
890             _autoflush(\*TESTOUT);
891             _autoflush(\*STDOUT);
892             _autoflush(\*TESTERR);
893             _autoflush(\*STDERR);
894            
895             $self->output(\*TESTOUT);
896             $self->failure_output(\*TESTERR);
897             $self->todo_output(\*TESTOUT);
898             }
899            
900            
901             my $Opened_Testhandles = 0;
902             sub _open_testhandles {
903             return if $Opened_Testhandles;
904             # We dup STDOUT and STDERR so people can change them in their
905             # test suites while still getting normal test output.
906             open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
907             open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
908             $Opened_Testhandles = 1;
909             }
910            
911            
912             #line 1395
913            
914             sub _message_at_caller {
915             my $self = shift;
916            
917             local $Level = $Level + 1;
918             my($pack, $file, $line) = $self->caller;
919 0     0 1 0 return join("", @_) . " at $file line $line.\n";
920 0         0 }
921            
922 0 0       0 sub carp {
923             my $self = shift;
924 0         0 warn $self->_message_at_caller(@_);
925             }
926            
927 0 0 0     0 sub croak {
    0          
928 0         0 my $self = shift;
929             die $self->_message_at_caller(@_);
930             }
931            
932             sub _plan_check {
933             my $self = shift;
934            
935 0 0       0 unless( $self->{Have_Plan} ) {
936             local $Level = $Level + 2;
937             $self->croak("You tried to run a test without a plan");
938 0         0 }
939             }
940            
941             #line 1443
942 0     0   0
943             sub current_test {
944 0         0 my($self, $num) = @_;
945 0         0
946 0 0       0 lock($self->{Curr_Test});
947 0         0 if( defined $num ) {
948 0         0 unless( $self->{Have_Plan} ) {
949 0         0 $self->croak("Can't change the current test number without a plan!");
950             }
951            
952             $self->{Curr_Test} = $num;
953 0         0
  0         0  
954 0         0 # If the test counter is being pushed forward fill in the details.
955             my $test_results = $self->{Test_Results};
956 0         0 if( $num > @$test_results ) {
957             my $start = @$test_results ? @$test_results : 0;
958             for ($start..$num-1) {
959             $test_results->[$_] = &share({
960 0         0 'ok' => 1,
961             actual_ok => undef,
962             reason => 'incrementing test number',
963 0 0       0 type => 'unknown',
964             name => undef
965 0         0 });
966 0         0 }
967             }
968             # If backward, wipe history. Its their funeral.
969 0 0       0 elsif( $num < @$test_results ) {
970 0 0       0 $#{$test_results} = $num - 1;
971 0 0       0 }
972 0         0 }
973             return $self->{Curr_Test};
974             }
975            
976            
977             #line 1488
978            
979 0         0 sub summary {
980             my($self) = shift;
981            
982             return map { $_->{'ok'} } @{ $self->{Test_Results} };
983             }
984            
985             #line 1543
986            
987             sub details {
988             my $self = shift;
989             return @{ $self->{Test_Results} };
990             }
991            
992             #line 1568
993            
994             sub todo {
995             my($self, $pack) = @_;
996            
997             $pack = $pack || $self->exported_to || $self->caller($Level);
998             return 0 unless $pack;
999            
1000             no strict 'refs';
1001 4     4   8 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1002             : 0;
1003 4         11 }
1004 4         6
1005 4         12 #line 1589
1006 4         6
  4         7  
1007             sub caller {
1008 4 50       11807 my($self, $height) = @_;
1009             $height ||= 0;
1010            
1011             my @caller = CORE::caller($self->level + $height + 1);
1012             return wantarray ? @caller : $caller[0];
1013             }
1014            
1015             #line 1601
1016            
1017             #line 1615
1018            
1019             #'#
1020             sub _sanity_check {
1021             my $self = shift;
1022            
1023 3     3 1 3 $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1024 3         3 $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1025 3 50       5 'Somehow your tests ran without a plan!');
1026             $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1027 3 50       12 'Somehow you got a different number of results than tests ran!');
1028 0 0       0 }
1029            
1030             #line 1636
1031            
1032 0   0     0 sub _whoa {
1033             my($self, $check, $desc) = @_;
1034             if( $check ) {
1035             local $Level = $Level + 1;
1036             $self->croak(<<"WHOA");
1037             WHOA! $desc
1038             This should never happen! Please contact the author immediately!
1039             WHOA
1040             }
1041             }
1042            
1043             #line 1658
1044            
1045             sub _my_exit {
1046             $? = $_[0];
1047            
1048             return 1;
1049             }
1050            
1051            
1052             #line 1671
1053            
1054             $SIG{__DIE__} = sub {
1055             # We don't want to muck with death in an eval, but $^S isn't
1056             # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1057             # with it. Instead, we use caller. This also means it runs under
1058             # 5.004!
1059             my $in_eval = 0;
1060             for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1061             $in_eval = 1 if $sub =~ /^\(eval\)/;
1062             }
1063             $Test->{Test_Died} = 1 unless $in_eval;
1064             };
1065            
1066             sub _ending {
1067             my $self = shift;
1068 1     1 1 3
1069             $self->_sanity_check();
1070 1 50       4
1071 0         0 # Don't bother with an ending if this is a forked copy. Only the parent
1072             # should do the ending.
1073 1         12 # Exit if plan() was never called. This is so "require Test::Simple"
1074             # doesn't puke.
1075             # Don't do an ending if we bailed out.
1076             if( ($self->{Original_Pid} != $$) or
1077             (!$self->{Have_Plan} && !$self->{Test_Died}) or
1078             $self->{Bailed_Out}
1079             )
1080             {
1081             _my_exit($?);
1082             return;
1083             }
1084            
1085             # Figure out if we passed or failed and print helpful messages.
1086             my $test_results = $self->{Test_Results};
1087             if( @$test_results ) {
1088             # The plan? We have no plan.
1089             if( $self->{No_Plan} ) {
1090             $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1091             $self->{Expected_Tests} = $self->{Curr_Test};
1092             }
1093            
1094             # Auto-extended arrays and elements which aren't explicitly
1095             # filled in with a shared reference will puke under 5.8.0
1096             # ithreads. So we have to fill them in by hand. :(
1097             my $empty_result = &share({});
1098             for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1099             $test_results->[$idx] = $empty_result
1100             unless defined $test_results->[$idx];
1101 1     1 1 2 }
1102            
1103 1 50       3 my $num_failed = grep !$_->{'ok'},
1104 0         0 @{$test_results}[0..$self->{Curr_Test}-1];
1105            
1106 1         7 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1107            
1108             if( $num_extra < 0 ) {
1109             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1110             $self->diag(<<"FAIL");
1111             Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1112             FAIL
1113             }
1114             elsif( $num_extra > 0 ) {
1115             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1116             $self->diag(<<"FAIL");
1117             Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1118             FAIL
1119             }
1120            
1121             if ( $num_failed ) {
1122             my $num_tests = $self->{Curr_Test};
1123             my $s = $num_failed == 1 ? '' : 's';
1124            
1125             my $qualifier = $num_extra == 0 ? '' : ' run';
1126            
1127             $self->diag(<<"FAIL");
1128             Looks like you failed $num_failed test$s of $num_tests$qualifier.
1129             FAIL
1130             }
1131            
1132             if( $self->{Test_Died} ) {
1133             $self->diag(<<"FAIL");
1134             Looks like your test died just after $self->{Curr_Test}.
1135             FAIL
1136            
1137             _my_exit( 255 ) && return;
1138 2     2   4 }
1139            
1140 2 50       7 my $exit_code;
1141 0         0 if( $num_failed ) {
1142             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1143 2         20 }
1144             elsif( $num_extra != 0 ) {
1145             $exit_code = 255;
1146 1     1   13 }
  1         2  
  1         1796  
1147             else {
1148             $exit_code = 0;
1149             }
1150            
1151             _my_exit( $exit_code ) && return;
1152             }
1153             elsif ( $self->{Skip_All} ) {
1154             _my_exit( 0 ) && return;
1155             }
1156             elsif ( $self->{Test_Died} ) {
1157             $self->diag(<<'FAIL');
1158             Looks like your test died before it could output anything.
1159             FAIL
1160             _my_exit( 255 ) && return;
1161             }
1162             else {
1163             $self->diag("No tests run!\n");
1164             _my_exit( 255 ) && return;
1165             }
1166             }
1167            
1168             END {
1169             $Test->_ending if defined $Test and !$Test->no_ending;
1170             }
1171            
1172             #line 1846
1173            
1174             1;