From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Sun, 23 Apr 2006 15:18:12 +0000 (+0000)
Subject: Fixed bug where overwrites weren't transaction-aware
X-Git-Tag: 0-99_01~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=504185fb219549d7f77912a182f5816925cb284b;p=dbsrgits%2FDBM-Deep.git

Fixed bug where overwrites weren't transaction-aware
---

diff --git a/MANIFEST b/MANIFEST
index e987ba5..4d5457e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -42,3 +42,4 @@ t/30_already_tied.t
 t/31_references.t
 t/32_dash_ell.t
 t/33_audit_trail.t
+t/34_transaction_arrays.t
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 1edb55f..7c83413 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -420,7 +420,8 @@ sub STORE {
         $self->_throw_error( 'Cannot write to a readonly filehandle' );
     }
 
-    if ( defined $orig_key ) {
+    #XXX The second condition needs to disappear
+    if ( defined $orig_key && !( $self->_type eq TYPE_ARRAY && $orig_key eq 'length') ) {
         my $rhs;
 
         my $r = Scalar::Util::reftype( $value ) || '';
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index 687cb19..fd161be 100644
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -36,19 +36,20 @@ sub _import {
 sub TIEARRAY {
     my $class = shift;
     my $args = $class->_get_args( @_ );
-	
-	$args->{type} = $class->TYPE_ARRAY;
-	
-	return $class->_init($args);
+
+    $args->{type} = $class->TYPE_ARRAY;
+
+    return $class->_init($args);
 }
 
 sub FETCH {
     my $self = shift->_get_self;
     my ($key) = @_;
 
-	$self->lock( $self->LOCK_SH );
+    $self->lock( $self->LOCK_SH );
 
-    my $orig_key = $key eq 'length' ? undef : $key;
+#    my $orig_key = $key eq 'length' ? undef : $key;
+    my $orig_key = $key;
     if ( $key =~ /^-?\d+$/ ) {
         if ( $key < 0 ) {
             $key += $self->FETCHSIZE;
@@ -74,7 +75,8 @@ sub STORE {
 
     $self->lock( $self->LOCK_EX );
 
-    my $orig = $key eq 'length' ? undef : $key;
+#    my $orig = $key eq 'length' ? undef : $key;
+    my $orig_key = $key;
 
     my $size;
     my $numeric_idx;
@@ -84,19 +86,19 @@ sub STORE {
             $size = $self->FETCHSIZE;
             $key += $size;
             if ( $key < 0 ) {
-                die( "Modification of non-creatable array value attempted, subscript $orig" );
+                die( "Modification of non-creatable array value attempted, subscript $orig_key" );
             }
         }
 
         $key = pack($self->{engine}{long_pack}, $key);
     }
 
-    my $rv = $self->SUPER::STORE( $key, $value, $orig );
+    my $rv = $self->SUPER::STORE( $key, $value, $orig_key );
 
     if ( $numeric_idx && $rv == 2 ) {
         $size = $self->FETCHSIZE unless defined $size;
-        if ( $orig >= $size ) {
-            $self->STORESIZE( $orig + 1 );
+        if ( $orig_key >= $size ) {
+            $self->STORESIZE( $orig_key + 1 );
         }
     }
 
@@ -109,7 +111,7 @@ sub EXISTS {
     my $self = shift->_get_self;
     my ($key) = @_;
 
-	$self->lock( $self->LOCK_SH );
+    $self->lock( $self->LOCK_SH );
 
     if ( $key =~ /^\-?\d+$/ ) {
         if ( $key < 0 ) {
@@ -154,9 +156,9 @@ sub DELETE {
 
     my $rv = $self->SUPER::DELETE( $key, $orig );
 
-	if ($rv && $unpacked_key == $size - 1) {
-		$self->STORESIZE( $unpacked_key );
-	}
+    if ($rv && $unpacked_key == $size - 1) {
+        $self->STORESIZE( $unpacked_key );
+    }
 
     $self->unlock;
 
@@ -168,38 +170,38 @@ sub FETCHSIZE {
 
     $self->lock( $self->LOCK_SH );
 
-	my $SAVE_FILTER = $self->_fileobj->{filter_fetch_value};
-	$self->_fileobj->{filter_fetch_value} = undef;
-	
-	my $packed_size = $self->FETCH('length');
-	
-	$self->_fileobj->{filter_fetch_value} = $SAVE_FILTER;
-	
+    my $SAVE_FILTER = $self->_fileobj->{filter_fetch_value};
+    $self->_fileobj->{filter_fetch_value} = undef;
+
+    my $packed_size = $self->FETCH('length');
+
+    $self->_fileobj->{filter_fetch_value} = $SAVE_FILTER;
+
     $self->unlock;
 
-	if ($packed_size) {
+    if ($packed_size) {
         return int(unpack($self->{engine}{long_pack}, $packed_size));
     }
 
-	return 0;
+    return 0;
 }
 
 sub STORESIZE {
     my $self = shift->_get_self;
-	my ($new_length) = @_;
-	
+    my ($new_length) = @_;
+
     $self->lock( $self->LOCK_EX );
 
-	my $SAVE_FILTER = $self->_fileobj->{filter_store_value};
-	$self->_fileobj->{filter_store_value} = undef;
-	
-	my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length));
-	
-	$self->_fileobj->{filter_store_value} = $SAVE_FILTER;
-	
+    my $SAVE_FILTER = $self->_fileobj->{filter_store_value};
+    $self->_fileobj->{filter_store_value} = undef;
+
+    my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length), 'length');
+
+    $self->_fileobj->{filter_store_value} = $SAVE_FILTER;
+
     $self->unlock;
 
-	return $result;
+    return $result;
 }
 
 sub POP {
@@ -207,33 +209,33 @@ sub POP {
 
     $self->lock( $self->LOCK_EX );
 
-	my $length = $self->FETCHSIZE();
-	
-	if ($length) {
-		my $content = $self->FETCH( $length - 1 );
-		$self->DELETE( $length - 1 );
+    my $length = $self->FETCHSIZE();
+
+    if ($length) {
+        my $content = $self->FETCH( $length - 1 );
+        $self->DELETE( $length - 1 );
 
         $self->unlock;
 
-		return $content;
-	}
-	else {
+        return $content;
+    }
+    else {
         $self->unlock;
-		return;
-	}
+        return;
+    }
 }
 
 sub PUSH {
     my $self = shift->_get_self;
-	
+
     $self->lock( $self->LOCK_EX );
 
-	my $length = $self->FETCHSIZE();
+    my $length = $self->FETCHSIZE();
 
-	while (my $content = shift @_) {
-		$self->STORE( $length, $content );
-		$length++;
-	}
+    while (my $content = shift @_) {
+        $self->STORE( $length, $content );
+        $length++;
+    }
 
     $self->unlock;
 
@@ -245,44 +247,44 @@ sub SHIFT {
 
     $self->lock( $self->LOCK_EX );
 
-	my $length = $self->FETCHSIZE();
-	
-	if ($length) {
-		my $content = $self->FETCH( 0 );
-		
-		for (my $i = 0; $i < $length - 1; $i++) {
-			$self->STORE( $i, $self->FETCH($i + 1) );
-		}
-		$self->DELETE( $length - 1 );
+    my $length = $self->FETCHSIZE();
+
+    if ($length) {
+        my $content = $self->FETCH( 0 );
+
+        for (my $i = 0; $i < $length - 1; $i++) {
+            $self->STORE( $i, $self->FETCH($i + 1) );
+        }
+        $self->DELETE( $length - 1 );
 
         $self->unlock;
-		
-		return $content;
-	}
-	else {
+
+        return $content;
+    }
+    else {
         $self->unlock;
-		return;
-	}
+        return;
+    }
 }
 
 sub UNSHIFT {
     my $self = shift->_get_self;
-	my @new_elements = @_;
+    my @new_elements = @_;
 
     $self->lock( $self->LOCK_EX );
 
-	my $length = $self->FETCHSIZE();
-	my $new_size = scalar @new_elements;
-	
-	if ($length) {
-		for (my $i = $length - 1; $i >= 0; $i--) {
-			$self->STORE( $i + $new_size, $self->FETCH($i) );
-		}
-	}
-	
-	for (my $i = 0; $i < $new_size; $i++) {
-		$self->STORE( $i, $new_elements[$i] );
-	}
+    my $length = $self->FETCHSIZE();
+    my $new_size = scalar @new_elements;
+
+    if ($length) {
+        for (my $i = $length - 1; $i >= 0; $i--) {
+            $self->STORE( $i + $new_size, $self->FETCH($i) );
+        }
+    }
+
+    for (my $i = 0; $i < $new_size; $i++) {
+        $self->STORE( $i, $new_elements[$i] );
+    }
 
     $self->unlock;
 
@@ -294,33 +296,33 @@ sub SPLICE {
 
     $self->lock( $self->LOCK_EX );
 
-	my $length = $self->FETCHSIZE();
-	
-	##
-	# Calculate offset and length of splice
-	##
-	my $offset = shift;
+    my $length = $self->FETCHSIZE();
+
+    ##
+    # Calculate offset and length of splice
+    ##
+    my $offset = shift;
     $offset = 0 unless defined $offset;
-	if ($offset < 0) { $offset += $length; }
-	
-	my $splice_length;
-	if (scalar @_) { $splice_length = shift; }
-	else { $splice_length = $length - $offset; }
-	if ($splice_length < 0) { $splice_length += ($length - $offset); }
-	
-	##
-	# Setup array with new elements, and copy out old elements for return
-	##
-	my @new_elements = @_;
-	my $new_size = scalar @new_elements;
-	
+    if ($offset < 0) { $offset += $length; }
+
+    my $splice_length;
+    if (scalar @_) { $splice_length = shift; }
+    else { $splice_length = $length - $offset; }
+    if ($splice_length < 0) { $splice_length += ($length - $offset); }
+
+    ##
+    # Setup array with new elements, and copy out old elements for return
+    ##
+    my @new_elements = @_;
+    my $new_size = scalar @new_elements;
+
     my @old_elements = map {
         $self->FETCH( $_ )
     } $offset .. ($offset + $splice_length - 1);
-	
-	##
-	# Adjust array length, and shift elements to accomodate new section.
-	##
+
+    ##
+    # Adjust array length, and shift elements to accomodate new section.
+    ##
     if ( $new_size != $splice_length ) {
         if ($new_size > $splice_length) {
             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
@@ -336,30 +338,30 @@ sub SPLICE {
                 $length--;
             }
         }
-	}
-	
-	##
-	# Insert new elements into array
-	##
-	for (my $i = $offset; $i < $offset + $new_size; $i++) {
-		$self->STORE( $i, shift @new_elements );
-	}
-	
+    }
+
+    ##
+    # Insert new elements into array
+    ##
+    for (my $i = $offset; $i < $offset + $new_size; $i++) {
+        $self->STORE( $i, shift @new_elements );
+    }
+
     $self->unlock;
 
-	##
-	# Return deleted section, or last element in scalar context.
-	##
-	return wantarray ? @old_elements : $old_elements[-1];
+    ##
+    # Return deleted section, or last element in scalar context.
+    ##
+    return wantarray ? @old_elements : $old_elements[-1];
 }
 
 # We don't need to define it, yet.
 # It will be useful, though, when we split out HASH and ARRAY
 sub EXTEND {
-	##
-	# Perl will call EXTEND() when the array is likely to grow.
-	# We don't care, but include it because it gets called at times.
-	##
+    ##
+    # Perl will call EXTEND() when the array is likely to grow.
+    # We don't care, but include it because it gets called at times.
+    ##
 }
 
 sub _copy_node {
diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index e9d0711..9538027 100644
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -421,6 +421,15 @@ sub add_bucket {
                 pack('n n', $fileobj->transaction_id, $deleted ),
             );
         }
+
+        my $old_value = $self->read_from_loc( $subloc, $orig_key );
+        for ( @transactions ) {
+            my $tag2 = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
+            $fileobj->{transaction_id} = $_;
+            $self->add_bucket( $tag2, $md5, $orig_key, $old_value, undef, $orig_key );
+            $fileobj->{transaction_id} = 0;
+        }
+        $tag = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
     }
     # Adding a new md5
     elsif ( defined $offset ) {
diff --git a/t/28_transactions.t b/t/28_transactions.t
index 747b57b..f888946 100644
--- a/t/28_transactions.t
+++ b/t/28_transactions.t
@@ -1,5 +1,5 @@
 use strict;
-use Test::More tests => 56;
+use Test::More tests => 58;
 use Test::Deep;
 use t::common qw( new_fh );
 
@@ -58,6 +58,10 @@ $db1->begin_work;
     is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
     is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is still Y" );
 
+    $db2->{other_x} = 'bar';
+    is( $db2->{other_x}, 'bar', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
+    is( $db1->{other_x}, 'foo', "Since other_x was modified after the transaction began, DB1 doesn't see the change." );
+
     cmp_bag( [ keys %$db1 ], [qw( x other_x )], "DB1 keys correct" );
     cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
 
@@ -70,7 +74,7 @@ $db1->begin_work;
 
     delete $db2->{other_x};
     ok( !exists $db2->{other_x}, "DB2 deleted other_x in DB1's transaction, so it can't see it anymore" );
-    is( $db1->{other_x}, 'foo', "Since other_x was deleted after the transaction began, DB1 still sees it." );
+    is( $db1->{other_x}, 'bar', "Since other_x was deleted after the transaction began, DB1 still sees it." );
 
     cmp_bag( [ keys %$db1 ], [qw( x other_x )], "DB1 keys correct" );
     cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
diff --git a/t/34_transaction_arrays.t b/t/34_transaction_arrays.t
new file mode 100644
index 0000000..5043c91
--- /dev/null
+++ b/t/34_transaction_arrays.t
@@ -0,0 +1,53 @@
+use strict;
+use Test::More tests => 17;
+use Test::Deep;
+use t::common qw( new_fh );
+
+use_ok( 'DBM::Deep' );
+
+my ($fh, $filename) = new_fh();
+my $db1 = DBM::Deep->new(
+    file => $filename,
+    locking => 1,
+    autoflush => 1,
+    type => DBM::Deep->TYPE_ARRAY,
+);
+
+my $db2 = DBM::Deep->new(
+    file => $filename,
+    locking => 1,
+    autoflush => 1,
+    type => DBM::Deep->TYPE_ARRAY,
+);
+
+$db1->[0] = 'y';
+is( $db1->[0], 'y', "Before transaction, DB1's 0 is Y" );
+is( $db2->[0], 'y', "Before transaction, DB2's 0 is Y" );
+
+$db1->begin_work;
+
+    is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
+    is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
+
+    $db1->[0] = 'z';
+    is( $db1->[0], 'z', "Within DB1 transaction, DB1's 0 is Z" );
+    is( $db2->[0], 'y', "Within DB1 transaction, DB2's 0 is still Y" );
+
+    $db2->[1] = 'foo';
+    is( $db2->[1], 'foo', "DB2 set 1 within DB1's transaction, so DB2 can see it" );
+    ok( !exists $db1->[1], "Since 1 was added after the transaction began, DB1 doesn't see it." );
+
+    cmp_ok( scalar(@$db1), '==', 1, "DB1 has 1 element" );
+    cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
+
+$db1->rollback;
+
+is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
+is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
+
+is( $db1->[1], 'foo', "After DB1 transaction is over, DB1 can see 1" );
+is( $db2->[1], 'foo', "After DB1 transaction is over, DB2 can still see 1" );
+
+cmp_ok( scalar(@$db1), '==', 2, "DB1 now has 2 elements" );
+cmp_ok( scalar(@$db2), '==', 2, "DB2 still has 2 elements" );
+