Added _dump_file and improved how arrays/hashes clean up after themselves

diff --git a/Changes b/Changes
index 2c39a3c..4e03a9c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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";