File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 40 276 14.4
branch 4 134 2.9
condition 2 42 4.7
subroutine 8 39 20.5
pod 21 22 95.4
total 75 513 14.6


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 1     1   795  
  1         3  
  1         37  
4             use 5.004;
5 1     1   6  
  1         1  
  1         93  
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 1     1   5  
  1         4  
  1         119  
19             use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
20             $VERSION = '0.72';
21             $VERSION = eval $VERSION; # make the alpha version come out as a number
22 1     1   633  
  1         4  
  1         8  
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 1     1 1 3 $obj_name = 'The object' unless defined $obj_name;
169 1         2 my $name = "$obj_name isa $class";
170             if( !defined $object ) {
171 1         3 $diag = "$obj_name isn't defined";
172 1         2 }
173 1         2 elsif( !ref $object ) {
  3         10  
174 2         5 $diag = "$obj_name isn't a reference";
175             }
176 2 50 33     26 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         4 my $ref = ref $object;
184             $diag = "$obj_name isn't a '$class' it's a '$ref'";
185             }
186 1         7 } 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 0 $tb->diag(<
260 0         0 Tried to use '$module'.
261             Error: $@
262 0         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              
318             sub _dne {
319             ref $_[0] eq ref $DNE;
320             }
321              
322              
323             sub is_deeply {
324             my $tb = Test::More->builder;
325              
326 0     0 1 0 unless( @_ == 2 or @_ == 3 ) {
327             my $msg = <
328 0         0 is_deeply() takes two or three args, you gave %d.
329             This usually means you passed an array or hash instead
330             of a reference to it
331             WARNING
332 0     0 1 0 chop $msg; # clip off newline so carp() will put in line/file
333              
334 0         0 _carp sprintf $msg, scalar @_;
335              
336             return $tb->ok(0);
337             }
338              
339             my($got, $expected, $name) = @_;
340              
341             $tb->_unoverload_str(\$expected, \$got);
342              
343             my $ok;
344             if( !ref $got and !ref $expected ) { # neither is a reference
345             $ok = $tb->is_eq($got, $expected, $name);
346             }
347             elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
348             $ok = $tb->ok(0, $name);
349             $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
350             }
351             else { # both references
352             local @Data_Stack = ();
353             if( _deep_check($got, $expected) ) {
354             $ok = $tb->ok(1, $name);
355             }
356             else {
357             $ok = $tb->ok(0, $name);
358             $tb->diag(_format_stack(@Data_Stack));
359             }
360             }
361              
362             return $ok;
363             }
364              
365             sub _format_stack {
366             my(@Stack) = @_;
367              
368             my $var = '$FOO';
369             my $did_arrow = 0;
370             foreach my $entry (@Stack) {
371 0     0 1 0 my $type = $entry->{type} || '';
372             my $idx = $entry->{'idx'};
373 0         0 if( $type eq 'HASH' ) {
374             $var .= "->" unless $did_arrow++;
375             $var .= "{$idx}";
376             }
377             elsif( $type eq 'ARRAY' ) {
378             $var .= "->" unless $did_arrow++;
379             $var .= "[$idx]";
380             }
381             elsif( $type eq 'REF' ) {
382             $var = "\${$var}";
383             }
384             }
385              
386             my @vals = @{$Stack[-1]{vals}}[0,1];
387 0     0 1 0 my @vars = ();
388             ($vars[0] = $var) =~ s/\$FOO/ \$got/;
389 0         0 ($vars[1] = $var) =~ s/\$FOO/\$expected/;
390              
391             my $out = "Structures begin differing at:\n";
392             foreach my $idx (0..$#vals) {
393             my $val = $vals[$idx];
394             $vals[$idx] = !defined $val ? 'undef' :
395             _dne($val) ? "Does not exist" :
396             ref $val ? "$val" :
397             "'$val'";
398             }
399              
400             $out .= "$vars[0] = $vals[0]\n";
401             $out .= "$vars[1] = $vals[1]\n";
402              
403             $out =~ s/^/ /msg;
404             return $out;
405             }
406              
407              
408             sub _type {
409             my $thing = shift;
410              
411             return '' if !ref $thing;
412              
413             for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
414             return $type if UNIVERSAL::isa($thing, $type);
415             }
416              
417             return '';
418             }
419              
420             #line 925
421              
422             sub diag {
423             my $tb = Test::More->builder;
424              
425             $tb->diag(@_);
426             }
427 0     0 1 0  
428              
429 0         0 #line 994
430              
431             #'#
432             sub skip {
433             my($why, $how_many) = @_;
434             my $tb = Test::More->builder;
435              
436             unless( defined $how_many ) {
437             # $how_many can only be avoided when no_plan is in use.
438             _carp "skip() needs to know \$how_many tests are in the block"
439             unless $tb->has_plan eq 'no_plan';
440             $how_many = 1;
441             }
442              
443             if( defined $how_many and $how_many =~ /\D/ ) {
444             _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
445             $how_many = 1;
446             }
447              
448             for( 1..$how_many ) {
449             $tb->skip($why);
450             }
451              
452             local $^W = 0;
453             last SKIP;
454             }
455              
456              
457             #line 1081
458              
459             sub todo_skip {
460             my($why, $how_many) = @_;
461             my $tb = Test::More->builder;
462              
463 0     0 1 0 unless( defined $how_many ) {
464 0   0     0 # $how_many can only be avoided when no_plan is in use.
465 0         0 _carp "todo_skip() needs to know \$how_many tests are in the block"
466             unless $tb->has_plan eq 'no_plan';
467 0 0       0 $how_many = 1;
468 0         0 }
469 0         0  
470 0         0 for( 1..$how_many ) {
471             $tb->todo_skip($why);
472             }
473 0 0       0  
474 0         0 local $^W = 0;
475 0         0 last TODO;
476 0         0 }
477              
478             #line 1134
479 0         0  
480 0         0 sub BAIL_OUT {
481 0 0   0   0 my $reason = shift;
  0         0  
482             my $tb = Test::More->builder;
483              
484 0         0 $tb->BAIL_OUT($reason);
485 0 0       0 }
486              
487             #line 1173
488 0         0  
489             #'#
490 0         0 sub eq_array {
491             local @Data_Stack;
492 0         0 _deep_check(@_);
493             }
494              
495             sub _eq_array {
496             my($a1, $a2) = @_;
497              
498             if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
499             warn "eq_array passed a non-array ref";
500             return 0;
501             }
502              
503             return 1 if $a1 eq $a2;
504              
505             my $ok = 1;
506             my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
507             for (0..$max) {
508             my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
509             my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
510              
511             push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
512             $ok = _deep_check($e1,$e2);
513             pop @Data_Stack if $ok;
514              
515             last unless $ok;
516             }
517              
518             return $ok;
519             }
520              
521             sub _deep_check {
522             my($e1, $e2) = @_;
523             my $tb = Test::More->builder;
524              
525 0     0 1 0 my $ok = 0;
526 0         0  
527             # Effectively turn %Refs_Seen into a stack. This avoids picking up
528 0         0 # the same referenced used twice (such as [\$a, \$a]) to be considered
529 0 0       0 # circular.
530 0         0 local %Refs_Seen = %Refs_Seen;
531 0 0       0  
    0          
532 0         0 {
533             # Quiet uninitialized value warnings when comparing undefs.
534             local $^W = 0;
535 0         0  
536             $tb->_unoverload_str(\$e1, \$e2);
537              
538             # Either they're both references or both not.
539 0     0   0 my $same_ref = !(!ref $e1 xor !ref $e2);
  0         0  
540 0 0       0 my $not_ref = (!ref $e1 and !ref $e2);
    0          
541 0 0       0  
542             if( defined $e1 xor defined $e2 ) {
543 0 0       0 $ok = 0;
544 0         0 }
545 0         0 elsif ( _dne($e1) xor _dne($e2) ) {
546             $ok = 0;
547             }
548 0         0 elsif ( $same_ref and ($e1 eq $e2) ) {
549             $ok = 1;
550             }
551             elsif ( $not_ref ) {
552             push @Data_Stack, { type => '', vals => [$e1, $e2] };
553             $ok = 0;
554             }
555             else {
556 0         0 if( $Refs_Seen{$e1} ) {
557 0         0 return $Refs_Seen{$e1} eq $e2;
558             }
559             else {
560             $Refs_Seen{$e1} = "$e2";
561             }
562              
563 0         0 my $type = _type($e1);
564 0 0       0 $type = 'DIFFERENT' unless _type($e2) eq $type;
565 0         0  
566 0         0 if( $type eq 'DIFFERENT' ) {
567             push @Data_Stack, { type => $type, vals => [$e1, $e2] };
568             $ok = 0;
569 0         0 }
570             elsif( $type eq 'ARRAY' ) {
571             $ok = _eq_array($e1, $e2);
572 0         0 }
573             elsif( $type eq 'HASH' ) {
574             $ok = _eq_hash($e1, $e2);
575             }
576             elsif( $type eq 'REF' ) {
577             push @Data_Stack, { type => $type, vals => [$e1, $e2] };
578             $ok = _deep_check($$e1, $$e2);
579             pop @Data_Stack if $ok;
580             }
581             elsif( $type eq 'SCALAR' ) {
582             push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
583             $ok = _deep_check($$e1, $$e2);
584             pop @Data_Stack if $ok;
585             }
586             elsif( $type ) {
587             push @Data_Stack, { type => $type, vals => [$e1, $e2] };
588             $ok = 0;
589             }
590             else {
591             _whoa(1, "No type in _deep_check");
592             }
593             }
594 0     0 1 0 }
595 0         0  
596             return $ok;
597             }
598              
599 0     0 1 0  
600 0         0 sub _whoa {
601             my($check, $desc) = @_;
602             if( $check ) {
603             die <
604             WHOA! $desc
605             This should never happen! Please contact the author immediately!
606             WHOA
607             }
608             }
609              
610              
611             #line 1304
612              
613             sub eq_hash {
614             local @Data_Stack;
615             return _deep_check(@_);
616             }
617              
618             sub _eq_hash {
619             my($a1, $a2) = @_;
620              
621             if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
622             warn "eq_hash passed a non-hash ref";
623             return 0;
624             }
625              
626             return 1 if $a1 eq $a2;
627              
628             my $ok = 1;
629             my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
630             foreach my $k (keys %$bigger) {
631             my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
632             my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
633              
634             push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
635             $ok = _deep_check($e1, $e2);
636             pop @Data_Stack if $ok;
637              
638             last unless $ok;
639             }
640              
641             return $ok;
642             }
643              
644             #line 1361
645              
646             sub eq_set {
647             my($a1, $a2) = @_;
648             return 0 unless @$a1 == @$a2;
649              
650             # There's faster ways to do this, but this is easiest.
651             local $^W = 0;
652              
653             # It really doesn't matter how we sort them, as long as both arrays are
654             # sorted with the same algorithm.
655 1     1 1 8 #
656 1 50       5 # Ensure that references are not accidentally treated the same as a
657 1         5 # string containing the reference.
658             #
659 1         4 # Have to inline the sort routine due to a threading/sort bug.
660             # See [rt.cpan.org 6782]
661 1         19 #
662             # I don't know how references would be sorted so we just don't sort
663 1 50 33     6 # them. This means eq_set doesn't really work with refs.
664             return eq_array(
665             [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
666 0         0 [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
667             );
668             }
669              
670             #line 1551
671              
672 1     1   7948 1;
  0         0  
  0         0  
  1         2767