File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 101 279 36.2
branch 29 134 21.6
condition 10 42 23.8
subroutine 17 39 43.5
pod 21 22 95.4
total 178 516 34.5


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