File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 44 275 16.0
branch 4 134 2.9
condition 2 42 4.7
subroutine 10 38 26.3
pod 21 22 95.4
total 81 511 15.8


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 2     2   1570
  2         7  
  2         86  
4             use 5.004;
5 2     2   9
  2         4  
  2         204  
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 2     2   12
  2         8  
  2         228  
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 2     2   1364
  2         6  
  2         13  
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 0     0 1 0 }
160            
161 0         0 #line 523
162            
163             sub isa_ok ($$;$) {
164             my($object, $class, $obj_name) = @_;
165             my $tb = Test::More->builder;
166            
167             my $diag;
168 2     2 1 5 $obj_name = 'The object' unless defined $obj_name;
169 2         4 my $name = "$obj_name isa $class";
170             if( !defined $object ) {
171 2         7 $diag = "$obj_name isn't defined";
172 2         4 }
173 2         4 elsif( !ref $object ) {
  6         21  
174 4         9 $diag = "$obj_name isn't a reference";
175             }
176 4 50 33     29 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 4         9 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
181             # Its an unblessed reference
182             if( !UNIVERSAL::isa($object, $class) ) {
183 4         7 my $ref = ref $object;
184             $diag = "$obj_name isn't a '$class' it's a '$ref'";
185             }
186 2         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 36     36 1 354 $tb->diag(<
260 36         111 Tried to use '$module'.
261             Error: $@
262 36         113 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 18     18 1 303 chop $msg; # clip off newline so carp() will put in line/file
327            
328 18         59 _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 0     0 1 0
526 0         0 {
527             # Quiet uninitialized value warnings when comparing undefs.
528 0         0 local $^W = 0;
529 0 0       0
530 0         0 $tb->_unoverload_str(\$e1, \$e2);
531 0 0       0
    0          
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 0     0   0 elsif ( $e1 == $DNE xor $e2 == $DNE ) {
  0         0  
540 0 0       0 $ok = 0;
    0          
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 0         0 }
564 0 0       0 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 0         0 }
570             elsif( $type eq 'REF' ) {
571             push @Data_Stack, { type => $type, vals => [$e1, $e2] };
572 0         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 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 1     1 1 6 #
656 1 50       4 # I don't know how references would be sorted so we just don't sort
657 1         5 # them. This means eq_set doesn't really work with refs.
658             return eq_array(
659 1         3 [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
660             [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
661 1         12 );
662             }
663 1 50 33     7
664             #line 1545
665            
666 0         0 1;