This patch lets Test::More compare circular data structures.
Get the latest version (0.47) of Test::More, apply fixes.patch to fix some
issues, then apply circular.patch. Test with circular.t,
F
--
Do you need someone with lots of Unix sysadmin and/or lots of OO software
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html
--- More.pm.orig 2002-08-26 17:20:41.000000000 +0100
+++ More.pm 2003-03-04 02:03:29.000000000 +0000
@@ -25,7 +25,7 @@
cmp_ok
skip todo todo_skip
pass fail
- eq_array eq_hash eq_set
+ eq_array eq_hash eq_set eq_deeply
$TODO
plan
can_ok isa_ok
@@ -937,7 +937,7 @@
my($this, $that, $name) = @_;
my $ok;
- if( !ref $this || !ref $that ) {
+ if( !ref $this && !ref $that ) {
$ok = $Test->is_eq($this, $that, $name);
}
else {
@@ -984,8 +984,9 @@
foreach my $idx (0..$#vals) {
my $val = $vals[$idx];
$vals[$idx] = !defined $val ? 'undef' :
- $val eq $DNE ? "Does not exist"
- : "'$val'";
+ ref $val ? $val eq $DNE ? "Does not exist"
+ : $val
+ : "'$val'"
}
$out .= "$vars[0] = $vals[0]\n";
@@ -995,6 +996,12 @@
return $out;
}
+sub eq_deeply {
+ my ($a1, $a2) = @_;
+
+ local @Data_Stack = ();
+ return _deep_check($a1, $a2);
+}
=item B<eq_array>
@@ -1006,7 +1013,14 @@
=cut
#'#
-sub eq_array {
+
+sub eq_array {
+ my ($a1, $a2) = @_;
+
+ return UNIVERSAL::isa($a2, "ARRAY") ? eq_deeply($a1, $a2) : 0;
+}
+
+sub _eq_array {
my($a1, $a2) = @_;
return 1 if $a1 eq $a2;
@@ -1034,19 +1048,24 @@
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
- if( $e1 eq $e2 ) {
+ if( ! (ref $e1 xor ref $e2) and $e1 eq $e2 ) {
$ok = 1;
}
else {
- if( UNIVERSAL::isa($e1, 'ARRAY') and
+ if ( (ref $e1 and $e1 eq $DNE) or
+ (ref $e2 and $e2 eq $DNE) )
+ {
+ $ok = 0;
+ }
+ elsif( UNIVERSAL::isa($e1, 'ARRAY') and
UNIVERSAL::isa($e2, 'ARRAY') )
{
- $ok = eq_array($e1, $e2);
+ $ok = _eq_array($e1, $e2);
}
elsif( UNIVERSAL::isa($e1, 'HASH') and
UNIVERSAL::isa($e2, 'HASH') )
{
- $ok = eq_hash($e1, $e2);
+ $ok = _eq_hash($e1, $e2);
}
elsif( UNIVERSAL::isa($e1, 'REF') and
UNIVERSAL::isa($e2, 'REF') )
@@ -1060,6 +1079,7 @@
{
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
}
else {
push @Data_Stack, { vals => [$e1, $e2] };
@@ -1082,6 +1102,12 @@
=cut
sub eq_hash {
+ my ($a1, $a2) = @_;
+
+ return UNIVERSAL::isa($a2, "HASH") ? eq_deeply($a1, $a2) : 0;
+}
+
+sub _eq_hash {
my($a1, $a2) = @_;
return 1 if $a1 eq $a2;
@@ -1156,6 +1182,10 @@
return Test::Builder->new;
}
+sub set_builder {
+ $Test = shift;
+}
+
=back
--- More.pm.dne 2003-03-04 02:03:29.000000000 +0000
+++ More.pm 2003-03-04 02:14:01.000000000 +0000
@@ -931,7 +931,7 @@
=cut
-use vars qw(@Data_Stack);
+use vars qw(@Data_Stack %Compared );
my $DNE = bless [], 'Does::Not::Exist';
sub is_deeply {
my($this, $that, $name) = @_;
@@ -942,6 +942,7 @@
}
else {
local @Data_Stack = ();
+ local %Compared = ();
if( _deep_check($this, $that) ) {
$ok = $Test->ok(1, $name);
}
@@ -1000,6 +1001,7 @@
my ($a1, $a2) = @_;
local @Data_Stack = ();
+ local %Compared = ();
return _deep_check($a1, $a2);
}
@@ -1040,6 +1042,16 @@
}
sub _deep_check {
+
+ # This handles circular references by remembering which structures we
+ # are already in the process of comapring so that if we need to compare
+ # them again after descending further into the structures, we know there
+ # is no point. We just assume they are equal and look for differences
+ # elsewhere.
+
+ # We also gain a speed boost from this by remembering the results of
+ # earlier deep comparions
+
my($e1, $e2) = @_;
my $ok = 0;
@@ -1052,38 +1064,58 @@
$ok = 1;
}
else {
- if ( (ref $e1 and $e1 eq $DNE) or
- (ref $e2 and $e2 eq $DNE) )
- {
- $ok = 0;
- }
- elsif( UNIVERSAL::isa($e1, 'ARRAY') and
- UNIVERSAL::isa($e2, 'ARRAY') )
- {
- $ok = _eq_array($e1, $e2);
- }
- elsif( UNIVERSAL::isa($e1, 'HASH') and
- UNIVERSAL::isa($e2, 'HASH') )
- {
- $ok = _eq_hash($e1, $e2);
- }
- elsif( UNIVERSAL::isa($e1, 'REF') and
- UNIVERSAL::isa($e2, 'REF') )
- {
- push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
- $ok = _deep_check($$e1, $$e2);
- pop @Data_Stack if $ok;
- }
- elsif( UNIVERSAL::isa($e1, 'SCALAR') and
- UNIVERSAL::isa($e2, 'SCALAR') )
- {
- push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
- $ok = _deep_check($$e1, $$e2);
- pop @Data_Stack if $ok;
+ if ( ref $e1 and ref $e2 and $Compared{$e1}->{$e2} ) {
+ # we've either:
+
+ # - compared these two before, in which case we know they're
+ # equal already or
+
+ # - we're in the process of comparing them and we've bumped
+ # into them again because one of them is a circular data
+ # structure, in which case we assume they're equal and go
+ # look for differences elsewhere
+
+ $ok = 1;
}
else {
- push @Data_Stack, { vals => [$e1, $e2] };
- $ok = 0;
+ if ( ref $e1 and ref $e2 ) {
+ $Compared{$e1}->{$e2} = 1;
+ $Compared{$e2}->{$e1} = 1;
+ }
+
+ if ( (ref $e1 and $e1 eq $DNE) or
+ (ref $e2 and $e2 eq $DNE) )
+ {
+ $ok = 0;
+ }
+ elsif( UNIVERSAL::isa($e1, 'ARRAY') and
+ UNIVERSAL::isa($e2, 'ARRAY') )
+ {
+ $ok = _eq_array($e1, $e2);
+ }
+ elsif( UNIVERSAL::isa($e1, 'HASH') and
+ UNIVERSAL::isa($e2, 'HASH') )
+ {
+ $ok = _eq_hash($e1, $e2);
+ }
+ elsif( UNIVERSAL::isa($e1, 'REF') and
+ UNIVERSAL::isa($e2, 'REF') )
+ {
+ push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+ $ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
+ }
+ elsif( UNIVERSAL::isa($e1, 'SCALAR') and
+ UNIVERSAL::isa($e2, 'SCALAR') )
+ {
+ push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+ $ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
+ }
+ else {
+ push @Data_Stack, { vals => [$e1, $e2] };
+ $ok = 0;
+ }
}
}
}
# -*-perl-*-
use strict;
use Test::More (tests => 10);
if(1)
{
my $a1 = gen_layers(2);
my $a2 = gen_layers(2);
is_deeply($a1, $a2, "2 layers");
push(@$a1, "break");
ok(! eq_deeply($a1, $a2), "2 layers broken");
push(@$a2, "break");
is_deeply($a1, $a2, "2 layers fixed");
}
if(1)
{
my $a1 = gen_layers(2);
my $a2 = gen_layers(3);
is_deeply($a1, $a2, "2 and 3 layers");
push(@$a1, "break");
ok(! eq_deeply($a1, $a2), "2 and 3 layers broken");
push(@$a2, "break");
ok(! eq_deeply($a1, $a2), "2 and 3 layers not fixed");
}
if(1)
{
my $a1 = gen_interleave();
my $a2 = gen_interleave();
is_deeply($a1, $a2, "interleave");
}
sub gen_layers
{
my $num = shift;
my $first = ['text', gen_circle()];
$num--;
my $last = $first;
while ($num--)
{
my $next = ['text', gen_circle()];
push(@$last, $next);
$last = $next;
}
push(@$last, $first);
return $first
}
sub gen_circle
{
my $a = ['circle'];
push(@$a, $a);
return $a
}
sub gen_interleave
{
my $a = [];
my $b = [];
push(@$a, $b, $a);
push(@$b, $a, $b);
return $a;
}
