File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 47 272 17.2
branch 5 130 3.8
condition 2 39 5.1
subroutine 11 37 29.7
pod 21 22 95.4
total 86 500 17.2


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