From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Wed, 19 Mar 2008 15:45:11 +0000 (+0000)
Subject:  r693@rob-kinyons-computer-2 (orig r10898):  rkinyon | 2008-03-10 02:03:23 -0400
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=CURRENT;p=dbsrgits%2FDBM-Deep.git

 r693@rob-kinyons-computer-2 (orig r10898):  rkinyon | 2008-03-10 02:03:23 -0400
 Removed _fh() method from DBM::Deep and refactored appropriately
 r5020@rob-kinyons-computer-2 (orig r10947):  rkinyon | 2008-03-19 11:44:54 -0400
 Fixed a couple problems, wrote tests for a couple more
---

diff --git a/Changes b/Changes
index d6066b3..b2f01a5 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,11 @@
 Revision history for DBM::Deep.
 
+1.0009 Mar 19 12:00:00 2008 EDT
+    - (This version is compatible with 1.0008)
+    - Internal refactorings to prepare for some optimizations.
+        - _fh() has been removed. It was marked as private, so don't complain.
+    - Skip a test that was spuriously failing on Win32 (Thanks, Alias!)
+
 1.0008 Mar 09 20:00:00 2008 EDT
     - (This version is compatible with 1.0007)
     - Fixed a number of Win32 issues (Reported by Steven Samelson - thank you!)
diff --git a/MANIFEST b/MANIFEST
index 74be757..b493fc6 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -59,6 +59,7 @@ t/43_transaction_maximum.t
 t/44_upgrade_db.t
 t/45_references.t
 t/46_blist_reindex.t
+t/47_odd_reference_behaviors.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 36a40a4..58e77ee 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -5,12 +5,9 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0008);
+our $VERSION = q(1.0009);
 
 use Fcntl qw( :flock );
-
-use Digest::MD5 ();
-use FileHandle::Fmode ();
 use Scalar::Util ();
 
 use DBM::Deep::Engine;
@@ -20,6 +17,8 @@ use overload
     '""' => sub { overload::StrVal( $_[0] ) },
     fallback => 1;
 
+use constant DEBUG => 0;
+
 ##
 # Setup constants for users to pass to new()
 ##
