File Coverage

inc/Test/Deep.pm
Criterion Covered Total %
statement 75 168 44.6
branch 21 70 30.0
condition 12 24 50.0
subroutine 15 35 42.8
pod 17 25 68.0
total 140 322 43.4


line stmt bran cond sub pod time code
1 2     2   2116 #line 1
  2         3  
  2         63  
2 2     2   9 use strict;
  2         4  
  2         64  
3             use warnings;
4              
5 2     2   10 package Test::Deep;
  2         3  
  2         106  
6             use Carp qw( confess );
7 2     2   2378  
  2         6  
  2         64  
8 2     2   1262 use Test::Deep::Cache;
  2         4  
  2         57  
9             use Test::Deep::Stack;
10 2     2   9 require overload;
  2         5  
  2         133  
11             use Scalar::Util;
12              
13             my $Test;
14             unless (defined $Test::Deep::NoTest::NoTest)
15             {
16             # for people who want eq_deeply but not Test::Builder
17             require Test::Builder;
18             $Test = Test::Builder->new;
19             }
20 2     2   9  
  2         2  
  2         133  
21             use Data::Dumper qw(Dumper);
22 2         723  
23             use vars qw(
24             $VERSION @EXPORT @EXPORT_OK @ISA
25             $Stack %Compared $CompareCache %WrapCache
26 2     2   9 $Snobby $Expects $DNE $DNE_ADDR $Shallow
  2         2  
27             );
28              
29             $VERSION = '0.103';
30              
31             require Exporter;
32             @ISA = qw( Exporter );
33              
34             @EXPORT = qw( eq_deeply cmp_deeply cmp_set cmp_bag cmp_methods
35             useclass noclass set bag subbagof superbagof subsetof supersetof
36             superhashof subhashof
37             );
38             # plus all the ones generated from %constructors below
39              
40             @EXPORT_OK = qw( descend render_stack deep_diag class_base );
41              
42             $Snobby = 1; # should we compare classes?
43             $Expects = 0; # are we comparing got vs expect or expect vs expect
44              
45             $DNE = \"";
46             $DNE_ADDR = Scalar::Util::refaddr($DNE);
47              
48             # if no sub name is supplied then we use the package name in lower case
49             my %constructors = (
50             Number => "num",
51             Methods => "",
52             ListMethods => "",
53             String => "str",
54             Boolean => "bool",
55             ScalarRef => "scalref",
56             ScalarRefOnly => "",
57             Array => "",
58             ArrayEach => "array_each",
59             ArrayElementsOnly => "",
60             Hash => "",
61             HashEach => "hash_each",
62             Regexp => "re",
63             RegexpMatches => "",
64             RegexpOnly => "",
65             RegexpRef => "",
66             Ignore => "",
67             Shallow => "",
68             Any => "",
69             All => "",
70             Isa => "Isa",
71             RegexpRefOnly => "",
72             RefType => "",
73             Blessed => "",
74             ArrayLength => "",
75             ArrayLengthOnly => "",
76             HashKeys => "",
77             HashKeysOnly => "",
78             Code => "",
79             );
80              
81             while (my ($pkg, $name) = each %constructors)
82             {
83             $name = lc($pkg) unless $name;
84             my $full_pkg = "Test::Deep::$pkg";
85             my $file = "$full_pkg.pm";
86             $file =~ s#::#/#g;
87 78     78   9914 my $sub = sub {
88 78         399 require $file;
89             return $full_pkg->new(@_);
90             };
91 2     2   10 {
  2         2  
  2         4181  
92             no strict 'refs';
93             *{$name} = $sub;
94             }
95             push(@EXPORT, $name);
96             }
97             my %count;
98             foreach my $e (@EXPORT)
99             {
100             $count{$e}++;
101             }
102              
103             # this is ugly, I should never have exported a sub called isa now I
104             # have to try figure out if the recipient wanted my isa or if a class
105             # imported us and UNIVERSAL::isa is being called on that class.
106             # Luckily our isa always expects 1 argument and U::isa always expects
107             # 2, so we can figure out (assuming the caller is no buggy).
108             sub isa
109 0 0   0 1 0 {
110             if (@_ == 1)
111 0         0 {
112             goto &Isa;
113             }
114             else
115 0         0 {
116             goto &UNIVERSAL::isa;
117             }
118             }
119              
120             push(@EXPORT, "isa");
121              
122             sub cmp_deeply
123 6     6 1 67 {
124             my ($d1, $d2, $name) = @_;
125 6         23  
126             my ($ok, $stack) = cmp_details($d1, $d2);
127 6 50       33  
128             if (not $Test->ok($ok, $name))
129 0         0 {
130 0         0 my $diag = deep_diag($stack);
131             $Test->diag($diag);
132             }
133 6         50  
134             return $ok;
135             }
136              
137             sub cmp_details
138 6     6 1 13 {
139             my ($d1, $d2) = @_;
140 6         61  
141 6         52 local $Stack = Test::Deep::Stack->new;
142 6         8 local $CompareCache = Test::Deep::Cache->new;
143             local %WrapCache;
144 6         20  
145             my $ok = descend($d1, $d2);
146 6         278  
147             return ($ok, $Stack);
148             }
149              
150             sub eq_deeply
151 0     0 1 0 {
152             my ($d1, $d2) = @_;
153 0         0  
154             my ($ok) = cmp_details($d1, $d2);
155 0         0  
156             return $ok
157             }
158              
159             sub eq_deeply_cache
160             {
161             # this is like cross between eq_deeply and descend(). It doesn't start
162             # with a new $CompareCache but if the comparison fails it will leave
163             # $CompareCache as if nothing happened. However, if the comparison
164             # succeeds then $CompareCache retains all the new information
165              
166             # this allows Set and Bag to handle circular refs
167 0     0 0 0  
168             my ($d1, $d2, $name) = @_;
169 0         0  
170 0         0 local $Stack = Test::Deep::Stack->new;
171             $CompareCache->local;
172 0         0  
173             my $ok = descend($d1, $d2);
174 0         0  
175             $CompareCache->finish($ok);
176 0         0  
177             return $ok;
178             }
179              
180             sub deep_diag
181 0     0 1 0 {
182             my $stack = shift;
183             # ick! incArrow and other things expect the stack has to be visible
184 0         0 # in a well known place . TODO clean this up
185             local $Stack = $stack;
186 0         0  
187             my $where = render_stack('$data', $stack);
188 0 0       0  
189 0         0 confess "No stack to diagnose" unless $stack;
190             my $last = $stack->getLast;
191 0         0  
192             my $diag;
193 0         0 my $message;
194 0         0 my $got;
195             my $expected;
196 0         0  
197 0 0       0 my $exp = $last->{exp};
198             if (ref $exp)
199 0 0       0 {
200             if ($exp->can("diagnostics"))
201 0         0 {
202 0         0 $diag = $exp->diagnostics($where, $last);
203             $diag =~ s/\n+$/\n/;
204             }
205             else
206 0 0       0 {
207             if ($exp->can("diag_message"))
208 0         0 {
209             $message = $exp->diag_message($where);
210             }
211             }
212             }
213 0 0       0  
214             if (not defined $diag)
215 0 0       0 {
216 0 0       0 $got = $exp->renderGot($last->{got}) unless defined $got;
217 0 0       0 $expected = $exp->renderExp unless defined $expected;
218             $message = "Compared $where" unless defined $message;
219 0         0  
220             $diag = <
221             $message
222             got : $got
223             expect : $expected
224             EOM
225             }
226 0         0  
227             return $diag;
228             }
229              
230             sub render_val
231             {
232 0     0 0 0 # add in Data::Dumper stuff
233             my $val = shift;
234 0         0  
235 0 0       0 my $rendered;
236             if (defined $val)
237 0 0       0 {
    0          
238             $rendered = ref($val) ?
239             (Scalar::Util::refaddr($val) eq $DNE_ADDR ?
240             "Does not exist" :
241             overload::StrVal($val)
242             ) :
243             qq('$val');
244             }
245             else
246 0         0 {
247             $rendered = "undef";
248             }
249 0         0  
250             return $rendered;
251             }
252              
253             sub descend
254 96     96 0 168 {
255             my ($d1, $d2) = @_;
256 96 50 66     590  
      66        
257             if (! $Expects and ref($d1) and UNIVERSAL::isa($d1, "Test::Deep::Cmp"))
258 0         0 {
259 0         0 my $where = $Stack->render('$data');
260             confess "Found a special comparison in $where\nYou can only the specials in the expects structure";
261             }
262 96 100 66     591  
263             if (ref $d1 and ref $d2)
264             {
265             # this check is only done when we're comparing 2 expecteds against each
266             # other
267 60 50 33     144  
268             if ($Expects and UNIVERSAL::isa($d1, "Test::Deep::Cmp"))
269             {
270 0 0       0 # check they are the same class
271 0 0       0 return 0 unless Test::Deep::blessed(Scalar::Util::blessed($d2))->descend($d1);
272             if ($d1->can("compare"))
273 0         0 {
274             return $d1->compare($d2);
275             }
276             }
277 60         134  
278 60         82 my $s1 = Scalar::Util::refaddr($d1);
279             my $s2 = Scalar::Util::refaddr($d2);
280 60 50       137  
281             if ($s1 eq $s2)
282 0         0 {
283             return 1;
284 60 50       194 }
285             if ($CompareCache->cmp($d1, $d2))
286             {
287             # we've tried comparing these already so either they turned out to
288             # be the same or we must be in a loop and we have to assume they're
289             # the same
290 0         0  
291             return 1;
292             }
293             else
294 60         188 {
295             $CompareCache->add($d1, $d2)
296             }
297             }
298 96         196  
299             $d2 = wrap($d2);
300 96         416  
301             $Stack->push({exp => $d2, got => $d1});
302 96 50 66     391  
303             if (ref($d1) and (Scalar::Util::refaddr($d1) == $DNE_ADDR))
304             {
305             # whatever it was suposed to be, it didn't exist and so it's an
306 0         0 # automatic fail
307             return 0;
308             }
309 96 50       257  
310             if ($d2->descend($d1))
311             {
312 96         223 # print "d1 = $d1, d2 = $d2\nok\n";
313             $Stack->pop;
314 96         435  
315             return 1;
316             }
317             else
318             {
319 0         0 # print "d1 = $d1, d2 = $d2\nnot ok\n";
320             return 0;
321             }
322             }
323              
324             sub wrap
325 96     96 0 102 {
326             my $data = shift;
327 96 100 100     585  
328             return $data if ref($data) and UNIVERSAL::isa($data, "Test::Deep::Cmp");
329 26         50  
330             my ($class, $base) = class_base($data);
331 26         35  
332             my $cmp;
333 26 100       58  
334             if($base eq '')
335 16         22 {
336             $cmp = shallow($data);
337             }
338             else
339 10         26 {
340             my $addr = Scalar::Util::refaddr($data);
341 10 50       35  
342             return $WrapCache{$addr} if $WrapCache{$addr};
343 10 0 0     36
    100          
    50          
    0          
    0          
344             if($base eq 'ARRAY')
345 4         13 {
346             $cmp = array($data);
347             }
348             elsif($base eq 'HASH')
349 6         18 {
350             $cmp = hash($data);
351             }
352             elsif($base eq 'SCALAR' or $base eq 'REF')
353 0         0 {
354             $cmp = scalref($data);
355             }
356             elsif($] <= 5.010 ? ($base eq 'Regexp') : ($base eq 'REGEXP'))
357 0         0 {
358             $cmp = regexpref($data);
359             }
360             else
361 0         0 {
362             $cmp = shallow($data);
363             }
364 10         31  
365             $WrapCache{$addr} = $cmp;
366 26         46 }
367             return $cmp;
368             }
369              
370             sub class_base
371 26     26 0 34 {
372             my $val = shift;
373 26 100       49  
374             if (ref $val)
375 10         26 {
376 10 50       23 my $blessed = Scalar::Util::blessed($val);
377 10         28 $blessed = defined($blessed) ? $blessed : "";
378             my $reftype = Scalar::Util::reftype($val);
379              
380 10 50       39  
381 0 0 0     0 if ($] <= 5.010) {
382             if ($blessed eq "Regexp" and $reftype eq "SCALAR")
383 0         0 {
384             $reftype = "Regexp"
385             }
386 10         41 }
387             return ($blessed, $reftype);
388             }
389             else
390 16         50 {
391             return ("", "");
392             }
393             }
394              
395             sub render_stack
396 0     0 0   {
397             my ($var, $stack) = @_;
398 0            
399             return $stack->render($var);
400             }
401              
402             sub cmp_methods
403 0     0 1   {
404 0           local $Test::Builder::Level = $Test::Builder::Level + 1;
  0            
405             return cmp_deeply(shift, methods(@{shift()}), shift);
406             }
407              
408             sub requireclass
409 0     0 0   {
410             require Test::Deep::Class;
411 0            
412             my $val = shift;
413 0            
414             return Test::Deep::Class->new(1, $val);
415             }
416              
417             # docs and export say this is call useclass, doh!
418              
419             *useclass = \&requireclass;
420              
421             sub noclass
422 0     0 1   {
423             require Test::Deep::Class;
424 0            
425             my $val = shift;
426 0            
427             return Test::Deep::Class->new(0, $val);
428             }
429              
430             sub set
431 0     0 1   {
432             require Test::Deep::Set;
433 0            
434             return Test::Deep::Set->new(1, "", @_);
435             }
436              
437             sub supersetof
438 0     0 1   {
439             require Test::Deep::Set;
440 0            
441             return Test::Deep::Set->new(1, "sup", @_);
442             }
443              
444             sub subsetof
445 0     0 1   {
446             require Test::Deep::Set;
447 0            
448             return Test::Deep::Set->new(1, "sub", @_);
449             }
450              
451             sub cmp_set
452 0     0 1   {
453 0           local $Test::Builder::Level = $Test::Builder::Level + 1;
  0            
454             return cmp_deeply(shift, set(@{shift()}), shift);
455             }
456              
457             sub bag
458 0     0 1   {
459             require Test::Deep::Set;
460 0            
461             return Test::Deep::Set->new(0, "", @_);
462             }
463              
464             sub superbagof
465 0     0 1   {
466             require Test::Deep::Set;
467 0            
468             return Test::Deep::Set->new(0, "sup", @_);
469             }
470              
471             sub subbagof
472 0     0 1   {
473             require Test::Deep::Set;
474 0            
475             return Test::Deep::Set->new(0, "sub", @_);
476             }
477              
478             sub cmp_bag
479 0     0 1   {
480 0           local $Test::Builder::Level = $Test::Builder::Level + 1;
  0            
481             return cmp_deeply(shift, bag(@{shift()}), shift);
482             }
483              
484             sub superhashof
485 0     0 1   {
486             require Test::Deep::Hash;
487 0            
488             my $val = shift;
489 0            
490             return Test::Deep::SuperHash->new($val);
491             }
492              
493             sub subhashof
494 0     0 1   {
495             require Test::Deep::Hash;
496 0            
497             my $val = shift;
498 0            
499             return Test::Deep::SubHash->new($val);
500             }
501              
502             sub builder
503 0 0   0 0   {
504             if (@_)
505 0           {
506             $Test = shift;
507 0           }
508             return $Test;
509             }
510              
511             1;
512