File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 74 203 36.4
branch 19 96 19.7
condition 3 20 15.0
subroutine 14 32 43.7
pod 20 21 95.2
total 130 372 34.9


line stmt bran cond sub pod time code
1             package Test::More;
2              
3 1     1   49126 use 5.004;
  1         4  
  1         40  
4              
5 1     1   7 use strict;
  1         2  
  1         28  
6 1     1   447 use Test::Builder;
  1         2  
  1         102  
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             sub _carp {
13 0     0   0 my($file, $line) = (caller(1))[1,2];
14 0         0 warn @_, " at $file line $line\n";
15             }
16              
17              
18              
19             require Exporter;
20 1     1   8 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
  1         3  
  1         2261  
21             $VERSION = '0.47';
22             @ISA = qw(Exporter);
23             @EXPORT = qw(ok use_ok require_ok
24             is isnt like unlike is_deeply
25             cmp_ok
26             skip todo todo_skip
27             pass fail
28             eq_array eq_hash eq_set
29             $TODO
30             plan
31             can_ok isa_ok
32             diag
33             );
34              
35             my $Test = Test::Builder->new;
36              
37              
38             # 5.004's Exporter doesn't have export_to_level.
39             sub _export_to_level
40             {
41 2     2   5 my $pkg = shift;
42 2         4 my $level = shift;
43 2         6 (undef) = shift; # redundant arg
44 2         5 my $callpkg = caller($level);
45 2         1062 $pkg->export($callpkg, @_);
46             }
47              
48              
49              
50             sub plan {
51 2     2 1 5743 my(@plan) = @_;
52              
53 2         8 my $caller = caller;
54              
55 2         592 $Test->exported_to($caller);
56              
57 2         4 my @imports = ();
58 2         10 foreach my $idx (0..$#plan) {
59 2 50       10 if( $plan[$idx] eq 'import' ) {
60 0         0 my($tag, $imports) = splice @plan, $idx, 2;
61 0         0 @imports = @$imports;
62 0         0 last;
63             }
64             }
65              
66 2         11 $Test->plan(@plan);
67              
68 2         11 __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
69             }
70              
71             sub import {
72 1     1   8 my($class) = shift;
73 1         6 goto &plan;
74             }
75              
76              
77              
78             sub ok ($;$) {
79 0     0 1 0 my($test, $name) = @_;
80 0         0 $Test->ok($test, $name);
81             }
82              
83              
84             sub is ($$;$) {
85 13     13 1 680 $Test->is_eq(@_);
86             }
87              
88             sub isnt ($$;$) {
89 0     0 1 0 $Test->isnt_eq(@_);
90             }
91              
92             *isn't = \&isnt;
93              
94              
95              
96             sub like ($$;$) {
97 0     0 1 0 $Test->like(@_);
98             }
99              
100              
101              
102             sub unlike {
103 0     0 1 0 $Test->unlike(@_);
104             }
105              
106              
107              
108             sub cmp_ok($$$;$) {
109 0     0 1 0 $Test->cmp_ok(@_);
110             }
111              
112              
113              
114             sub can_ok ($@) {
115 0     0 1 0 my($proto, @methods) = @_;
116 0   0     0 my $class = ref $proto || $proto;
117              
118 0 0       0 unless( @methods ) {
119 0         0 my $ok = $Test->ok( 0, "$class->can(...)" );
120 0         0 $Test->diag(' can_ok() called with no methods');
121 0         0 return $ok;
122             }
123              
124 0         0 my @nok = ();
125 0         0 foreach my $method (@methods) {
126 0         0 local($!, $@); # don't interfere with caller's $@
127             # eval sometimes resets $!
128 0 0       0 eval { $proto->can($method) } || push @nok, $method;
  0         0  
129             }
130              
131 0         0 my $name;
132 0 0       0 $name = @methods == 1 ? "$class->can('$methods[0]')"
133             : "$class->can(...)";
134            
135 0         0 my $ok = $Test->ok( !@nok, $name );
136              
137 0         0 $Test->diag(map " $class->can('$_') failed\n", @nok);
138              
139 0         0 return $ok;
140             }
141              
142              
143             sub isa_ok ($$;$) {
144 20     20 1 234 my($object, $class, $obj_name) = @_;
145              
146 20         38 my $diag;
147 20 50       68 $obj_name = 'The object' unless defined $obj_name;
148 20         57 my $name = "$obj_name isa $class";
149 20 50       109 if( !defined $object ) {
    50          
150 0         0 $diag = "$obj_name isn't defined";
151             }
152             elsif( !ref $object ) {
153 0         0 $diag = "$obj_name isn't a reference";
154             }
155             else {
156             # We can't use UNIVERSAL::isa because we want to honor isa() overrides
157 20         116 local($@, $!); # eval sometimes resets $!
158 20         44 my $rslt = eval { $object->isa($class) };
  20         147  
159 20 50       138 if( $@ ) {
    50          
160 0 0       0 if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
161 0 0       0 if( !UNIVERSAL::isa($object, $class) ) {
162 0         0 my $ref = ref $object;
163 0         0 $diag = "$obj_name isn't a '$class' it's a '$ref'";
164             }
165             } else {
166 0         0 die <
167             WHOA! I tried to call ->isa on your object and got some weird error.
168             This should never happen. Please contact the author immediately.
169             Here's the error.
170             $@
171             WHOA
172             }
173             }
174             elsif( !$rslt ) {
175 0         0 my $ref = ref $object;
176 0         0 $diag = "$obj_name isn't a '$class' it's a '$ref'";
177             }
178             }
179            
180            
181              
182 20         27 my $ok;
183 20 50       48 if( $diag ) {
184 0         0 $ok = $Test->ok( 0, $name );
185 0         0 $Test->diag(" $diag\n");
186             }
187             else {
188 20         135 $ok = $Test->ok( 1, $name );
189             }
190              
191 20         71 return $ok;
192             }
193              
194              
195              
196             sub pass (;$) {
197 6     6 1 24 $Test->ok(1, @_);
198             }
199              
200             sub fail (;$) {
201 0     0 1 0 $Test->ok(0, @_);
202             }
203              
204              
205             sub diag {
206 0     0 1 0 $Test->diag(@_);
207             }
208              
209              
210              
211             sub use_ok ($;@) {
212 0     0 1 0 my($module, @imports) = @_;
213 0 0       0 @imports = () unless @imports;
214              
215 0         0 my $pack = caller;
216              
217 0         0 local($@,$!); # eval sometimes interferes with $!
218 0         0 eval <
219             package $pack;
220             require $module;
221             '$module'->import(\@imports);
222             USE
223              
224 0         0 my $ok = $Test->ok( !$@, "use $module;" );
225              
226 0 0       0 unless( $ok ) {
227 0         0 chomp $@;
228 0         0 $Test->diag(<
229             Tried to use '$module'.
230             Error: $@
231             DIAGNOSTIC
232              
233             }
234              
235 0         0 return $ok;
236             }
237              
238              
239             sub require_ok ($) {
240 0     0 1 0 my($module) = shift;
241              
242 0         0 my $pack = caller;
243              
244 0         0 local($!, $@); # eval sometimes interferes with $!
245 0         0 eval <
246             package $pack;
247             require $module;
248             REQUIRE
249              
250 0         0 my $ok = $Test->ok( !$@, "require $module;" );
251              
252 0 0       0 unless( $ok ) {
253 0         0 chomp $@;
254 0         0 $Test->diag(<
255             Tried to require '$module'.
256             Error: $@
257             DIAGNOSTIC
258              
259             }
260              
261 0         0 return $ok;
262             }
263              
264             sub skip {
265 0     0 0 0 my($why, $how_many) = @_;
266              
267 0 0       0 unless( defined $how_many ) {
268             # $how_many can only be avoided when no_plan is in use.
269 0 0       0 _carp "skip() needs to know \$how_many tests are in the block"
270             unless $Test::Builder::No_Plan;
271 0         0 $how_many = 1;
272             }
273              
274 0         0 for( 1..$how_many ) {
275 0         0 $Test->skip($why);
276             }
277              
278 0         0 local $^W = 0;
279 0         0 last SKIP;
280             }
281              
282              
283              
284             sub todo_skip {
285 0     0 1 0 my($why, $how_many) = @_;
286              
287 0 0       0 unless( defined $how_many ) {
288             # $how_many can only be avoided when no_plan is in use.
289 0 0       0 _carp "todo_skip() needs to know \$how_many tests are in the block"
290             unless $Test::Builder::No_Plan;
291 0         0 $how_many = 1;
292             }
293              
294 0         0 for( 1..$how_many ) {
295 0         0 $Test->todo_skip($why);
296             }
297              
298 0         0 local $^W = 0;
299 0         0 last TODO;
300             }
301              
302              
303 1     1   9 use vars qw(@Data_Stack);
  1         2  
  1         1351  
304             my $DNE = bless [], 'Does::Not::Exist';
305             sub is_deeply {
306 16     16 1 19008 my($this, $that, $name) = @_;
307              
308 16         33 my $ok;
309 16 50 33     149 if( !ref $this || !ref $that ) {
310 0         0 $ok = $Test->is_eq($this, $that, $name);
311             }
312             else {
313 16         147 local @Data_Stack = ();
314 16 50       79 if( _deep_check($this, $that) ) {
315 16         110 $ok = $Test->ok(1, $name);
316             }
317             else {
318 0         0 $ok = $Test->ok(0, $name);
319 0         0 $ok = $Test->diag(_format_stack(@Data_Stack));
320             }
321             }
322              
323 16         367 return $ok;
324             }
325              
326             sub _format_stack {
327 0     0   0 my(@Stack) = @_;
328              
329 0         0 my $var = '$FOO';
330 0         0 my $did_arrow = 0;
331 0         0 foreach my $entry (@Stack) {
332 0   0     0 my $type = $entry->{type} || '';
333 0         0 my $idx = $entry->{'idx'};
334 0 0       0 if( $type eq 'HASH' ) {
    0          
    0          
335 0 0       0 $var .= "->" unless $did_arrow++;
336 0         0 $var .= "{$idx}";
337             }
338             elsif( $type eq 'ARRAY' ) {
339 0 0       0 $var .= "->" unless $did_arrow++;
340 0         0 $var .= "[$idx]";
341             }
342             elsif( $type eq 'REF' ) {
343 0         0 $var = "\${$var}";
344             }
345             }
346              
347 0         0 my @vals = @{$Stack[-1]{vals}}[0,1];
  0         0  
348 0         0 my @vars = ();
349 0         0 ($vars[0] = $var) =~ s/\$FOO/ \$got/;
350 0         0 ($vars[1] = $var) =~ s/\$FOO/\$expected/;
351              
352 0         0 my $out = "Structures begin differing at:\n";
353 0         0 foreach my $idx (0..$#vals) {
354 0         0 my $val = $vals[$idx];
355 0 0       0 $vals[$idx] = !defined $val ? 'undef' :
    0          
356             $val eq $DNE ? "Does not exist"
357             : "'$val'";
358             }
359              
360 0         0 $out .= "$vars[0] = $vals[0]\n";
361 0         0 $out .= "$vars[1] = $vals[1]\n";
362              
363 0         0 $out =~ s/^/ /msg;
364 0         0 return $out;
365             }
366              
367              
368             sub eq_array {
369 0     0 1 0 my($a1, $a2) = @_;
370 0 0       0 return 1 if $a1 eq $a2;
371              
372 0         0 my $ok = 1;
373 0 0       0 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
374 0         0 for (0..$max) {
375 0 0       0 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
376 0 0       0 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
377              
378 0         0 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
379 0         0 $ok = _deep_check($e1,$e2);
380 0 0       0 pop @Data_Stack if $ok;
381              
382 0 0       0 last unless $ok;
383             }
384 0         0 return $ok;
385             }
386              
387             sub _deep_check {
388 162     162   268 my($e1, $e2) = @_;
389 162         183 my $ok = 0;
390              
391 162         161 my $eq;
392             {
393             # Quiet uninitialized value warnings when comparing undefs.
394 162         151 local $^W = 0;
  162         716  
395              
396 162 100       358 if( $e1 eq $e2 ) {
397 66         133 $ok = 1;
398             }
399             else {
400 96 50 33     1285 if( UNIVERSAL::isa($e1, 'ARRAY') and
    50 33        
    0 0        
    0 0        
401             UNIVERSAL::isa($e2, 'ARRAY') )
402             {
403 0         0 $ok = eq_array($e1, $e2);
404             }
405             elsif( UNIVERSAL::isa($e1, 'HASH') and
406             UNIVERSAL::isa($e2, 'HASH') )
407             {
408 96         212 $ok = eq_hash($e1, $e2);
409             }
410             elsif( UNIVERSAL::isa($e1, 'REF') and
411             UNIVERSAL::isa($e2, 'REF') )
412             {
413 0         0 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
414 0         0 $ok = _deep_check($$e1, $$e2);
415 0 0       0 pop @Data_Stack if $ok;
416             }
417             elsif( UNIVERSAL::isa($e1, 'SCALAR') and
418             UNIVERSAL::isa($e2, 'SCALAR') )
419             {
420 0         0 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
421 0         0 $ok = _deep_check($$e1, $$e2);
422             }
423             else {
424 0         0 push @Data_Stack, { vals => [$e1, $e2] };
425 0         0 $ok = 0;
426             }
427             }
428             }
429              
430 162         481 return $ok;
431             }
432              
433              
434              
435             sub eq_hash {
436 96     96 1 128 my($a1, $a2) = @_;
437 96 50       237 return 1 if $a1 eq $a2;
438              
439 96         108 my $ok = 1;
440 96 50       282 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
441 96         213 foreach my $k (keys %$bigger) {
442 146 50       423 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
443 146 50       554 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
444              
445 146         551 push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
446 146         546 $ok = _deep_check($e1, $e2);
447 146 50       297 pop @Data_Stack if $ok;
448              
449 146 50       508 last unless $ok;
450             }
451              
452 96         296 return $ok;
453             }
454              
455 0 0   0     sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b }
  0            
456              
457             sub eq_set {
458 0     0 1   my($a1, $a2) = @_;
459 0 0         return 0 unless @$a1 == @$a2;
460              
461             # There's faster ways to do this, but this is easiest.
462 0           return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
463             }
464              
465              
466             sub builder {
467 0     0 1   return Test::Builder->new;
468             }
469              
470              
471             1;