File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 97 283 34.2
branch 28 134 20.9
condition 13 42 30.9
subroutine 16 40 40.0
pod 21 22 95.4
total 175 521 33.5


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 4     4   6225  
  4         14  
  4         171  
4 4     4   24 use 5.006;
  4         11  
  4         529  
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 4     4   25  
  4         10  
  4         549  
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 4     4   4469  
  4         73174  
  4         29  
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 2     2 1 873 }
159              
160 2         33 #line 522
161              
162             sub isa_ok ($$;$) {
163             my($object, $class, $obj_name) = @_;
164             my $tb = Test::More->builder;
165              
166             my $diag;
167 4     4 1 196 $obj_name = 'The object' unless defined $obj_name;
168 4         9 my $name = "$obj_name isa $class";
169             if( !defined $object ) {
170 4         11 $diag = "$obj_name isn't defined";
171 4         7 }
172 4         30 elsif( !ref $object ) {
  8         38  
173 4         9 $diag = "$obj_name isn't a reference";
174             }
175 4 50 33     40 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 4         11 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
180             # Its an unblessed reference
181             if( !UNIVERSAL::isa($object, $class) ) {
182 4         7 my $ref = ref $object;
183             $diag = "$obj_name isn't a '$class' it's a '$ref'";
184             }
185 4         20 } 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 7     7 1 38 $module =~ s/\b::\b//g;
326             $module =~ /^[a-zA-Z]\w*$/;
327 7         99 }
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 7 last unless $ok;
655 1 50       4 }
656 1         15  
657             return $ok;
658 1         20 }
659              
660 1         3 #line 1377
661 1 50 33     6  
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         5 #
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         12 return eq_array(
681             [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
682 1 50       855 [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
683 0         0 );
684 0         0 }
685              
686 0         0 #line 1567
687              
688             1;