From: rkinyon Date: Sun, 26 Mar 2006 14:29:02 +0000 (+0000) Subject: Checked in the failure case for the retying X-Git-Tag: 0-983~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7e2662ec33e55fdbc9e2005ebb2fff18c5452497;p=dbsrgits%2FDBM-Deep.git Checked in the failure case for the retying --- diff --git a/Changes b/Changes index e811aa5..42090f5 100644 --- 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 --- 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 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 encountered the very same -issue with his I module (see L), -and it is also mentioned in the BUGS section for the I module ). 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 checked diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index 4c24806..2c28afa 100644 --- 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 --- 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 --- 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 --- 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' );