r14402@Rob-Kinyons-PowerBook (orig r6525): rkinyon | 2006-06-19 09:05:12 -0400

 Added Todd's files

diff --git a/Deep.pm.patch b/Deep.pm.patch
new file mode 100644 (file)
index 0000000..95a2037
--- /dev/null
+++ b/Deep.pm.patch
@@ -0,0 +1,71 @@
+--- DBM-Deep-0.983/lib/DBM/Deep.pm     2006-04-10 21:59:17.000000000 -0500
++++ DBM-Deep-0.983_copy/lib/DBM/Deep.pm        2006-06-15 10:15:07.569349000 -0500
+@@ -149,7 +149,9 @@
+               tie %$self, $class, %$args;
+       }
+ 
+-      return bless $self, $class;
++    bless $self, $class;
++    $self->_set_ref($self);
++    return $self;
+ }
+ 
+ sub _init {
+@@ -604,6 +606,8 @@
+                               root => $root,
+                       };
+             %$value = %x;
++            bless $value, 'DBM::Deep::Hash';
++            $value->_set_ref($value);
+               }
+               elsif ($r eq 'ARRAY') {
+             my @x = @$value;
+@@ -613,6 +617,8 @@
+                               root => $root,
+                       };
+             @$value = @x;
++            bless $value, 'DBM::Deep::Array';
++            $value->_set_ref($value);
+               }
+               
+               return $result;
+@@ -663,7 +669,8 @@
+         # If value is a hash or array, return new DBM::Deep object with correct offset
+         ##
+         if (($signature eq TYPE_HASH) || ($signature eq TYPE_ARRAY)) {
+-            my $obj = DBM::Deep->new(
++            my $obj = $self->_get_ref($subloc);
++            $obj ||= DBM::Deep->new(
+                 type => $signature,
+                 base_offset => $subloc,
+                 root => $self->_root
+@@ -1221,6 +1228,20 @@
+       return $self->{base_offset};
+ }
+ 
++sub _set_ref {
++    my $self = $_[0]->_get_self;
++    my $base_offset = $self->_base_offset;
++    my $refs = $self->_root->{refs};
++    $refs->{$base_offset} = $_[1];
++    Scalar::Util::weaken $refs->{$base_offset};
++}
++
++sub _get_ref {
++    my $self = $_[0]->_get_self;
++    my $refs = $self->_root->{refs};
++    return $refs->{ $_[1] };
++}
++
+ sub error {
+       ##
+       # Get last error string, or undef if no error
+@@ -1585,6 +1606,7 @@
+         filter_fetch_value => undef,
+         autobless => undef,
+         locked => 0,
++        refs => {},
+         %$args,
+     }, $class;
+ 
+

diff --git a/t/39_singletons.t b/t/39_singletons.t
new file mode 100644 (file)
index 0000000..2681931
--- /dev/null
+++ b/t/39_singletons.t
@@ -0,0 +1,18 @@
+use strict;
+use Test::More tests => 2;
+
+use_ok( 'DBM::Deep' );
+
+unlink 't/test.db';
+my $db = DBM::Deep->new(
+    file => "t/test.db",
+    locking => 1,
+    autoflush => 1,
+);
+
+$db->{foo} = { a => 'b' };
+my $x = $db->{foo};
+my $y = $db->{foo};
+is( $x, $y, "The references are the same" );
+
+