File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 272 488 55.7
branch 93 256 36.3
condition 21 75 28.0
subroutine 49 71 69.0
pod 35 35 100.0
total 470 925 50.8


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 11     11   199  
  11         38  
  11         652  
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 11     11   57  
  11         20  
  11         643  
10 11     11   59 use strict;
  11         18  
  11         803  
11             use vars qw($VERSION);
12             $VERSION = '0.72';
13             $VERSION = eval $VERSION; # make the alpha version come out as a number
14              
15             # Make Test::Builder thread-safe for ithreads.
16 11     11   61 BEGIN {
  11         22  
  11         4023  
17             use Config;
18             # Load threads::shared when threads are turned on.
19 11 50 33 11   15639 # 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 11     74   93 else {
  74         160  
64 11     45   1608 *share = sub { return $_[0] };
  45         443  
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 116     116 1 235 if( defined $pack ) {
132 116   66     547 $self->{Exported_To} = $pack;
133 116         542 }
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 11     11 1 38 }
153             elsif( $cmd eq 'skip_all' ) {
154 11         46 return $self->skip_all($arg);
155 11         51 }
156             elsif( $cmd eq 'tests' ) {
157 11         45 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 11     11   87 $self->croak("plan() doesn't understand @args");
  11         71  
  11         69637  
171             }
172              
173 11     11 1 23 return 1;
174             }
175              
176             #line 290
177 11         26  
178             sub expected_tests {
179 11         126 my $self = shift;
180 11         29 my($max) = @_;
181 11         36  
182 11         122 if( @_ ) {
183             $self->croak("Number of tests must be a positive integer. You gave it '$max'")
184 11         64 unless $max =~ /^\+?\d+$/ and $max > 0;
185 11         35  
186 11         48 $self->{Expected_Tests} = $max;
187             $self->{Have_Plan} = 1;
188 11         30  
189 11         34 $self->_print("1..$max\n") unless $self->no_header;
190             }
191 11         171 return $self->{Expected_Tests};
192             }
193 11         28  
194              
195 11         24 #line 315
196 11         24  
197             sub no_plan {
198 11 50       66 my $self = shift;
199              
200 11         37 $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 27     27 1 59  
224             $self->{Skip_All} = 1;
225 27 100       92  
226 22         62 $self->_print($out) unless $self->no_header;
227             exit(0);
228 27         91 }
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 25     25 1 58 $self->_unoverload_str(\$name);
246              
247 25 100       92 $self->diag(<
248             You named your test '$name'. You shouldn't use numbers for your test names.
249 11         35 Very confusing.
250             ERR
251 11 50       56  
252 0         0 my($pack, $file, $line) = $self->caller;
253              
254             my $todo = $self->todo($pack);
255 11 50       120 $self->_unoverload_str(\$todo);
    100          
    50          
256 0         0  
257             my $out;
258             my $result = &share({});
259 3         23  
260             unless( $test ) {
261             $out .= "not ";
262 8 50       41 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
    0          
    0          
263 8         18 }
264 8         42 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 8     8 1 14  
293 8         18 $self->_print($out);
294              
295 8 50       32 unless( $test ) {
296 8 50 33     96 my $msg = $todo ? "Failed (TODO)" : "Failed";
297             $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
298              
299 8         23 if( defined $name ) {
300 8         17 $self->diag(qq[ $msg test '$name'\n]);
301             $self->diag(qq[ at $file line $line.\n]);
302 8 50       38 }
303             else {
304 8         57 $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 3     3 1 8 }
351              
352 3         7  
353 3 50       94 # This is a hack to detect a dualvar such as $!
354 3         9 sub _is_dualvar {
355             my($self, $val) = @_;
356 3         8  
357             local $^W = 0;
358 3 50       14 my $numval = $val+0;
359 3         1399 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 45     45 1 100 sub is_num {
385             my($self, $got, $expect, $name) = @_;
386             local $Level = $Level + 1;
387              
388 45 100       101 $self->_unoverload_num(\$got, \$expect);
389              
390 45         129 if( !defined $got || !defined $expect ) {
391             # undef only matches undef and nothing else
392 45         396 my $test = !defined $got && !defined $expect;
393 45         69  
394             $self->ok($test, $name);
395             $self->_is_diag($got, '==', $expect) unless $test;
396 45         122 return $test;
397             }
398 45 50 33     598  
399             return $self->cmp_ok($got, '==', $expect, $name);
400             }
401              
402             sub _is_diag {
403 45         131 my($self, $got, $type, $expect) = @_;
404              
405 45         319 foreach my $val (\$got, \$expect) {
406 45         118 if( defined $$val ) {
407             if( $type eq 'eq' ) {
408 45         78 # quote and force string context
409 45         129 $$val = "'$$val'"
410             }
411 45 100       111 else {
412 1         5 # force numeric context
413 1 50       10 $self->_unoverload_num($val);
414             }
415             }
416 44         176 else {
417             $$val = 'undef';
418             }
419 45         87 }
420 45 50       124  
421             return $self->diag(sprintf <
422 45 50       215 got: %s
423 45         93 expected: %s
424 45         89 DIAGNOSTIC
425 45         104  
426             }
427              
428 0         0 #line 608
429              
430             sub isnt_eq {
431 45 50       109 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 45         562  
438 45         103 $self->ok($test, $name);
439             $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
440             return $test;
441 45         142 }
442 45         80  
443             return $self->cmp_ok($got, 'ne', $dont_expect, $name);
444 45         128 }
445              
446 45 100       149 sub isnt_num {
447 1 50       7 my($self, $got, $dont_expect, $name) = @_;
448 1 50       11 local $Level = $Level + 1;
449              
450 1 50       7 if( !defined $got || !defined $dont_expect ) {
451 1         9 # undef only matches undef and nothing else
452 1         9 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 45 100       226 return $self->cmp_ok($got, '!=', $dont_expect, $name);
460             }
461              
462              
463             #line 660
464 144     144   170  
465 144         177 sub like {
466             my($self, $this, $regex, $name) = @_;
467 144 50   144   665  
  144         2808  
468             local $Level = $Level + 1;
469 144         491 $self->_regex_ok($this, $regex, '=~', $name);
470 198 100       2904 }
471 10 50       36  
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 198     198   292 #line 685
481              
482 198 100   198   758  
  198 100       1581  
483             my %numeric_cmps = map { ($_, 1) }
484             ("<", "<=", ">", ">=", "==", "!=", "<=>");
485              
486             sub cmp_ok {
487 144     144   205 my($self, $got, $type, $expect, $name) = @_;
488              
489 144         350 # 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 5     5 1 15 DIAGNOSTIC
533 5         14 }
534              
535 5         30  
536             sub _caller_context {
537 5 50 33     40 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 5         38  
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 5     5 1 12 # I'm not ready to publish this. It doesn't deal with array return
692             # values from the code or context.
693              
694             #line 1000
695 5 50       29  
696             sub _try {
697             my($self, $code) = @_;
698 5         26
699             local $!; # eval can mess up $!
700             local $@; # don't set $@ in the test
701 5         9 local $SIG{__DIE__}; # don't trip an outside DIE handler.
702             my $return = eval { $code->() };
703 5         8
  5         25  
704             return wantarray ? ($return, $@) : $return;
705 5         23 }
706              
707             #line 1022
708              
709 5         249 sub is_fh {
710             my $self = shift;
711             my $maybe_fh = shift;
712             return 0 unless defined $maybe_fh;
713 5         174  
714 5         23 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
715             return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
716 5 50       19  
717 0 0       0 return eval { $maybe_fh->isa("IO::Handle") } ||
718 0         0 # 5.5.4's tied() and can() doesn't like getting undef
719             eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
720             }
721 0         0  
722              
723             #line 1067
724 5         22  
725             sub level {
726             my($self, $level) = @_;
727              
728 0     0   0 if( defined $level ) {
729             $Level = $level;
730 0 0       0 }
731 0 0       0 return $Level;
732 0         0 }
733              
734              
735             #line 1100
736              
737             sub use_numbers {
738             my($self, $use_nums) = @_;
739              
740             if( defined $use_nums ) {
741 5     5   8 $self->{Use_Nums} = $use_nums;
742             }
743 5         36 return $self->{Use_Nums};
744             }
745 5         146  
746 5 50 33     66  
747             #line 1134
748 5         16  
749             foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
750             my $method = lc $attribute;
751              
752             my $code = sub {
753             my($self, $no) = @_;
754              
755             if( defined $no ) {
756             $self->{$attribute} = $no;
757             }
758             return $self->{$attribute};
759             };
760              
761             no strict 'refs';
762             *{__PACKAGE__.'::'.$method} = $code;
763             }
764              
765              
766             #line 1188
767              
768             sub diag {
769             my($self, @msgs) = @_;
770              
771             return if $self->no_diag;
772             return unless @msgs;
773 0     0 1 0  
774             # Prevent printing headers when compiling (i.e. -c)
775 0         0 return if $^C;
776 0         0  
777 0         0 # Smash args together like print does.
778             # Convert undef to 'undef' so its readable.
779             my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
780              
781             # Escape each line with a #.
782             $msg =~ s/^/# /gm;
783              
784             # Stick a newline on the end if it needs it.
785             $msg .= "\n" unless $msg =~ /\n\Z/;
786              
787             local $Level = $Level + 1;
788             $self->_print_diag($msg);
789              
790             return 0;
791             }
792              
793             #line 1225
794              
795             sub _print {
796             my($self, @msgs) = @_;
797              
798 0     0 1 0 # Prevent printing headers when only compiling. Mostly for when
799 0   0     0 # tests are deparsed with B::Deparse
800 0         0 return if $^C;
801              
802 0         0 my $msg = join '', @msgs;
803              
804 0         0 local($\, $", $,) = (undef, ' ', '');
805 0         0 my $fh = $self->output;
806              
807 0         0 # Escape each line after the first with a # so we don't
808             # confuse Test::Harness.
809             $msg =~ s/\n(.)/\n# $1/sg;
810              
811             # Stick a newline on the end if it needs it.
812             $msg .= "\n" unless $msg =~ /\n\Z/;
813              
814             print $fh $msg;
815 0         0 }
816 0 0       0  
817 0         0 #line 1259
818 0 0       0  
819 0         0 sub _print_diag {
820             my $self = shift;
821 0         0  
822             local($\, $", $,) = (undef, ' ', '');
823 0         0 my $fh = $self->todo ? $self->todo_output : $self->failure_output;
824             print $fh @_;
825             }
826              
827             #line 1296
828              
829             sub output {
830             my($self, $fh) = @_;
831              
832             if( defined $fh ) {
833             $self->{Out_FH} = $self->_new_fh($fh);
834             }
835             return $self->{Out_FH};
836             }
837              
838             sub failure_output {
839             my($self, $fh) = @_;
840 0     0 1 0  
841 0   0     0 if( defined $fh ) {
842             $self->{Fail_FH} = $self->_new_fh($fh);
843 0         0 }
844             return $self->{Fail_FH};
845 0         0 }
846 0         0  
847             sub todo_output {
848 0         0 my($self, $fh) = @_;
849              
850             if( defined $fh ) {
851             $self->{Todo_FH} = $self->_new_fh($fh);
852             }
853             return $self->{Todo_FH};
854             }
855              
856 0         0  
857 0 0       0 sub _new_fh {
858 0         0 my $self = shift;
859             my($file_or_fh) = shift;
860 0         0  
861             my $fh;
862 0         0 if( $self->is_fh($file_or_fh) ) {
863             $fh = $file_or_fh;
864             }
865             else {
866             $fh = do { local *FH };
867             open $fh, ">$file_or_fh" or
868             $self->croak("Can't open test output log $file_or_fh: $!");
869             _autoflush($fh);
870             }
871              
872             return $fh;
873             }
874              
875              
876             sub _autoflush {
877             my($fh) = shift;
878             my $old_fh = select $fh;
879             $| = 1;
880             select $old_fh;
881             }
882              
883              
884             sub _dup_stdhandles {
885             my $self = shift;
886              
887             $self->_open_testhandles;
888              
889             # Set everything to unbuffered else plain prints to STDOUT will
890             # come out in the wrong order from our own prints.
891             _autoflush(\*TESTOUT);
892             _autoflush(\*STDOUT);
893             _autoflush(\*TESTERR);
894             _autoflush(\*STDERR);
895              
896             $self->output(\*TESTOUT);
897             $self->failure_output(\*TESTERR);
898             $self->todo_output(\*TESTOUT);
899             }
900              
901              
902             my $Opened_Testhandles = 0;
903             sub _open_testhandles {
904             return if $Opened_Testhandles;
905             # We dup STDOUT and STDERR so people can change them in their
906             # test suites while still getting normal test output.
907             open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
908             open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
909             $Opened_Testhandles = 1;
910             }
911              
912              
913             #line 1396
914              
915             sub _message_at_caller {
916             my $self = shift;
917              
918             local $Level = $Level + 1;
919 0     0 1 0 my($pack, $file, $line) = $self->caller;
920 0         0 return join("", @_) . " at $file line $line.\n";
921             }
922 0 0       0  
923             sub carp {
924 0         0 my $self = shift;
925             warn $self->_message_at_caller(@_);
926             }
927 0 0 0     0  
    0          
928 0         0 sub croak {
929             my $self = shift;
930             die $self->_message_at_caller(@_);
931             }
932              
933             sub _plan_check {
934             my $self = shift;
935 0 0       0  
936             unless( $self->{Have_Plan} ) {
937             local $Level = $Level + 2;
938 0         0 $self->croak("You tried to run a test without a plan");
939             }
940             }
941              
942 0     0   0 #line 1444
943              
944 0         0 sub current_test {
945 0         0 my($self, $num) = @_;
946 0 0       0  
947 0         0 lock($self->{Curr_Test});
948 0         0 if( defined $num ) {
949 0         0 unless( $self->{Have_Plan} ) {
950             $self->croak("Can't change the current test number without a plan!");
951             }
952              
953 0         0 $self->{Curr_Test} = $num;
  0         0  
954 0         0  
955             # If the test counter is being pushed forward fill in the details.
956 0         0 my $test_results = $self->{Test_Results};
957             if( $num > @$test_results ) {
958             my $start = @$test_results ? @$test_results : 0;
959             for ($start..$num-1) {
960 0         0 $test_results->[$_] = &share({
961             'ok' => 1,
962             actual_ok => undef,
963 0 0       0 reason => 'incrementing test number',
964             type => 'unknown',
965 0         0 name => undef
966 0         0 });
967             }
968             }
969 0 0       0 # If backward, wipe history. Its their funeral.
970 0 0       0 elsif( $num < @$test_results ) {
971 0 0       0 $#{$test_results} = $num - 1;
972 0         0 }
973             }
974             return $self->{Curr_Test};
975             }
976              
977              
978             #line 1489
979 0         0  
980             sub summary {
981             my($self) = shift;
982              
983             return map { $_->{'ok'} } @{ $self->{Test_Results} };
984             }
985              
986             #line 1544
987              
988             sub details {
989             my $self = shift;
990             return @{ $self->{Test_Results} };
991             }
992              
993             #line 1569
994              
995             sub todo {
996             my($self, $pack) = @_;
997              
998             $pack = $pack || $self->exported_to || $self->caller($Level);
999             return 0 unless $pack;
1000              
1001             no strict 'refs';
1002 372     372   504 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1003             : 0;
1004 372         1456 }
1005 372         412  
1006 372         1022 #line 1590
1007 372         522  
  372         821  
1008             sub caller {
1009 372 100       30021 my($self, $height) = @_;
1010             $height ||= 0;
1011              
1012             my @caller = CORE::caller($self->level + $height + 1);
1013             return wantarray ? @caller : $caller[0];
1014             }
1015              
1016             #line 1602
1017              
1018             #line 1616
1019              
1020             #'#
1021             sub _sanity_check {
1022             my $self = shift;
1023              
1024 33     33 1 43 $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1025 33         35 $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1026 33 50       81 'Somehow your tests ran without a plan!');
1027             $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1028 33 50       167 'Somehow you got a different number of results than tests ran!');
1029 0 0       0 }
1030              
1031             #line 1637
1032              
1033 0   0     0 sub _whoa {
1034             my($self, $check, $desc) = @_;
1035             if( $check ) {
1036             local $Level = $Level + 1;
1037             $self->croak(<<"WHOA");
1038             WHOA! $desc
1039             This should never happen! Please contact the author immediately!
1040             WHOA
1041             }
1042             }
1043              
1044             #line 1659
1045              
1046             sub _my_exit {
1047             $? = $_[0];
1048              
1049             return 1;
1050             }
1051              
1052              
1053             #line 1672
1054              
1055             $SIG{__DIE__} = sub {
1056             # We don't want to muck with death in an eval, but $^S isn't
1057             # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1058             # with it. Instead, we use caller. This also means it runs under
1059             # 5.004!
1060             my $in_eval = 0;
1061             for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1062             $in_eval = 1 if $sub =~ /^\(eval\)/;
1063             }
1064             $Test->{Test_Died} = 1 unless $in_eval;
1065             };
1066              
1067             sub _ending {
1068             my $self = shift;
1069 50     50 1 75  
1070             $self->_sanity_check();
1071 50 50       127  
1072 0         0 # Don't bother with an ending if this is a forked copy. Only the parent
1073             # should do the ending.
1074 50         577 # Exit if plan() was never called. This is so "require Test::Simple"
1075             # doesn't puke.
1076             # Don't do an ending if we bailed out.
1077             if( ($self->{Original_Pid} != $$) or
1078             (!$self->{Have_Plan} && !$self->{Test_Died}) or
1079             $self->{Bailed_Out}
1080             )
1081             {
1082             _my_exit($?);
1083             return;
1084             }
1085              
1086             # Figure out if we passed or failed and print helpful messages.
1087             my $test_results = $self->{Test_Results};
1088             if( @$test_results ) {
1089             # The plan? We have no plan.
1090             if( $self->{No_Plan} ) {
1091             $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1092             $self->{Expected_Tests} = $self->{Curr_Test};
1093             }
1094              
1095             # Auto-extended arrays and elements which aren't explicitly
1096             # filled in with a shared reference will puke under 5.8.0
1097             # ithreads. So we have to fill them in by hand. :(
1098             my $empty_result = &share({});
1099             for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1100             $test_results->[$idx] = $empty_result
1101             unless defined $test_results->[$idx];
1102 45     45 1 73 }
1103              
1104 45 50       151 my $num_failed = grep !$_->{'ok'},
1105 0         0 @{$test_results}[0..$self->{Curr_Test}-1];
1106              
1107 45         200 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1108              
1109             if( $num_extra < 0 ) {
1110             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1111             $self->diag(<<"FAIL");
1112             Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1113             FAIL
1114             }
1115             elsif( $num_extra > 0 ) {
1116             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1117             $self->diag(<<"FAIL");
1118             Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1119             FAIL
1120             }
1121              
1122             if ( $num_failed ) {
1123             my $num_tests = $self->{Curr_Test};
1124             my $s = $num_failed == 1 ? '' : 's';
1125              
1126             my $qualifier = $num_extra == 0 ? '' : ' run';
1127              
1128             $self->diag(<<"FAIL");
1129             Looks like you failed $num_failed test$s of $num_tests$qualifier.
1130             FAIL
1131             }
1132              
1133             if( $self->{Test_Died} ) {
1134             $self->diag(<<"FAIL");
1135             Looks like your test died just after $self->{Curr_Test}.
1136             FAIL
1137              
1138             _my_exit( 255 ) && return;
1139 45     45   101 }
1140              
1141 45 50       157 my $exit_code;
1142 0         0 if( $num_failed ) {
1143             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1144 45         336 }
1145             elsif( $num_extra != 0 ) {
1146             $exit_code = 255;
1147 11     11   1168 }
  11         23  
  11         19631  
1148             else {
1149             $exit_code = 0;
1150             }
1151              
1152             _my_exit( $exit_code ) && return;
1153             }
1154             elsif ( $self->{Skip_All} ) {
1155             _my_exit( 0 ) && return;
1156             }
1157             elsif ( $self->{Test_Died} ) {
1158             $self->diag(<<'FAIL');
1159             Looks like your test died before it could output anything.
1160             FAIL
1161             _my_exit( 255 ) && return;
1162             }
1163             else {
1164             $self->diag("No tests run!\n");
1165             _my_exit( 255 ) && return;
1166             }
1167             }
1168              
1169             END {
1170             $Test->_ending if defined $Test and !$Test->no_ending;
1171             }
1172              
1173             #line 1847
1174              
1175             1;