File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 33 203 16.3
branch 1 96 1.0
condition 0 20 0.0
subroutine 10 32 31.2
pod 20 21 95.2
total 64 372 17.2


line stmt bran cond sub pod time code
1             #line 1
2             package Test::More;
3 8     8   535  
  8         72  
  8         74  
4             use 5.004;
5 8     8   160  
  8         72  
  8         121  
6 8     8   338 use strict;
  8         77  
  8         168  
7             use Test::Builder;
8              
9              
10             # Can't use Carp because it might cause use_ok() to accidentally succeed
11             # even though the module being used forgot to use Carp. Yes, this
12             # actually happened.
13 0     0   0 sub _carp {
14 0         0     my($file, $line) = (caller(1))[1,2];
15                 warn @_, " at $file line $line\n";
16             }
17              
18              
19              
20 8     8   149 require Exporter;
  8         74  
  8         129  
21             use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
22             $VERSION = '0.47';
23             @ISA    = qw(Exporter);
24             @EXPORT = qw(ok use_ok require_ok
25             is isnt like unlike is_deeply
26             cmp_ok
27             skip todo todo_skip
28             pass fail
29             eq_array eq_hash eq_set
30             $TODO
31             plan
32             can_ok isa_ok
33             diag
34             );
35              
36             my $Test = Test::Builder->new;
37              
38              
39             # 5.004's Exporter doesn't have export_to_level.
40             sub _export_to_level
41 8     8   84 {
42 8         144       my $pkg = shift;
43 8         85       my $level = shift;
44 8         93       (undef) = shift; # redundant arg
45 8         193       my $callpkg = caller($level);
46                   $pkg->export($callpkg, @_);
47             }
48              
49              
50             #line 171
51              
52             sub plan {
53                 my(@plan) = @_;
54              
55                 my $caller = caller;
56              
57                 $Test->exported_to($caller);
58              
59                 my @imports = ();
60                 foreach my $idx (0..$#plan) {
61                     if( $plan[$idx] eq 'import' ) {
62                         my($tag, $imports) = splice @plan, $idx, 2;
63                         @imports = @$imports;
64                         last;
65                     }
66                 }
67              
68                 $Test->plan(@plan);
69              
70                 __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
71             }
72              
73             sub import {
74                 my($class) = shift;
75                 goto &plan;
76             }
77              
78              
79             #line 265
80              
81             sub ok ($;$) {
82                 my($test, $name) = @_;
83                 $Test->ok($test, $name);
84             }
85              
86             #line 329
87              
88             sub is ($$;$) {
89                 $Test->is_eq(@_);
90             }
91              
92             sub isnt ($$;$) {
93                 $Test->isnt_eq(@_);
94             }
95              
96             *isn't = \&isnt;
97              
98              
99             #line 370
100              
101             sub like ($$;$) {
102                 $Test->like(@_);
103             }
104              
105              
106             #line 384
107              
108             sub unlike {
109                 $Test->unlike(@_);
110             }
111              
112              
113             #line 422
114              
115             sub cmp_ok($$$;$) {
116                 $Test->cmp_ok(@_);
117             }
118              
119              
120             #line 456
121              
122             sub can_ok ($@) {
123                 my($proto, @methods) = @_;
124                 my $class = ref $proto || $proto;
125              
126                 unless( @methods ) {
127                     my $ok = $Test->ok( 0, "$class->can(...)" );
128                     $Test->diag(' can_ok() called with no methods');
129                     return $ok;
130                 }
131              
132                 my @nok = ();
133                 foreach my $method (@methods) {
134                     local($!, $@); # don't interfere with caller's $@
135             # eval sometimes resets $!
136                     eval { $proto->can($method) } || push @nok, $method;
137                 }
138              
139                 my $name;
140                 $name = @methods == 1 ? "$class->can('$methods[0]')"
141                                       : "$class->can(...)";
142                 
143                 my $ok = $Test->ok( !@nok, $name );
144              
145                 $Test->diag(map " $class->can('$_') failed\n", @nok);
146              
147                 return $ok;
148             }
149              
150             #line 513
151              
152             sub isa_ok ($$;$) {
153                 my($object, $class, $obj_name) = @_;
154              
155                 my $diag;
156                 $obj_name = 'The object' unless defined $obj_name;
157                 my $name = "$obj_name isa $class";
158                 if( !defined $object ) {
159                     $diag = "$obj_name isn't defined";
160                 }
161                 elsif( !ref $object ) {
162                     $diag = "$obj_name isn't a reference";
163                 }
164                 else {
165             # We can't use UNIVERSAL::isa because we want to honor isa() overrides
166                     local($@, $!); # eval sometimes resets $!
167                     my $rslt = eval { $object->isa($class) };
168                     if( $@ ) {
169                         if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
170                             if( !UNIVERSAL::isa($object, $class) ) {
171                                 my $ref = ref $object;
172                                 $diag = "$obj_name isn't a '$class' it's a '$ref'";
173 8     8 1 208                 }
174                         } else {
175 8         90                 die <<WHOA;
176             WHOA! I tried to call ->isa on your object and got some weird error.
177 8         108 This should never happen. Please contact the author immediately.
178             Here's the error.
179 8         72 $@
180 8         110 WHOA
181 16 50       207             }
182 0         0         }
183 0         0         elsif( !$rslt ) {
184 0         0             my $ref = ref $object;
185                         $diag = "$obj_name isn't a '$class' it's a '$ref'";
186                     }
187                 }
188 8         110             
189                   
190 8         99  
191                 my $ok;
192                 if( $diag ) {
193                     $ok = $Test->ok( 0, $name );
194 8     8   89         $Test->diag(" $diag\n");
195 8         102     }
196                 else {
197                     $ok = $Test->ok( 1, $name );
198                 }
199              
200                 return $ok;
201             }
202              
203              
204             #line 582
205              
206             sub pass (;$) {
207                 $Test->ok(1, @_);
208             }
209              
210             sub fail (;$) {
211                 $Test->ok(0, @_);
212             }
213              
214             #line 626
215              
216             sub diag {
217                 $Test->diag(@_);
218             }
219              
220              
221             #line 676
222              
223             sub use_ok ($;@) {
224                 my($module, @imports) = @_;
225                 @imports = () unless @imports;
226              
227                 my $pack = caller;
228              
229                 local($@,$!); # eval sometimes interferes with $!
230                 eval <<USE;
231             package $pack;
232             require $module;
233             '$module'->import(\@imports);
234             USE
235              
236                 my $ok = $Test->ok( !$@, "use $module;" );
237              
238                 unless( $ok ) {
239                     chomp $@;
240                     $Test->diag(<<DIAGNOSTIC);
241             Tried to use '$module'.
242             Error: $@
243             DIAGNOSTIC
244              
245                 }
246              
247                 return $ok;
248             }
249              
250             #line 711
251              
252             sub require_ok ($) {
253                 my($module) = shift;
254              
255                 my $pack = caller;
256              
257                 local($!, $@); # eval sometimes interferes with $!
258                 eval <<REQUIRE;
259             package $pack;
260             require $module;
261             REQUIRE
262              
263                 my $ok = $Test->ok( !$@, "require $module;" );
264              
265                 unless( $ok ) {
266                     chomp $@;
267 55     55 1 699         $Test->diag(<<DIAGNOSTIC);
268 55         723 Tried to require '$module'.
269             Error: $@
270             DIAGNOSTIC
271              
272                 }
273              
274                 return $ok;
275             }
276              
277             #line 795
278              
279             #'#
280             sub skip {
281                 my($why, $how_many) = @_;
282              
283                 unless( defined $how_many ) {
284             # $how_many can only be avoided when no_plan is in use.
285                     _carp "skip() needs to know \$how_many tests are in the block"
286                       unless $Test::Builder::No_Plan;
287                     $how_many = 1;
288                 }
289              
290                 for( 1..$how_many ) {
291                     $Test->skip($why);
292                 }
293              
294                 local $^W = 0;
295                 last SKIP;
296             }
297              
298              
299             #line 873
300              
301             sub todo_skip {
302                 my($why, $how_many) = @_;
303              
304                 unless( defined $how_many ) {
305             # $how_many can only be avoided when no_plan is in use.
306                     _carp "todo_skip() needs to know \$how_many tests are in the block"
307                       unless $Test::Builder::No_Plan;
308                     $how_many = 1;
309                 }
310              
311                 for( 1..$how_many ) {
312                     $Test->todo_skip($why);
313                 }
314              
315                 local $^W = 0;
316                 last TODO;
317             }
318              
319             #line 932
320              
321             use vars qw(@Data_Stack);
322             my $DNE = bless [], 'Does::Not::Exist';
323             sub is_deeply {
324                 my($this, $that, $name) = @_;
325              
326                 my $ok;
327                 if( !ref $this || !ref $that ) {
328                     $ok = $Test->is_eq($this, $that, $name);
329                 }
330                 else {
331 60     60 1 1071         local @Data_Stack = ();
332                     if( _deep_check($this, $that) ) {
333                         $ok = $Test->ok(1, $name);
334                     }
335 0     0 1           else {
336                         $ok = $Test->ok(0, $name);
337                         $ok = $Test->diag(_format_stack(@Data_Stack));
338                     }
339                 }
340              
341                 return $ok;
342             }
343              
344             sub _format_stack {
345                 my(@Stack) = @_;
346              
347                 my $var = '$FOO';
348                 my $did_arrow = 0;
349                 foreach my $entry (@Stack) {
350                     my $type = $entry->{type} || '';
351                     my $idx = $entry->{'idx'};
352                     if( $type eq 'HASH' ) {
353                         $var .= "->" unless $did_arrow++;
354                         $var .= "{$idx}";
355                     }
356                     elsif( $type eq 'ARRAY' ) {
357                         $var .= "->" unless $did_arrow++;
358                         $var .= "[$idx]";
359                     }
360                     elsif( $type eq 'REF' ) {
361                         $var = "\${$var}";
362                     }
363                 }
364              
365                 my @vals = @{$Stack[-1]{vals}}[0,1];
366                 my @vars = ();
367                 ($vars[0] = $var) =~ s/\$FOO/ \$got/;
368                 ($vars[1] = $var) =~ s/\$FOO/\$expected/;
369              
370                 my $out = "Structures begin differing at:\n";
371                 foreach my $idx (0..$#vals) {
372 0     0 1          &