exists now works on negative arrays

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 669ba3e..8fd2fa3 100644 (file)
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -1410,9 +1410,8 @@ sub EXISTS {
        # Check if a single key or element exists given plain key or array index
        ##
     my $self = $_[0]->_get_self;
-       my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1];
+       my $key = $_[1];
        
-       if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); }
        my $md5 = $DIGEST_FUNC->($key);
 
        ##
@@ -1483,9 +1482,9 @@ sub put { (shift)->STORE( @_ ) }
 sub store { (shift)->STORE( @_ ) }
 sub get { (shift)->FETCH( @_ ) }
 sub fetch { (shift)->FETCH( @_ ) }
-*delete = *DELETE;
-*exists = *EXISTS;
-*clear = *CLEAR;
+sub delete { (shift)->DELETE( @_ ) }
+sub exists { (shift)->EXISTS( @_ ) }
+sub clear { (shift)->CLEAR( @_ ) }
 
 package DBM::Deep::_::Root;
 

diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index 4cb8919..8fd633a 100644 (file)
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -59,7 +59,7 @@ sub STORE {
     my $self = shift->_get_self;
     my ($key, $value) = @_;
 
-    my $unpacked_key = $key;
+    my $orig = $key;
     my $size = $self->FETCHSIZE;
 
     my $numeric_idx;
@@ -67,8 +67,9 @@ sub STORE {
         $numeric_idx = 1;
         if ( $key < 0 ) {
             $key += $size;
-            #XXX What to do here?
-#            return unless $key >= 0;
+            if ( $key < 0 ) {
+                die( "Modification of non-creatable array value attempted, subscript $orig" );
+            }
         }
 
         $key = pack($DBM::Deep::LONG_PACK, $key);
@@ -76,13 +77,29 @@ sub STORE {
 
     my $rv = $self->SUPER::STORE( $key, $value );
 
-    if ( $numeric_idx && $rv == 2 && $unpacked_key >= $size ) {
-        $self->STORESIZE( $unpacked_key + 1 );
+    if ( $numeric_idx && $rv == 2 && $orig >= $size ) {
+        $self->STORESIZE( $orig + 1 );
     }
 
     return $rv;
 }
 
+sub EXISTS {
+    my $self = $_[0]->_get_self;
+    my $key = $_[1];
+
+    if ( $key =~ /^-?\d+$/ ) {
+        if ( $key < 0 ) {
+            $key += $self->FETCHSIZE;
+            return unless $key >= 0;
+        }
+
+        $key = pack($DBM::Deep::LONG_PACK, $key);
+    }
+
+    return $self->SUPER::EXISTS( $key );
+}
+
 sub FETCHSIZE {
        ##
        # Return the length of the array

diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index 7dc9acd..a6a27ba 100644 (file)
--- a/lib/DBM/Deep/Hash.pm
+++ b/lib/DBM/Deep/Hash.pm
@@ -52,6 +52,15 @@ sub STORE {
     return $self->SUPER::STORE( $key, $value );
 }
 
+sub EXISTS {
+    my $self = shift->_get_self;
+       my $key = ($self->root->{filter_store_key})
+        ? $self->root->{filter_store_key}->($_[0])
+        : $_[0];
+
+    return $self->SUPER::EXISTS( $key );
+}
+
 sub FIRSTKEY {
        ##
        # Locate and return first key (in no particular order)

diff --git a/t/04_array.t b/t/04_array.t
index fd25f9e..3017714 100644 (file)
--- a/t/04_array.t
+++ b/t/04_array.t
@@ -2,7 +2,7 @@
 # DBM::Deep Test
 ##
 use strict;
-use Test::More tests => 94;
+use Test::More tests => 95;
 use Test::Exception;
 
 use_ok( 'DBM::Deep' );
@@ -67,6 +67,10 @@ is( $db->[4], 'elem4.1' );
 is( $db->get(4), 'elem4.1' );
 is( $db->fetch(4), 'elem4.1' );
 
+throws_ok {
+    $db->[-6] = 'whoops!';
+} qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown"; 
+
 my $popped = $db->pop;
 is( $db->length, 4, "... and we have four after popping" );
 is( $db->[0], 'elem0', "0th element still there after popping" );
@@ -125,10 +129,7 @@ $db->[1] = 'elem2';
 ok( $db->exists(1), "The 1st value exists" );
 ok( !$db->exists(0), "The 0th value doesn't exists" );
 ok( !$db->exists(22), "The 22nd value doesn't exists" );
-TODO: {
-    local $TODO = "exists on negative values should work";
-    ok( $db->exists(-1), "The -1st value does exists" );
-}
+ok( $db->exists(-1), "The -1st value does exists" );
 ok( !$db->exists(-22), "The -22nd value doesn't exists" );
 
 ##