From: rkinyon Date: Wed, 19 Mar 2008 15:44:54 +0000 (+0000) Subject: Fixed a couple problems, wrote tests for a couple more X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fbugfixes;p=dbsrgits%2FDBM-Deep.git Fixed a couple problems, wrote tests for a couple more --- diff --git a/Changes b/Changes index e752491..b2f01a5 100644 --- 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 --- 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 --- 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 --- 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 --- 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 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__