File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 237 488 48.5
branch 70 256 27.3
condition 17 75 22.6
subroutine 46 71 64.7
pod 35 35 100.0
total 405 925 43.7


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 3     3   48  
  3         10  
  3         170  
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 3     3   17  
  3         5  
  3         112  
10 3     3   14 use strict;
  3         6  
  3         203  
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 3     3   83 BEGIN {
  3         5  
  3         1172  
17             use Config;
18             # Load threads::shared when threads are turned on.
19 3 50 33 3   111 # 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 3     8   28 else {
  8         19  
64 3     1   417 *share = sub { return $_[0] };
  1         6  
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 13     13 1 31 if( defined $pack ) {
132 13   66     78 $self->{Exported_To} = $pack;
133 13         50 }
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 3     3 1 7 }
153             elsif( $cmd eq 'skip_all' ) {
154 3         12 return $self->skip_all($arg);
155 3         12 }
156             elsif( $cmd eq 'tests' ) {
157 3         10 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 3     3   19 $self->croak("plan() doesn't understand @args");
  3         28  
  3         13076  
171             }
172              
173 3     3 1 5 return 1;
174             }
175              
176             #line 290
177 3         5  
178             sub expected_tests {
179 3         166 my $self = shift;
180 3         7 my($max) = @_;
181 3         6  
182 3         43 if( @_ ) {
183             $self->croak("Number of tests must be a positive integer. You gave it '$max'")
184 3         17 unless $max =~ /^\+?\d+$/ and $max > 0;
185 3         11  
186 3         11 $self->{Expected_Tests} = $max;
187             $self->{Have_Plan} = 1;
188 3         8  
189 3         10 $self->_print("1..$max\n") unless $self->no_header;
190             }
191 3         7 return $self->{Expected_Tests};
192             }
193 3         7  
194              
195 3         7 #line 315
196 3         6  
197             sub no_plan {
198 3 50       20 my $self = shift;
199              
200 3         6 $self->{No_Plan} = 1;
201             $self->{Have_Plan} = 1;
202             }
203              
204             #line 330
205              
206             sub has_plan {
207             my $self = shift;
208              
209             return($self->{Expected_Tests}) if $self->{Expected_Tests};
210             return('no_plan') if $self->{No_Plan};
211             return(undef);
212             };
213              
214              
215             #line 348
216              
217             sub skip_all {
218             my($self, $reason) = @_;
219              
220             my $out = "1..0";
221             $out .= " # Skip $reason" if $reason;
222             $out .= "\n";
223 7     7 1 16  
224             $self->{Skip_All} = 1;
225 7 100       24  
226 6         18 $self->_print($out) unless $self->no_header;
227             exit(0);
228 7         31 }
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 8     8 1 18 $self->_unoverload_str(\$name);
246              
247 8 100       103 $self->diag(<
248             You named your test '$name'. You shouldn't use numbers for your test names.
249 3         9 Very confusing.
250             ERR
251 3 50       37  
252 0         0 my($pack, $file, $line) = $self->caller;
253              
254             my $todo = $self->todo($pack);
255 3 50       21 $self->_unoverload_str(\$todo);
    100          
    50          
256 0         0  
257             my $out;
258             my $result = &share({});
259 2         32  
260             unless( $test ) {
261             $out .= "not ";
262 1 50       5 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
    0          
    0          
263 1         3 }
264 1         5 else {
265             @$result{ 'ok', 'actual_ok' } = ( 1, $test );
266             }
267 0         0  
268             $out .= "ok";
269             $out .= " $self->{Curr_Test}" if $self->use_numbers;
270 0         0  
271             if( defined $name ) {
272             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
273             $out .= " - $name";
274 0         0 $result->{name} = $name;
  0         0  
275 0         0 }
276             else {
277             $result->{name} = '';
278 0         0 }
279              
280             if( $todo ) {
281             $out .= " # TODO $todo";
282             $result->{reason} = $todo;
283             $result->{type} = 'todo';
284             }
285             else {
286             $result->{reason} = '';
287             $result->{type} = '';
288             }
289              
290             $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
291             $out .= "\n";
292 1     1 1 2  
293 1         2 $self->_print($out);
294              
295 1 50       4 unless( $test ) {
296 1 50 33     11 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 2     2 1 7 }
351              
352 2         65  
353 2 50       11 # This is a hack to detect a dualvar such as $!
354 2         5 sub _is_dualvar {
355             my($self, $val) = @_;
356 2         4  
357             local $^W = 0;
358 2 50       8 my $numval = $val+0;
359 2         172 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 2 sub is_num {
385             my($self, $got, $expect, $name) = @_;
386             local $Level = $Level + 1;
387              
388 1 50       121 $self->_unoverload_num(\$got, \$expect);
389              
390 1         5 if( !defined $got || !defined $expect ) {
391             # undef only matches undef and nothing else
392 1         4 my $test = !defined $got && !defined $expect;
393 1         1  
394             $self->ok($test, $name);
395             $self->_is_diag($got, '==', $expect) unless $test;
396 1         4 return $test;
397             }
398 1 50 33     12  
399             return $self->cmp_ok($got, '==', $expect, $name);
400             }
401              
402             sub _is_diag {
403 1         4 my($self, $got, $type, $expect) = @_;
404              
405 1         5 foreach my $val (\$got, \$expect) {
406 1         4 if( defined $$val ) {
407             if( $type eq 'eq' ) {
408 1         2 # quote and force string context
409 1         4 $$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         4 else {
417             $$val = 'undef';
418             }
419 1         2 }
420 1 50       4  
421             return $self->diag(sprintf <
422 1 50       4 got: %s
423 1         3 expected: %s
424 1         2 DIAGNOSTIC
425 1         2  
426             }
427              
428 0         0 #line 608
429              
430             sub isnt_eq {
431 1 50       10 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         3  
438 1         2 $self->ok($test, $name);
439             $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
440             return $test;
441 1         3 }
442 1         2  
443             return $self->cmp_ok($got, 'ne', $dont_expect, $name);
444 1         4 }
445              
446 1 50       12 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       5 return $self->cmp_ok($got, '!=', $dont_expect, $name);
460             }
461              
462              
463             #line 660
464 2     2   3  
465 2         3 sub like {
466             my($self, $this, $regex, $name) = @_;
467 2 50   2   10  
  2         15  
468             local $Level = $Level + 1;
469 2         8 $self->_regex_ok($this, $regex, '=~', $name);
470 2 50       6 }
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   3 #line 685
481              
482 2 50   2   7  
  2 50       19  
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         7 # 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   7 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1002             : 0;
1003 4         11 }
1004 4         5  
1005 4         12 #line 1589
1006 4         4  
  4         8  
1007             sub caller {
1008 4 50       29 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 9     9 1 14 $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1024 9         10 $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1025 9 50       26 'Somehow your tests ran without a plan!');
1026             $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1027 9 50       50 '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 2  
1069             $self->_sanity_check();
1070 1 50       3  
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         10 # 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         5 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 7     7   46 }
1139              
1140 7 50       24 my $exit_code;
1141 0         0 if( $num_failed ) {
1142             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1143 7         54 }
1144             elsif( $num_extra != 0 ) {
1145             $exit_code = 255;
1146 3     3   28 }
  3         6  
  3         4631  
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;