File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 214 501 42.7
branch 60 266 22.5
condition 10 66 15.1
subroutine 42 73 57.5
pod 35 35 100.0
total 361 941 38.3


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 1     1   21  
  1         3  
  1         37  
4 1     1   5 use 5.006;
  1         2  
  1         60  
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 1     1   5 BEGIN {
  1         2  
  1         325  
12             use Config;
13             # Load threads::shared when threads are turned on.
14 1 50 33 1   33 # 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 1     4   5 else {
  4         10  
59 1     1   120 *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 3     3 1 17 $self->{No_Ending} = 0;
114 3   66     19  
115 3         18 $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 1     1 1 2  
135             if( $cmd eq 'no_plan' ) {
136 1         3 $self->no_plan;
137 1         4 }
138             elsif( $cmd eq 'skip_all' ) {
139 1         5 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 1     1   5 }
  1         2  
  1         3936  
153             else {
154             my @args = grep { defined } ($cmd, $arg);
155 1     1 1 2 $self->croak("plan() doesn't understand @args");
156             }
157              
158             return 1;
159 1         2 }
160              
161 1         7 #line 254
162 1         2  
163 1         11 sub expected_tests {
164             my $self = shift;
165 1         6 my($max) = @_;
166 1         3  
167 1         3 if( @_ ) {
168             $self->croak("Number of tests must be a positive integer. You gave it '$max'")
169 1         5 unless $max =~ /^\+?\d+$/ and $max > 0;
170 1         1  
171             $self->{Expected_Tests} = $max;
172 1         3 $self->{Have_Plan} = 1;
173              
174 1         2 $self->_print("1..$max\n") unless $self->no_header;
175             }
176 1         2 return $self->{Expected_Tests};
177 1         2 }
178              
179 1         2  
180             #line 279
181 1 50       7  
182             sub no_plan {
183 1         18 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 1     1 1 2 $self->{Skip_All} = 1;
210              
211 1 50       4 $self->_print($out) unless $self->no_header;
212             exit(0);
213 1         2 }
214              
215 1 50       5  
216 0         0 #line 339
217              
218             sub exported_to {
219 1 50       6 my($self, $pack) = @_;
    50          
    50          
220 0         0  
221             if( defined $pack ) {
222             $self->{Exported_To} = $pack;
223 0         0 }
224             return $self->{Exported_To};
225             }
226 1 50       4  
    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 1  
257 1         2 my $out;
258             my $result = &share({});
259 1 50       3  
260 1 50 33     11 unless( $test ) {
261             $out .= "not ";
262             @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
263 1         3 }
264 1         2 else {
265             @$result{ 'ok', 'actual_ok' } = ( 1, $test );
266 1 50       3 }
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 0     0 1 0 my $self = shift;
315             my $type = shift;
316 0         0  
317 0 0       0 $self->_try(sub { require overload } ) || return;
318 0         0  
319             foreach my $thing (@_) {
320 0         0 if( $self->_is_object($$thing) ) {
321             if( my $string_meth = overload::Method($$thing, $type) ) {
322 0 0       0 $$thing = $$thing->$string_meth();
323 0         0 }
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 1     1 1 3  
342             sub _unoverload_num {
343 1 50       4 my $self = shift;
344 1         4  
345             $self->_unoverload('0+', @_);
346 1         4  
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         5 $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         6 }
384              
385 1 50 33     14 sub is_num {
386             my($self, $got, $expect, $name) = @_;
387             local $Level = $Level + 1;
388              
389             $self->_unoverload_num(\$got, \$expect);
390 1         13  
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         4 $self->_is_diag($got, '==', $expect) unless $test;
397             return $test;
398 1         52 }
399 1         6  
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         2 # quote and force string context
410 1 50       6 $$val = "'$$val'"
411             }
412 1 50       5 else {
413 1         3 # force numeric context
414 1         3 $self->_unoverload_num($val);
415 1         3 }
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         9  
428 1         3 }
429              
430             #line 600
431 1         5  
432 1         2 sub isnt_eq {
433             my($self, $got, $dont_expect, $name) = @_;
434 1         4 local $Level = $Level + 1;
435              
436 1 50       5 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       7 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         4 $self->ok($test, $name);
457             $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
458 2 50   2   12 return $test;
  2         1844  
459             }
460 2         8  
461 2 50       7 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   5 $self->_regex_ok($this, $regex, '=~', $name);
472             }
473 2 50   2   10  
  2 50       13  
474             sub unlike {
475             my($self, $this, $regex, $name) = @_;
476              
477             local $Level = $Level + 1;
478 2     2   5 $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         11  
1014 4         5  
1015 4         13 #line 1516
1016 4         5  
  4         9  
1017             sub summary {
1018 4 50       1197 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 3     3 1 4 my($self, $pack) = @_;
1034 3         3  
1035 3 50       7 return $self->{TODO} if defined $self->{TODO};
1036              
1037 3 50       13 $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       5 }
1081 0         0 }
1082              
1083 1         9 #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         7  
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 2     2   6 $self->diag(<<"FAIL");
1149             Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1150 2 50       6 FAIL
1151 0         0 }
1152              
1153 2         30 if ( $num_failed ) {
1154             my $num_tests = $self->{Curr_Test};
1155             my $s = $num_failed == 1 ? '' : 's';
1156 1     1   7  
  1         3  
  1         1672  
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;