File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 43 279 15.4
branch 4 134 2.9
condition 2 42 4.7
subroutine 8 39 20.5
pod 21 22 95.4
total 78 516 15.1


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 2     2   1545  
  2         8  
  2         90  
4             use 5.004;
5 2     2   13  
  2         4  
  2         219  
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   13  
  2         4  
  2         238  
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 2     2   1303  
  2         6  
  2         14  
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 6 $obj_name = 'The object' unless defined $obj_name;
169 2         5 my $name = "$obj_name isa $class";
170             if( !defined $object ) {
171 2         5 $diag = "$obj_name isn't defined";
172 2         5 }
173 2         4 elsif( !ref $object ) {
  5         17  
174 3         7 $diag = "$obj_name isn't a reference";
175             }
176 3 50 33     22 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 3         7 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
181             # Its an unblessed reference
182             if( !UNIVERSAL::isa($object, $class) ) {
183 3         6 my $ref = ref $object;
184             $diag = "$obj_name isn't a '$class' it's a '$ref'";
185             }
186 2         11 } 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 0     0 1 0  
260 0         0 unless( $ok ) {
261             chomp $eval_error;
262 0         0 $@ =~ 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 0     0 1 0  
327              
328 0         0 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 0     0 1 0  
526 0         0 sub _deep_check {
527             my($e1, $e2) = @_;
528 0         0 my $tb = Test::More->builder;
529 0 0       0  
530 0         0 my $ok = 0;
531 0 0       0  
    0          
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 0     0   0 local $^W = 0;
  0         0  
540 0 0       0  
    0          
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 0         0 }
564 0 0       0 else {
565 0         0 $Refs_Seen{$e1} = "$e2";
566 0         0 }
567              
568             my $type = _type($e1);
569 0         0 $type = 'DIFFERENT' unless _type($e2) eq $type;
570              
571             if( $type eq 'DIFFERENT' ) {
572 0         0 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 1     1 1 6 # There's faster ways to do this, but this is easiest.
656 1 50       5 local $^W = 0;
657 1         6  
658             # It really doesn't matter how we sort them, as long as both arrays are
659 1         5 # sorted with the same algorithm.
660             #
661             # Ensure that references are not accidentally treated the same as a
662 1         2 # string containing the reference.
663             #
664 1         2 # Have to inline the sort routine due to a threading/sort bug.
  1         14  
665             # See [rt.cpan.org 6782]
666 1 50 33     7 #
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 1     1   960 #line 1556
  0         0  
  0         0  
  1         75  
676              
677             1;