File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 134 314 42.6
branch 33 152 21.7
condition 15 49 30.6
subroutine 27 48 56.2
pod 25 26 96.1
total 234 589 39.7


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