File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 188 363 51.7
branch 42 144 29.1
condition 15 46 32.6
subroutine 36 61 59.0
pod 24 25 96.0
total 305 639 47.7


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3             # $Id$
4 23     23   20356  
  23         127  
  23         938  
5 23     23   124 use 5.006;
  23         40  
  23         875  
6 23     23   126 use strict;
  23         52  
  23         3425  
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 23     23   15081  
  23         85  
  23         171  
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 13     13 1 202 my( $object, $class, $obj_name ) = @_;
161             my $tb = Test::More->builder;
162 13         93  
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 32     32 1 68 }
169 32         61 elsif( !ref $object ) {
170             $diag = "$obj_name isn't a reference";
171 32         73 }
172 32         64 else {
173 32         68 # We can't use UNIVERSAL::isa because we want to honor isa() overrides
  112         381  
174 80         156 my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
175             if($error) {
176 80 50 33     497 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 80         194 $diag = "$obj_name isn't a '$class' it's a '$ref'";
181             }
182             }
183 80         134 else {
184             die <
185             WHOA! I tried to call ->isa on your object and got some weird error.
186 32         132 Here's the error.
187             $error
188 32         116 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 17     17 1 153 # for it to work with non-Exporter based modules.
261 17         103 $code = <
262             package $pack;
263 17         57 use $module $imports[0];
264             1;
265             USE
266             }
267             else {
268             $code = <
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(<
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 = <
323             package $pack;
324             require $module;
325             1;
326             REQUIRE
327 86     86 1 679  
328             my( $eval_result, $eval_error ) = _eval($code);
329 86         389 my $ok = $tb->ok( $eval_result, "require $module;" );
330              
331             unless($ok) {
332             chomp $eval_error;
333 0     0 1 0 $tb->diag(<
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 0     0 1 0 of a reference to it
372             WARNING
373 0         0 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 0     0 1 0  
522 0         0 no warnings 'exiting';
523             last TODO;
524 0         0 }
525 0 0       0  
526 0         0 #line 1231
527 0 0       0  
    0          
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 0     0   0 #line 1270
  0         0  
536 0 0       0  
    0          
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 0         0  
559 0 0       0 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 0         0 }
565              
566             return $ok;
567 0         0 }
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 4     4 1 78 pop @Data_Stack if $ok;
633             }
634 4         21 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 15     15 1 115  
696 15 50       63 no warnings 'uninitialized';
697 15         84  
698             # It really doesn't matter how we sort them, as long as both arrays are
699 15         59 # sorted with the same algorithm.
700             #
701 15         26 # Ensure that references are not accidentally treated the same as a
702 15 50 33     69 # 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 15         51 );
713             }
714              
715             #line 1645
716              
717             1;