From: Rob Kinyon <rob.kinyon@gmail.com>
Date: Wed, 6 Jan 2010 03:12:11 +0000 (-0500)
Subject: Merge cd5303b: RT# 50541: Fix for clear bug. Introduces a speed regression
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBM-Deep.git;a=commitdiff_plain;h=39baa1fda99986614022920b8fabd856c09c69b8

Merge cd5303b: RT# 50541: Fix for clear bug. Introduces a speed regression
---

diff --git a/Changes b/Changes
index 8247baf..7409959 100644
--- a/Changes
+++ b/Changes
@@ -5,6 +5,7 @@ Revision history for DBM::Deep.
     - New caveat in the docs explaining stale references (RT#42129)
     - All included modules now have the same version in META.yml, so
       the CPAN shell will no longer try to downgrade.
+    - Fixed bug in clear() for hashes (RT#50541)
 
 1.0015 Jan 25 22:05:00 2010 PST
     - (This version is compatible with 1.0014)
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index ef13ec3..5757d59 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -581,25 +581,8 @@ sub CLEAR {
 
     $self->lock_exclusive;
 
-    #XXX Rewrite this dreck to do it in the engine as a tight loop vs.
-    # iterating over keys - such a WASTE - is this required for transactional
-    # clearning?! Surely that can be detected in the engine ...
-    if ( $self->_type eq TYPE_HASH ) {
-        my $key = $self->first_key;
-        while ( $key ) {
-            # Retrieve the key before deleting because we depend on next_key
-            my $next_key = $self->next_key( $key );
-            $self->_engine->delete_key( $self, $key, $key );
-            $key = $next_key;
-        }
-    }
-    else {
-        my $size = $self->FETCHSIZE;
-        for my $key ( 0 .. $size - 1 ) {
-            $self->_engine->delete_key( $self, $key, $key );
-        }
-        $self->STORESIZE( 0 );
-    }
+    # Dispatch to the specific clearing functionality.
+    $self->_clear;
 
     $self->unlock;
 
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index 69be60a..a82be56 100644
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -396,6 +396,18 @@ sub _copy_node {
     return 1;
 }
 
+sub _clear {
+    my $self = shift;
+
+    my $size = $self->FETCHSIZE;
+    for my $key ( 0 .. $size - 1 ) {
+        $self->_engine->delete_key( $self, $key, $key );
+    }
+    $self->STORESIZE( 0 );
+
+    return;
+}
+
 ##
 # Public method aliases
 ##
diff --git a/lib/DBM/Deep/Engine/Sector/Reference.pm b/lib/DBM/Deep/Engine/Sector/Reference.pm
index ff40670..c681cda 100644
--- a/lib/DBM/Deep/Engine/Sector/Reference.pm
+++ b/lib/DBM/Deep/Engine/Sector/Reference.pm
@@ -283,9 +283,10 @@ sub get_bucket_list {
     $sector->find_md5( $args->{key_md5} );
 
     # See whether or not we need to reindex the bucketlist
-    # Yes, the double-braces are there for a reason. if() doesn't create a redo-able block,
-    # so we have to create a bare block within the if() for redo-purposes. Patch and idea
-    # submitted by sprout@cpan.org. -RobK, 2008-01-09
+    # Yes, the double-braces are there for a reason. if() doesn't create a
+    # redo-able block, so we have to create a bare block within the if() for
+    # redo-purposes.
+    # Patch and idea submitted by sprout@cpan.org. -RobK, 2008-01-09
     if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
         my $redo;
 
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index f09f674..e3188ec 100644
--- a/lib/DBM/Deep/Hash.pm
+++ b/lib/DBM/Deep/Hash.pm
@@ -111,6 +111,16 @@ sub NEXTKEY {
 sub first_key { (shift)->FIRSTKEY(@_) }
 sub next_key { (shift)->NEXTKEY(@_) }
 
+sub _clear {
+    my $self = shift;
+
+    while ( my $key = $self->first_key ) {
+        $self->_engine->delete_key( $self, $key, $key );
+    }
+
+    return;
+}
+
 sub _copy_node {
     my $self = shift;
     my ($db_temp) = @_;
diff --git a/t/02_hash.t b/t/02_hash.t
index 3d81ca0..6fd66d8 100644
--- a/t/02_hash.t
+++ b/t/02_hash.t
@@ -2,7 +2,7 @@
 # DBM::Deep Test
 ##
 use strict;
-use Test::More tests => 51;
+use Test::More tests => 53;
 use Test::Exception;
 use t::common qw( new_fh );
 
@@ -202,3 +202,22 @@ throws_ok {
     $db->exists(undef);
 } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
 
+{
+    # RT# 50541 (reported by Peter Scott)
+    # clear() leaves one key unless there's only one
+    my ($fh, $filename) = new_fh();
+    my $db = DBM::Deep->new(
+        file => $filename,
+        fh => $fh,
+    );
+
+    $db->{block} = { };
+    $db->{critical} = { };
+    $db->{minor} = { };
+
+    cmp_ok( scalar(keys( %$db )), '==', 3, "Have 3 keys" );
+
+    $db->clear;
+
+    cmp_ok( scalar(keys( %$db )), '==', 0, "clear clears everything" );
+}