From: rkinyon@cpan.org <rkinyon@cpan.org>
Date: Sat, 14 Jun 2008 01:51:40 +0000 (+0000)
Subject: Applied patch by Wulfram Humann for improving reindex_entry()
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=695c88b11ccf82f4faf67bada78fb17169310d6b;p=dbsrgits%2FDBM-Deep.git

Applied patch by Wulfram Humann for improving reindex_entry()

git-svn-id: http://svn.ali.as/cpan/trunk/DBM-Deep@3569 88f4d9cd-8a04-0410-9d60-8f63309c3137
---

diff --git a/Changes b/Changes
index 77936e8..58c58b3 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,10 @@
 Revision history for DBM::Deep.
 
+1.0013 Jun 18 00:00:00 2008 EST
+    - (This version is compatible with 1.0012)
+    - Fix for RT#30144 (Optimization failure on Win32)
+    - Fixed a bug in reindex_entry (Thanks, Wulfram Humann!)
+
 1.0012 Jun 09 15:00:00 2008 EST
     - (This version is compatible with 1.0011)
     - Fix for RT#30085 (Remove dependency on XS module)
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index a888d44..e4a21fa 100644
--- 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.0012);
+our $VERSION = q(1.0013);
 
 use Data::Dumper ();
 use Fcntl qw( :flock );
@@ -328,7 +328,7 @@ sub optimize {
     $self->lock();
     $self->_engine->clear_cache;
     $self->_copy_node( $db_temp );
-    $dbtemp->_storage->close;
+    $db_temp->_storage->close;
     undef $db_temp;
 
     ##
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index 6c83b27..38c5186 100644
--- 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.0012);
+our $VERSION = q(1.0013);
 
 # 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 5bd76a5..fa04b4f 100644
--- 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.0012);
+our $VERSION = q(1.0013);
 
 # Never import symbols into our namespace. We are a class, not a library.
 # -RobK, 2008-05-27
@@ -628,12 +628,10 @@ sub reindex_entry {
 
     TRANS:
     while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
-        foreach my $orig_loc ( keys %{ $locs } ) {
-            if ( $orig_loc == $old_loc ) {
-                delete $locs->{orig_loc};
-                $locs->{$new_loc} = undef;
-                next TRANS;
-            }
+        if ( exists $locs->{$old_loc} ) {
+            delete $locs->{$old_loc};
+            $locs->{$new_loc} = undef;
+            next TRANS;
         }
     }
 }
diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index 73c8b0e..13342d8 100644
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -5,10 +5,12 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0012);
+our $VERSION = q(1.0013);
 
 use Fcntl qw( :DEFAULT :flock :seek );
 
+use constant DEBUG => 0;
+
 sub new {
     my $class = shift;
     my ($args) = @_;
@@ -110,6 +112,12 @@ sub print_at {
         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
     }
 
+    if ( DEBUG ) {
+        my $caller = join ':', (caller)[0,2];
+        my $len = length( join '', @_ );
+        warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
+    }
+
     print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
 
     return 1;
@@ -126,6 +134,11 @@ sub read_at {
         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
     }
 
+    if ( DEBUG ) {
+        my $caller = join ':', (caller)[0,2];
+        warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
+    }
+
     my $buffer;
     read( $fh, $buffer, $size);
 
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index 4c77e78..6db4e21 100644
--- 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.0012);
+our $VERSION = q(1.0013);
 
 use base 'DBM::Deep';
 
diff --git a/t/01_basic.t b/t/01_basic.t
index 7025ea9..5798da4 100644
--- a/t/01_basic.t
+++ b/t/01_basic.t
@@ -25,3 +25,5 @@ if ( $@ ) {
 
 isa_ok( $db, 'DBM::Deep' );
 ok(1, "We can successfully open a file!" );
+
+$db->{foo} = 'bar';
diff --git a/t/44_upgrade_db.t b/t/44_upgrade_db.t
index 47ce1ce..245f473 100644
--- a/t/44_upgrade_db.t
+++ b/t/44_upgrade_db.t
@@ -20,7 +20,7 @@ BEGIN {
     }
 }
 
-plan tests => 282;
+plan tests => 292;
 
 use t::common qw( new_fh );
 use File::Spec;
@@ -72,7 +72,7 @@ my @output_versions = (
     '0.981', '0.982', '0.983',
     '0.99_01', '0.99_02', '0.99_03', '0.99_04',
     '1.00', '1.000', '1.0000', '1.0001', '1.0002',
-    '1.0003', '1.0004', '1.0005', '1.0006', '1.0007', '1.0008', '1.0009', '1.0010', '1.0011', '1.0012',
+    '1.0003', '1.0004', '1.0005', '1.0006', '1.0007', '1.0008', '1.0009', '1.0010', '1.0011', '1.0012', '1.0013',
 );
 
 foreach my $input_filename (
@@ -125,7 +125,7 @@ foreach my $input_filename (
         die "$output\n" if $output;
 
         my $db;
-        if ( $v =~ /^1\.001[0-2]/ || $v =~ /^1\.000[3-9]/ ) {
+        if ( $v =~ /^1\.001[0-3]/ || $v =~ /^1\.000[3-9]/ ) {
             push @INC, 'lib';
             eval "use DBM::Deep";
             $db = DBM::Deep->new( $output_filename );
diff --git a/utils/upgrade_db.pl b/utils/upgrade_db.pl
index c25af18..91003c3 100755
--- a/utils/upgrade_db.pl
+++ b/utils/upgrade_db.pl
@@ -28,7 +28,7 @@ my %is_dev = (
 my %opts = (
   man => 0,
   help => 0,
-  version => '1.0012',
+  version => '1.0013',
   autobless => 1,
 );
 GetOptions( \%opts,
@@ -71,7 +71,7 @@ my %db;
 
 {
   my $ver = $opts{version};
-  if ( $ver =~ /^1\.001[0-2]/) {
+  if ( $ver =~ /^1\.001[0-3]/) {
     $ver = 3;
   }
   elsif ( $ver =~ /^1\.000[3-9]/) {