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)
use strict;
use warnings;
-our $VERSION = q(1.0001);
+our $VERSION = q(1.0002);
use Fcntl qw( :flock );
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 {
=head1 VERSION DIFFERENCES
-B<NOTE>: 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<NOT> backwards compatible with any
-other release of DBM::Deep.
-
-B<NOTE>: 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<NOT> backwards compatible
-with 0.983 and before.
+B<NOTE>: 1.0000 has significant file format differences from prior versions.
+THere is a backwards-compatibility layer at C<utils/upgrade_db.pl>. Files
+created by 1.0000 or higher are B<NOT> compatible with scripts using prior
+versions.
=head1 SETUP
B<Devel::Cover> is used to test the code coverage of the tests. Below is the
B<Devel::Cover> 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
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
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;
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 );
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 );
}
}
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 );
use strict;
use warnings;
-our $VERSION = q(1.0001);
+our $VERSION = q(1.0002);
use Scalar::Util ();
use strict;
use warnings;
-our $VERSION = q(1.0001);
+our $VERSION = q(1.0002);
use Fcntl qw( :DEFAULT :flock :seek );
use strict;
use warnings;
-our $VERSION = q(1.0001);
+our $VERSION = q(1.0002);
use base 'DBM::Deep';
# DBM::Deep Test
##
use strict;
-use Test::More tests => 116;
+use Test::More tests => 124;
use Test::Exception;
use t::common qw( new_fh );
$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" );
+}
}
{
+ 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,
my %opts = (
man => 0,
help => 0,
- version => '1.0000',
+ version => '1.0002',
autobless => 0,
);
GetOptions( \%opts,
elsif ( $ver =~ /^0\.99/) {
$ver = 1;
}
- elsif ( $ver =~ /^1\.000?0?/) {
+ elsif ( $ver =~ /^1\.000?[0-2]?/) {
$ver = 2;
}
else {
projects / dbsrgits/DBM-Deep.git / commitdiff