File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 71 313 22.6
branch 8 152 5.2
condition 3 49 6.1
subroutine 14 48 29.1
pod 25 26 96.1
total 121 588 20.5


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