Checked in the failure case for the retying

diff --git a/Changes b/Changes
index e811aa5..42090f5 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,17 @@
 Revision history for DBM::Deep.
 
+0.983 Mar 25 08:00:00 2006 Pacific
+    - Added patch inspired by Jeff Janes (Thanks!)
+      - Autovivification now works correctly
+      - The following now works correctly
+        my %hash = ( a => 1 );
+        $db->{hash} = \%hash;
+        $hash{b} = 2;
+        cmp_ok( $db->{hash}{b}, '==', 2 );
+    - NOTE: This patch works by tying the underlying datastructure that was
+      passed in. There are currently no checks to see if the datastructure was
+      previously tied.
+
 0.982 Mar 08 11:00:00 2006 Pacific
     - Fixed smoketests that were failing on Win32
     - Added restriction for Perl 5.6.0 or higher.

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 7583324..5452843 100644 (file)
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -571,26 +571,22 @@ sub _add_bucket {
                # pass each key or element to it.
                ##
                if ($r eq 'HASH') {
-                       my $branch = DBM::Deep->new(
+            my %x = %$value;
+            tie %$value, 'DBM::Deep', {
                                type => TYPE_HASH,
                                base_offset => $location,
                                root => $root,
-                       );
-                       foreach my $key (keys %{$value}) {
-                $branch->STORE( $key, $value->{$key} );
-                       }
+                       };
+            %$value = %x;
                }
                elsif ($r eq 'ARRAY') {
-                       my $branch = DBM::Deep->new(
+            my @x = @$value;
+            tie @$value, 'DBM::Deep', {
                                type => TYPE_ARRAY,
                                base_offset => $location,
                                root => $root,
-                       );
-                       my $index = 0;
-                       foreach my $element (@{$value}) {
-                $branch->STORE( $index, $element );
-                               $index++;
-                       }
+                       };
+            @$value = @x;
                }
                
                return $result;
@@ -2454,26 +2450,6 @@ B<WARNING:> Only call optimize() on the top-level node of the database, and
 make sure there are no child references lying around.  DBM::Deep keeps a reference 
 counter, and if it is greater than 1, optimize() will abort and return undef.
 
-=head2 AUTOVIVIFICATION
-
-Unfortunately, autovivification doesn't work with tied hashes.  This appears to 
-be a bug in Perl's tie() system, as I<Jakob Schmidt> encountered the very same 
-issue with his I<DWH_FIle> module (see L<http://search.cpan.org/search?module=DWH_File>),
-and it is also mentioned in the BUGS section for the I<MLDBM> module <see 
-L<http://search.cpan.org/search?module=MLDBM>).  Basically, on a new db file,
-this does not work:
-
-       $db->{foo}->{bar} = "hello";
-
-Since "foo" doesn't exist, you cannot add "bar" to it.  You end up with "foo"
-being an empty hash.  Try this instead, which works fine:
-
-       $db->{foo} = { bar => "hello" };
-
-As of Perl 5.8.7, this bug still exists.  I have walked very carefully through
-the execution path, and Perl indeed passes an empty hash to the STORE() method.
-Probably a bug in Perl.
-
 =head2 FILE CORRUPTION
 
 The current level of error handling in DBM::Deep is minimal.  Files I<are> checked

diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index 4c24806..2c28afa 100644 (file)
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -364,14 +364,12 @@ sub SPLICE {
        return wantarray ? @old_elements : $old_elements[-1];
 }
 
-#XXX We don't need to define it, yet.
-#XXX It will be useful, though, when we split out HASH and ARRAY
-#sub EXTEND {
+sub EXTEND {
        ##
        # Perl will call EXTEND() when the array is likely to grow.
        # We don't care, but include it for compatibility.
        ##
-#}
+}
 
 ##
 # Public method aliases

diff --git a/t/02_hash.t b/t/02_hash.t
index 67c7c95..9a57b91 100644 (file)
--- a/t/02_hash.t
+++ b/t/02_hash.t
@@ -2,7 +2,7 @@
 # DBM::Deep Test
 ##
 use strict;
-use Test::More tests => 29;
+use Test::More tests => 33;
 use Test::Exception;
 
 use_ok( 'DBM::Deep' );
@@ -120,3 +120,18 @@ ok(
        ($first_key ne $next_key)
     ,"keys() still works if you replace long values with shorter ones"
 );
+
+my %hash = ( a => 1 );
+$db->{hash} = \%hash;
+$hash{b} = 2;
+cmp_ok( $db->{hash}{b}, '==', 2 );
+
+# Test autovivification
+
+$db->{unknown}{bar} = 1;
+ok( $db->{unknown} );
+cmp_ok( $db->{unknown}{bar}, '==', 1 );
+
+$db->clear;
+$db->{foo}->{bar} = 'baz';
+is( $db->{foo}{bar}, 'baz' );

diff --git a/t/04_array.t b/t/04_array.t
index 94251f8..2e07c8f 100644 (file)
--- a/t/04_array.t
+++ b/t/04_array.t
@@ -2,7 +2,7 @@
 # DBM::Deep Test
 ##
 use strict;
-use Test::More tests => 107;
+use Test::More tests => 110;
 use Test::Exception;
 
 use_ok( 'DBM::Deep' );
@@ -203,10 +203,18 @@ is($db->[0], "elem first");
 is($db->[1], "elem last");
 is($returned[0], "middle ABC");
 
-# These tests verify that the hash methods cannot be called on arraytypes.
-# They will be removed once the ARRAY and HASH types are refactored into their own classes.
+my %hash = ( a => 'foo' );
 
 $db->[0] = [ 1 .. 3 ];
-$db->[1] = { a => 'foo' };
+$db->[1] = \%hash;
 is( $db->[0]->length, 3, "Reuse of same space with array successful" );
 is( $db->[1]->fetch('a'), 'foo', "Reuse of same space with hash successful" );
+
+$hash{b} = '2';
+cmp_ok( $db->[1]{b}, '==', 2 );
+
+# Test autovivification
+
+$db->[9999]{bar} = 1;
+ok( $db->[9999] );
+cmp_ok( $db->[9999]{bar}, '==', 1 );

diff --git a/t/19_crossref.t b/t/19_crossref.t
index 56f96de..339c14c 100644 (file)
--- a/t/19_crossref.t
+++ b/t/19_crossref.t
@@ -2,7 +2,7 @@
 # DBM::Deep Test
 ##
 use strict;
-use Test::More tests => 5;
+use Test::More tests => 15;
 
 use_ok( 'DBM::Deep' );
 
@@ -36,10 +36,43 @@ is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
 ##
 $db2->{copy} = $db->{hash1};
 
+$db->{hash1}{subkey3} = 'where does this go?';
+is( $db->{hash1}{subkey3}, 'where does this go?' );
+
+$db2->{copy}{subkey4} = 'from the other side';
+is( $db2->{copy}{subkey4}, 'from the other side' );
+
+########
+# This is the failure case
+#
+{
+    my $left = $db->{hash1};
+    $db2->{right} = $left;
+
+    $db2->{right}{rightward} = 'floober';
+    is( $db2->{right}{rightward}, 'floober' );
+    isnt( $db->{hash1}{rightward}, 'floober' );
+}
+#
+#
+########
+
 ##
 # close, delete $db
 ##
 undef $db;
+
+{
+    my $db3 = DBM::Deep->new( 't/test.db' );
+    if ($db3->error()) {
+        die "ERROR: " . $db3->error();
+    }
+    is( $db3->{hash1}{subkey1}, 'subvalue1' );
+    is( $db3->{hash1}{subkey2}, 'subvalue2' );
+    is( $db3->{hash1}{subkey3}, 'where does this go?' );
+    isnt( $db3->{hash1}{subkey4}, 'from the other side' );
+}
+
 unlink "t/test.db";
 
 ##
@@ -47,3 +80,5 @@ unlink "t/test.db";
 ##
 is( $db2->{copy}{subkey1}, 'subvalue1', "Value copied correctly" );
 is( $db2->{copy}{subkey2}, 'subvalue2', "Value copied correctly" );
+isnt( $db2->{copy}{subkey3}, 'where does this go?' );
+is( $db2->{copy}{subkey4}, 'from the other side' );