File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 124 323 38.3
branch 40 166 24.1
condition 14 55 25.4
subroutine 22 49 44.9
pod 26 27 96.3
total 226 620 36.4


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