From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Fri, 11 Jan 2008 04:44:20 +0000 (+0000)
Subject:  r12194@rob-kinyons-computer-2 (orig r10513):  rkinyon | 2008-01-10 23:43:55 -0500
X-Git-Tag: 1-0007~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5a70a6c032a79557eddd062e8dd5f7c326690721;p=dbsrgits%2FDBM-Deep.git

 r12194@rob-kinyons-computer-2 (orig r10513):  rkinyon | 2008-01-10 23:43:55 -0500
  r12193@rob-kinyons-computer-2 (orig r10512):  rkinyon | 2008-01-10 23:43:35 -0500
  Fixes for 1.0007
---

diff --git a/Build.PL b/Build.PL
index abcf310..7143cbf 100644
--- a/Build.PL
+++ b/Build.PL
@@ -13,6 +13,7 @@ my $build = Module::Build->new(
         'FileHandle::Fmode' => '0.05',
     },
     optional => {
+        'Pod::Usage'        => '1.3',
     },
     build_requires => {
         'File::Path'      => '0.01',
diff --git a/Changes b/Changes
index 22535e0..60dda1d 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,17 @@
 Revision history for DBM::Deep.
 
+1.0007 Jan 10 00:00:00 2008 EDT
+    - (This version is compatible with 1.0006)
+    - Applied a patch+failing test submitted by sprout@cpan.org. Thanks!
+      - Turns out that the case of 17 keys with the same first character in the
+        MD5 hash wasn't being tested for. This was a crashbug.
+    - A fix has been made to upgrade_db.pl (RT# 30067)
+      - The version determinations were in the wrong order or evaluation. This
+        meant that upgrade_db.pl wouldn't work as expected (or at all).
+    - Added a minimum Pod::Usage requirement (RT# 29976)
+      - It's an optional item in Build.PL
+      - utils/upgrade_db.pl now checks for that version, as does the test.
+
 1.0006 Oct 01 23:15:00 2007 EDT
     - (This version is compatible with 1.0005)
     - Removed Clone and replaced it with a hand-written datastructure walker.
diff --git a/MANIFEST b/MANIFEST
index a0bbd13..74be757 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -58,6 +58,7 @@ t/42_transaction_indexsector.t
 t/43_transaction_maximum.t
 t/44_upgrade_db.t
 t/45_references.t
+t/46_blist_reindex.t
 t/97_dump_file.t
 t/98_pod.t
 t/99_pod_coverage.t
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index d34e675..54a2638 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.0006);
+our $VERSION = q(1.0007);
 
 use Fcntl qw( :flock );
 
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index 6f78c0d..7522549 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.0006);
+our $VERSION = q(1.0007);
 
 # 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 1a841f8..89216ae 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.0006);
+our $VERSION = q(1.0007);
 
 use Scalar::Util ();
 
@@ -1599,7 +1599,12 @@ sub get_bucket_list {
     $sector->find_md5( $args->{key_md5} );
 
     # See whether or not we need to reindex the bucketlist
-    if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {
+    # 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;
+
         my $new_index = DBM::Deep::Engine::Sector::Index->new({
             engine => $engine,
         });
@@ -1625,23 +1630,48 @@ sub get_bucket_list {
         # Handle the new item separately.
         {
             my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
-            my $blist = $blist_cache{$idx}
-                ||= DBM::Deep::Engine::Sector::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::Engine::Sector::Null->new({
-                    engine => $engine,
-                    data   => undef,
-                }),
-            });
+            # If all the previous blist's items have been thrown into one
+            # blist and the new item belongs in there too, we need
+            # another index.
+            if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
+                ++$i, ++$redo;
+            } else {
+                my $blist = $blist_cache{$idx}
+                    ||= DBM::Deep::Engine::Sector::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::Engine::Sector::Null->new({
+                        engine => $engine,
+                        data   => undef,
+                    }),
+                });
+            }
+#            my $blist = $blist_cache{$idx}
+#                ||= DBM::Deep::Engine::Sector::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::Engine::Sector::Null->new({
+#                    engine => $engine,
+#                    data   => undef,
+#                }),
+#            });
         }
 
         if ( $last_sector ) {
@@ -1658,9 +1688,15 @@ sub get_bucket_list {
         $sector->clear;
         $sector->free;
 
+        if ( $redo ) {
+            (undef, $sector) = %blist_cache;
+            $last_sector = $new_index;
+            redo;
+        }
+
         $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
         $sector->find_md5( $args->{key_md5} );
-    }
+    }}
 
     return $sector;
 }
diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index 83835d9..5216eaf 100644
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -5,7 +5,7 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0006);
+our $VERSION = q(1.0007);
 
 use Fcntl qw( :DEFAULT :flock :seek );
 
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index 7bca7ce..c152b22 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.0006);
+our $VERSION = q(1.0007);
 
 use base 'DBM::Deep';
 
diff --git a/t/44_upgrade_db.t b/t/44_upgrade_db.t
index f72ef70..ba0a06a 100644
--- a/t/44_upgrade_db.t
+++ b/t/44_upgrade_db.t
@@ -5,7 +5,7 @@ use Test::More;
 # Add skips here
 BEGIN {
     my @failures;
-    eval { use Pod::Usage; }; push @failures, 'Pod::Usage' if $@;
+    eval { use Pod::Usage 1.3; }; push @failures, 'Pod::Usage' if $@;
     eval { use IO::Scalar; }; push @failures, 'IO::Scalar' if $@;
     if ( @failures ) {
         my $missing = join ',', @failures;
@@ -13,7 +13,7 @@ BEGIN {
     }
 }
 
-plan tests => 222;
+plan tests => 232;
 
 use t::common qw( new_fh );
 use File::Spec;
@@ -48,6 +48,8 @@ is(
     "Input is not a DBM::Deep file",
 );
 
+unlink $input_filename;unlink $output_filename;
+
 # All files are of the form:
 #   $db->{foo} = [ 1 .. 3 ];
 
@@ -63,7 +65,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.0003', '1.0004', '1.0005', '1.0006', '1.0007',
 );
 
 foreach my $input_filename (
@@ -116,20 +118,20 @@ foreach my $input_filename (
         die "$output\n" if $output;
 
         my $db;
-        if ( $v =~ /^0/ ) {
-            push @INC, File::Spec->catdir( 'utils', 'lib' );
-            eval "use DBM::Deep::09830";
-            $db = DBM::Deep::09830->new( $output_filename );
+        if ( $v =~ /^1\.000[3-7]/ ) {
+            push @INC, 'lib';
+            eval "use DBM::Deep";
+            $db = DBM::Deep->new( $output_filename );
         }
         elsif ( $v =~ /^1\.000?[0-2]?/ ) {
             push @INC, File::Spec->catdir( 'utils', 'lib' );
             eval "use DBM::Deep::10002";
             $db = DBM::Deep::10002->new( $output_filename );
         }
-        elsif ( $v =~ /^1\.000[3-6]/ ) {
-            push @INC, 'lib';
-            eval "use DBM::Deep";
-            $db = DBM::Deep->new( $output_filename );
+        elsif ( $v =~ /^0/ ) {
+            push @INC, File::Spec->catdir( 'utils', 'lib' );
+            eval "use DBM::Deep::09830";
+            $db = DBM::Deep::09830->new( $output_filename );
         }
         else {
             die "How did we get here?!\n";
diff --git a/t/46_blist_reindex.t b/t/46_blist_reindex.t
new file mode 100644
index 0000000..d6e009d
--- /dev/null
+++ b/t/46_blist_reindex.t
@@ -0,0 +1,62 @@
+# This test (and accompanying patch) was submitted by Father Chrysostomos (sprout@cpan.org)
+
+use 5.006;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More tests => 5;
+
+use t::common qw( new_fh );
+
+use_ok( 'DBM::Deep' );
+
+{
+    my ($fh, $filename) = new_fh();
+    my $db = DBM::Deep->new( $filename );
+    
+    ok eval {
+        for ( # the checksums of all these begin with ^@:
+            qw/ s340l 1970 thronos /,
+            "\320\277\320\276\320\262\320\265\320\273\320\265\320\275".
+            "\320\275\320\276\320\265", qw/ mr094 despite
+            geographically binding bed handmaiden infer lela infranarii
+            lxv evtropia recognizes maladies /
+        ) {
+            $db->{$_} = undef;
+        }
+        1;
+    }, '2 indices can be created at once';
+    
+    is_deeply [sort keys %$db], [ sort
+       qw/ s340l 1970 thronos /,
+        "\320\277\320\276\320\262\320\265\320\273\320\265\320\275".
+        "\320\275\320\276\320\265", qw/ mr094 despite
+        geographically binding bed handmaiden infer lela infranarii
+        lxv evtropia recognizes maladies /
+    ], 'and the keys were stored correctly';
+}
+
+{
+    my ($fh, $filename) = new_fh();
+    my $db = DBM::Deep->new( $filename );
+    
+    ok eval {
+        for ( # the checksums of all these begin with ^@^@^@:
+            qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda
+                lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII
+                FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW /
+        ) {
+            $db->{$_} = undef;
+        }
+        1;
+    }, 'multiple nested indices can be created at once';
+    
+    is_deeply [sort keys %$db], [ sort
+        qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda
+            lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII
+            FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW /
+    ], 'and the keys were stored correctly';
+}
+
+__END__
diff --git a/t/common.pm b/t/common.pm
index 2348cb9..5312600 100644
--- a/t/common.pm
+++ b/t/common.pm
@@ -1,4 +1,5 @@
-package t::common;
+package # Hide from PAUSE
+    t::common;
 
 use 5.006_000;
 
@@ -18,6 +19,7 @@ use Fcntl qw( :flock );
 
 my $parent = $ENV{WORK_DIR} || File::Spec->tmpdir;
 my $dir = tempdir( CLEANUP => 1, DIR => $parent );
+#my $dir = tempdir( DIR => '.' );
 
 sub new_fh {
     my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir );
@@ -30,4 +32,3 @@ sub new_fh {
 
 1;
 __END__
-
diff --git a/utils/upgrade_db.pl b/utils/upgrade_db.pl
index b80889b..ac6d97e 100755
--- a/utils/upgrade_db.pl
+++ b/utils/upgrade_db.pl
@@ -13,7 +13,7 @@ use lib File::Spec->catdir( $FindBin::Bin, 'lib' );
 use lib File::Spec->catdir( $FindBin::Bin, '..', 'lib' );
 
 use Getopt::Long qw( GetOptions );
-use Pod::Usage;
+use Pod::Usage 1.3;
 
 my %headerver_to_module = (
   '0' => 'DBM::Deep::09830',
@@ -28,7 +28,7 @@ my %is_dev = (
 my %opts = (
   man => 0,
   help => 0,
-  version => '1.0006',
+  version => '1.0007',
   autobless => 1,
 );
 GetOptions( \%opts,
@@ -71,17 +71,17 @@ my %db;
 
 {
   my $ver = $opts{version};
-  if ( $ver =~ /^0\.9[1-8]/ ) {
-    $ver = 0;
-  }
-  elsif ( $ver =~ /^0\.99/) { 
-    $ver = 1;
+  if ( $ver =~ /^1\.000[3-7]/) {
+    $ver = 3;
   }
   elsif ( $ver =~ /^1\.000?[0-2]?/) {
     $ver = 2;
   }
-  elsif ( $ver =~ /^1\.000[3-6]/) {
-    $ver = 3;
+  elsif ( $ver =~ /^0\.99/) { 
+    $ver = 1;
+  }
+  elsif ( $ver =~ /^0\.9[1-8]/ ) {
+    $ver = 0;
   }
   else {
     _exit( "'$ver' is an unrecognized version." );