File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 105 272 38.6
branch 39 134 29.1
condition 12 42 28.5
subroutine 16 37 43.2
pod 21 22 95.4
total 193 507 38.0


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 4     4   3018  
  4         15  
  4         154  
4             use 5.004;
5 4     4   20  
  4         6  
  4         350  
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 4     4   20  
  4         8  
  4         389  
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 4     4   3704  
  4         54806  
  4         27  
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 658 }
160              
161 2         48 #line 523
162              
163             sub isa_ok ($$;$) {
164             my($object, $class, $obj_name) = @_;
165             my $tb = Test::More->builder;
166              
167             my $diag;
168 4     4 1 157 $obj_name = 'The object' unless defined $obj_name;
169 4         7 my $name = "$obj_name isa $class";
170             if( !defined $object ) {
171 4         9 $diag = "$obj_name isn't defined";
172 4         7 }
173 4         26 elsif( !ref $object ) {
  6         28  
174 2         4 $diag = "$obj_name isn't a reference";
175             }
176 2 50 33     12 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 2         5 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
181             # Its an unblessed reference
182             if( !UNIVERSAL::isa($object, $class) ) {
183 2         3 my $ref = ref $object;
184             $diag = "$obj_name isn't a '$class' it's a '$ref'";
185             }
186 4         16 } 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 1     1 1 947 $tb->diag(<
260 1         10 Tried to use '$module'.
261             Error: $@
262 1         26 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 13     13 1 542 chop $msg; # clip off newline so carp() will put in line/file
327              
328 13         122 _carp sprintf $msg, scalar @_;
329              
330             return $tb->ok(0);
331             }
332 0     0 1 0  
333             my($got, $expected, $name) = @_;
334 0         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 0 elsif( $type eq 'ARRAY' ) {
372             $var .= "->" unless $did_arrow++;
373 0         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 0 my $val = $vals[$idx];
388             $vals[$idx] = !defined $val ? 'undef' :
389 0         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 0 my($why, $how_many) = @_;
428             my $tb = Test::More->builder;
429 0         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 0  
464 0   0     0 for( 1..$how_many ) {
465 0         0 $tb->todo_skip($why);
466             }
467 0 0       0  
468 0         0 local $^W = 0;
469 0         0 last TODO;
470 0         0 }
471              
472             #line 1128
473 0 0       0  
474 0         0 sub BAIL_OUT {
475 0         0 my $reason = shift;
476 0         0 my $tb = Test::More->builder;
477              
478             $tb->BAIL_OUT($reason);
479 0         0 }
480 0         0  
481 0 0   0   0 #line 1167
  0         0  
482              
483             #'#
484 0         0 sub eq_array {
485 0 0       0 local @Data_Stack;
486             _deep_check(@_);
487             }
488 0         0  
489             sub _eq_array {
490 0         0 my($a1, $a2) = @_;
491              
492 0         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 4     4 1 10132  
526 4         40 {
527             # Quiet uninitialized value warnings when comparing undefs.
528 4         49 local $^W = 0;
529 4 50       16  
530 4         15 $tb->_unoverload_str(\$e1, \$e2);
531 4 50       23  
    50          
532 0         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         0  
536             if( defined $e1 xor defined $e2 ) {
537             $ok = 0;
538             }
539 4     4   52 elsif ( $e1 == $DNE xor $e2 == $DNE ) {
  4         73  
540 4 50       69 $ok = 0;
    50          
541 0 0       0 }
542             elsif ( $same_ref and ($e1 eq $e2) ) {
543 0 0       0 $ok = 1;
544 0         0 }
545 0         0 elsif ( $not_ref ) {
546             push @Data_Stack, { type => '', vals => [$e1, $e2] };
547             $ok = 0;
548 0         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         0  
557 0         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 4         9 }
564 4 50       11 elsif( $type eq 'ARRAY' ) {
565 0         0 $ok = _eq_array($e1, $e2);
566 0         0 }
567             elsif( $type eq 'HASH' ) {
568             $ok = _eq_hash($e1, $e2);
569 4         18 }
570             elsif( $type eq 'REF' ) {
571             push @Data_Stack, { type => $type, vals => [$e1, $e2] };
572 4         2712 $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 0 sub _whoa {
595 0         0 my($check, $desc) = @_;
596             if( $check ) {
597             die <
598             WHOA! $desc
599 0     0 1 0 This should never happen! Please contact the author immediately!
600 0         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 0 #
656 0 0       0 # I don't know how references would be sorted so we just don't sort
657 0         0 # them. This means eq_set doesn't really work with refs.
658             return eq_array(
659 0         0 [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
660             [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
661 0         0 );
662             }
663 0 0 0     0  
664             #line 1545
665              
666 0         0 1;