File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 104 323 32.2
branch 31 166 18.6
condition 14 55 25.4
subroutine 18 49 36.7
pod 26 27 96.3
total 193 620 31.1


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 2     2   1715  
  2         6  
  2         104  
4 2     2   10 use 5.006;
  2         2  
  2         55  
5 2     2   8 use strict;
  2         14  
  2         229  
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 2     2   2061  
  2         29269  
  2         13  
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 2     2 1 92 $obj_name = 'The thing' unless defined $obj_name;
175 2         4 $diag = "$obj_name isn't defined";
176             }
177 2         4 else {
178 2         4 my $whatami = ref $object ? 'object' : 'class';
179 2         3 # We can't use UNIVERSAL::isa because we want to honor isa() overrides
  4         17  
180 2         4 my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
181             if($error) {
182 2 50 33     13 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         12 }
190             elsif( $error =~ /Can't call method "isa" without a package/ ) {
191             # It's something that can't even be a class
192 2         7 $obj_name = 'The thing' unless defined $obj_name;
193             $diag = "$obj_name isn't a class or reference";
194 2         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 1     1 1 5 $ok = $tb->ok( 1, $name );
220 1         11 }
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;