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

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

diff --git a/Changes b/Changes
index 7f1a918..bc138c5 100644
--- a/Changes
+++ b/Changes
@@ -11,6 +11,11 @@ Revision history for DBM::Deep.
     - (RT #51888) Applied POD patch (Thanks, FWIE!)
     - (RT #44981) Added VERSION to ::Array, ::Engine, and ::Hash
     - Removed extraneous slashes from POD links (Thanks ilmari!)
+    - (RT #50541) Fixed bug in clear() for hashes in the File backend.
+        - This has caused a regression in speed for clear() when clearing
+          large hashes using running with the File backend. ->clear() (on my
+          machine) now takes ( N / 40 ) ** (1.66) seconds. So, clearing 4000
+          keys (as is the test in t/03_bighash.t) would take ~2070 seconds.
 
 1.0019_001 Dec 31 22:00:00 2009 EST
     (This is the first developer release for 1.0020.)
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index ff2585d..294f5ab 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -572,25 +572,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 4b8a2cc..247d730 100644
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -394,6 +394,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;
+}
+
 sub length  { (shift)->FETCHSIZE(@_) }
 sub pop     { (shift)->POP(@_)       }
 sub push    { (shift)->PUSH(@_)      }
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index c4ee232..102f367 100644
--- a/lib/DBM/Deep/Hash.pm
+++ b/lib/DBM/Deep/Hash.pm
@@ -102,6 +102,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/lib/DBM/Deep/Sector/File/Reference.pm b/lib/DBM/Deep/Sector/File/Reference.pm
index 5b4ee12..7430b0a 100644
--- a/lib/DBM/Deep/Sector/File/Reference.pm
+++ b/lib/DBM/Deep/Sector/File/Reference.pm
@@ -284,9 +284,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/t/02_hash.t b/t/02_hash.t
index c8a0cab..774ab49 100644
--- a/t/02_hash.t
+++ b/t/02_hash.t
@@ -177,4 +177,23 @@ while ( my $dbm_maker = $dbm_factory->() ) {
     } 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 $dbm_factory = new_dbm();
+    while ( my $dbm_maker = $dbm_factory->() ) {
+        my $db = $dbm_maker->();
+
+        $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" );
+    }
+}
+
 done_testing;
diff --git a/t/common.pm b/t/common.pm
index 53d9e29..146c88b 100644
--- a/t/common.pm
+++ b/t/common.pm
@@ -70,6 +70,7 @@ sub new_dbm {
 
     if ( $ENV{TEST_MYSQL_DSN} ) {
         push @reset_funcs, sub {
+            require 'DBI.pm';
             my $dbh = DBI->connect(
                 $ENV{TEST_MYSQL_DSN},
                 $ENV{TEST_MYSQL_USER},