From: Rob Kinyon <rob.kinyon@gmail.com>
Date: Mon, 11 Jan 2010 02:09:00 +0000 (-0500)
Subject: Added recursion test, hoisted staleness() to Sector.pm, and refactored to write_bucke... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBM-Deep.git;a=commitdiff_plain;h=d3aaaf5ed9523707a1fe38ec09ea9c937fa1000f

Added recursion test, hoisted staleness() to Sector.pm, and refactored to write_bucket_list() in prep for clear()
---

diff --git a/Changes b/Changes
index e23ae4f..5576df8 100644
--- a/Changes
+++ b/Changes
@@ -7,6 +7,7 @@ Revision history for DBM::Deep.
         - (No-one apparently tried to install this till Steven Lembark. Thanks!)
     - Fixed speed regression with keys in the File backend.
         - Introduced in 1.0019_002 to fix #50541
+    - (RT #53575) Recursion failure in STORE (Thanks, SPROUT)
 
 1.0019_002 Jan 05 22:30:00 2010 EST
     (This is the second developer release for 1.0020.)
diff --git a/MANIFEST b/MANIFEST
index c9d020d..9078113 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -83,6 +83,7 @@ t/50_deletes.t
 t/52_memory_leak.t
 t/53_misc_transactions.t
 t/54_output_punct_vars.t
+t/55_recursion.t
 t/97_dump_file.t
 t/98_pod.t
 t/99_pod_coverage.t
diff --git a/lib/DBM/Deep/Engine/DBI.pm b/lib/DBM/Deep/Engine/DBI.pm
index 10f5b17..4e6d719 100644
--- a/lib/DBM/Deep/Engine/DBI.pm
+++ b/lib/DBM/Deep/Engine/DBI.pm
@@ -288,7 +288,7 @@ sub write_value {
         my @temp = @$value;
         tie @$value, 'DBM::Deep', {
             base_offset => $value_sector->offset,
-#            staleness   => $value_sector->staleness,
+            staleness   => $value_sector->staleness,
             storage     => $self->storage,
             engine      => $self,
         };
@@ -299,7 +299,7 @@ sub write_value {
         my %temp = %$value;
         tie %$value, 'DBM::Deep', {
             base_offset => $value_sector->offset,
-#            staleness   => $value_sector->staleness,
+            staleness   => $value_sector->staleness,
             storage     => $self->storage,
             engine      => $self,
         };
diff --git a/lib/DBM/Deep/Sector.pm b/lib/DBM/Deep/Sector.pm
index 3f44fca..2241d6e 100644
--- a/lib/DBM/Deep/Sector.pm
+++ b/lib/DBM/Deep/Sector.pm
@@ -29,6 +29,7 @@ sub clone {
 sub engine { $_[0]{engine} }
 sub offset { $_[0]{offset} }
 sub type   { $_[0]{type}   }
+sub staleness { $_[0]{staleness} }
 
 sub load { die "load must be implemented in a child class" }
 
diff --git a/lib/DBM/Deep/Sector/File/BucketList.pm b/lib/DBM/Deep/Sector/File/BucketList.pm
index d218d0d..df57a7b 100644
--- a/lib/DBM/Deep/Sector/File/BucketList.pm
+++ b/lib/DBM/Deep/Sector/File/BucketList.pm
@@ -40,7 +40,7 @@ sub _init {
     return $self;
 }
 
-sub clear {
+sub wipe {
     my $self = shift;
     $self->engine->storage->print_at( $self->offset + $self->base_size,
         chr(0) x ($self->size - $self->base_size), # Zero-fill the data
diff --git a/lib/DBM/Deep/Sector/File/Reference.pm b/lib/DBM/Deep/Sector/File/Reference.pm
index 7430b0a..1e7a874 100644
--- a/lib/DBM/Deep/Sector/File/Reference.pm
+++ b/lib/DBM/Deep/Sector/File/Reference.pm
@@ -57,8 +57,6 @@ sub _init {
     return;
 }
 
-sub staleness { $_[0]{staleness} }
-
 sub get_data_location_for {
     my $self = shift;
     my ($args) = @_;
@@ -212,6 +210,17 @@ sub delete_key {
     return $data;
 }
 
+sub write_blist_loc {
+    my $self = shift;
+    my ($loc) = @_;
+
+    my $engine = $self->engine;
+    $engine->storage->print_at( $self->offset + $self->base_size,
+        pack( $StP{$engine->byte_size}, $loc ),
+    );
+
+}
+
 sub get_blist_loc {
     my $self = shift;
 
@@ -220,6 +229,27 @@ 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) = @_;
@@ -240,9 +270,10 @@ sub get_bucket_list {
             key_md5 => $args->{key_md5},
         });
 
-        $engine->storage->print_at( $self->offset + $self->base_size,
-            pack( $StP{$engine->byte_size}, $blist->offset ),
-        );
+        $self->write_blist_loc( $blist->offset );
+#        $engine->storage->print_at( $self->offset + $self->base_size,
+#            pack( $StP{$engine->byte_size}, $blist->offset ),
+#        );
 
         return $blist;
     }
@@ -341,23 +372,6 @@ sub get_bucket_list {
                     }),
                 });
             }
-#            my $blist = $blist_cache{$idx}
-#                ||= DBM::Deep::Sector::File::BucketList->new({
-#                    engine => $engine,
-#                });
-#
-#            $new_index->set_entry( $idx => $blist->offset );
-#
-#            #XXX THIS IS HACKY!
-#            $blist->find_md5( $args->{key_md5} );
-#            $blist->write_md5({
-#                key     => $args->{key},
-#                key_md5 => $args->{key_md5},
-#                value   => DBM::Deep::Sector::File::Null->new({
-#                    engine => $engine,
-#                    data   => undef,
-#                }),
-#            });
         }
 
         if ( $last_sector ) {
@@ -371,7 +385,7 @@ sub get_bucket_list {
             );
         }
 
-        $sector->clear;
+        $sector->wipe;
         $sector->free;
 
         if ( $redo ) {
diff --git a/t/55_recursion.t b/t/55_recursion.t
new file mode 100644
index 0000000..edec0d9
--- /dev/null
+++ b/t/55_recursion.t
@@ -0,0 +1,25 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More;
+use Test::Exception;
+use t::common qw( new_dbm );
+
+use_ok( 'DBM::Deep' );
+
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+    my $db = $dbm_maker->();
+
+    my $h = {};
+    my $tmp = $h;
+    for (1..4) { # 98 is ok, 99 is bad.
+        %$tmp = ("" => {});
+        $tmp = $tmp->{""};
+    }
+    lives_ok {
+        $db->{""} = $h;
+    } 'deep recursion causes no errors';
+}
+
+done_testing;