File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 158 276 57.2
branch 62 134 46.2
condition 16 42 38.1
subroutine 21 39 53.8
pod 21 22 95.4
total 278 513 54.1


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 11     11   9010  
  11         40  
  11         475  
4             use 5.004;
5 11     11   157  
  11         21  
  11         1114  
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 11     11   65  
  11         22  
  11         1254  
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 11     11   8707  
  11         36  
  11         73  
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 3     3 1 49 }
160              
161 3         19 #line 523
162              
163             sub isa_ok ($$;$) {
164             my($object, $class, $obj_name) = @_;
165             my $tb = Test::More->builder;
166              
167             my $diag;
168 11     11 1 28 $obj_name = 'The object' unless defined $obj_name;
169 11         25 my $name = "$obj_name isa $class";
170             if( !defined $object ) {
171 11         34 $diag = "$obj_name isn't defined";
172 11         24 }
173 11         24 elsif( !ref $object ) {
  27         1566  
174 16         43 $diag = "$obj_name isn't a reference";
175             }
176 16 50 33     117 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 16         40 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
181             # Its an unblessed reference
182             if( !UNIVERSAL::isa($object, $class) ) {
183 16         44 my $ref = ref $object;
184             $diag = "$obj_name isn't a '$class' it's a '$ref'";
185             }
186 11         56 } 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 5     5 1 120 unless( @_ == 2 or @_ == 3 ) {
327             my $msg = <
328 5         37 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 19     19 1 104 unless( defined $how_many ) {
464 19   33     55 # $how_many can only be avoided when no_plan is in use.
465 19         75 _carp "todo_skip() needs to know \$how_many tests are in the block"
466             unless $tb->has_plan eq 'no_plan';
467 19 50       52 $how_many = 1;
468 0         0 }
469 0         0  
470 0         0 for( 1..$how_many ) {
471             $tb->todo_skip($why);
472             }
473 19 50       48  
474 0         0 local $^W = 0;
475 0         0 last TODO;
476 0         0 }
477              
478             #line 1134
479 19         27  
480 19         35 sub BAIL_OUT {
481 19 50   19   108 my $reason = shift;
  19         120  
482             my $tb = Test::More->builder;
483              
484 19         26 $tb->BAIL_OUT($reason);
485 19 50       70 }
486              
487             #line 1173
488 19         64  
489             #'#
490 19         80 sub eq_array {
491             local @Data_Stack;
492 19         98 _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 11     11 1 112 my $ok = 0;
526 11         70  
527             # Effectively turn %Refs_Seen into a stack. This avoids picking up
528 11         18 # the same referenced used twice (such as [\$a, \$a]) to be considered
529 11 50       34 # circular.
530 11         31 local %Refs_Seen = %Refs_Seen;
531 11 50       53  
    50          
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 11     11   75 my $same_ref = !(!ref $e1 xor !ref $e2);
  11         157  
540 11 50       70 my $not_ref = (!ref $e1 and !ref $e2);
    50          
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 11         22 my $type = _type($e1);
564 11 50       25 $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 11         45 }
570             elsif( $type eq 'ARRAY' ) {
571             $ok = _eq_array($e1, $e2);
572 11         64 }
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 4 #
656 1 50       4 # Ensure that references are not accidentally treated the same as a
657 1         3 # string containing the reference.
658             #
659 1         3 # Have to inline the sort routine due to a threading/sort bug.
660             # See [rt.cpan.org 6782]
661 1         8 #
662             # I don't know how references would be sorted so we just don't sort
663 1 50 33     4 # 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   532 1;
  1         4  
  1         12  
  1         60