File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 77 333 23.1
branch 8 168 4.7
condition 3 55 5.4
subroutine 17 48 35.4
pod 26 27 96.3
total 131 631 20.7


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