From: rkinyon Date: Mon, 24 Sep 2007 18:24:05 +0000 (+0000) Subject: Added references and a fix for 29583 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e137c258e24a6075c4c0146b14d1a7bdd467a7d4;p=dbsrgits%2FDBM-Deep.git Added references and a fix for 29583 --- diff --git a/Changes b/Changes index 7211f45..0c3c432 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ Revision history for DBM::Deep. +1.0009_01 Sep 24 14:00:00 2007 EDT + - Further fixes for unshift/shift/splice and references (RT# 29583) + - To fix that, I had to put support for real references in. + - the 16 and 22 tests are now re-enabled. + 1.0002 Sep 20 22:00:00 2007 EDT - (This version is compatible with 1.0001) - Expanded _throw_error() so that it provides better information. diff --git a/MANIFEST b/MANIFEST index ad92bcd..6fdb5b6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -57,6 +57,7 @@ t/41_transaction_multilevel.t t/42_transaction_indexsector.t t/43_transaction_maximum.t t/44_upgrade_db.t +t/45_references.t t/98_pod.t t/99_pod_coverage.t t/common.pm diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index f5ecd68..39342a6 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0002); +our $VERSION = q(1.0009_01); use Fcntl qw( :flock ); diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index db84214..7e875f5 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0002); +our $VERSION = q(1.0009_01); # This is to allow DBM::Deep::Array to handle negative indices on # its own. Otherwise, Perl would intercept the call to negative @@ -257,16 +257,7 @@ sub _move_value { my $self = shift; my ($old_key, $new_key) = @_; - my $val = $self->FETCH( $old_key ); - if ( eval { local $SIG{'__DIE__'}; $val->isa( 'DBM::Deep::Hash' ) } ) { - $self->STORE( $new_key, { %$val } ); - } - elsif ( eval { local $SIG{'__DIE__'}; $val->isa( 'DBM::Deep::Array' ) } ) { - $self->STORE( $new_key, [ @$val ] ); - } - else { - $self->STORE( $new_key, $val ); - } + return $self->_engine->make_reference( $self, $old_key, $new_key ); } sub SHIFT { @@ -276,22 +267,21 @@ sub SHIFT { my $length = $self->FETCHSIZE(); - if ($length) { - my $content = $self->FETCH( 0 ); - - for (my $i = 0; $i < $length - 1; $i++) { - $self->_move_value( $i+1, $i ); - } - $self->DELETE( $length - 1 ); - - $self->unlock; - - return $content; - } - else { + if ( !$length ) { $self->unlock; return; } + + my $content = $self->FETCH( 0 ); + + for (my $i = 0; $i < $length - 1; $i++) { + $self->_move_value( $i+1, $i ); + } + $self->DELETE( $length - 1 ); + + $self->unlock; + + return $content; } sub UNSHIFT { @@ -307,6 +297,8 @@ sub UNSHIFT { for (my $i = $length - 1; $i >= 0; $i--) { $self->_move_value( $i, $i+$new_size ); } + + $self->STORESIZE( $length + $new_size ); } for (my $i = 0; $i < $new_size; $i++) { @@ -355,6 +347,7 @@ sub SPLICE { for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { $self->_move_value( $i, $i + ($new_size - $splice_length) ); } + $self->STORESIZE( $length + $new_size - $splice_length ); } else { for (my $i = $offset + $splice_length; $i < $length; $i++) { diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index ea8b794..ff57671 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0002); +our $VERSION = q(1.0009_01); use Scalar::Util (); @@ -164,6 +164,55 @@ sub get_classname { return $sector->get_classname; } +sub make_reference { + my $self = shift; + my ($obj, $old_key, $new_key) = @_; + + # This will be a Reference sector + my $sector = $self->_load_sector( $obj->_base_offset ) + or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" ); + + if ( $sector->staleness != $obj->_staleness ) { + return; + } + + my $old_md5 = $self->_apply_digest( $old_key ); + + my $value_sector = $sector->get_data_for({ + key_md5 => $old_md5, + allow_head => 1, + }); + + unless ( $value_sector ) { + $value_sector = DBM::Deep::Engine::Sector::Null->new({ + engine => $self, + data => undef, + }); + + $sector->write_data({ + key_md5 => $old_md5, + key => $old_key, + value => $value_sector, + }); + } + + if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) { + $sector->write_data({ + key => $new_key, + key_md5 => $self->_apply_digest( $new_key ), + value => $value_sector, + }); + $value_sector->increment_refcount; + } + else { + $sector->write_data({ + key => $new_key, + key_md5 => $self->_apply_digest( $new_key ), + value => $value_sector->clone, + }); + } +} + sub key_exists { my $self = shift; my ($obj, $key) = @_; @@ -217,11 +266,34 @@ sub write_value { ); } + # This will be a Reference sector + my $sector = $self->_load_sector( $obj->_base_offset ) + or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." ); + + if ( $sector->staleness != $obj->_staleness ) { + DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep.n" ); + } + my ($class, $type); if ( !defined $value ) { $class = 'DBM::Deep::Engine::Sector::Null'; } elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) { + my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep' ); }; + if ( $is_dbm_deep ) { + if ( $value->_engine->storage == $self->storage ) { + my $value_sector = $self->_load_sector( $value->_base_offset ); + $sector->write_data({ + key => $key, + key_md5 => $self->_apply_digest( $key ), + value => $value_sector, + }); + $value_sector->increment_refcount; + return 1; + } + + DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." ); + } if ( $r eq 'ARRAY' && tied(@$value) ) { DBM::Deep->_throw_error( "Cannot store something that is tied." ); } @@ -232,17 +304,12 @@ sub write_value { $type = substr( $r, 0, 1 ); } else { + if ( tied($value) ) { + DBM::Deep->_throw_error( "Cannot store something that is tied." ); + } $class = 'DBM::Deep::Engine::Sector::Scalar'; } - # This will be a Reference sector - my $sector = $self->_load_sector( $obj->_base_offset ) - or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." ); - - if ( $sector->staleness != $obj->_staleness ) { - DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep.n" ); - } - # Create this after loading the reference sector in case something bad happens. # This way, we won't allocate value sector(s) needlessly. my $value_sector = $class->new({ @@ -1179,7 +1246,7 @@ sub _init { unless ( $self->offset ) { my $classname = Scalar::Util::blessed( delete $self->{data} ); - my $leftover = $self->size - $self->base_size - 2 * $e->byte_size; + my $leftover = $self->size - $self->base_size - 3 * $e->byte_size; my $class_offset = 0; if ( defined $classname ) { @@ -1196,6 +1263,7 @@ sub _init { $e->storage->print_at( $self->offset + $self->base_size, pack( $StP{$e->byte_size}, 0 ), # Index/BList loc pack( $StP{$e->byte_size}, $class_offset ), # Classname loc + pack( $StP{$e->byte_size}, 1 ), # Initial refcount chr(0) x $leftover, # Zero-fill the rest ); } @@ -1214,6 +1282,11 @@ sub _init { sub free { my $self = shift; + # We're not ready to be removed yet. + if ( $self->decrement_refcount > 0 ) { + return; + } + my $blist_loc = $self->get_blist_loc; $self->engine->_load_sector( $blist_loc )->free if $blist_loc; @@ -1543,6 +1616,60 @@ sub data { return $new_obj; } +sub increment_refcount { + my $self = shift; + + my $e = $self->engine; + my $refcount = unpack( + $StP{$e->byte_size}, + $e->storage->read_at( + $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size, + ), + ); + + $refcount++; + + $e->storage->print_at( + $self->offset + $self->base_size + 2 * $e->byte_size, + pack( $StP{$e->byte_size}, $refcount ), + ); + + return $refcount; +} + +sub decrement_refcount { + my $self = shift; + + my $e = $self->engine; + my $refcount = unpack( + $StP{$e->byte_size}, + $e->storage->read_at( + $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size, + ), + ); + + $refcount--; + + $e->storage->print_at( + $self->offset + $self->base_size + 2 * $e->byte_size, + pack( $StP{$e->byte_size}, $refcount ), + ); + + return $refcount; +} + +sub get_refcount { + my $self = shift; + + my $e = $self->engine; + return unpack( + $StP{$e->byte_size}, + $e->storage->read_at( + $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size, + ), + ); +} + package DBM::Deep::Engine::Sector::BucketList; our @ISA = qw( DBM::Deep::Engine::Sector ); diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm index 3f8511e..8830f1e 100644 --- a/lib/DBM/Deep/File.pm +++ b/lib/DBM/Deep/File.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0002); +our $VERSION = q(1.0009_01); use Fcntl qw( :DEFAULT :flock :seek ); diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index 3602a90..fbadd80 100644 --- a/lib/DBM/Deep/Hash.pm +++ b/lib/DBM/Deep/Hash.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0002); +our $VERSION = q(1.0009_01); use base 'DBM::Deep'; @@ -52,7 +52,7 @@ sub FETCH { sub STORE { my $self = shift->_get_self; DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; - my $key = ($self->_storage->{filter_store_key}) + my $key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; my $value = $_[1]; @@ -63,7 +63,7 @@ sub STORE { sub EXISTS { my $self = shift->_get_self; DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; - my $key = ($self->_storage->{filter_store_key}) + my $key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; @@ -73,7 +73,7 @@ sub EXISTS { sub DELETE { my $self = shift->_get_self; DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; - my $key = ($self->_storage->{filter_store_key}) + my $key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; @@ -81,45 +81,45 @@ sub DELETE { } sub FIRSTKEY { - ## - # Locate and return first key (in no particular order) - ## + ## + # Locate and return first key (in no particular order) + ## my $self = shift->_get_self; - ## - # Request shared lock for reading - ## - $self->lock( $self->LOCK_SH ); - - my $result = $self->_engine->get_next_key( $self ); - - $self->unlock(); - - return ($result && $self->_storage->{filter_fetch_key}) + ## + # Request shared lock for reading + ## + $self->lock( $self->LOCK_SH ); + + my $result = $self->_engine->get_next_key( $self ); + + $self->unlock(); + + return ($result && $self->_storage->{filter_fetch_key}) ? $self->_storage->{filter_fetch_key}->($result) : $result; } sub NEXTKEY { - ## - # Return next key (in no particular order), given previous one - ## + ## + # Return next key (in no particular order), given previous one + ## my $self = shift->_get_self; - my $prev_key = ($self->_storage->{filter_store_key}) + my $prev_key = ($self->_storage->{filter_store_key}) ? $self->_storage->{filter_store_key}->($_[0]) : $_[0]; - ## - # Request shared lock for reading - ## - $self->lock( $self->LOCK_SH ); - - my $result = $self->_engine->get_next_key( $self, $prev_key ); - - $self->unlock(); - - return ($result && $self->_storage->{filter_fetch_key}) + ## + # Request shared lock for reading + ## + $self->lock( $self->LOCK_SH ); + + my $result = $self->_engine->get_next_key( $self, $prev_key ); + + $self->unlock(); + + return ($result && $self->_storage->{filter_fetch_key}) ? $self->_storage->{filter_fetch_key}->($result) : $result; } diff --git a/t/04_array.t b/t/04_array.t index cc2b2b9..01eb346 100644 --- a/t/04_array.t +++ b/t/04_array.t @@ -2,7 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 124; +use Test::More tests => 125; use Test::Exception; use t::common qw( new_fh ); @@ -77,6 +77,7 @@ is( $db->length, 3, "... and we have three after shifting" ); is( $db->[0], 'elem1', "0th element still there after shifting" ); is( $db->[1], 'elem2', "1st element still there after shifting" ); is( $db->[2], 'elem3', "2nd element still there after shifting" ); +is( $db->[3], undef, "There is no third element now" ); is( $shifted, 'elem0', "Shifted value is correct" ); ## @@ -240,6 +241,7 @@ throws_ok { } qr/Cannot use an undefined array index/, "EXISTS fails on an undefined key"; # Bug reported by Mike Schilli +# Also, RT #29583 reported by HANENKAMP { my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( @@ -247,23 +249,23 @@ throws_ok { type => DBM::Deep->TYPE_ARRAY ); - push @{$db}, 1, { foo => 1 }; + push @{$db}, 3, { foo => 1 }; lives_ok { shift @{$db}; } "Shift doesn't die moving references around"; is( $db->[0]{foo}, 1, "Right hashref there" ); lives_ok { - unshift @{$db}, [ 1 .. 3 ]; + unshift @{$db}, [ 1 .. 3, [ 1 .. 3 ] ]; unshift @{$db}, 1; } "Unshift doesn't die moving references around"; - is( $db->[1][1], 2, "Right arrayref there" ); + is( $db->[1][3][1], 2, "Right arrayref there" ); is( $db->[2]{foo}, 1, "Right hashref there" ); # Add test for splice moving references around lives_ok { splice @{$db}, 0, 0, 1 .. 3; } "Splice doesn't die moving references around"; - is( $db->[4][1], 2, "Right arrayref there" ); + is( $db->[4][3][1], 2, "Right arrayref there" ); is( $db->[5]{foo}, 1, "Right hashref there" ); } diff --git a/t/16_circular.t b/t/16_circular.t index 61ec238..501435d 100644 --- a/t/16_circular.t +++ b/t/16_circular.t @@ -2,8 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More skip_all => "Internal references are not supported right now"; -#use Test::More tests => 32; +use Test::More tests => 32; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); diff --git a/t/19_crossref.t b/t/19_crossref.t index fcd48eb..c41747d 100644 --- a/t/19_crossref.t +++ b/t/19_crossref.t @@ -2,7 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 6; +use Test::More tests => 9; use Test::Exception; use t::common qw( new_fh ); @@ -11,6 +11,28 @@ use_ok( 'DBM::Deep' ); my ($fh2, $filename2) = new_fh(); my $db2 = DBM::Deep->new( $filename2 ); +SKIP: { + skip "Apparently, we cannot detect a tied scalar?", 1; + tie my $foo, 'Tied::Scalar'; + throws_ok { + $db2->{failure} = $foo; + } qr/Cannot store something that is tied\./, "tied scalar storage fails"; +} + +{ + tie my @foo, 'Tied::Array'; + throws_ok { + $db2->{failure} = \@foo; + } qr/Cannot store something that is tied\./, "tied array storage fails"; +} + +{ + tie my %foo, 'Tied::Hash'; + throws_ok { + $db2->{failure} = \%foo; + } qr/Cannot store something that is tied\./, "tied hash storage fails"; +} + { my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( $filename ); @@ -30,7 +52,7 @@ my $db2 = DBM::Deep->new( $filename2 ); # Test cross-ref nested hash accross DB objects throws_ok { $db2->{copy} = $db->{hash1}; - } qr/Cannot store something that is tied\./, "cross-ref fails"; + } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails"; # This error text is for when internal cross-refs are implemented #} qr/Cannot cross-reference\. Use export\(\) instead\./, "cross-ref fails"; @@ -43,3 +65,13 @@ my $db2 = DBM::Deep->new( $filename2 ); ## is( $db2->{copy}{subkey1}, 'subvalue1', "Value copied correctly" ); is( $db2->{copy}{subkey2}, 'subvalue2', "Value copied correctly" ); + +package Tied::Scalar; +sub TIESCALAR { bless {}, $_[0]; } +sub FETCH{} + +package Tied::Array; +sub TIEARRAY { bless {}, $_[0]; } + +package Tied::Hash; +sub TIEHASH { bless {}, $_[0]; } diff --git a/t/22_internal_copy.t b/t/22_internal_copy.t index edd2531..9de69f4 100644 --- a/t/22_internal_copy.t +++ b/t/22_internal_copy.t @@ -2,8 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More skip_all => "Internal references are not supported right now"; -#use Test::More tests => 13; +use Test::More tests => 13; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); diff --git a/t/45_references.t b/t/45_references.t new file mode 100644 index 0000000..1cd157f --- /dev/null +++ b/t/45_references.t @@ -0,0 +1,39 @@ +## +# DBM::Deep Test +## +use strict; +use Test::More tests => 10; +use Test::Exception; +use t::common qw( new_fh ); + +use_ok( 'DBM::Deep' ); + +my ($fh, $filename) = new_fh(); +my $db = DBM::Deep->new( + file => $filename, +); + +$db->{foo} = 5; +$db->{bar} = $db->{foo}; + +is( $db->{foo}, 5, "Foo is still 5" ); +is( $db->{bar}, 5, "Bar is now 5" ); + +$db->{foo} = 6; + +is( $db->{foo}, 6, "Foo is now 6" ); +is( $db->{bar}, 5, "Bar is still 5" ); + +$db->{foo} = [ 1 .. 3 ]; +$db->{bar} = $db->{foo}; + +is( $db->{foo}[1], 2, "Foo[1] is still 2" ); +is( $db->{bar}[1], 2, "Bar[1] is now 2" ); + +$db->{foo}[3] = 42; + +is( $db->{foo}[3], 42, "Foo[3] is now 42" ); +is( $db->{bar}[3], 42, "Bar[3] is also 42" ); + +delete $db->{foo}; +is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );