File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 81 306 26.4
branch 11 144 7.6
condition 3 46 6.5
subroutine 18 47 38.3
pod 24 25 96.0
total 137 568 24.1


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