Revision history for DBM::Deep.
1.0004 Sep 25 00:00:00 2007 EDT
+ - (This version is compatible with 1.0003)
- Fixed the Changes file (wrong version was displayed for 1.0003)
- Added filter sugar methods to be more API-compatible with other DBMs
- Implemented _dump_file in order to display the file structure. As a
- result, the following bugs are fixed:
+ result, the following bugs were fixed:
- Arrays and hashes now clean up after themselves better.
- Bucketlists now clean up after themselves better.
- Reindexing properly clears the old bucketlist before freeing it.
type => $self->_type,
# Bring over all the parameters that we need to bring over
- num_txns => $self->_engine->num_txns,
- byte_size => $self->_engine->byte_size,
- max_buckets => $self->_engine->max_buckets,
+ ( map { $_ => $self->_engine->$_ } qw(
+ byte_size max_buckets data_sector_size num_txns
+ )),
);
$self->lock();
+ #DBM::Deep::Engine::Sector::Reference->_clear_cache;
$self->_copy_node( $db_temp );
undef $db_temp;
##
sub _throw_error {
- die "DBM::Deep: $_[1]\n";
my $n = 0;
while( 1 ) {
my @caller = caller( ++$n );
next if $caller[0] =~ m/^DBM::Deep/;
die "DBM::Deep: $_[1] at $0 line $caller[2]\n";
- last;
}
}
B<Devel::Cover> is used to test the code coverage of the tests. Below is the
B<Devel::Cover> report on this distribution's test suite.
- ----------------------------------- ------ ------ ------ ------ ------ ------
- File stmt bran cond sub time total
- ----------------------------------- ------ ------ ------ ------ ------ ------
- blib/lib/DBM/Deep.pm 94.4 85.0 90.5 100.0 5.0 93.4
- blib/lib/DBM/Deep/Array.pm 100.0 94.6 100.0 100.0 4.7 98.8
- blib/lib/DBM/Deep/Engine.pm 97.2 85.8 82.4 100.0 51.3 93.8
- blib/lib/DBM/Deep/File.pm 97.2 81.6 66.7 100.0 36.5 91.9
- blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 2.5 100.0
- Total 97.2 87.4 83.9 100.0 100.0 94.6
- ----------------------------------- ------ ------ ------ ------ ------ ------
-
------------------------------------------ ------ ------ ------ ------ ------
File stmt bran cond sub total
------------------------------------------ ------ ------ ------ ------ ------
$self->lock( $self->LOCK_SH );
if ( !defined $key ) {
+ $self->unlock;
DBM::Deep->_throw_error( "Cannot use an undefined array index." );
}
elsif ( $key =~ /^-?\d+$/ ) {
my $size;
my $idx_is_numeric;
if ( !defined $key ) {
+ $self->unlock;
DBM::Deep->_throw_error( "Cannot use an undefined array index." );
}
elsif ( $key =~ /^-?\d+$/ ) {
$self->lock( $self->LOCK_SH );
if ( !defined $key ) {
+ $self->unlock;
DBM::Deep->_throw_error( "Cannot use an undefined array index." );
}
elsif ( $key =~ /^-?\d+$/ ) {
my $size = $self->FETCHSIZE;
if ( !defined $key ) {
+ $self->unlock;
DBM::Deep->_throw_error( "Cannot use an undefined array index." );
}
elsif ( $key =~ /^-?\d+$/ ) {
return;
}
-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;
-
- my $class_loc = $self->get_class_offset;
- $self->engine->_load_sector( $class_loc )->free if $class_loc;
-
- $self->SUPER::free();
-}
-
sub staleness { $_[0]{staleness} }
sub get_data_for {
}
#XXX Add singleton handling here
-sub data {
- my $self = shift;
+{
+ my %cache;
+ # XXX This is insufficient
+# sub _clear_cache { %cache = (); }
+ sub data {
+ my $self = shift;
- my $new_obj = DBM::Deep->new({
- type => $self->type,
- base_offset => $self->offset,
- staleness => $self->staleness,
- storage => $self->engine->storage,
- engine => $self->engine,
- });
+# unless ( $cache{ $self->offset } ) {
+ my $new_obj = DBM::Deep->new({
+ type => $self->type,
+ base_offset => $self->offset,
+ staleness => $self->staleness,
+ storage => $self->engine->storage,
+ engine => $self->engine,
+ });
- if ( $self->engine->storage->{autobless} ) {
- my $classname = $self->get_classname;
- if ( defined $classname ) {
- bless $new_obj, $classname;
- }
+ if ( $self->engine->storage->{autobless} ) {
+ my $classname = $self->get_classname;
+ if ( defined $classname ) {
+ bless $new_obj, $classname;
+ }
+ }
+
+ $cache{$self->offset} = $new_obj;
+# }
+ return $cache{$self->offset};
}
- return $new_obj;
+ sub free {
+ my $self = shift;
+
+ # We're not ready to be removed yet.
+ if ( $self->decrement_refcount > 0 ) {
+ return;
+ }
+
+ # Rebless the object into DBM::Deep::Null.
+# %{$cache{ $self->offset }} = ();
+# bless $cache{$self->offset}, 'DBM::Deep::Null';
+
+ my $blist_loc = $self->get_blist_loc;
+ $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
+
+ my $class_loc = $self->get_class_offset;
+ $self->engine->_load_sector( $class_loc )->free if $class_loc;
+
+ $self->SUPER::free();
+ }
}
sub increment_refcount {
);
}
+# This was copied from MARCEL's Class::Null. However, I couldn't use it because
+# I need an undef value, not an implementation of the Null Class pattern.
+package DBM::Deep::Null;
+
+use overload
+ 'bool' => sub { undef},
+ '""' => sub { undef },
+ '0+' => sub { undef},
+ fallback => 1;
+
+sub AUTOLOAD { return; }
+
1;
__END__
# DBM::Deep Test
##
use strict;
-use Test::More tests => 125;
+use Test::More tests => 128;
use Test::Exception;
use t::common qw( new_fh );
is($db->[1], "elem last");
is($returned[0], "middle ABC");
+@returned = $db->splice;
+is( $db->length, 0 );
+is( $returned[0], "elem first" );
+is( $returned[1], "elem last" );
+
$db->[0] = [ 1 .. 3 ];
$db->[1] = { a => 'foo' };
is( $db->[0]->length, 3, "Reuse of same space with array successful" );
{
open(my $fh, '<', $filename) || die("Can't open '$filename' for reading: $!\n");
- my $db;
-
# test if we can open and read a db using its filehandle
- ok(($db = DBM::Deep->new(fh => $fh)), "open db in filehandle");
- ok($db->{hash}->{foo}->[1] eq 'b', "and get at stuff in the database");
+ my $db;
+ ok( ($db = DBM::Deep->new( fh => $fh )), "open db in filehandle" );
+ ok( $db->{hash}{foo}[1] eq 'b', "and get at stuff in the database" );
throws_ok {
$db->{foo} = 1;
- } qr/Cannot write to a readonly filehandle/,
- "Can't write to a read-only filehandle";
+ } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
ok( !$db->exists( 'foo' ), "foo doesn't exist" );
my $db_obj = $db->_get_self;
-##
-# DBM::Deep Test
-##
use strict;
+
use Test::More tests => 16;
use Test::Exception;
use t::common qw( new_fh );
my %hash2 = ( abc => [ 1 .. 3 ] );
$array[3] = \%hash2;
-SKIP: {
- skip "Internal references are not supported right now", 1;
- $hash2{ def } = \%hash;
- is( $array[3]{def}{foo}, 2 );
-}
+$hash2{ def } = \%hash;
+is( $array[3]{def}{foo}, 2 );
use strict;
-use Test::More tests => 2;
+use Test::More tests => 5;
use Test::Deep;
use t::common qw( new_fh );
print "$x -> $y\n";
TODO: {
- local $TODO = "Singletons aren't working yet";
-is( $x, $y, "The references are the same" );
+ local $TODO = "Singletons are unimplmeneted yet";
+ is( $x, $y, "The references are the same" );
+
+ delete $db->{foo};
+ is( $x, undef );
+ is( $y, undef );
}
+is( $db->{foo}, undef );
projects / dbsrgits/DBM-Deep.git / commitdiff