File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 39 276 14.1
branch 4 134 2.9
condition 2 42 4.7
subroutine 8 36 22.2
pod 21 22 95.4
total 74 510 14.5


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