File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 35 333 10.5
branch 1 168 0.6
condition 1 55 1.8
subroutine 9 48 18.7
pod 26 27 96.3
total 72 631 11.4


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 1     1   541  
  1         2  
  1         36  
4 1     1   4 use 5.006;
  1         2  
  1         25  
5 1     1   3 use strict;
  1         4  
  1         100  
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.001014';
22             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
23 1     1   372  
  1         24  
  1         5  
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 0     0 1 0  
166             #line 578
167 0         0  
168             sub isa_ok ($$;$) {
169             my( $thing, $class, $thing_name ) = @_;
170             my $tb = Test::More->builder;
171              
172             my $whatami;
173 1     1 1 2 if( !defined $thing ) {
174 1         2 $whatami = 'undef';
175             }
176 1         1 elsif( ref $thing ) {
177 1         2 $whatami = 'reference';
178 1         2  
  3         7  
179 2         3 local($@,$!);
180             require Scalar::Util;
181 2 50 33     15 if( Scalar::Util::blessed($thing) ) {
182 0         0 $whatami = 'object';
183             }
184             }
185 2         3 else {
186             $whatami = 'class';
187             }
188 2         3  
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 1         3  
192             if($error) {
193 1         3 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 0     0 1 0 sub fail (;$) {
291 0         0 my $tb = Test::More->builder;
292              
293 0         0 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 0     0 1 0 my( $eval_result, $eval_error ) = _eval( $code, \@imports );
374             my $ok = $tb->ok( $eval_result, "use $module;" );
375 0         0  
376             unless($ok) {
377             chomp $eval_error;
378             $@ =~ s{^BEGIN failed--compilation aborted at .*$}
379 0     0 1 0 {BEGIN failed--compilation aborted at $filename line $line.}m;
380             $tb->diag(<
381 0         0 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 0     0 1 0 ## no critic (Subroutines::RequireArgUnpacking)
419             sub is_deeply {
420 0         0 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 0     0 1 0 }
434              
435 0         0 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 1     1 1 16  
792             1;