From: rkinyon Date: Thu, 27 Sep 2007 01:30:53 +0000 (+0000) Subject: Added _dump_file and improved how arrays/hashes clean up after themselves X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9f83dc318a8ab30bf5277a0ee92cebcad39149d2;p=dbsrgits%2FDBM-Deep.git Added _dump_file and improved how arrays/hashes clean up after themselves --- diff --git a/Changes b/Changes index 2c39a3c..4e03a9c 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,12 @@ Revision history for DBM::Deep. -1.0009_01 Sep 24 14:00:00 2007 EDT +1.0004 Sep 25 00:00:00 2007 EDT + - Fixed the Changes file + - Added filter sugar methods to be more API-compatible with other DBMs + - Implemented _dump_file in order to display the file structure. + - Arrays now clean up after themselves better. + +1.0003 Sep 24 14:00:00 2007 EDT - THIS VERSION IS INCOMPATIBLE WITH FILES FROM ALL OTHER PRIOR VERSIONS. - Further fixes for unshift/shift/splice and references (RT# 29583) - To fix that, I had to put support for real references in. diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index b307009..34091e7 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.0003); +our $VERSION = q(1.0004); use Fcntl qw( :flock ); @@ -333,6 +333,11 @@ sub clone { return; } + + sub filter_store_key { $_[0]->set_filter( store_key => $_[1] ); } + sub filter_store_value { $_[0]->set_filter( store_value => $_[1] ); } + sub filter_fetch_key { $_[0]->set_filter( fetch_key => $_[1] ); } + sub filter_fetch_value { $_[0]->set_filter( fetch_value => $_[1] ); } } sub begin_work { @@ -552,5 +557,10 @@ sub delete { (shift)->DELETE( @_ ) } sub exists { (shift)->EXISTS( @_ ) } sub clear { (shift)->CLEAR( @_ ) } +sub _dump_file { + my $self = shift->_get_self; + return $self->_engine->_dump_file; +} + 1; __END__ diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index 500473b..2593fdd 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.0003); +our $VERSION = q(1.0004); # This is to allow DBM::Deep::Array to handle negative indices on # its own. Otherwise, Perl would intercept the call to negative diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index 4441278..da8445d 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.0003); +our $VERSION = q(1.0004); use Scalar::Util (); @@ -875,6 +875,98 @@ sub set_trans_loc { $_[0]{trans_loc} = $_[1] } sub chains_loc { $_[0]{chains_loc} } sub set_chains_loc { $_[0]{chains_loc} = $_[1] } +sub _dump_file { + my $self = shift; + + # Read the header + my $spot = $self->_read_file_header(); + + my %types = ( + 0 => 'B', + 1 => 'D', + 2 => 'I', + ); + + my %sizes = ( + 'D' => $self->data_sector_size, + 'B' => 387, + 'I' => 1234, + ); + + # Read the free sector chains + my %sectors; + foreach my $multiple ( 0 .. 2 ) { + my $chains_offset = $multiple * $self->byte_size; + + my $old_loc = $self->chains_loc + $chains_offset; + while ( 1 ) { + my $loc = unpack( + $StP{$self->byte_size}, + $self->storage->read_at( $old_loc, $self->byte_size ), + ); + + # We're now out of free sectors of this kind. + unless ( $loc ) { + last; + } + + $sectors{ $types{$multiple} }{ $loc } = undef; + $old_loc = $loc + SIG_SIZE + $STALE_SIZE; + } + } + + my $return = ""; + SECTOR: + while ( $spot < $self->storage->{end} ) { + # Read each sector in order. + my $sector = $self->_load_sector( $spot ); + if ( !$sector ) { + # Find it in the free-sectors that were found already + foreach my $type ( keys %sectors ) { + if ( exists $sectors{$type}{$spot} ) { + my $size = $sizes{$type}; + $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size; + $spot += $size; + next SECTOR; + } + } + + die "Didn't find free sector for $spot in chains\n"; + } + else { + $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size; + if ( $sector->type eq 'D' ) { + $return .= ' ' . $sector->data; + } + elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) { + $return .= ' REF: ' . $sector->get_refcount; + } + elsif ( $sector->type eq 'B' ) { + foreach my $bucket ( $sector->chopped_up ) { + $return .= "\n "; + $return .= sprintf "%04d", unpack($StP{$self->byte_size}, + substr( $bucket->[-1], $self->hash_size, $self->byte_size), + ); + foreach my $txn ( 0 .. $self->num_txns - 1 ) { + my $l = unpack( $StP{$self->byte_size}, + substr( $bucket->[-1], + $self->hash_size + $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE), + $self->byte_size, + ), + ); + $return .= sprintf " %04d", $l; + } + } + } + $return .= $/; + + $spot += $sector->size; + } + } + + return $return; +} + ################################################################################ package DBM::Deep::Iterator; @@ -1709,6 +1801,31 @@ sub size { sub free_meth { return '_add_free_blist_sector' } +sub free { + my $self = shift; + + my $e = $self->engine; + foreach my $bucket ( $self->chopped_up ) { + my $rest = $bucket->[-1]; + + # Delete the keysector + my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size, $e->byte_size ) ); + my $s = $e->_load_sector( $l ); $s->free if $s; + + foreach my $txn ( 0 .. $e->num_txns - 1 ) { + my $l = unpack( $StP{$e->byte_size}, + substr( $rest, + $e->hash_size + $e->byte_size + $txn * ($e->byte_size + $STALE_SIZE), + $e->byte_size, + ), + ); + my $s = $e->_load_sector( $l ); $s->free if $s; + } + } + + $self->SUPER::free(); +} + sub bucket_size { my $self = shift; unless ( $self->{bucket_size} ) { diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm index c62d81f..ccedf04 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.0003); +our $VERSION = q(1.0004); use Fcntl qw( :DEFAULT :flock :seek ); diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index 22a7acc..b703705 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.0003); +our $VERSION = q(1.0004); use base 'DBM::Deep'; diff --git a/t/01_basic.t b/t/01_basic.t index 7025ea9..8c9c430 100644 --- a/t/01_basic.t +++ b/t/01_basic.t @@ -25,3 +25,16 @@ if ( $@ ) { isa_ok( $db, 'DBM::Deep' ); ok(1, "We can successfully open a file!" ); +__END__ +$db->{foo} = [ 1 ]; +$db->{bar} = $db->{foo}; + +warn -s $filename, $/; +warn $db->_dump_file; + +warn $/; + +delete $db->{foo}; +$db->{bar} = 'x'; +warn -s $filename, $/; +warn $db->_dump_file; diff --git a/t/45_references.t b/t/45_references.t index 1cd157f..d39ba0a 100644 --- a/t/45_references.t +++ b/t/45_references.t @@ -2,7 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 10; +use Test::More tests => 15; use Test::Exception; use t::common qw( new_fh ); @@ -10,7 +10,17 @@ use_ok( 'DBM::Deep' ); my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( - file => $filename, + file => $filename, + locking => 1, + autoflush => 1, + num_txns => 16, +); + +my $db2 = DBM::Deep->new( + file => $filename, + locking => 1, + autoflush => 1, + num_txns => 16, ); $db->{foo} = 5; @@ -37,3 +47,37 @@ 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" ); + +$db->{foo} = $db->{bar}; +$db2->begin_work; + + delete $db2->{bar}; + delete $db2->{foo}; + + is( $db2->{bar}, undef, "It's deleted in the transaction" ); + is( $db->{bar}[3], 42, "... but not in the main" ); + +$db2->rollback; + +# Why hasn't this failed!? Is it because stuff isn't getting deleted as expected? +# I need a test that walks the sectors +is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); +is( $db2->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); + +delete $db->{foo}; + +is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); + +__END__ +warn "-2\n"; +$db2->begin_work; + +warn "-1\n"; + delete $db2->{bar}; + +warn "0\n"; +$db2->commit; + +warn "1\n"; +ok( !exists $db->{bar}, "After commit, bar is gone" ); +warn "2\n";