Fixed a couple problems, wrote tests for a couple more

diff --git a/Changes b/Changes
index e752491..b2f01a5 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,9 +1,10 @@
 Revision history for DBM::Deep.
 
-1.0008 Mar 09 20:00:00 2008 EDT
-    - (This version is compatible with 1.0007)
+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, don't complain.
+        - _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)

diff --git a/MANIFEST b/MANIFEST
index 74be757..b493fc6 100644 (file)
--- 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 1769c90..58e77ee 100644 (file)
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -8,8 +8,6 @@ use warnings;
 our $VERSION = q(1.0009);
 
 use Fcntl qw( :flock );
-
-use Digest::MD5 ();
 use Scalar::Util ();
 
 use DBM::Deep::Engine;
@@ -19,6 +17,8 @@ use overload
     '""' => sub { overload::StrVal( $_[0] ) },
     fallback => 1;
 
+use constant DEBUG => 0;
+
 ##
 # Setup constants for users to pass to new()
 ##
@@ -457,6 +457,7 @@ sub STORE {
     ##
     my $self = shift->_get_self;
     my ($key, $value) = @_;
+    warn "STORE($self, $key, $value)\n" if DEBUG;
 
     unless ( $self->_storage->is_writable ) {
         $self->_throw_error( 'Cannot write to a readonly filehandle' );
@@ -486,6 +487,7 @@ sub FETCH {
     ##
     my $self = shift->_get_self;
     my ($key) = @_;
+    warn "FETCH($self,$key)\n" if DEBUG;
 
     ##
     # Request shared lock for reading
@@ -509,6 +511,7 @@ sub DELETE {
     ##
     my $self = shift->_get_self;
     my ($key) = @_;
+    warn "DELETE($self,$key)\n" if DEBUG;
 
     unless ( $self->_storage->is_writable ) {
         $self->_throw_error( 'Cannot write to a readonly filehandle' );
@@ -539,6 +542,7 @@ sub EXISTS {
     ##
     my $self = shift->_get_self;
     my ($key) = @_;
+    warn "EXISTS($self,$key)\n" if DEBUG;
 
     ##
     # Request shared lock for reading
@@ -557,6 +561,7 @@ sub CLEAR {
     # Clear all keys from hash, or all elements from array.
     ##
     my $self = shift->_get_self;
+    warn "CLEAR($self)\n" if DEBUG;
 
     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 817b3cf..3b0c8bd 100644 (file)
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -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/t/27_filehandle.t b/t/27_filehandle.t
index 11f9eca..c70b09d 100644 (file)
--- 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/47_odd_reference_behaviors.t b/t/47_odd_reference_behaviors.t
new file mode 100644 (file)
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__