File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 223 501 44.5
branch 65 266 24.4
condition 11 66 16.6
subroutine 43 73 58.9
pod 35 35 100.0
total 377 941 40.0


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