File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 57 323 17.6
branch 5 166 3.0
condition 3 55 5.4
subroutine 11 49 22.4
pod 26 27 96.3
total 102 620 16.4


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 1     1   2035  
  1         4  
  1         56  
4 1     1   7 use 5.006;
  1         2  
  1         35  
5 1     1   5 use strict;
  1         16  
  1         144  
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.98';
22             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
23 1     1   1799  
  1         24073  
  1         7  
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 372
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 416
108              
109             sub like ($$;$) {
110             my $tb = Test::More->builder;
111              
112             return $tb->like(@_);
113             }
114              
115             #line 431
116              
117             sub unlike ($$;$) {
118             my $tb = Test::More->builder;
119              
120             return $tb->unlike(@_);
121             }
122              
123             #line 476
124              
125             sub cmp_ok($$$;$) {
126             my $tb = Test::More->builder;
127              
128             return $tb->cmp_ok(@_);
129             }
130              
131             #line 511
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 577
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 1     1 1 55 $obj_name = 'The thing' unless defined $obj_name;
175 1         2 $diag = "$obj_name isn't defined";
176             }
177 1         3 else {
178 1         3 my $whatami = ref $object ? 'object' : 'class';
179 1         2 # We can't use UNIVERSAL::isa because we want to honor isa() overrides
  3         12  
180 2         5 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         5 my $ref = ref $object;
187             $diag = "$obj_name isn't a '$class' it's a '$ref'";
188             }
189 2         13 }
190             elsif( $error =~ /Can't call method "isa" without a package/ ) {
191             # It's something that can't even be a class
192 1         4 $obj_name = 'The thing' unless defined $obj_name;
193             $diag = "$obj_name isn't a class or reference";
194 1         4 }
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 656
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 741
251              
252             sub subtest {
253             my ($name, $subtests) = @_;
254              
255             my $tb = Test::More->builder;
256             return $tb->subtest(@_);
257             }
258              
259             #line 765
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 833
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 0     0 1 0 }
292 0         0 else {
293             $code = <
294 0         0 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 902
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             my $module = shift;
370              
371             # Module names start with a letter.
372             # End with an alphanumeric.
373             # The rest is an alphanumeric or ::
374 0     0 1 0 $module =~ s/\b::\b//g;
375              
376 0         0 return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
377             }
378              
379             #line 979
380 0     0 1 0  
381             our( @Data_Stack, %Refs_Seen );
382 0         0 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             elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
414             $ok = $tb->ok( 0, $name );
415             $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
416             }
417             else { # both references
418 0     0 1 0 local @Data_Stack = ();
419             if( _deep_check( $got, $expected ) ) {
420 0         0 $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             return $ok;
429             }
430              
431             sub _format_stack {
432             my(@Stack) = @_;
433 0     0 1 0  
434             my $var = '$FOO';
435 0         0 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              
474             sub _type {
475             my $thing = shift;
476              
477             return '' if !ref $thing;
478 0     0 1 0  
479             for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
480 0         0 return $type if UNIVERSAL::isa( $thing, $type );
481             }
482              
483             return '';
484             }
485              
486             #line 1139
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 1165
497              
498             sub explain {
499             return Test::More->builder->explain(@_);
500             }
501              
502             #line 1231
503              
504             ## no critic (Subroutines::RequireFinalReturn)
505             sub skip {
506             my( $why, $how_many ) = @_;
507             my $tb = Test::More->builder;
508              
509             unless( defined $how_many ) {
510             # $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             unless $tb->has_plan eq 'no_plan';
513 0     0 1 0 $how_many = 1;
514 0   0     0 }
515 0         0  
516             if( defined $how_many and $how_many =~ /\D/ ) {
517 0 0       0 _carp
518 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              
522             for( 1 .. $how_many ) {
523 0 0       0 $tb->skip($why);
524 0         0 }
525 0         0  
526 0         0 no warnings 'exiting';
527             last SKIP;
528             }
529 0         0  
530 0         0 #line 1315
531 0 0   0   0  
  0         0  
532             sub todo_skip {
533             my( $why, $how_many ) = @_;
534 0 0       0 my $tb = Test::More->builder;
535              
536             unless( defined $how_many ) {
537 0         0 # $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 0         0 unless $tb->has_plan eq 'no_plan';
540             $how_many = 1;
541 0         0 }
542              
543             for( 1 .. $how_many ) {
544             $tb->todo_skip($why);
545             }
546              
547             no warnings 'exiting';
548             last TODO;
549             }
550              
551             #line 1370
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 1409
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             }
575              
576             return 1 if $a1 eq $a2;
577              
578             my $ok = 1;
579 0     0 1 0 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
580 0         0 for( 0 .. $max ) {
581             my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
582 0         0 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
583              
584 0 0       0 next if _equal_nonrefs($e1, $e2);
585 0 0       0  
586 0         0 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
587             $ok = _deep_check( $e1, $e2 );
588             pop @Data_Stack if $ok;
589 0 0       0  
590             last unless $ok;
591 0     0   0 }
  0         0  
592 0 0       0  
593 0 0       0 return $ok;
    0          
594             }
595 0 0       0  
596 0 0       0 sub _equal_nonrefs {
597 0         0 my( $e1, $e2 ) = @_;
598 0         0  
599             return if ref $e1 or ref $e2;
600              
601             if ( defined $e1 ) {
602             return 1 if defined $e2 and $e1 eq $e2;
603 0 0       0 }
604 0         0 else {
605             return 1 if !defined $e2;
606             }
607 0         0  
608             return;
609             }
610              
611             sub _deep_check {
612             my( $e1, $e2 ) = @_;
613             my $tb = Test::More->builder;
614              
615 0 0       0 my $ok = 0;
616 0 0       0  
617 0         0 # 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             # circular.
620             local %Refs_Seen = %Refs_Seen;
621              
622             {
623 0         0 $tb->_unoverload_str( \$e1, \$e2 );
624 0         0  
625 0 0       0 # Either they're both references or both not.
626 0         0 my $same_ref = !( !ref $e1 xor !ref $e2 );
627 0         0 my $not_ref = ( !ref $e1 and !ref $e2 );
628              
629             if( defined $e1 xor defined $e2 ) {
630 0         0 $ok = 0;
631             }
632             elsif( !defined $e1 and !defined $e2 ) {
633 0         0 # 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              
654             my $type = _type($e1);
655             $type = 'DIFFERENT' unless _type($e2) eq $type;
656              
657             if( $type eq 'DIFFERENT' ) {
658 0     0 1 0 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
659 0 0       0 $ok = 0;
660             }
661 0         0 elsif( $type eq 'ARRAY' ) {
662             $ok = _eq_array( $e1, $e2 );
663 0   0     0 }
664 0 0       0 elsif( $type eq 'HASH' ) {
665             $ok = _eq_hash( $e1, $e2 );
666 0         0 }
667 0     0   0 elsif( $type eq 'REF' ) {
  0         0  
  0         0  
668 0 0       0 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
669 0         0 $ok = _deep_check( $$e1, $$e2 );
670 0         0 pop @Data_Stack if $ok;
671             }
672             elsif( $type eq 'SCALAR' ) {
673 0         0 push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
674 0         0 $ok = _deep_check( $$e1, $$e2 );
675             pop @Data_Stack if $ok;
676             }
677 0         0 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 1556
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 1615
736              
737             sub eq_set {
738             my( $a1, $a2 ) = @_;
739             return 0 unless @$a1 == @$a2;
740              
741             no warnings 'uninitialized';
742              
743 0     0 1 0 # It really doesn't matter how we sort them, as long as both arrays are
744             # sorted with the same algorithm.
745 0         0 #
746 0         0 # 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 1817
761              
762             1;