File Coverage

File:	local/lib/perl5/Test/Deep.pm
Coverage:	37.5%

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