Negative indices all work and all the array methods are correctly locked

diff --git a/MANIFEST b/MANIFEST
index 4c5a94a..64212fb 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -32,4 +32,3 @@ t/22_internal_copy.t
 t/23_misc.t
 t/24_autobless.t
 t/25_tie_return_value.t
-t/26_scalar_ref.t

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 1f81f8d..8644eed 100644 (file)
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -1387,8 +1387,6 @@ sub DELETE {
     my $self = $_[0]->_get_self;
        my $key = $_[1];
        
-       my $unpacked_key = $key;
-       if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); }
        my $md5 = $DIGEST_FUNC->($key);
 
        ##
@@ -1421,9 +1419,6 @@ sub DELETE {
        # If this object is an array and the key deleted was on the end of the stack,
        # decrement the length variable.
        ##
-       if ($result && ($self->type eq TYPE_ARRAY) && ($unpacked_key == $self->FETCHSIZE() - 1)) {
-               $self->STORESIZE( $unpacked_key );
-       }
        
        $self->unlock();
        

diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index 6c7d7d4..1a0ec8e 100644 (file)
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -28,22 +28,33 @@ sub FETCH {
     my $self = $_[0]->_get_self;
     my $key = $_[1];
 
+       $self->lock( $self->LOCK_SH );
+       
     if ( $key =~ /^-?\d+$/ ) {
         if ( $key < 0 ) {
             $key += $self->FETCHSIZE;
-            return unless $key >= 0;
+            unless ( $key >= 0 ) {
+                $self->unlock;
+                return;
+            }
         }
 
         $key = pack($DBM::Deep::LONG_PACK, $key);
     }
 
-    return $self->SUPER::FETCH( $key );
+    my $rv = $self->SUPER::FETCH( $key );
+
+    $self->unlock;
+
+    return $rv;
 }
 
 sub STORE {
     my $self = shift->_get_self;
     my ($key, $value) = @_;
 
+    $self->lock( $self->LOCK_EX );
+
     my $orig = $key;
     my $size = $self->FETCHSIZE;
 
@@ -66,6 +77,8 @@ sub STORE {
         $self->STORESIZE( $orig + 1 );
     }
 
+    $self->unlock;
+
     return $rv;
 }
 
@@ -73,24 +86,67 @@ sub EXISTS {
     my $self = $_[0]->_get_self;
     my $key = $_[1];
 
+       $self->lock( $self->LOCK_SH );
+
     if ( $key =~ /^-?\d+$/ ) {
         if ( $key < 0 ) {
             $key += $self->FETCHSIZE;
-            return unless $key >= 0;
+            unless ( $key >= 0 ) {
+                $self->unlock;
+                return;
+            }
+        }
+
+        $key = pack($DBM::Deep::LONG_PACK, $key);
+    }
+
+    my $rv = $self->SUPER::EXISTS( $key );
+
+    $self->unlock;
+
+    return $rv;
+}
+
+sub DELETE {
+    my $self = $_[0]->_get_self;
+    my $key = $_[1];
+
+    my $unpacked_key = $key;
+
+    $self->lock( $self->LOCK_EX );
+
+    my $size = $self->FETCHSIZE;
+    if ( $key =~ /^-?\d+$/ ) {
+        if ( $key < 0 ) {
+            $key += $size;
+            unless ( $key >= 0 ) {
+                $self->unlock;
+                return;
+            }
         }
 
         $key = pack($DBM::Deep::LONG_PACK, $key);
     }
 
-    return $self->SUPER::EXISTS( $key );
+    my $rv = $self->SUPER::DELETE( $key );
+
+       if ($rv && $unpacked_key == $size - 1) {
+               $self->STORESIZE( $unpacked_key );
+       }
+
+    $self->unlock;
+
+    return $rv;
 }
 
 sub FETCHSIZE {
        ##
        # Return the length of the array
        ##
-    my $self = $_[0]->_get_self;
-       
+    my $self = shift->_get_self;
+
+    $self->lock( $self->LOCK_SH );
+
        my $SAVE_FILTER = $self->root->{filter_fetch_value};
        $self->root->{filter_fetch_value} = undef;
        
@@ -98,6 +154,8 @@ sub FETCHSIZE {
        
        $self->root->{filter_fetch_value} = $SAVE_FILTER;
        
+    $self->unlock;
+
        if ($packed_size) {
         return int(unpack($DBM::Deep::LONG_PACK, $packed_size));
     }
@@ -112,6 +170,8 @@ sub STORESIZE {
     my $self = $_[0]->_get_self;
        my $new_length = $_[1];
        
+    $self->lock( $self->LOCK_EX );
+
        my $SAVE_FILTER = $self->root->{filter_store_value};
        $self->root->{filter_store_value} = undef;
        
@@ -119,6 +179,8 @@ sub STORESIZE {
        
        $self->root->{filter_store_value} = $SAVE_FILTER;
        
+    $self->unlock;
+
        return $result;
 }
 
@@ -127,14 +189,21 @@ sub POP {
        # Remove and return the last element on the array
        ##
     my $self = $_[0]->_get_self;
+
+    $self->lock( $self->LOCK_EX );
+
        my $length = $self->FETCHSIZE();
        
        if ($length) {
                my $content = $self->FETCH( $length - 1 );
                $self->DELETE( $length - 1 );
+
+        $self->unlock;
+
                return $content;
        }
        else {
+        $self->unlock;
                return;
        }
 }
@@ -144,13 +213,18 @@ sub PUSH {
        # Add new element(s) to the end of the array
        ##
     my $self = shift->_get_self;
-       my $length = $self->FETCHSIZE();
        
+    $self->lock( $self->LOCK_EX );
+
+       my $length = $self->FETCHSIZE();
+
        while (my $content = shift @_) {
                $self->STORE( $length, $content );
                $length++;
        }
 
+    $self->unlock;
+
     return $length;
 }
 
@@ -160,6 +234,9 @@ sub SHIFT {
        # Shift over remaining elements to take up space.
        ##
     my $self = $_[0]->_get_self;
+
+    $self->lock( $self->LOCK_EX );
+
        my $length = $self->FETCHSIZE();
        
        if ($length) {
@@ -172,10 +249,13 @@ sub SHIFT {
                        $self->STORE( $i, $self->FETCH($i + 1) );
                }
                $self->DELETE( $length - 1 );
+
+        $self->unlock;
                
                return $content;
        }
        else {
+        $self->unlock;
                return;
        }
 }
@@ -187,6 +267,9 @@ sub UNSHIFT {
        ##
     my $self = shift->_get_self;
        my @new_elements = @_;
+
+    $self->lock( $self->LOCK_EX );
+
        my $length = $self->FETCHSIZE();
        my $new_size = scalar @new_elements;
        
@@ -200,6 +283,8 @@ sub UNSHIFT {
                $self->STORE( $i, $new_elements[$i] );
        }
 
+    $self->unlock;
+
     return $length + $new_size;
 }
 
@@ -209,6 +294,9 @@ sub SPLICE {
        # Returns deleted section, or last element deleted in scalar context.
        ##
     my $self = shift->_get_self;
+
+    $self->lock( $self->LOCK_EX );
+
        my $length = $self->FETCHSIZE();
        
        ##
@@ -260,13 +348,15 @@ sub SPLICE {
                $self->STORE( $i, shift @new_elements );
        }
        
+    $self->unlock;
+
        ##
        # Return deleted section, or last element in scalar context.
        ##
        return wantarray ? @old_elements : $old_elements[-1];
 }
 
-#XXX We don't need to define it.
+#XXX We don't need to define it, yet.
 #XXX It will be useful, though, when we split out HASH and ARRAY
 #sub EXTEND {
        ##

diff --git a/t/04_array.t b/t/04_array.t
index 3017714..c765cd5 100644 (file)
--- a/t/04_array.t
+++ b/t/04_array.t
@@ -111,15 +111,9 @@ is( $db->length, 3, "... and we still have three after a DELETE on an out-of-ran
 $deleted = $db->delete(-2);
 is( $db->length, 3, "... and we still have three after deleting" );
 is( $db->[0], undef, "0th element still undef" );
-TODO: {
-    local $TODO = "delete on a negative array element should work";
-    is( $db->[1], undef, "1st element now undef" );
-}
+is( $db->[1], undef, "1st element now undef" );
 is( $db->[2], 'elem3', "2nd element still there after deleting" );
-TODO: {
-    local $TODO = "delete on a negative array element should return the deleted value";
-    is( $deleted, 'elem2', "Deleted value is correct" );
-}
+is( $deleted, 'elem2', "Deleted value is correct" );
 
 $db->[1] = 'elem2';