File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 24 272 8.8
branch 0 134 0.0
condition 0 42 0.0
subroutine 7 37 18.9
pod 21 22 95.4
total 52 507 10.2


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