File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 244 488 50.0
branch 77 256 30.0
condition 13 75 17.3
subroutine 46 71 64.7
pod 35 35 100.0
total 415 925 44.8


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 2     2   35  
  2         7  
  2         118  
4             use 5.004;
5              
6             # $^C was only introduced in 5.005-ish. We do this to prevent
7             # use of uninitialized value warnings in older perls.
8             $^C ||= 0;
9 2     2   12  
  2         4  
  2         76  
10 2     2   10 use strict;
  2         3  
  2         145  
11             use vars qw($VERSION);
12             $VERSION = '0.74';
13             $VERSION = eval $VERSION; # make the alpha version come out as a number
14              
15             # Make Test::Builder thread-safe for ithreads.
16 2     2   15 BEGIN {
  2         6  
  2         900  
17             use Config;
18             # Load threads::shared when threads are turned on.
19 2 50 33 2   62 # 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 2     6   13 else {
  6         16  
64 2     1   276 *share = sub { return $_[0] };
  1         3  
65             *lock = sub { 0 };
66             }
67             }
68              
69              
70             #line 128
71              
72             my $Test = Test::Builder->new;
73             sub new {
74             my($class) = shift;
75             $Test ||= $class->create;
76             return $Test;
77             }
78              
79              
80             #line 150
81              
82             sub create {
83             my $class = shift;
84              
85             my $self = bless {}, $class;
86             $self->reset;
87              
88             return $self;
89             }
90              
91             #line 169
92              
93             use vars qw($Level);
94              
95             sub reset {
96             my ($self) = @_;
97              
98             # We leave this a global because it has to be localized and localizing
99             # hash keys is just asking for pain. Also, it was documented.
100             $Level = 1;
101              
102             $self->{Test_Died} = 0;
103             $self->{Have_Plan} = 0;
104             $self->{No_Plan} = 0;
105             $self->{Original_Pid} = $$;
106              
107             share($self->{Curr_Test});
108             $self->{Curr_Test} = 0;
109             $self->{Test_Results} = &share([]);
110              
111             $self->{Exported_To} = undef;
112             $self->{Expected_Tests} = 0;
113              
114             $self->{Skip_All} = 0;
115              
116             $self->{Use_Nums} = 1;
117              
118             $self->{No_Header} = 0;
119             $self->{No_Ending} = 0;
120              
121             $self->_dup_stdhandles unless $^C;
122              
123             return undef;
124             }
125              
126             #line 221
127              
128             sub exported_to {
129             my($self, $pack) = @_;
130              
131 7     7 1 16 if( defined $pack ) {
132 7   66     36 $self->{Exported_To} = $pack;
133 7         19 }
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 2     2 1 5 }
153             elsif( $cmd eq 'skip_all' ) {
154 2         6 return $self->skip_all($arg);
155 2         8 }
156             elsif( $cmd eq 'tests' ) {
157 2         8 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 2     2   13 $self->croak("plan() doesn't understand @args");
  2         28  
  2         8241  
171             }
172              
173 2     2 1 3 return 1;
174             }
175              
176             #line 290
177 2         6  
178             sub expected_tests {
179 2         21 my $self = shift;
180 2         6 my($max) = @_;
181 2         3  
182 2         27 if( @_ ) {
183             $self->croak("Number of tests must be a positive integer. You gave it '$max'")
184 2         10 unless $max =~ /^\+?\d+$/ and $max > 0;
185 2         4  
186 2         8 $self->{Expected_Tests} = $max;
187             $self->{Have_Plan} = 1;
188 2         5  
189 2         5 $self->_print("1..$max\n") unless $self->no_header;
190             }
191 2         5 return $self->{Expected_Tests};
192             }
193 2         3  
194              
195 2         4 #line 315
196 2         4  
197             sub no_plan {
198 2 50       12 my $self = shift;
199              
200 2         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 10     10 1 19  
224             $self->{Skip_All} = 1;
225 10 100       30  
226 4         10 $self->_print($out) unless $self->no_header;
227             exit(0);
228 10         42 }
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 4     4 1 11 $self->_unoverload_str(\$name);
246              
247 4 100       15 $self->diag(<
248             You named your test '$name'. You shouldn't use numbers for your test names.
249 2         5 Very confusing.
250             ERR
251 2 50       10  
252 0         0 my($pack, $file, $line) = $self->caller;
253              
254             my $todo = $self->todo($pack);
255 2 100       12 $self->_unoverload_str(\$todo);
    50          
    50          
256 1         4  
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         2 }
264 1         5 else {
265             @$result{ 'ok', 'actual_ok' } = ( 1, $test );
266             }
267 0         0  
268             $out .= "ok";
269             $out .= " $self->{Curr_Test}" if $self->use_numbers;
270 0         0  
271             if( defined $name ) {
272             $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
273             $out .= " - $name";
274 0         0 $result->{name} = $name;
  0         0  
275 0         0 }
276             else {
277             $result->{name} = '';
278 1         3 }
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         3 $self->_print($out);
294              
295 1 50       7 unless( $test ) {
296 1 50 33     13 my $msg = $todo ? "Failed (TODO)" : "Failed";
297             $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
298              
299 1         3 if( defined $name ) {
300 1         2 $self->diag(qq[ $msg test '$name'\n]);
301             $self->diag(qq[ at $file line $line.\n]);
302 1 50       5 }
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 1     1 1 2  
318             foreach my $thing (@_) {
319 1         4 if( $self->_is_object($$thing) ) {
320 1         2 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 4 sub is_num {
385             my($self, $got, $expect, $name) = @_;
386             local $Level = $Level + 1;
387              
388 1 50       6 $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         2  
394             $self->ok($test, $name);
395             $self->_is_diag($got, '==', $expect) unless $test;
396 1         5 return $test;
397             }
398 1 50 33     16  
399             return $self->cmp_ok($got, '==', $expect, $name);
400             }
401              
402             sub _is_diag {
403 1         14 my($self, $got, $type, $expect) = @_;
404              
405 1         7 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         6 $$val = "'$$val'"
410             }
411 1 50       4 else {
412 1         3 # force numeric context
413 1 50       9 $self->_unoverload_num($val);
414             }
415             }
416 0         0 else {
417             $$val = 'undef';
418             }
419 1         3 }
420 1 50       5  
421             return $self->diag(sprintf <
422 1 50       5 got: %s
423 1         3 expected: %s
424 1         3 DIAGNOSTIC
425 1         6  
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         3  
438 1         3 $self->ok($test, $name);
439             $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
440             return $test;
441 1         5 }
442 1         3  
443             return $self->cmp_ok($got, 'ne', $dont_expect, $name);
444 1         5 }
445              
446 1 50       6 sub isnt_num {
447 1 50       3 my($self, $got, $dont_expect, $name) = @_;
448 1 50       8 local $Level = $Level + 1;
449              
450 1 50       4 if( !defined $got || !defined $dont_expect ) {
451 1         9 # undef only matches undef and nothing else
452 1         6 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       8 return $self->cmp_ok($got, '!=', $dont_expect, $name);
460             }
461              
462              
463             #line 660
464 2     2   5  
465 2         3 sub like {
466             my($self, $this, $regex, $name) = @_;
467 2 50   2   13  
  2         1944  
468             local $Level = $Level + 1;
469 2         11 $self->_regex_ok($this, $regex, '=~', $name);
470 2 50       11 }
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   5 #line 685
481              
482 2 50   2   13  
  2 50       10  
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              
694             #line 1000
695 0 0       0  
696             sub _try {
697             my($self, $code) = @_;
698 0         0
699             local $!; # eval can mess up $!
700             local $@; # don't set $@ in the test
701 0         0 local $SIG{__DIE__}; # don't trip an outside DIE handler.
702             my $return = eval { $code->() };
703 0         0
  0         0  
704             return wantarray ? ($return, $@) : $return;
705 0         0 }
706              
707             #line 1022
708              
709 0         0 sub is_fh {
710             my $self = shift;
711             my $maybe_fh = shift;
712             return 0 unless defined $maybe_fh;
713 0         0  
714 0         0 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 0 0       0  
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 0         0  
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 0     0   0 $self->{Use_Nums} = $use_nums;
742             }
743 0         0 return $self->{Use_Nums};
744             }
745 0         0  
746 0 0 0     0  
747             #line 1134
748 0         0  
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 4     4   8 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1003             : 0;
1004 4         12 }
1005 4         6  
1006 4         13 #line 1590
1007 4         5  
  4         9  
1008             sub caller {
1009 4 50       1336 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 6     6 1 8 $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1025 6         7 $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1026 6 50       15 'Somehow your tests ran without a plan!');
1027             $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1028 6 50       32 '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 1     1 1 3  
1070             $self->_sanity_check();
1071 1 50       5  
1072 0         0 # Don't bother with an ending if this is a forked copy. Only the parent
1073             # should do the ending.
1074 1         12 # 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 1     1 1 3 }
1103              
1104 1 50       6 my $num_failed = grep !$_->{'ok'},
1105 0         0 @{$test_results}[0..$self->{Curr_Test}-1];
1106              
1107 1         40 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 8     8   16 }
1140              
1141 8 50       23 my $exit_code;
1142 0         0 if( $num_failed ) {
1143             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1144 8         326 }
1145             elsif( $num_extra != 0 ) {
1146             $exit_code = 255;
1147 2     2   22 }
  2         4  
  2         3589  
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;