File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 132 332 39.7
branch 50 168 29.7
condition 17 55 30.9
subroutine 22 48 45.8
pod 26 27 96.3
total 247 630 39.2


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 32     32   48905  
  32         80  
4 32     32   119 use 5.006;
  32         35  
  32         590  
5 32     32   106 use strict;
  32         42  
  32         3520  
6             use warnings;
7              
8             #---- perlcritic exemptions. ----#
9              
10             # We use a lot of subroutine prototypes
11             ## no critic (Subroutines::ProhibitSubroutinePrototypes)
12              
13             # Can't use Carp because it might cause C to accidentally succeed
14             # even though the module being used forgot to use Carp. Yes, this
15             # actually happened.
16 0     0   0 sub _carp {
17 0         0 my( $file, $line ) = ( caller(1) )[ 1, 2 ];
18             return warn @_, " at $file line $line\n";
19             }
20              
21             our $VERSION = '1.001009';
22             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
23 32     32   12163  
  32         573  
  32         140  
24             use Test::Builder::Module 0.99;
25             our @ISA = qw(Test::Builder::Module);
26             our @EXPORT = qw(ok use_ok require_ok
27             is isnt like unlike is_deeply
28             cmp_ok
29             skip todo todo_skip
30             pass fail
31             eq_array eq_hash eq_set
32             $TODO
33             plan
34             done_testing
35             can_ok isa_ok new_ok
36             diag note explain
37             subtest
38             BAIL_OUT
39             );
40              
41             #line 163
42              
43             sub plan {
44             my $tb = Test::More->builder;
45              
46             return $tb->plan(@_);
47             }
48              
49             # This implements "use Test::More 'no_diag'" but the behavior is
50             # deprecated.
51             sub import_extra {
52             my $class = shift;
53             my $list = shift;
54              
55             my @other = ();
56             my $idx = 0;
57             while( $idx <= $#{$list} ) {
58             my $item = $list->[$idx];
59              
60             if( defined $item and $item eq 'no_diag' ) {
61             $class->builder->no_diag(1);
62             }
63             else {
64             push @other, $item;
65             }
66              
67             $idx++;
68             }
69              
70             @$list = @other;
71              
72             return;
73             }
74              
75             #line 216
76              
77             sub done_testing {
78             my $tb = Test::More->builder;
79             $tb->done_testing(@_);
80             }
81              
82             #line 288
83              
84             sub ok ($;$) {
85             my( $test, $name ) = @_;
86             my $tb = Test::More->builder;
87              
88             return $tb->ok( $test, $name );
89             }
90              
91             #line 371
92              
93             sub is ($$;$) {
94             my $tb = Test::More->builder;
95              
96             return $tb->is_eq(@_);
97             }
98              
99             sub isnt ($$;$) {
100             my $tb = Test::More->builder;
101              
102             return $tb->isnt_eq(@_);
103             }
104              
105             *isn't = \&isnt;
106             # ' to unconfuse syntax higlighters
107              
108             #line 416
109              
110             sub like ($$;$) {
111             my $tb = Test::More->builder;
112              
113             return $tb->like(@_);
114             }
115              
116             #line 431
117              
118             sub unlike ($$;$) {
119             my $tb = Test::More->builder;
120              
121             return $tb->unlike(@_);
122             }
123              
124             #line 477
125              
126             sub cmp_ok($$$;$) {
127             my $tb = Test::More->builder;
128              
129             return $tb->cmp_ok(@_);
130             }
131              
132             #line 512
133              
134             sub can_ok ($@) {
135             my( $proto, @methods ) = @_;
136             my $class = ref $proto || $proto;
137             my $tb = Test::More->builder;
138              
139             unless($class) {
140             my $ok = $tb->ok( 0, "->can(...)" );
141             $tb->diag(' can_ok() called with empty class or reference');
142             return $ok;
143             }
144              
145             unless(@methods) {
146             my $ok = $tb->ok( 0, "$class->can(...)" );
147             $tb->diag(' can_ok() called with no methods');
148             return $ok;
149             }
150              
151             my @nok = ();
152             foreach my $method (@methods) {
153             $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
154             }
155              
156             my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
157             "$class->can(...)" ;
158              
159             my $ok = $tb->ok( !@nok, $name );
160              
161             $tb->diag( map " $class->can('$_') failed\n", @nok );
162              
163             return $ok;
164             }
165 13     13 1 1211  
166             #line 578
167 13         63  
168             sub isa_ok ($$;$) {
169             my( $thing, $class, $thing_name ) = @_;
170             my $tb = Test::More->builder;
171              
172             my $whatami;
173 44     44 1 65 if( !defined $thing ) {
174 44         597 $whatami = 'undef';
175             }
176 44         981 elsif( ref $thing ) {
177 44         57 $whatami = 'reference';
178 44         765  
  81         201  
179 37         57 local($@,$!);
180             require Scalar::Util;
181 37 50 33     1400 if( Scalar::Util::blessed($thing) ) {
182 0         0 $whatami = 'object';
183             }
184             }
185 37         53 else {
186             $whatami = 'class';
187             }
188 37         34  
189             # We can't use UNIVERSAL::isa because we want to honor isa() overrides
190             my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } );
191 44         1051  
192             if($error) {
193 44         99 die <
194             WHOA! I tried to call ->isa on your $whatami and got some weird error.
195             Here's the error.
196             $error
197             WHOA
198             }
199              
200             # Special case for isa_ok( [], "ARRAY" ) and like
201             if( $whatami eq 'reference' ) {
202             $rslt = UNIVERSAL::isa($thing, $class);
203             }
204              
205             my($diag, $name);
206             if( defined $thing_name ) {
207             $name = "'$thing_name' isa '$class'";
208             $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined";
209             }
210             elsif( $whatami eq 'object' ) {
211             my $my_class = ref $thing;
212             $thing_name = qq[An object of class '$my_class'];
213             $name = "$thing_name isa '$class'";
214             $diag = "The object of class '$my_class' isn't a '$class'";
215             }
216             elsif( $whatami eq 'reference' ) {
217             my $type = ref $thing;
218 0     0 1 0 $thing_name = qq[A reference of type '$type'];
219 0         0 $name = "$thing_name isa '$class'";
220             $diag = "The reference of type '$type' isn't a '$class'";
221             }
222             elsif( $whatami eq 'undef' ) {
223             $thing_name = 'undef';
224             $name = "$thing_name isa '$class'";
225             $diag = "$thing_name isn't defined";
226             }
227             elsif( $whatami eq 'class' ) {
228             $thing_name = qq[The class (or class-like) '$thing'];
229             $name = "$thing_name isa '$class'";
230             $diag = "$thing_name isn't a '$class'";
231             }
232             else {
233             die;
234             }
235              
236             my $ok;
237             if($rslt) {
238             $ok = $tb->ok( 1, $name );
239             }
240             else {
241             $ok = $tb->ok( 0, $name );
242             $tb->diag(" $diag\n");
243             }
244              
245             return $ok;
246             }
247              
248             #line 679
249              
250             sub new_ok {
251             my $tb = Test::More->builder;
252             $tb->croak("new_ok() must be given at least a class") unless @_;
253              
254             my( $class, $args, $object_name ) = @_;
255              
256             $args ||= [];
257              
258             my $obj;
259             my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
260             if($success) {
261             local $Test::Builder::Level = $Test::Builder::Level + 1;
262             isa_ok $obj, $class, $object_name;
263             }
264             else {
265             $class = 'undef' if !defined $class;
266             $tb->ok( 0, "$class->new() died" );
267             $tb->diag(" Error was: $error");
268             }
269              
270             return $obj;
271             }
272              
273             #line 765
274              
275             sub subtest {
276             my ($name, $subtests) = @_;
277              
278             my $tb = Test::More->builder;
279             return $tb->subtest(@_);
280             }
281              
282             #line 789
283              
284             sub pass (;$) {
285             my $tb = Test::More->builder;
286              
287             return $tb->ok( 1, @_ );
288             }
289              
290 16     16 1 484 sub fail (;$) {
291 16         125 my $tb = Test::More->builder;
292              
293 16         67 return $tb->ok( 0, @_ );
294             }
295              
296             #line 842
297              
298             sub require_ok ($) {
299             my($module) = shift;
300             my $tb = Test::More->builder;
301              
302             my $pack = caller;
303              
304             # Try to determine if we've been given a module name or file.
305             # Module names must be barewords, files not.
306             $module = qq['$module'] unless _is_module_name($module);
307              
308             my $code = <
309             package $pack;
310             require $module;
311             1;
312             REQUIRE
313              
314             my( $eval_result, $eval_error ) = _eval($code);
315             my $ok = $tb->ok( $eval_result, "require $module;" );
316              
317             unless($ok) {
318             chomp $eval_error;
319             $tb->diag(<
320             Tried to require '$module'.
321             Error: $eval_error
322             DIAGNOSTIC
323              
324             }
325              
326             return $ok;
327             }
328              
329             sub _is_module_name {
330             my $module = shift;
331              
332             # Module names start with a letter.
333             # End with an alphanumeric.
334             # The rest is an alphanumeric or ::
335             $module =~ s/\b::\b//g;
336              
337             return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
338             }
339              
340              
341             #line 936
342              
343             sub use_ok ($;@) {
344             my( $module, @imports ) = @_;
345             @imports = () unless @imports;
346             my $tb = Test::More->builder;
347              
348             my( $pack, $filename, $line ) = caller;
349             $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line
350              
351             my $code;
352             if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
353             # probably a version check. Perl needs to see the bare number
354             # for it to work with non-Exporter based modules.
355             $code = <
356             package $pack;
357              
358             #line $line $filename
359             use $module $imports[0];
360             1;
361             USE
362             }
363             else {
364             $code = <
365             package $pack;
366              
367             #line $line $filename
368             use $module \@{\$args[0]};
369             1;
370             USE
371             }
372              
373 584     584 1 112362 my( $eval_result, $eval_error ) = _eval( $code, \@imports );
374             my $ok = $tb->ok( $eval_result, "use $module;" );
375 584         1821  
376             unless($ok) {
377             chomp $eval_error;
378             $@ =~ s{^BEGIN failed--compilation aborted at .*$}
379 3     3 1 18 {BEGIN failed--compilation aborted at $filename line $line.}m;
380             $tb->diag(<
381 3         9 Tried to use '$module'.
382             Error: $eval_error
383             DIAGNOSTIC
384              
385             }
386              
387             return $ok;
388             }
389              
390             sub _eval {
391             my( $code, @args ) = @_;
392              
393             # Work around oddities surrounding resetting of $@ by immediately
394             # storing it.
395             my( $sigdie, $eval_result, $eval_error );
396             {
397             local( $@, $!, $SIG{__DIE__} ); # isolate eval
398             $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
399             $eval_error = $@;
400             $sigdie = $SIG{__DIE__} || undef;
401             }
402             # make sure that $code got a chance to set $SIG{__DIE__}
403             $SIG{__DIE__} = $sigdie if defined $sigdie;
404              
405             return( $eval_result, $eval_error );
406             }
407              
408              
409             #line 1037
410              
411             our( @Data_Stack, %Refs_Seen );
412             my $DNE = bless [], 'Does::Not::Exist';
413              
414             sub _dne {
415             return ref $_[0] eq ref $DNE;
416             }
417              
418 15     15 1 652 ## no critic (Subroutines::RequireArgUnpacking)
419             sub is_deeply {
420 15         49 my $tb = Test::More->builder;
421              
422             unless( @_ == 2 or @_ == 3 ) {
423             my $msg = <<'WARNING';
424             is_deeply() takes two or three args, you gave %d.
425             This usually means you passed an array or hash instead
426             of a reference to it
427             WARNING
428             chop $msg; # clip off newline so carp() will put in line/file
429              
430             _carp sprintf $msg, scalar @_;
431              
432             return $tb->ok(0);
433 3     3 1 155 }
434              
435 3         12 my( $got, $expected, $name ) = @_;
436              
437             $tb->_unoverload_str( \$expected, \$got );
438              
439             my $ok;
440             if( !ref $got and !ref $expected ) { # neither is a reference
441             $ok = $tb->is_eq( $got, $expected, $name );
442             }
443             elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
444             $ok = $tb->ok( 0, $name );
445             $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
446             }
447             else { # both references
448             local @Data_Stack = ();
449             if( _deep_check( $got, $expected ) ) {
450             $ok = $tb->ok( 1, $name );
451             }
452             else {
453             $ok = $tb->ok( 0, $name );
454             $tb->diag( _format_stack(@Data_Stack) );
455             }
456             }
457              
458             return $ok;
459             }
460              
461             sub _format_stack {
462             my(@Stack) = @_;
463              
464             my $var = '$FOO';
465             my $did_arrow = 0;
466             foreach my $entry (@Stack) {
467             my $type = $entry->{type} || '';
468             my $idx = $entry->{'idx'};
469             if( $type eq 'HASH' ) {
470             $var .= "->" unless $did_arrow++;
471             $var .= "{$idx}";
472             }
473             elsif( $type eq 'ARRAY' ) {
474             $var .= "->" unless $did_arrow++;
475             $var .= "[$idx]";
476             }
477             elsif( $type eq 'REF' ) {
478             $var = "\${$var}";
479 0     0 1 0 }
480             }
481 0         0  
482             my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
483             my @vars = ();
484             ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
485             ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
486              
487             my $out = "Structures begin differing at:\n";
488             foreach my $idx ( 0 .. $#vals ) {
489             my $val = $vals[$idx];
490             $vals[$idx]
491             = !defined $val ? 'undef'
492             : _dne($val) ? "Does not exist"
493             : ref $val ? "$val"
494             : "'$val'";
495             }
496              
497             $out .= "$vars[0] = $vals[0]\n";
498             $out .= "$vars[1] = $vals[1]\n";
499              
500             $out =~ s/^/ /msg;
501             return $out;
502             }
503              
504             sub _type {
505             my $thing = shift;
506              
507             return '' if !ref $thing;
508              
509             for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
510             return $type if UNIVERSAL::isa( $thing, $type );
511             }
512              
513             return '';
514 0     0 1 0 }
515 0   0     0  
516 0         0 #line 1197
517              
518 0 0       0 sub diag {
519 0         0 return Test::More->builder->diag(@_);
520 0         0 }
521 0         0  
522             sub note {
523             return Test::More->builder->note(@_);
524 0 0       0 }
525 0         0  
526 0         0 #line 1223
527 0         0  
528             sub explain {
529             return Test::More->builder->explain(@_);
530 0         0 }
531 0         0  
532 0 0   0   0 #line 1289
  0         0  
