File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 325 595 54.6
branch 84 298 28.1
condition 20 75 26.6
subroutine 59 89 66.2
pod 43 43 100.0
total 531 1100 48.2


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