From: rkinyon Date: Fri, 21 Sep 2007 02:09:05 +0000 (+0000) Subject: r6127@000-443-371 (orig r9960): rkinyon | 2007-09-20 21:13:08 -0400 X-Git-Tag: 1-0002~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=807f63a7218ff60795f39942940df83687eeeb77;hp=151e00777a6e5ff803b5456075042d257dbcd4fc;p=dbsrgits%2FDBM-Deep.git r6127@000-443-371 (orig r9960): rkinyon | 2007-09-20 21:13:08 -0400 r6122@000-443-371 (orig r9951): rkinyon | 2007-09-19 22:33:23 -0400 Extended _throw_error per brian d foy's suggestion r6126@000-443-371 (orig r9959): rkinyon | 2007-09-20 21:12:41 -0400 Incremented version number, added diag for 5.9.5 failures in t/17_import.t, and updated Changes file r6129@000-443-371 (orig r9964): rkinyon | 2007-09-20 22:08:16 -0400 Final updates before uploading 1.0002 --- diff --git a/Changes b/Changes index 850dc44..7211f45 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,16 @@ Revision history for DBM::Deep. +1.0002 Sep 20 22:00:00 2007 EDT + - (This version is compatible with 1.0001) + - Expanded _throw_error() so that it provides better information. + (Thanks brian d foy!) + - Fixed how shift, unshift, and splice work when there are references + being moved. It now no longer dies. + - Added diag in t/17_import.t to note that the failing tests on blead + are due to Clone being broken, not DBM::Deep. The tests will still + fail because I don't want users to install something that's broken + and deal with those bug reports. + 1.0001 Mar 12 16:15:00 2007 EDT - (This version is compatible with 1.0000) - Added a missing dependency on IO::Scalar (RT #25387) diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 6a005a0..f5ecd68 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.0001); +our $VERSION = q(1.0002); use Fcntl qw( :flock ); @@ -390,6 +390,14 @@ sub _fh { sub _throw_error { die "DBM::Deep: $_[1]\n"; + my $n = 0; + while( 1 ) { + my @caller = caller( ++$n ); + next if $caller[0] =~ m/^DBM::Deep/; + + die "DBM::Deep: $_[1] at $0 line $caller[2]\n"; + last; + } } sub STORE { diff --git a/lib/DBM/Deep.pod b/lib/DBM/Deep.pod index c519335..57a6151 100644 --- a/lib/DBM/Deep.pod +++ b/lib/DBM/Deep.pod @@ -45,15 +45,10 @@ Windows. =head1 VERSION DIFFERENCES -B: 0.99_03 has significant file format differences from prior versions. -THere will be a backwards-compatibility layer in 1.00, but that is slated for -a later 0.99_x release. This version is B backwards compatible with any -other release of DBM::Deep. - -B: 0.99_01 and above have significant file format differences from 0.983 and -before. There will be a backwards-compatibility layer in 1.00, but that is -slated for a later 0.99_x release. This version is B backwards compatible -with 0.983 and before. +B: 1.0000 has significant file format differences from prior versions. +THere is a backwards-compatibility layer at C. Files +created by 1.0000 or higher are B compatible with scripts using prior +versions. =head1 SETUP @@ -1164,16 +1159,16 @@ reference to be imported in order to explicitly leave it untied. B is used to test the code coverage of the tests. Below is the B report on this distribution's test suite. - ---------------------------- ------ ------ ------ ------ ------ ------ ------ - File stmt bran cond sub pod time total - ---------------------------- ------ ------ ------ ------ ------ ------ ------ - blib/lib/DBM/Deep.pm 96.8 87.9 90.5 100.0 89.5 4.5 95.2 - blib/lib/DBM/Deep/Array.pm 100.0 94.3 100.0 100.0 100.0 4.8 98.7 - blib/lib/DBM/Deep/Engine.pm 97.2 86.4 86.0 100.0 0.0 56.8 91.0 - blib/lib/DBM/Deep/File.pm 98.1 83.3 66.7 100.0 0.0 31.4 88.0 - blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0 2.5 100.0 - Total 97.7 88.1 86.6 100.0 31.6 100.0 93.0 - ---------------------------- ------ ------ ------ ------ ------ ------ ------ + ----------------------------------- ------ ------ ------ ------ ------ ------ + File stmt bran cond sub time total + ----------------------------------- ------ ------ ------ ------ ------ ------ + blib/lib/DBM/Deep.pm 94.4 85.0 90.5 100.0 5.0 93.4 + blib/lib/DBM/Deep/Array.pm 100.0 94.6 100.0 100.0 4.7 98.8 + blib/lib/DBM/Deep/Engine.pm 97.2 85.8 82.4 100.0 51.3 93.8 + blib/lib/DBM/Deep/File.pm 97.2 81.6 66.7 100.0 36.5 91.9 + blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 2.5 100.0 + Total 97.2 87.4 83.9 100.0 100.0 94.6 + ----------------------------------- ------ ------ ------ ------ ------ ------ =head1 MORE INFORMATION diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index e60c152..db84214 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.0001); +our $VERSION = q(1.0002); # This is to allow DBM::Deep::Array to handle negative indices on # its own. Otherwise, Perl would intercept the call to negative @@ -251,6 +251,24 @@ sub PUSH { return $length; } +# XXX This really needs to be something more direct within the file, not a +# fetch and re-store. -RobK, 2007-09-20 +sub _move_value { + my $self = shift; + my ($old_key, $new_key) = @_; + + my $val = $self->FETCH( $old_key ); + if ( eval { local $SIG{'__DIE__'}; $val->isa( 'DBM::Deep::Hash' ) } ) { + $self->STORE( $new_key, { %$val } ); + } + elsif ( eval { local $SIG{'__DIE__'}; $val->isa( 'DBM::Deep::Array' ) } ) { + $self->STORE( $new_key, [ @$val ] ); + } + else { + $self->STORE( $new_key, $val ); + } +} + sub SHIFT { my $self = shift->_get_self; @@ -262,7 +280,7 @@ sub SHIFT { my $content = $self->FETCH( 0 ); for (my $i = 0; $i < $length - 1; $i++) { - $self->STORE( $i, $self->FETCH($i + 1) ); + $self->_move_value( $i+1, $i ); } $self->DELETE( $length - 1 ); @@ -287,7 +305,7 @@ sub UNSHIFT { if ($length) { for (my $i = $length - 1; $i >= 0; $i--) { - $self->STORE( $i + $new_size, $self->FETCH($i) ); + $self->_move_value( $i, $i+$new_size ); } } @@ -335,12 +353,12 @@ sub SPLICE { if ( $new_size != $splice_length ) { if ($new_size > $splice_length) { for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) { - $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); + $self->_move_value( $i, $i + ($new_size - $splice_length) ); } } else { for (my $i = $offset + $splice_length; $i < $length; $i++) { - $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) ); + $self->_move_value( $i, $i + ($new_size - $splice_length) ); } for (my $i = 0; $i < $splice_length - $new_size; $i++) { $self->DELETE( $length - 1 ); diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index 2603045..ea8b794 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.0001); +our $VERSION = q(1.0002); use Scalar::Util (); diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm index 91c28ba..3f8511e 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.0001); +our $VERSION = q(1.0002); use Fcntl qw( :DEFAULT :flock :seek ); diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index 19035df..3602a90 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.0001); +our $VERSION = q(1.0002); use base 'DBM::Deep'; diff --git a/t/04_array.t b/t/04_array.t index a3f9ce3..cc2b2b9 100644 --- a/t/04_array.t +++ b/t/04_array.t @@ -2,7 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 116; +use Test::More tests => 124; use Test::Exception; use t::common qw( new_fh ); @@ -239,3 +239,31 @@ throws_ok { $db->exists(); } qr/Cannot use an undefined array index/, "EXISTS fails on an undefined key"; +# Bug reported by Mike Schilli +{ + my ($fh, $filename) = new_fh(); + my $db = DBM::Deep->new( + file => $filename, + type => DBM::Deep->TYPE_ARRAY + ); + + push @{$db}, 1, { foo => 1 }; + lives_ok { + shift @{$db}; + } "Shift doesn't die moving references around"; + is( $db->[0]{foo}, 1, "Right hashref there" ); + + lives_ok { + unshift @{$db}, [ 1 .. 3 ]; + unshift @{$db}, 1; + } "Unshift doesn't die moving references around"; + is( $db->[1][1], 2, "Right arrayref there" ); + is( $db->[2]{foo}, 1, "Right hashref there" ); + + # Add test for splice moving references around + lives_ok { + splice @{$db}, 0, 0, 1 .. 3; + } "Splice doesn't die moving references around"; + is( $db->[4][1], 2, "Right arrayref there" ); + is( $db->[5]{foo}, 1, "Right hashref there" ); +} diff --git a/t/17_import.t b/t/17_import.t index 7792b6d..b4ff262 100644 --- a/t/17_import.t +++ b/t/17_import.t @@ -56,6 +56,9 @@ use_ok( 'DBM::Deep' ); } { + diag "\nThere seems to be a bug in Clone on Perl 5.9+ that is causing\nthese tests to fail." + if $] >= 5.009; + my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new({ file => $filename, diff --git a/utils/upgrade_db.pl b/utils/upgrade_db.pl index 8fbf30c..84fc833 100755 --- a/utils/upgrade_db.pl +++ b/utils/upgrade_db.pl @@ -27,7 +27,7 @@ my %is_dev = ( my %opts = ( man => 0, help => 0, - version => '1.0000', + version => '1.0002', autobless => 0, ); GetOptions( \%opts, @@ -73,7 +73,7 @@ my %db; elsif ( $ver =~ /^0\.99/) { $ver = 1; } - elsif ( $ver =~ /^1\.000?0?/) { + elsif ( $ver =~ /^1\.000?[0-2]?/) { $ver = 2; } else {