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.
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
use strict;
use warnings;
-our $VERSION = q(1.0002);
+our $VERSION = q(1.0009_01);
use Fcntl qw( :flock );
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
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 {
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 {
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++) {
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++) {
use strict;
use warnings;
-our $VERSION = q(1.0002);
+our $VERSION = q(1.0009_01);
use Scalar::Util ();
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) = @_;
);
}
+ # 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." );
}
$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({
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 ) {
$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
);
}
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;
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 );
use strict;
use warnings;
-our $VERSION = q(1.0002);
+our $VERSION = q(1.0009_01);
use Fcntl qw( :DEFAULT :flock :seek );
use strict;
use warnings;
-our $VERSION = q(1.0002);
+our $VERSION = q(1.0009_01);
use base 'DBM::Deep';
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];
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];
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];
}
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;
}
# DBM::Deep Test
##
use strict;
-use Test::More tests => 124;
+use Test::More tests => 125;
use Test::Exception;
use t::common qw( new_fh );
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" );
##
} 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(
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" );
}
# 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' );
# DBM::Deep Test
##
use strict;
-use Test::More tests => 6;
+use Test::More tests => 9;
use Test::Exception;
use t::common qw( new_fh );
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 );
# 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";
##
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]; }
# 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' );
--- /dev/null
+##
+# 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" );
projects / dbsrgits/DBM-Deep.git / commitdiff