File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 141 318 44.3
branch 44 154 28.5
condition 15 49 30.6
subroutine 23 49 46.9
pod 26 27 96.3
total 249 597 41.7


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 5     5   4745  
  5         14  
  5         302  
4 5     5   27 use 5.006;
  5         8  
  5         129  
5 5     5   162 use strict;
  5         13  
  5         4227  
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.94';
22             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
23 5     5   11041  
  5         17  
  5         32  
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 5     5 1 10 $obj_name = 'The thing' unless defined $obj_name;
175 5         11 $diag = "$obj_name isn't defined";
176             }
177 5         10 else {
178 5         10 my $whatami = ref $object ? 'object' : 'class';
179 5         8 # We can't use UNIVERSAL::isa because we want to honor isa() overrides
  15         44  
180 10         21 my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
181             if($error) {
182 10 50 33     63 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 10         22 my $ref = ref $object;
187             $diag = "$obj_name isn't a '$class' it's a '$ref'";
188             }
189 10         16 }
190             elsif( $error =~ /Can't call method "isa" without a package/ ) {
191             # It's something that can't even be a class
192 5         21 $obj_name = 'The thing' unless defined $obj_name;
193             $diag = "$obj_name isn't a class or reference";
194 5         18 }
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 0     0 1 0 $ok = $tb->ok( 1, $name );
220 0         0 }
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 719
251              
252             sub subtest($&) {
253             my ($name, $subtests) = @_;
254              
255             my $tb = Test::More->builder;
256             return $tb->subtest(@_);
257             }
258              
259             #line 743
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 806
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 10     10 1 202 }
292 10         70 else {
293             $code = <
294 10         40 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 875
336              
337             sub require_ok ($) {
338             my($module) = shift;
339             my $tb = Test::More->builder;
340              
341             my $pack = caller;
342              
343             # Try to deterine 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 8     8 1 112 my $module = shift;
370              
371 8         44 # 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 952
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 2     2 1 43 elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
414             $ok = $tb->ok( 0, $name );
415 2         14 $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(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
480             return $type if UNIVERSAL::isa( $thing, $type );
481             }
482              
483             return '';
484             }
485              
486             #line 1112
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 1138
497              
498             sub explain {
499             return Test::More->builder->explain(@_);
500             }
501              
502             #line 1204
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 1288
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 1343
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 1382
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 5     5 1 40 }
575 5         62  
576             return 1 if $a1 eq $a2;
577 5         13  
578             my $ok = 1;
579 5 50       22 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 5 50       24 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
585             $ok = _deep_check( $e1, $e2 );
586 5     5   58 pop @Data_Stack if $ok;
  5         51  
587 5 50       36  
588 0 0       0 last unless $ok;
    0          
589             }
590 0 0       0  
591 0 0       0 return $ok;
592 0         0 }
593 0         0  
594             sub _deep_check {
595             my( $e1, $e2 ) = @_;
596             my $tb = Test::More->builder;
597              
598 0 0       0 my $ok = 0;
599 0         0  
600             # Effectively turn %Refs_Seen into a stack. This avoids picking up
601             # the same referenced used twice (such as [\$a, \$a]) to be considered
602 0         0 # circular.
603             local %Refs_Seen = %Refs_Seen;
604              
605             {
606             # Quiet uninitialized value warnings when comparing undefs.
607             no warnings 'uninitialized';
608              
609             $tb->_unoverload_str( \$e1, \$e2 );
610 5 50       28  
611 5 50       69 # Either they're both references or both not.
612 0         0 my $same_ref = !( !ref $e1 xor !ref $e2 );
613 0         0 my $not_ref = ( !ref $e1 and !ref $e2 );
614              
615             if( defined $e1 xor defined $e2 ) {
616             $ok = 0;
617             }
618 5         20 elsif( !defined $e1 and !defined $e2 ) {
619 5         12 # Shortcut if they're both defined.
620 5 50       18 $ok = 1;
621 0         0 }
622 0         0 elsif( _dne($e1) xor _dne($e2) ) {
623             $ok = 0;
624             }
625 5         32 elsif( $same_ref and( $e1 eq $e2 ) ) {
626             $ok = 1;
627             }
628 5         17 elsif($not_ref) {
629             push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
630             $ok = 0;
631             }
632             else {
633             if( $Refs_Seen{$e1} ) {
634             return $Refs_Seen{$e1} eq $e2;
635             }
636             else {
637             $Refs_Seen{$e1} = "$e2";
638             }
639              
640             my $type = _type($e1);
641             $type = 'DIFFERENT' unless _type($e2) eq $type;
642              
643             if( $type eq 'DIFFERENT' ) {
644             push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
645             $ok = 0;
646             }
647             elsif( $type eq 'ARRAY' ) {
648             $ok = _eq_array( $e1, $e2 );
649             }
650             elsif( $type eq 'HASH' ) {
651             $ok = _eq_hash( $e1, $e2 );
652             }
653 0     0 1 0 elsif( $type eq 'REF' ) {
654 0 0       0 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
655             $ok = _deep_check( $$e1, $$e2 );
656 0         0 pop @Data_Stack if $ok;
657             }
658 0   0     0 elsif( $type eq 'SCALAR' ) {
659 0 0       0 push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
660             $ok = _deep_check( $$e1, $$e2 );
661 0         0 pop @Data_Stack if $ok;
662 0     0   0 }
  0         0  
  0         0  
663 0 0       0 elsif($type) {
664 0         0 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
665 0         0 $ok = 0;
666             }
667             else {
668 0         0 _whoa( 1, "No type in _deep_check" );
669 0         0 }
670             }
671             }
672 0         0  
673             return $ok;
674             }
675              
676             sub _whoa {
677             my( $check, $desc ) = @_;
678             if($check) {
679             die <<"WHOA";
680             WHOA! $desc
681             This should never happen! Please contact the author immediately!
682             WHOA
683             }
684             }
685              
686             #line 1515
687              
688             sub eq_hash {
689             local @Data_Stack = ();
690             return _deep_check(@_);
691             }
692              
693             sub _eq_hash {
694             my( $a1, $a2 ) = @_;
695              
696             if( grep _type($_) ne 'HASH', $a1, $a2 ) {
697             warn "eq_hash passed a non-hash ref";
698             return 0;
699             }
700              
701             return 1 if $a1 eq $a2;
702              
703             my $ok = 1;
704             my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
705             foreach my $k ( keys %$bigger ) {
706             my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
707             my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
708              
709             push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
710             $ok = _deep_check( $e1, $e2 );
711             pop @Data_Stack if $ok;
712              
713             last unless $ok;
714             }
715              
716             return $ok;
717             }
718              
719             #line 1572
720              
721 0     0 1 0 sub eq_set {
722             my( $a1, $a2 ) = @_;
723 0         0 return 0 unless @$a1 == @$a2;
724 0         0  
725             no warnings 'uninitialized';
726              
727             # It really doesn't matter how we sort them, as long as both arrays are
728             # sorted with the same algorithm.
729             #
730             # Ensure that references are not accidentally treated the same as a
731             # string containing the reference.
732             #
733             # Have to inline the sort routine due to a threading/sort bug.
734             # See [rt.cpan.org 6782]
735             #
736             # I don't know how references would be sorted so we just don't sort
737             # them. This means eq_set doesn't really work with refs.
738             return eq_array(
739             [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
740             [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
741             );
742             }
743              
744             #line 1774
745 0     0 1 0  
746             1;