@@ -300,8 +299,9 @@ sub optimize {
     #XXX Do we have to lock the tempfile?
 
     #XXX Should we use tempfile() here instead of a hard-coded name?
+    my $temp_filename = $self->_storage->{file} . '.tmp';
     my $db_temp = DBM::Deep->new(
-        file => $self->_storage->{file} . '.tmp',
+        file => $temp_filename,
         type => $self->_type,
 
         # Bring over all the parameters that we need to bring over
@@ -318,12 +318,7 @@ sub optimize {
     ##
     # Attempt to copy user, group and permissions over to new file
     ##
-    my @stats = stat($self->_fh);
-    my $perms = $stats[2] & 07777;
-    my $uid = $stats[4];
-    my $gid = $stats[5];
-    chown( $uid, $gid, $self->_storage->{file} . '.tmp' );
-    chmod( $perms, $self->_storage->{file} . '.tmp' );
+    $self->_storage->copy_stats( $temp_filename );
 
     # q.v. perlport for more information on this variable
     if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
@@ -337,8 +332,8 @@ sub optimize {
         $self->_storage->close;
     }
 
-    if (!rename $self->_storage->{file} . '.tmp', $self->_storage->{file}) {
-        unlink $self->_storage->{file} . '.tmp';
+    if (!rename $temp_filename, $self->_storage->{file}) {
+        unlink $temp_filename;
         $self->unlock();
         $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
     }
@@ -442,11 +437,6 @@ sub _staleness {
     return $self->{staleness};
 }
 
-sub _fh {
-    my $self = $_[0]->_get_self;
-    return $self->_storage->{fh};
-}
-
 ##
 # Utility methods
 ##
@@ -467,8 +457,9 @@ sub STORE {
     ##
     my $self = shift->_get_self;
     my ($key, $value) = @_;
+    warn "STORE($self, $key, $value)\n" if DEBUG;
 
-    if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
+    unless ( $self->_storage->is_writable ) {
         $self->_throw_error( 'Cannot write to a readonly filehandle' );
     }
 
@@ -496,6 +487,7 @@ sub FETCH {
     ##
     my $self = shift->_get_self;
     my ($key) = @_;
+    warn "FETCH($self,$key)\n" if DEBUG;
 
     ##
     # Request shared lock for reading
@@ -519,8 +511,9 @@ sub DELETE {
     ##
     my $self = shift->_get_self;
     my ($key) = @_;
+    warn "DELETE($self,$key)\n" if DEBUG;
 
-    if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
+    unless ( $self->_storage->is_writable ) {
         $self->_throw_error( 'Cannot write to a readonly filehandle' );
     }
 
@@ -549,6 +542,7 @@ sub EXISTS {
     ##
     my $self = shift->_get_self;
     my ($key) = @_;
+    warn "EXISTS($self,$key)\n" if DEBUG;
 
     ##
     # Request shared lock for reading
@@ -567,8 +561,9 @@ sub CLEAR {
     # Clear all keys from hash, or all elements from array.
     ##
     my $self = shift->_get_self;
+    warn "CLEAR($self)\n" if DEBUG;
 
-    if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
+    unless ( $self->_storage->is_writable ) {
         $self->_throw_error( 'Cannot write to a readonly filehandle' );
     }
 
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index e12e7c9..3b0c8bd 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.0008);
+our $VERSION = q(1.0009);
 
 # This is to allow DBM::Deep::Array to handle negative indices on
 # its own. Otherwise, Perl would intercept the call to negative
@@ -137,6 +137,7 @@ sub EXISTS {
 sub DELETE {
     my $self = shift->_get_self;
     my ($key) = @_;
+    warn "ARRAY::DELETE($self,$key)\n" if DBM::Deep::DEBUG;
 
     $self->lock( $self->LOCK_EX );
 
@@ -257,6 +258,7 @@ sub _move_value {
 
 sub SHIFT {
     my $self = shift->_get_self;
+    warn "SHIFT($self)\n" if DBM::Deep::DEBUG;
 
     $self->lock( $self->LOCK_EX );
 
@@ -272,6 +274,7 @@ sub SHIFT {
     for (my $i = 0; $i < $length - 1; $i++) {
         $self->_move_value( $i+1, $i );
     }
+
     $self->DELETE( $length - 1 );
 
     $self->unlock;
diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index a6d69b6..d2d0f4b 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.0008);
+our $VERSION = q(1.0009);
 
 use Scalar::Util ();
 
diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index a37b4a3..042cbaa 100644
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -5,9 +5,10 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0008);
+our $VERSION = q(1.0009);
 
 use Fcntl qw( :DEFAULT :flock :seek );
+use FileHandle::Fmode ();
 
 sub new {
     my $class = shift;
@@ -235,5 +236,22 @@ sub flush {
     return 1;
 }
 
+sub is_writable {
+    my $self = shift;
+    return FileHandle::Fmode::is_W( $self->{fh} );
+}
+
+sub copy_stats {
+    my $self = shift;
+    my ($temp_filename) = @_;
+
+    my @stats = stat( $self->{fh} );
+    my $perms = $stats[2] & 07777;
+    my $uid = $stats[4];
+    my $gid = $stats[5];
+    chown( $uid, $gid, $temp_filename );
+    chmod( $perms, $temp_filename );
+}
+
 1;
 __END__
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index 0ee6fca..d4ae61d 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.0008);
+our $VERSION = q(1.0009);
 
 use base 'DBM::Deep';
 
diff --git a/t/11_optimize.t b/t/11_optimize.t
index 61741bf..5fb6d11 100644
--- a/t/11_optimize.t
+++ b/t/11_optimize.t
@@ -49,9 +49,9 @@ delete $db->{a}{b};
 ##
 # take byte count readings before, and after optimize
 ##
-my $before = (stat($db->_fh()))[7];
+my $before = (stat($filename))[7];
 my $result = $db->optimize();
-my $after = (stat($db->_fh()))[7];
+my $after = (stat($filename))[7];
 
 ok( $result, "optimize succeeded" );
 ok( $after < $before, "file size has shrunk" ); # make sure file shrunk
diff --git a/t/13_setpack.t b/t/13_setpack.t
index 9b468b4..e7ef34b 100644
--- a/t/13_setpack.t
+++ b/t/13_setpack.t
@@ -18,7 +18,7 @@ my ($default, $small, $medium, $large);
     );
     $db->{key1} = "value1";
     $db->{key2} = "value2";
-    $default = (stat($db->_fh()))[7];
+    $default = (stat($filename))[7];
 }
 
 {
@@ -32,7 +32,7 @@ my ($default, $small, $medium, $large);
 
         $db->{key1} = "value1";
         $db->{key2} = "value2";
-        $medium = (stat($db->_fh()))[7];
+        $medium = (stat($filename))[7];
     }
 
     # This tests the header to verify that the pack_size is really there
@@ -59,7 +59,7 @@ my ($default, $small, $medium, $large);
 
         $db->{key1} = "value1";
         $db->{key2} = "value2";
-        $small = (stat($db->_fh()))[7];
+        $small = (stat($filename))[7];
     }
 
     # This tests the header to verify that the pack_size is really there
@@ -89,7 +89,7 @@ SKIP: {
 
         $db->{key1} = "value1";
         $db->{key2} = "value2";
-        $large = (stat($db->_fh()))[7];
+        $large = (stat($filename))[7];
     }
 
     # This tests the header to verify that the pack_size is really there
diff --git a/t/26_scalar_ref.t b/t/26_scalar_ref.t
index d04b439..7f6e3e7 100644
--- a/t/26_scalar_ref.t
+++ b/t/26_scalar_ref.t
@@ -28,7 +28,7 @@ my $x = 25;
     'Storage of code refs not supported';
 
     throws_ok {
-        $db->{scalarref} = $db->_get_self->_fh;
+        $db->{scalarref} = $fh;
     } qr/Storage of references of type 'GLOB' is not supported/,
     'Storage of glob refs not supported';
 
diff --git a/t/27_filehandle.t b/t/27_filehandle.t
index 11f9eca..c70b09d 100644
--- a/t/27_filehandle.t
+++ b/t/27_filehandle.t
@@ -30,8 +30,12 @@ use_ok( 'DBM::Deep' );
         } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
         ok( !$db->exists( 'foo' ), "foo doesn't exist" );
 
-        my $db_obj = $db->_get_self;
-        ok( $db_obj->_storage->{inode}, "The inode has been set" );
+        SKIP: {
+            skip( "No inode tests on Win32", 1 )
+                if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
+            my $db_obj = $db->_get_self;
+            ok( $db_obj->_storage->{inode}, "The inode has been set" );
+        }
 
         close($fh);
     }
diff --git a/t/44_upgrade_db.t b/t/44_upgrade_db.t
index 6c7abde..53711e6 100644
--- a/t/44_upgrade_db.t
+++ b/t/44_upgrade_db.t
@@ -16,7 +16,7 @@ BEGIN {
     }
 }
 
-plan tests => 232;
+plan tests => 252;
 
 use t::common qw( new_fh );
 use File::Spec;
@@ -68,7 +68,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.0003', '1.0004', '1.0005', '1.0006', '1.0007', '1.0008', '1.0009',
 );
 
 foreach my $input_filename (
@@ -121,7 +121,7 @@ foreach my $input_filename (
         die "$output\n" if $output;
 
         my $db;
-        if ( $v =~ /^1\.000[3-7]/ ) {
+        if ( $v =~ /^1\.000[3-9]/ ) {
             push @INC, 'lib';
             eval "use DBM::Deep";
             $db = DBM::Deep->new( $output_filename );
diff --git a/t/47_odd_reference_behaviors.t b/t/47_odd_reference_behaviors.t
new file mode 100644
index 0000000..1157dbc
--- /dev/null
+++ b/t/47_odd_reference_behaviors.t
@@ -0,0 +1,58 @@
+use 5.006;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Scalar::Util qw( reftype );
+use Test::More tests => 10;
+
+use t::common qw( new_fh );
+
+use_ok( 'DBM::Deep' );
+
+# This is bug #29957, reported by HANENKAMP
+TODO: {
+    todo_skip "This crashes the code", 4;
+    my ($fh, $filename) = new_fh();
+    my $db = DBM::Deep->new(
+        file => $filename,
+        fh => $fh,
+    );
+
+    $db->{foo} = [];
+
+    for my $value ( 1 .. 3 ) {
+        my $ref = $db->{foo};
+        push @$ref, $value;
+        $db->{foo} = $ref;
+        ok( 1, "T $value" );
+    }
+}
+
+# This is bug #33863, reported by PJS
+{
+    my ($fh, $filename) = new_fh();
+    my $db = DBM::Deep->new(
+        file => $filename,
+        fh => $fh,
+    );
+
+    $db->{foo} = [ 42 ];
+    my $foo = shift @{ $db->{foo} };
+    cmp_ok( @{ $db->{foo} }, '==', 0, "Shifting a scalar leaves no values" );
+    cmp_ok( $foo, '==', 42, "... And the value is correct." );
+
+#    $db->{bar} = [ [] ];
+#    my $bar = shift @{ $db->{bar} };
+#    cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" );
+#    use Data::Dumper; warn Dumper $bar;
+
+    $db->{baz} = { foo => [ 1 .. 3 ] };
+    $db->{baz2} = [ $db->{baz} ];
+    my $baz2 = shift @{ $db->{baz2} };
+    cmp_ok( @{ $db->{baz2} }, '==', 0, "Shifting an arrayref leaves no values" );
+    ok( exists $db->{baz}{foo} );
+    ok( exists $baz2->{foo} );
+}
+
+__END__
diff --git a/utils/upgrade_db.pl b/utils/upgrade_db.pl
index ac6d97e..3c36b31 100755
--- a/utils/upgrade_db.pl
+++ b/utils/upgrade_db.pl
@@ -71,7 +71,7 @@ my %db;
 
 {
   my $ver = $opts{version};
-  if ( $ver =~ /^1\.000[3-7]/) {
+  if ( $ver =~ /^1\.000[3-9]/) {
     $ver = 3;
   }
   elsif ( $ver =~ /^1\.000?[0-2]?/) {