return $length;
}
+sub _move_value {
+ my $self = shift;
+ my ($old_key, $new_key) = @_;
+
+ my $val = $self->FETCH( $old_key );
+ if ( eval { $val->isa( 'DBM::Deep::Hash' ) } ) {
+ $self->STORE( $new_key, { %$val } );
+ }
+ elsif ( eval { $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 );
# 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" );
+}