File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 47 283 16.6
branch 4 134 2.9
condition 2 42 4.7
subroutine 9 40 22.5
pod 21 22 95.4
total 83 521 15.9


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 1     1   658  
  1         3  
  1         39  
4 1     1   4 use 5.006;
  1         2  
  1         79  
5             use strict;
6              
7              
8             # Can't use Carp because it might cause use_ok() to accidentally succeed
9             # even though the module being used forgot to use Carp. Yes, this
10             # actually happened.
11 0     0   0 sub _carp {
12 0         0 my($file, $line) = (caller(1))[1,2];
13             warn @_, " at $file line $line\n";
14             }
15              
16              
17 1     1   5  
  1         10  
  1         97  
18             use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
19             $VERSION = '0.80';
20             $VERSION = eval $VERSION; # make the alpha version come out as a number
21 1     1   2809  
  1         4  
  1         6  
22             use Test::Builder::Module;
23             @ISA = qw(Test::Builder::Module);
24             @EXPORT = qw(ok use_ok require_ok
25             is isnt like unlike is_deeply
26             cmp_ok
27             skip todo todo_skip
28             pass fail
29             eq_array eq_hash eq_set
30             $TODO
31             plan
32             can_ok isa_ok
33             diag
34             BAIL_OUT
35             );
36              
37              
38             #line 156
39              
40             sub plan {
41             my $tb = Test::More->builder;
42              
43             $tb->plan(@_);
44             }
45              
46              
47             # This implements "use Test::More 'no_diag'" but the behavior is
48             # deprecated.
49             sub import_extra {
50             my $class = shift;
51             my $list = shift;
52              
53             my @other = ();
54             my $idx = 0;
55             while( $idx <= $#{$list} ) {
56             my $item = $list->[$idx];
57              
58             if( defined $item and $item eq 'no_diag' ) {
59             $class->builder->no_diag(1);
60             }
61             else {
62             push @other, $item;
63             }
64              
65             $idx++;
66             }
67              
68             @$list = @other;
69             }
70              
71              
72             #line 256
73              
74             sub ok ($;$) {
75             my($test, $name) = @_;
76             my $tb = Test::More->builder;
77              
78             $tb->ok($test, $name);
79             }
80              
81             #line 323
82              
83             sub is ($$;$) {
84             my $tb = Test::More->builder;
85              
86             $tb->is_eq(@_);
87             }
88              
89             sub isnt ($$;$) {
90             my $tb = Test::More->builder;
91              
92             $tb->isnt_eq(@_);
93             }
94              
95             *isn't = \&isnt;
96              
97              
98             #line 368
99              
100             sub like ($$;$) {
101             my $tb = Test::More->builder;
102              
103             $tb->like(@_);
104             }
105              
106              
107             #line 384
108              
109             sub unlike ($$;$) {
110             my $tb = Test::More->builder;
111              
112             $tb->unlike(@_);
113             }
114              
115              
116             #line 424
117              
118             sub cmp_ok($$$;$) {
119             my $tb = Test::More->builder;
120              
121             $tb->cmp_ok(@_);
122             }
123              
124              
125             #line 460
126              
127             sub can_ok ($@) {
128             my($proto, @methods) = @_;
129             my $class = ref $proto || $proto;
130             my $tb = Test::More->builder;
131              
132             unless( $class ) {
133             my $ok = $tb->ok( 0, "->can(...)" );
134             $tb->diag(' can_ok() called with empty class or reference');
135             return $ok;
136             }
137              
138             unless( @methods ) {
139             my $ok = $tb->ok( 0, "$class->can(...)" );
140             $tb->diag(' can_ok() called with no methods');
141             return $ok;
142             }
143              
144             my @nok = ();
145             foreach my $method (@methods) {
146             $tb->_try(sub { $proto->can($method) }) or push @nok, $method;
147             }
148              
149             my $name;
150             $name = @methods == 1 ? "$class->can('$methods[0]')"
151             : "$class->can(...)";
152              
153             my $ok = $tb->ok( !@nok, $name );
154              
155             $tb->diag(map " $class->can('$_') failed\n", @nok);
156              
157             return $ok;
158 0     0 1 0 }
159              
160 0         0 #line 522
161              
162             sub isa_ok ($$;$) {
163             my($object, $class, $obj_name) = @_;
164             my $tb = Test::More->builder;
165              
166             my $diag;
167 1     1 1 2 $obj_name = 'The object' unless defined $obj_name;
168 1         2 my $name = "$obj_name isa $class";
169             if( !defined $object ) {
170 1         2 $diag = "$obj_name isn't defined";
171 1         2 }
172 1         2 elsif( !ref $object ) {
  3         8  
173 2         11 $diag = "$obj_name isn't a reference";
174             }
175 2 50 33     15 else {
176 0         0 # We can't use UNIVERSAL::isa because we want to honor isa() overrides
177             my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
178             if( $error ) {
179 2         4 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
180             # Its an unblessed reference
181             if( !UNIVERSAL::isa($object, $class) ) {
182 2         4 my $ref = ref $object;
183             $diag = "$obj_name isn't a '$class' it's a '$ref'";
184             }
185 1         5 } else {
186             die <
187             WHOA! I tried to call ->isa on your object and got some weird error.
188             Here's the error.
189             $error
190             WHOA
191             }
192             }
193             elsif( !$rslt ) {
194             my $ref = ref $object;
195             $diag = "$obj_name isn't a '$class' it's a '$ref'";
196             }
197             }
198            
199            
200              
201             my $ok;
202             if( $diag ) {
203             $ok = $tb->ok( 0, $name );
204             $tb->diag(" $diag\n");
205             }
206             else {
207             $ok = $tb->ok( 1, $name );
208             }
209              
210             return $ok;
211             }
212              
213              
214             #line 591
215              
216             sub pass (;$) {
217             my $tb = Test::More->builder;
218             $tb->ok(1, @_);
219             }
220              
221             sub fail (;$) {
222             my $tb = Test::More->builder;
223             $tb->ok(0, @_);
224             }
225              
226             #line 652
227              
228             sub use_ok ($;@) {
229             my($module, @imports) = @_;
230             @imports = () unless @imports;
231             my $tb = Test::More->builder;
232              
233             my($pack,$filename,$line) = caller;
234              
235             my $code;
236             if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
237             # probably a version check. Perl needs to see the bare number
238             # for it to work with non-Exporter based modules.
239             $code = <
240             package $pack;
241             use $module $imports[0];
242             1;
243             USE
244             }
245             else {
246             $code = <
247             package $pack;
248             use $module \@{\$args[0]};
249             1;
250             USE
251             }
252              
253              
254             my($eval_result, $eval_error) = _eval($code, \@imports);
255             my $ok = $tb->ok( $eval_result, "use $module;" );
256            
257             unless( $ok ) {
258 0     0 1 0 chomp $eval_error;
259 0         0 $@ =~ s{^BEGIN failed--compilation aborted at .*$}
260             {BEGIN failed--compilation aborted at $filename line $line.}m;
261 0         0 $tb->diag(<
262             Tried to use '$module'.
263             Error: $eval_error
264             DIAGNOSTIC
265              
266             }
267              
268             return $ok;
269             }
270              
271              
272             sub _eval {
273             my($code) = shift;
274             my @args = @_;
275              
276             # Work around oddities surrounding resetting of $@ by immediately
277             # storing it.
278             local($@,$!,$SIG{__DIE__}); # isolate eval
279             my $eval_result = eval $code;
280             my $eval_error = $@;
281              
282             return($eval_result, $eval_error);
283             }
284              
285             #line 718
286              
287             sub require_ok ($) {
288             my($module) = shift;
289             my $tb = Test::More->builder;
290              
291             my $pack = caller;
292              
293             # Try to deterine if we've been given a module name or file.
294             # Module names must be barewords, files not.
295             $module = qq['$module'] unless _is_module_name($module);
296              
297             my $code = <
298             package $pack;
299             require $module;
300             1;
301             REQUIRE
302              
303             my($eval_result, $eval_error) = _eval($code);
304             my $ok = $tb->ok( $eval_result, "require $module;" );
305              
306             unless( $ok ) {
307             chomp $eval_error;
308             $tb->diag(<
309             Tried to require '$module'.
310             Error: $eval_error
311             DIAGNOSTIC
312              
313             }
314              
315             return $ok;
316             }
317              
318              
319             sub _is_module_name {
320             my $module = shift;
321              
322             # Module names start with a letter.
323             # End with an alphanumeric.
324             # The rest is an alphanumeric or ::
325 0     0 1 0 $module =~ s/\b::\b//g;
326             $module =~ /^[a-zA-Z]\w*$/;
327 0         0 }
328              
329             #line 795
330              
331 0     0 1 0 use vars qw(@Data_Stack %Refs_Seen);
332             my $DNE = bless [], 'Does::Not::Exist';
333 0         0  
334             sub _dne {
335             ref $_[0] eq ref $DNE;
336             }
337              
338              
339             sub is_deeply {
340             my $tb = Test::More->builder;
341              
342             unless( @_ == 2 or @_ == 3 ) {
343             my $msg = <
344             is_deeply() takes two or three args, you gave %d.
345             This usually means you passed an array or hash instead
346             of a reference to it
347             WARNING
348             chop $msg; # clip off newline so carp() will put in line/file
349              
350             _carp sprintf $msg, scalar @_;
351              
352             return $tb->ok(0);
353             }
354              
355             my($got, $expected, $name) = @_;
356              
357             $tb->_unoverload_str(\$expected, \$got);
358              
359             my $ok;
360             if( !ref $got and !ref $expected ) { # neither is a reference
361             $ok = $tb->is_eq($got, $expected, $name);
362             }
363             elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
364             $ok = $tb->ok(0, $name);
365             $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
366             }
367             else { # both references
368             local @Data_Stack = ();
369             if( _deep_check($got, $expected) ) {
370 0     0 1 0 $ok = $tb->ok(1, $name);
371             }
372 0         0 else {
373             $ok = $tb->ok(0, $name);
374             $tb->diag(_format_stack(@Data_Stack));
375             }
376             }
377              
378             return $ok;
379             }
380              
381             sub _format_stack {
382             my(@Stack) = @_;
383              
384             my $var = '$FOO';
385             my $did_arrow = 0;
386 0     0 1 0 foreach my $entry (@Stack) {
387             my $type = $entry->{type} || '';
388 0         0 my $idx = $entry->{'idx'};
389             if( $type eq 'HASH' ) {
390             $var .= "->" unless $did_arrow++;
391             $var .= "{$idx}";
392             }
393             elsif( $type eq 'ARRAY' ) {
394             $var .= "->" unless $did_arrow++;
395             $var .= "[$idx]";
396             }
397             elsif( $type eq 'REF' ) {
398             $var = "\${$var}";
399             }
400             }
401              
402             my @vals = @{$Stack[-1]{vals}}[0,1];
403             my @vars = ();
404             ($vars[0] = $var) =~ s/\$FOO/ \$got/;
405             ($vars[1] = $var) =~ s/\$FOO/\$expected/;
406              
407             my $out = "Structures begin differing at:\n";
408             foreach my $idx (0..$#vals) {
409             my $val = $vals[$idx];
410             $vals[$idx] = !defined $val ? 'undef' :
411             _dne($val) ? "Does not exist" :
412             ref $val ? "$val" :
413             "'$val'";
414             }
415              
416             $out .= "$vars[0] = $vals[0]\n";
417             $out .= "$vars[1] = $vals[1]\n";
418              
419             $out =~ s/^/ /msg;
420             return $out;
421             }
422              
423              
424             sub _type {
425             my $thing = shift;
426 0     0 1 0  
427             return '' if !ref $thing;
428 0         0  
429             for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
430             return $type if UNIVERSAL::isa($thing, $type);
431             }
432              
433             return '';
434             }
435              
436             #line 941
437              
438             sub diag {
439             my $tb = Test::More->builder;
440              
441             $tb->diag(@_);
442             }
443              
444              
445             #line 1010
446              
447             #'#
448             sub skip {
449             my($why, $how_many) = @_;
450             my $tb = Test::More->builder;
451              
452             unless( defined $how_many ) {
453             # $how_many can only be avoided when no_plan is in use.
454             _carp "skip() needs to know \$how_many tests are in the block"
455             unless $tb->has_plan eq 'no_plan';
456             $how_many = 1;
457             }
458              
459             if( defined $how_many and $how_many =~ /\D/ ) {
460             _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
461             $how_many = 1;
462 0     0 1 0 }
463 0   0     0  
464 0         0 for( 1..$how_many ) {
465             $tb->skip($why);
466 0 0       0 }
467 0         0  
468 0         0 local $^W = 0;
469 0         0 last SKIP;
470             }
471              
472 0 0       0  
473 0         0 #line 1097
474 0         0  
475 0         0 sub todo_skip {
476             my($why, $how_many) = @_;
477             my $tb = Test::More->builder;
478 0         0  
479 0         0 unless( defined $how_many ) {
480 0 0   0   0 # $how_many can only be avoided when no_plan is in use.
  0         0  
481             _carp "todo_skip() needs to know \$how_many tests are in the block"
482             unless $tb->has_plan eq 'no_plan';
483 0         0 $how_many = 1;
484 0 0       0 }
485              
486             for( 1..$how_many ) {
487 0         0 $tb->todo_skip($why);
488             }
489 0         0  
490             local $^W = 0;
491 0         0 last TODO;
492             }
493              
494             #line 1150
495              
496             sub BAIL_OUT {
497             my $reason = shift;
498             my $tb = Test::More->builder;
499              
500             $tb->BAIL_OUT($reason);
501             }
502              
503             #line 1189
504              
505             #'#
506             sub eq_array {
507             local @Data_Stack;
508             _deep_check(@_);
509             }
510              
511             sub _eq_array {
512             my($a1, $a2) = @_;
513              
514             if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
515             warn "eq_array passed a non-array ref";
516             return 0;
517             }
518              
519             return 1 if $a1 eq $a2;
520              
521             my $ok = 1;
522             my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
523             for (0..$max) {
524 0     0 1 0 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
525 0         0 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
526              
527 0         0 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
528 0 0       0 $ok = _deep_check($e1,$e2);
529 0         0 pop @Data_Stack if $ok;
530 0 0       0  
    0          
531 0         0 last unless $ok;
532             }
533              
534 0         0 return $ok;
535             }
536              
537             sub _deep_check {
538 0     0   0 my($e1, $e2) = @_;
  0         0  
539 0 0       0 my $tb = Test::More->builder;
    0          
540 0 0       0  
541             my $ok = 0;
542 0 0       0  
543 0         0 # Effectively turn %Refs_Seen into a stack. This avoids picking up
544 0         0 # the same referenced used twice (such as [\$a, \$a]) to be considered
545             # circular.
546             local %Refs_Seen = %Refs_Seen;
547 0         0  
548             {
549             # Quiet uninitialized value warnings when comparing undefs.
550             local $^W = 0;
551              
552             $tb->_unoverload_str(\$e1, \$e2);
553              
554             # Either they're both references or both not.
555 0         0 my $same_ref = !(!ref $e1 xor !ref $e2);
556 0         0 my $not_ref = (!ref $e1 and !ref $e2);
557              
558             if( defined $e1 xor defined $e2 ) {
559             $ok = 0;
560             }
561             elsif ( _dne($e1) xor _dne($e2) ) {
562 0         0 $ok = 0;
563 0 0       0 }
564 0         0 elsif ( $same_ref and ($e1 eq $e2) ) {
565 0         0 $ok = 1;
566             }
567             elsif ( $not_ref ) {
568 0         0 push @Data_Stack, { type => '', vals => [$e1, $e2] };
569             $ok = 0;
570             }
571 0         0 else {
572             if( $Refs_Seen{$e1} ) {
573             return $Refs_Seen{$e1} eq $e2;
574             }
575             else {
576             $Refs_Seen{$e1} = "$e2";
577             }
578              
579             my $type = _type($e1);
580             $type = 'DIFFERENT' unless _type($e2) eq $type;
581              
582             if( $type eq 'DIFFERENT' ) {
583             push @Data_Stack, { type => $type, vals => [$e1, $e2] };
584             $ok = 0;
585             }
586             elsif( $type eq 'ARRAY' ) {
587             $ok = _eq_array($e1, $e2);
588             }
589             elsif( $type eq 'HASH' ) {
590             $ok = _eq_hash($e1, $e2);
591             }
592             elsif( $type eq 'REF' ) {
593 0     0 1 0 push @Data_Stack, { type => $type, vals => [$e1, $e2] };
594 0         0 $ok = _deep_check($$e1, $$e2);
595             pop @Data_Stack if $ok;
596             }
597             elsif( $type eq 'SCALAR' ) {
598 0     0 1 0 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
599 0         0 $ok = _deep_check($$e1, $$e2);
600             pop @Data_Stack if $ok;
601             }
602             elsif( $type ) {
603             push @Data_Stack, { type => $type, vals => [$e1, $e2] };
604             $ok = 0;
605             }
606             else {
607             _whoa(1, "No type in _deep_check");
608             }
609             }
610             }
611              
612             return $ok;
613             }
614              
615              
616             sub _whoa {
617             my($check, $desc) = @_;
618             if( $check ) {
619             die <
620             WHOA! $desc
621             This should never happen! Please contact the author immediately!
622             WHOA
623             }
624             }
625              
626              
627             #line 1320
628              
629             sub eq_hash {
630             local @Data_Stack;
631             return _deep_check(@_);
632             }
633              
634             sub _eq_hash {
635             my($a1, $a2) = @_;
636              
637             if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
638             warn "eq_hash passed a non-hash ref";
639             return 0;
640             }
641              
642             return 1 if $a1 eq $a2;
643              
644             my $ok = 1;
645             my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
646             foreach my $k (keys %$bigger) {
647             my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
648             my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
649              
650             push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
651             $ok = _deep_check($e1, $e2);
652             pop @Data_Stack if $ok;
653              
654 1     1 1 5 last unless $ok;
655 1 50       5 }
656 1         3  
657             return $ok;
658 1         3 }
659              
660 1         3 #line 1377
661 1 50 33     16  
662             sub eq_set {
663             my($a1, $a2) = @_;
664 0         0 return 0 unless @$a1 == @$a2;
665              
666             # There's faster ways to do this, but this is easiest.
667             local $^W = 0;
668              
669             # It really doesn't matter how we sort them, as long as both arrays are
670             # sorted with the same algorithm.
671 1         4 #
672             # Ensure that references are not accidentally treated the same as a
673             # string containing the reference.
674             #
675             # Have to inline the sort routine due to a threading/sort bug.
676             # See [rt.cpan.org 6782]
677             #
678             # I don't know how references would be sorted so we just don't sort
679 1         4 # them. This means eq_set doesn't really work with refs.
680 1         11 return eq_array(
681             [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
682 1 50       4 [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
683 0         0 );
684 0         0 }
685              
686 0         0 #line 1567
687              
688             1;