From: rkinyon Date: Fri, 28 Sep 2007 15:29:08 +0000 (+0000) Subject: A raft of minor improvements X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3300d0b3bfe0eb981ac25f97750bfec95249c1c5;p=dbsrgits%2FDBM-Deep.git A raft of minor improvements --- diff --git a/Changes b/Changes index a7cd00f..e4dd4d1 100644 --- a/Changes +++ b/Changes @@ -1,10 +1,11 @@ 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. diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index bfb63de..a72833d 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -245,12 +245,13 @@ sub optimize { 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; @@ -391,14 +392,12 @@ sub _fh { ## 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; } } diff --git a/lib/DBM/Deep.pod b/lib/DBM/Deep.pod index 2e3da4b..8b4b689 100644 --- a/lib/DBM/Deep.pod +++ b/lib/DBM/Deep.pod @@ -1023,17 +1023,6 @@ reference to be imported in order to explicitly leave it untied. B is used to test the code coverage of the tests. Below is the B 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 ------------------------------------------ ------ ------ ------ ------ ------ diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index 2593fdd..f9b9af2 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -47,6 +47,7 @@ sub FETCH { $self->lock( $self->LOCK_SH ); if ( !defined $key ) { + $self->unlock; DBM::Deep->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { @@ -79,6 +80,7 @@ sub STORE { my $size; my $idx_is_numeric; if ( !defined $key ) { + $self->unlock; DBM::Deep->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { @@ -117,6 +119,7 @@ sub EXISTS { $self->lock( $self->LOCK_SH ); if ( !defined $key ) { + $self->unlock; DBM::Deep->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { @@ -148,6 +151,7 @@ sub DELETE { my $size = $self->FETCHSIZE; if ( !defined $key ) { + $self->unlock; DBM::Deep->_throw_error( "Cannot use an undefined array index." ); } elsif ( $key =~ /^-?\d+$/ ) { diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index 6d14136..99198fe 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -1372,23 +1372,6 @@ sub _init { 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 { @@ -1691,25 +1674,54 @@ sub get_classname { } #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 { @@ -2191,5 +2203,17 @@ sub set_entry { ); } +# 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__ diff --git a/t/04_array.t b/t/04_array.t index 01eb346..e4616ee 100644 --- a/t/04_array.t +++ b/t/04_array.t @@ -2,7 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 125; +use Test::More tests => 128; use Test::Exception; use t::common qw( new_fh ); @@ -197,6 +197,11 @@ is($db->[0], "elem first"); 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" ); diff --git a/t/27_filehandle.t b/t/27_filehandle.t index 810154d..11f9eca 100644 --- a/t/27_filehandle.t +++ b/t/27_filehandle.t @@ -20,16 +20,14 @@ use_ok( 'DBM::Deep' ); { 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; diff --git a/t/31_references.t b/t/31_references.t index ebeb811..0184795 100644 --- a/t/31_references.t +++ b/t/31_references.t @@ -1,7 +1,5 @@ -## -# DBM::Deep Test -## use strict; + use Test::More tests => 16; use Test::Exception; use t::common qw( new_fh ); @@ -55,9 +53,6 @@ is( $db->{array}[2]{b}, 'floober' ); 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 ); diff --git a/t/39_singletons.t b/t/39_singletons.t index f9ff2e1..8a3573e 100644 --- a/t/39_singletons.t +++ b/t/39_singletons.t @@ -1,5 +1,5 @@ use strict; -use Test::More tests => 2; +use Test::More tests => 5; use Test::Deep; use t::common qw( new_fh ); @@ -19,6 +19,11 @@ my $y = $db->{foo}; 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 );