533              
534             ## no critic (Subroutines::RequireFinalReturn)
535 0 0       0 sub skip {
536             my( $why, $how_many ) = @_;
537             my $tb = Test::More->builder;
538 0         0  
539             unless( defined $how_many ) {
540 0         0 # $how_many can only be avoided when no_plan is in use.
541             _carp "skip() needs to know \$how_many tests are in the block"
542 0         0 unless $tb->has_plan eq 'no_plan';
543             $how_many = 1;
544             }
545              
546             if( defined $how_many and $how_many =~ /\D/ ) {
547             _carp
548             "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
549             $how_many = 1;
550             }
551              
552             for( 1 .. $how_many ) {
553             $tb->skip($why);
554             }
555              
556             no warnings 'exiting';
557             last SKIP;
558             }
559              
560             #line 1373
561              
562             sub todo_skip {
563             my( $why, $how_many ) = @_;
564             my $tb = Test::More->builder;
565              
566             unless( defined $how_many ) {
567             # $how_many can only be avoided when no_plan is in use.
568             _carp "todo_skip() needs to know \$how_many tests are in the block"
569             unless $tb->has_plan eq 'no_plan';
570             $how_many = 1;
571             }
572              
573             for( 1 .. $how_many ) {
574             $tb->todo_skip($why);
575             }
576              
577             no warnings 'exiting';
578             last TODO;
579             }
580 0     0 1 0  
581 0         0 #line 1428
582              
583 0         0 sub BAIL_OUT {
584 0 0       0 my $reason = shift;
    0          
585 0         0 my $tb = Test::More->builder;
586              
587             $tb->BAIL_OUT($reason);
588 0         0 }
589              
590 0         0 #line 1467
591 0         0  
592 0 0       0 #'#
593 0         0 sub eq_array {
594             local @Data_Stack = ();
595             _deep_check(@_);
596             }
597 0         0  
598             sub _eq_array {
599             my( $a1, $a2 ) = @_;
600              
601 0     0   0 if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
  0         0  
602             warn "eq_array passed a non-array ref";
603 0 0       0 return 0;
604 0 0       0 }
605              
606             return 1 if $a1 eq $a2;
607              
608             my $ok = 1;
609             my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
610             for( 0 .. $max ) {
611             my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
612 0 0       0 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
613 0         0  
614             next if _equal_nonrefs($e1, $e2);
615              
616 0         0 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
617 0 0       0 $ok = _deep_check( $e1, $e2 );
    0          
    0          
    0          
    0          
618 0         0 pop @Data_Stack if $ok;
619 0 0       0  
620             last unless $ok;
621             }
622 0         0  
623 0         0 return $ok;
624 0         0 }
625 0         0  
626             sub _equal_nonrefs {
627             my( $e1, $e2 ) = @_;
628 0         0  
629 0         0 return if ref $e1 or ref $e2;
630 0         0  
631 0         0 if ( defined $e1 ) {
632             return 1 if defined $e2 and $e1 eq $e2;
633             }
634 0         0 else {
635 0         0 return 1 if !defined $e2;
636 0         0 }
637              
638             return;
639 0         0 }
640 0         0  
641 0         0 sub _deep_check {
642             my( $e1, $e2 ) = @_;
643             my $tb = Test::More->builder;
644 0         0  
645             my $ok = 0;
646              
647 0         0 # Effectively turn %Refs_Seen into a stack. This avoids picking up
648 0 0       0 # the same referenced used twice (such as [\$a, \$a]) to be considered
649 0         0 # circular.
650             local %Refs_Seen = %Refs_Seen;
651              
652 0         0 {
653 0         0 $tb->_unoverload_str( \$e1, \$e2 );
654              
655             # Either they're both references or both not.
656 0         0 my $same_ref = !( !ref $e1 xor !ref $e2 );
657             my $not_ref = ( !ref $e1 and !ref $e2 );
658              
659             if( defined $e1 xor defined $e2 ) {
660             $ok = 0;
661             }
662             elsif( !defined $e1 and !defined $e2 ) {
663             # Shortcut if they're both undefined.
664             $ok = 1;
665             }
666             elsif( _dne($e1) xor _dne($e2) ) {
667             $ok = 0;
668             }
669             elsif( $same_ref and( $e1 eq $e2 ) ) {
670             $ok = 1;
671             }
672             elsif($not_ref) {
673             push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
674             $ok = 0;
675             }
676             else {
677             if( $Refs_Seen{$e1} ) {
678             return $Refs_Seen{$e1} eq $e2;
679             }
680             else {
681 0     0 1 0 $Refs_Seen{$e1} = "$e2";
682 0 0       0 }
683              
684 0         0 my $type = _type($e1);
685             $type = 'DIFFERENT' unless _type($e2) eq $type;
686 0   0     0  
687             if( $type eq 'DIFFERENT' ) {
688 0         0 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
689 0     0   0 $ok = 0;
  0         0  
  0         0  
690 0 0       0 }
691 0         0 elsif( $type eq 'ARRAY' ) {
692 0         0 $ok = _eq_array( $e1, $e2 );
693             }
694             elsif( $type eq 'HASH' ) {
695 0 0       0 $ok = _eq_hash( $e1, $e2 );
696 0         0 }
697 0         0 elsif( $type eq 'REF' ) {
698             push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
699             $ok = _deep_check( $$e1, $$e2 );
700 0         0 pop @Data_Stack if $ok;
701             }
702             elsif( $type eq 'SCALAR' ) {
703             push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
704             $ok = _deep_check( $$e1, $$e2 );
705             pop @Data_Stack if $ok;
706             }
707             elsif($type) {
708             push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
709             $ok = 0;
710             }
711             else {
712             _whoa( 1, "No type in _deep_check" );
713             }
714             }
715             }
716              
717             return $ok;
718             }
719              
720             sub _whoa {
721             my( $check, $desc ) = @_;
722             if($check) {
723             die <<"WHOA";
724             WHOA! $desc
725             This should never happen! Please contact the author immediately!
726             WHOA
727             }
728             }
729              
730             #line 1614
731              
732             sub eq_hash {
733             local @Data_Stack = ();
734             return _deep_check(@_);
735             }
736              
737             sub _eq_hash {
738             my( $a1, $a2 ) = @_;
739              
740             if( grep _type($_) ne 'HASH', $a1, $a2 ) {
741             warn "eq_hash passed a non-hash ref";
742             return 0;
743             }
744              
745             return 1 if $a1 eq $a2;
746              
747             my $ok = 1;
748             my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
749             foreach my $k ( keys %$bigger ) {
750             my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
751             my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
752              
753             next if _equal_nonrefs($e1, $e2);
754              
755             push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
756             $ok = _deep_check( $e1, $e2 );
757             pop @Data_Stack if $ok;
758              
759             last unless $ok;
760             }
761              
762             return $ok;
763             }
764              
765             #line 1673
766              
767 0     0 1 0 sub eq_set {
768             my( $a1, $a2 ) = @_;
769 0         0 return 0 unless @$a1 == @$a2;
770 0         0  
771             no warnings 'uninitialized';
772              
773             # It really doesn't matter how we sort them, as long as both arrays are
774             # sorted with the same algorithm.
775             #
776             # Ensure that references are not accidentally treated the same as a
777             # string containing the reference.
778             #
779             # Have to inline the sort routine due to a threading/sort bug.
780             # See [rt.cpan.org 6782]
781             #
782             # I don't know how references would be sorted so we just don't sort
783             # them. This means eq_set doesn't really work with refs.
784             return eq_array(
785             [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
786             [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
787             );
788             }
789              
790             #line 1946
791 0     0 1 0  
792             1;