From: Rob Kinyon <rob.kinyon@gmail.com>
Date: Tue, 16 Feb 2010 04:13:36 +0000 (-0500)
Subject: Had to turn off caching, but I've merged everything from SPROUT's fixes
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e73f12ce9c4e8bdc89f1bc84d8f2a101bdb21518;p=dbsrgits%2FDBM-Deep.git

Had to turn off caching, but I've merged everything from SPROUT's fixes
---

diff --git a/Build.PL b/Build.PL
index 02a2d47..956bbc4 100644
--- a/Build.PL
+++ b/Build.PL
@@ -15,7 +15,7 @@ my $build = Module::Build->subclass(
 
         sub ACTION_test {
             my $self = shift;
-            if ( $self->notes('TEST_MYSQL_DSN') ) {
+            if ( $self->notes(\'TEST_MYSQL_DSN\') ) {
                 $ENV{$_} = $self->notes($_) for qw(
                     TEST_MYSQL_DSN TEST_MYSQL_USER TEST_MYSQL_PASS
                 );
diff --git a/TODO b/TODO
index 9ab8e51..925520f 100644
--- a/TODO
+++ b/TODO
@@ -1,3 +1,4 @@
 * clear() should use the Engine to clear. In the File backend, this would mean
   that Sector::File::Reference should have a function similar to get_bucket_list
   that iterates and deletes as appropriate.
+* Does the cache work with reblessing?
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 3458bc2..174082c 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -4,6 +4,7 @@ use 5.006_000;
 
 use strict;
 use warnings FATAL => 'all';
+no warnings 'recursion';
 
 our $VERSION = q(1.0019_003);
 
@@ -51,7 +52,7 @@ sub new {
     my $class = shift;
     my $args = $class->_get_args( @_ );
     my $self;
-    
+
     if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
         $class = 'DBM::Deep::Array';
         require DBM::Deep::Array;
@@ -135,6 +136,8 @@ sub lock_exclusive {
 *lock = \&lock_exclusive;
 sub lock_shared {
     my $self = shift->_get_self;
+use Carp qw( cluck ); use Data::Dumper;
+cluck Dumper($self) unless $self->_engine;
     return $self->_engine->lock_shared( $self, @_ );
 }
 
@@ -324,6 +327,7 @@ sub optimize {
     $self->lock_exclusive;
     $self->_engine->clear_cache;
     $self->_copy_node( $db_temp );
+    $self->unlock;
     $db_temp->_engine->storage->close;
     undef $db_temp;
 
@@ -362,9 +366,6 @@ sub optimize {
 }
 
 sub clone {
-    ##
-    # Make copy of object and return
-    ##
     my $self = shift->_get_self;
 
     return __PACKAGE__->new(
@@ -424,6 +425,7 @@ sub begin_work {
 
 sub rollback {
     my $self = shift->_get_self;
+
     $self->lock_exclusive;
     my $rv = eval {
         local $SIG{'__DIE__'};
@@ -582,11 +584,17 @@ sub CLEAR {
     }
 
     $self->lock_exclusive;
-
-    $engine->clear;
+    eval {
+        local $SIG{'__DIE__'};
+        $engine->clear( $self );
+    };
+    my $e = $@;
+    warn "$e\n" if $e;
 
     $self->unlock;
 
+    die $e if $e;
+
     return 1;
 }
 
diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index 7ebeb40..212788d 100644
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -349,20 +349,6 @@ elements, returning nothing.
 
 =cut
 
-sub clear {
-    my $self = shift;
-    my $obj = shift;
-
-    my $sector = $self->_load_sector( $obj->_base_offset )
-        or return;
-
-    return unless $sector->staleness == $obj->_staleness;
-
-    $sector->clear;
-
-    return;
-}
-
 =head2 cache / clear_cache
 
 This is the cache of loaded Reference sectors.
diff --git a/lib/DBM/Deep/Engine/DBI.pm b/lib/DBM/Deep/Engine/DBI.pm
index 845771b..8f6e7aa 100644
--- a/lib/DBM/Deep/Engine/DBI.pm
+++ b/lib/DBM/Deep/Engine/DBI.pm
@@ -4,6 +4,7 @@ use 5.006_000;
 
 use strict;
 use warnings FATAL => 'all';
+no warnings 'recursion';
 
 use base 'DBM::Deep::Engine';
 
@@ -348,5 +349,17 @@ sub supports {
     return;
 }
 
+sub clear {
+    my $self = shift;
+    my $obj = shift;
+
+    my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+        or return;
+
+    $sector->clear;
+
+    return;
+}
+
 1;
 __END__
diff --git a/lib/DBM/Deep/Engine/File.pm b/lib/DBM/Deep/Engine/File.pm
index f2e4398..5218abe 100644
--- a/lib/DBM/Deep/Engine/File.pm
+++ b/lib/DBM/Deep/Engine/File.pm
@@ -4,6 +4,7 @@ use 5.006_000;
 
 use strict;
 use warnings FATAL => 'all';
+no warnings 'recursion';
 
 use base qw( DBM::Deep::Engine );
 
@@ -1009,6 +1010,20 @@ sub supports {
     return;
 }
 
+sub clear {
+    my $self = shift;
+    my $obj = shift;
+
+    my $sector = $self->load_sector( $obj->_base_offset )
+        or return;
+
+    return unless $sector->staleness == $obj->_staleness;
+
+    $sector->clear;
+
+    return;
+}
+
 =head2 _dump_file()
 
 This method takes no arguments. It's used to print out a textual representation
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index 1671788..40f0bf6 100644
--- a/lib/DBM/Deep/Hash.pm
+++ b/lib/DBM/Deep/Hash.pm
@@ -102,10 +102,12 @@ sub first_key { (shift)->FIRSTKEY(@_) }
 sub next_key  { (shift)->NEXTKEY(@_)  }
 
 sub _clear {
-    my $self = shift;
+    my $self = shift->_get_self;
 
-    while ( defined( my $key = $self->first_key ) ) {
+    while ( defined(my $key = $self->first_key) ) {
+      do {
         $self->_engine->delete_key( $self, $key, $key );
+      } while defined($key = $self->next_key($key));
     }
 
     return;
diff --git a/lib/DBM/Deep/Sector/DBI/Reference.pm b/lib/DBM/Deep/Sector/DBI/Reference.pm
index 290bec1..15584dd 100644
--- a/lib/DBM/Deep/Sector/DBI/Reference.pm
+++ b/lib/DBM/Deep/Sector/DBI/Reference.pm
@@ -112,27 +112,28 @@ sub data {
     my ($args) = @_;
     $args ||= {};
 
-    my $obj;
-    unless ( $obj = $self->engine->cache->{ $self->offset } ) {
-        $obj = DBM::Deep->new({
+    my $engine = $self->engine;
+#    if ( !exists $engine->cache->{ $self->offset } ) {
+        my $obj = DBM::Deep->new({
             type        => $self->type,
             base_offset => $self->offset,
-            storage     => $self->engine->storage,
-            engine      => $self->engine,
+            storage     => $engine->storage,
+            engine      => $engine,
         });
 
-        if ( $self->engine->storage->{autobless} ) {
+#        $engine->cache->{$self->offset} = $obj;
+#    }
+#    my $obj = $engine->cache->{$self->offset};
+
+    # We're not exporting, so just return.
+    unless ( $args->{export} ) {
+        if ( $engine->storage->{autobless} ) {
             my $classname = $self->get_classname;
             if ( defined $classname ) {
                 bless $obj, $classname;
             }
         }
 
-        $self->engine->cache->{$self->offset} = $obj;
-    }
-
-    # We're not exporting, so just return.
-    unless ( $args->{export} ) {
         return $obj;
     }
 
@@ -201,5 +202,18 @@ sub write_refcount {
     );
 }
 
+sub clear {
+    my $self = shift;
+
+    DBM::Deep->new({
+        type        => $self->type,
+        base_offset => $self->offset,
+        storage     => $self->engine->storage,
+        engine      => $self->engine,
+    })->_clear;
+
+    return;
+}
+
 1;
 __END__
diff --git a/lib/DBM/Deep/Sector/File/Reference.pm b/lib/DBM/Deep/Sector/File/Reference.pm
index 1e7a874..cae63e5 100644
--- a/lib/DBM/Deep/Sector/File/Reference.pm
+++ b/lib/DBM/Deep/Sector/File/Reference.pm
@@ -218,7 +218,6 @@ sub write_blist_loc {
     $engine->storage->print_at( $self->offset + $self->base_size,
         pack( $StP{$engine->byte_size}, $loc ),
     );
-
 }
 
 sub get_blist_loc {
@@ -229,27 +228,6 @@ sub get_blist_loc {
     return unpack( $StP{$e->byte_size}, $blist_loc );
 }
 
-#sub clear {
-#    my $self = shift;
-#    my ($args) = @_;
-#    $args ||= {};
-#
-#    my $engine = $self->engine;
-#
-#    # If there's nothing pointed to from this reference, there's nothing to do.
-#    my $loc = $self->get_blist_loc
-#        or return;
-#
-#    my $sector = $engine->load_sector( $loc )
-#        or DBM::Deep->_throw_error( "Cannot read sector at $loc in clear()" );
-#
-#    $sector->clear;
-#
-#    $self->write_blist_loc( 0 );
-#
-#    return;
-#}
-
 sub get_bucket_list {
     my $self = shift;
     my ($args) = @_;
@@ -429,28 +407,29 @@ sub data {
     my ($args) = @_;
     $args ||= {};
 
-    my $obj;
-    unless ( $obj = $self->engine->cache->{ $self->offset } ) {
-        $obj = DBM::Deep->new({
+    my $engine = $self->engine;
+#    if ( !exists $engine->cache->{ $self->offset } ) {
+        my $obj = DBM::Deep->new({
             type        => $self->type,
             base_offset => $self->offset,
             staleness   => $self->staleness,
-            storage     => $self->engine->storage,
-            engine      => $self->engine,
+            storage     => $engine->storage,
+            engine      => $engine,
         });
 
-        if ( $self->engine->storage->{autobless} ) {
+#        $engine->cache->{$self->offset} = $obj;
+#    }
+#    my $obj = $engine->cache->{$self->offset};
+
+    # We're not exporting, so just return.
+    unless ( $args->{export} ) {
+        if ( $engine->storage->{autobless} ) {
             my $classname = $self->get_classname;
             if ( defined $classname ) {
                 bless $obj, $classname;
             }
         }
 
-        $self->engine->cache->{$self->offset} = $obj;
-    }
-
-    # We're not exporting, so just return.
-    unless ( $args->{export} ) {
         return $obj;
     }
 
@@ -530,5 +509,36 @@ sub write_refcount {
     );
 }
 
+sub clear {
+    my $self = shift;
+
+    my $blist_loc = $self->get_blist_loc or return;
+
+    my $engine = $self->engine;
+
+    # This won't work with autoblessed items.
+    if ($engine->get_running_txn_ids) {
+        # ~~~ Temporary; the code below this block needs to be modified to
+        #     take transactions into account.
+        $self->data->_get_self->_clear;
+        return;
+    }
+
+    my $sector = $engine->load_sector( $blist_loc )
+        or DBM::Deep->_throw_error(
+           "Cannot read sector at $blist_loc in clear()"
+        );
+
+    # Set blist offset to 0
+    $engine->storage->print_at( $self->offset + $self->base_size,
+        pack( $StP{$engine->byte_size}, 0 ),
+    );
+
+    # Free the blist
+    $sector->free;
+
+    return;
+}
+
 1;
 __END__
diff --git a/t/41_transaction_multilevel.t b/t/41_transaction_multilevel.t
index 790fa36..ef4b3e9 100644
--- a/t/41_transaction_multilevel.t
+++ b/t/41_transaction_multilevel.t
@@ -19,6 +19,15 @@ while ( my $dbm_maker = $dbm_factory->() ) {
     is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" );
     is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" );
 
+    cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+    cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+
+    cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
+    cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+
+    cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
+    cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
+
     $db1->begin_work;
 
         cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
diff --git a/t/47_odd_reference_behaviors.t b/t/47_odd_reference_behaviors.t
index 68162d1..c31cb4e 100644
--- a/t/47_odd_reference_behaviors.t
+++ b/t/47_odd_reference_behaviors.t
@@ -20,13 +20,14 @@ use_ok( 'DBM::Deep' );
         eval {
             $db->{bar} = $bar;
             $db->{bar} = $bar;
-        };
+        }; if ( $@ ) { warn $@ }
 
         ok(!$@, "repeated object assignment");
         isa_ok($db->{bar}, 'Foo');
     }
 }
-
+done_testing;
+__END__
 # This is bug #29957, reported by HANENKAMP
 {
     my $dbm_factory = new_dbm();