From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Fri, 21 Apr 2006 19:30:36 +0000 (+0000)
Subject: Phantom reads because transactional writes aren't deleted yet have been fixed
X-Git-Tag: 0-99_01~7
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=633df1fd39c75f846b5e772d0905e13279c5d0ff;p=dbsrgits%2FDBM-Deep.git

Phantom reads because transactional writes aren't deleted yet have been fixed
---

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 29318f6..2ad8b28 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -385,6 +385,7 @@ sub _find_parent {
     my $self = shift;
 
     my $base = '';
+    #XXX This if() is redundant
     if ( my $parent = $self->{parent} ) {
         my $child = $self;
         while ( $parent->{parent} ) {
@@ -392,12 +393,10 @@ sub _find_parent {
                 $parent->_type eq TYPE_HASH
                     ? "\{$child->{parent_key}\}"
                     : "\[$child->{parent_key}\]"
-#                "->get('$child->{parent_key}')"
             ) . $base;
 
             $child = $parent;
             $parent = $parent->{parent};
-#            last unless $parent;
         }
         if ( $base ) {
             $base = "\$db->get( '$child->{parent_key}' )->" . $base;
@@ -406,8 +405,6 @@ sub _find_parent {
             $base = "\$db->get( '$child->{parent_key}' )";
         }
     }
-#    return '$db->' . $base;
-#    return '$db' . $base;
     return $base;
 }
 
@@ -459,8 +456,6 @@ sub STORE {
             $lhs = "\$db->put('$orig_key',$rhs);";
         }
 
-#        $self->_fileobj->audit( "$lhs = $rhs;" );
-#        $self->_fileobj->audit( "$lhs $rhs);" );
         $self->_fileobj->audit($lhs);
     }
 
@@ -536,15 +531,6 @@ sub DELETE {
 
     if ( defined $orig_key ) {
         my $lhs = $self->_find_parent;
-#        if ( $self->_type eq TYPE_HASH ) {
-#            $lhs .= "\{$orig_key\}";
-#        }
-#        else {
-#            $lhs .= "\[$orig_key]\]";
-#        }
-
-#        $self->_fileobj->audit( "delete $lhs;" );
-#        $self->_fileobj->audit( "$lhs->delete('$orig_key');" );
         if ( $lhs ) {
             $self->_fileobj->audit( "delete $lhs;" );
         }
diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index f87adfa..5b7f50a 100644
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -5,7 +5,7 @@ use 5.6.0;
 use strict;
 use warnings;
 
-use Fcntl qw( :DEFAULT :flock :seek );
+use Fcntl qw( :DEFAULT :flock );
 use Scalar::Util ();
 
 # File-wide notes:
@@ -92,6 +92,8 @@ sub _fileobj { return $_[0]{fileobj} }
 sub calculate_sizes {
     my $self = shift;
 
+    # The 2**8 here indicates the number of different characters in the
+    # current hashing algorithm
     #XXX Does this need to be updated with different hashing algorithms?
     $self->{index_size}       = (2**8) * $self->{long_size};
     $self->{bucket_size}      = $self->{hash_size} + $self->{long_size} * 3;
@@ -323,19 +325,22 @@ sub _length_needed {
         $value->isa( 'DBM::Deep' );
     };
 
-    my $len = SIG_SIZE + $self->{data_size}
-            + $self->{data_size} + length( $key );
+    my $len = SIG_SIZE
+            + $self->{data_size} # size for value
+            + $self->{data_size} # size for key
+            + length( $key );    # length of key
 
     if ( $is_dbm_deep && $value->_fileobj eq $self->_fileobj ) {
+        # long_size is for the internal reference
         return $len + $self->{long_size};
     }
 
-    my $r = Scalar::Util::reftype( $value ) || '';
     if ( $self->_fileobj->{autobless} ) {
         # This is for the bit saying whether or not this thing is blessed.
         $len += 1;
     }
 
+    my $r = Scalar::Util::reftype( $value ) || '';
     unless ( $r eq 'HASH' || $r eq 'ARRAY' ) {
         if ( defined $value ) {
             $len += length( $value );
@@ -494,8 +499,7 @@ sub write_value {
     # If value is blessed, preserve class name
     ##
     if ( $fileobj->{autobless} ) {
-        my $c = Scalar::Util::blessed($value);
-        if ( defined $c && !$dbm_deep_obj ) {
+        if ( defined( my $c = Scalar::Util::blessed($value) ) ) {
             $fileobj->print_at( undef, chr(1), pack($self->{data_pack}, length($c)) . $c );
         }
         else {
@@ -563,6 +567,8 @@ sub split_index {
 
     my @newloc = ();
     BUCKET:
+    # The <= here is deliberate - we have max_buckets+1 keys to iterate
+    # through, unlike every other loop that uses max_buckets as a stop.
     for (my $i = 0; $i <= $self->{max_buckets}; $i++) {
         my ($key, $old_subloc, $size) = $self->_get_key_subloc( $keys, $i );
 
@@ -579,7 +585,10 @@ sub split_index {
                 { content => $subkeys }, '',
             );
 
-            $fileobj->print_at( $newloc[$num] + $offset, $key . pack($self->{long_pack}, $old_subloc) );
+            $fileobj->print_at(
+                $newloc[$num] + $offset,
+                $key, pack($self->{long_pack}, $old_subloc),
+            );
 
             next;
         }
@@ -617,9 +626,6 @@ sub read_from_loc {
 
     my $fileobj = $self->_fileobj;
 
-    ##
-    # Found match -- seek to offset and read signature
-    ##
     my $signature = $fileobj->read_at( $subloc, SIG_SIZE );
 
     ##
@@ -715,18 +721,48 @@ sub delete_bucket {
     my ($tag, $md5, $orig_key) = @_;
 
     #ACID - This is a mutation. Must only find the exact transaction
-    my ($subloc, $offset, $size) = $self->_find_in_buckets( $tag, $md5, 1 );
-#XXX This needs _release_space() for the value and anything below
-    if ( $subloc ) {
-        $self->_fileobj->print_at(
+    my ($subloc, $offset, $size,$is_deleted) = $self->_find_in_buckets( $tag, $md5, 1 );
+
+    return if !$subloc;
+
+    my $fileobj = $self->_fileobj;
+
+    my @transactions;
+    if ( $fileobj->transaction_id == 0 ) {
+        @transactions = $fileobj->current_transactions;
+    }
+
+#XXX This code taken from add_bucket() as an example
+#    for ( @transactions ) {
+#        my $tag2 = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
+#        $fileobj->{transaction_id} = $_;
+#        $self->add_bucket( $tag2, $md5, '', '', 1, $orig_key );
+#        $fileobj->{transaction_id} = 0;
+#    }
+
+    #XXX This needs _release_space() for the value and anything below
+    if ( $fileobj->transaction_id == 0 ) {
+        my $value = $self->read_from_loc( $subloc, $orig_key );
+
+        for (@transactions) {
+#            warn "Marking $_ $orig_key : $value as still there\n";
+            my $tag2 = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
+            $fileobj->{transaction_id} = $_;
+            #XXX Need to use real key
+            $self->add_bucket( $tag2, $md5, $orig_key, $value, 0, $orig_key );
+            $fileobj->{transaction_id} = 0;
+        }
+
+        $fileobj->print_at(
             $tag->{offset} + $offset,
-            substr($tag->{content}, $offset + $self->{bucket_size} ),
+            substr( $tag->{content}, $offset + $self->{bucket_size} ),
             chr(0) x $self->{bucket_size},
         );
-
-        return 1;
     }
-    return;
+    else {
+    }
+
+    return 1;
 }
 
 sub bucket_exists {
@@ -953,7 +989,7 @@ sub _find_in_buckets {
         my @rv = ($subloc, $i * $self->{bucket_size}, $size, $is_deleted);
 
         unless ( $subloc ) {
-            if ( !$exact && @zero and $trans_id ) {
+            if ( !$exact && @zero && $trans_id ) {
                 @rv = ($zero[2], $zero[0] * $self->{bucket_size},$zero[3],$is_deleted);
             }
             return @rv;
diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index 3c3d6fc..52792c0 100644
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -33,7 +33,7 @@ sub new {
         # $args. They are here for documentation purposes.
         transaction_id     => 0,
         transaction_offset => 0,
-        trans_audit        => undef,
+        transaction_audit  => undef,
         base_db_obj        => undef,
     }, $class;
 
@@ -70,6 +70,7 @@ sub new {
 
 sub set_db {
     my $self = shift;
+
     unless ( $self->{base_db_obj} ) {
         $self->{base_db_obj} = shift;
         Scalar::Util::weaken( $self->{base_db_obj} );
@@ -81,7 +82,7 @@ sub set_db {
 sub open {
     my $self = shift;
 
-    # Adding O_BINARY does remove the need for the binmode below. However,
+    # Adding O_BINARY should remove the need for the binmode below. However,
     # I'm not going to remove it because I don't have the Win32 chops to be
     # absolutely certain everything will be ok.
     my $flags = O_RDWR | O_CREAT | O_BINARY;
@@ -292,8 +293,8 @@ sub audit {
         flock( $afh, LOCK_UN );
     }
 
-    if ( $self->{trans_audit} ) {
-        push @{$self->{trans_audit}}, $string;
+    if ( $self->{transaction_audit} ) {
+        push @{$self->{transaction_audit}}, $string;
     }
 
     return 1;
@@ -306,24 +307,27 @@ sub begin_transaction {
 
     $self->lock;
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    my $buffer;
-    read( $fh, $buffer, 4 );
-    $buffer = unpack( 'N', $buffer );
+    my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
+    my ($next, @trans) = unpack( 'C C C C', $buffer );
+
+    $self->{transaction_id} = ++$next;
 
-    for ( 1 .. 32 ) {
-        next if $buffer & (1 << ($_ - 1));
-        $self->{transaction_id} = $_;
-        $buffer |= (1 << $_-1 );
+    die if $trans[-1] != 0;
+
+    for ( my $i = 0; $i <= $#trans; $i++ ) {
+        next if $trans[$i] != 0;
+        $trans[$i] = $next;
         last;
     }
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    print( $fh pack( 'N', $buffer ) );
+    $self->print_at(
+        $self->{transaction_offset},
+        pack( 'C C C C', $next, @trans),
+    );
 
     $self->unlock;
 
-    $self->{trans_audit} = [];
+    $self->{transaction_audit} = [];
 
     return $self->{transaction_id};
 }
@@ -335,21 +339,26 @@ sub end_transaction {
 
     $self->lock;
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    my $buffer;
-    read( $fh, $buffer, 4 );
-    $buffer = unpack( 'N', $buffer );
+    my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
+    my ($next, @trans) = unpack( 'C C C C', $buffer );
+
+    @trans = grep { $_ != $self->{transaction_id} } @trans;
 
-    # Unset $self->{transaction_id} bit
-    $buffer ^= (1 << $self->{transaction_id}-1);
+    $self->print_at(
+        $self->{transaction_offset},
+        pack( 'C C C C', $next, @trans),
+    );
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    print( $fh pack( 'N', $buffer ) );
+    #XXX Need to free the space used by the current transaction
 
     $self->unlock;
 
     $self->{transaction_id} = 0;
-    $self->{trans_audit} = undef;
+    $self->{transaction_audit} = undef;
+
+#    $self->{base_db_obj}->optimize;
+#    $self->{inode} = undef;
+#    $self->set_inode;
 
     return 1;
 }
@@ -361,21 +370,12 @@ sub current_transactions {
 
     $self->lock;
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    my $buffer;
-    read( $fh, $buffer, 4 );
-    $buffer = unpack( 'N', $buffer );
+    my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
+    my ($next, @trans) = unpack( 'C C C C', $buffer );
 
     $self->unlock;
 
-    my @transactions;
-    for ( 1 .. 32 ) {
-        if ( $buffer & (1 << ($_ - 1)) ) {
-            push @transactions, $_;
-        }
-    }
-
-    return grep { $_ != $self->{transaction_id} } @transactions;
+    return grep { $_ && $_ != $self->{transaction_id} } @trans;
 }
 
 sub transaction_id { return $_[0]->{transaction_id} }
@@ -383,7 +383,7 @@ sub transaction_id { return $_[0]->{transaction_id} }
 sub commit_transaction {
     my $self = shift;
 
-    my @audit = @{$self->{trans_audit}};
+    my @audit = @{$self->{transaction_audit}};
 
     $self->end_transaction;
 
diff --git a/t/28_transactions.t b/t/28_transactions.t
index 30e2fc9..a8a998f 100644
--- a/t/28_transactions.t
+++ b/t/28_transactions.t
@@ -1,5 +1,5 @@
 use strict;
-use Test::More tests => 29;
+use Test::More tests => 31;
 use Test::Exception;
 use t::common qw( new_fh );
 
@@ -24,16 +24,16 @@ is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
 
 $db1->begin_work;
 
-is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
-is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
+    is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
+    is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
 
-$db1->{x} = 'z';
-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" );
+    $db1->{x} = 'z';
+    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} = 'foo';
-is( $db2->{other_x}, 'foo', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
-is( $db1->{other_x}, undef, "Since other_x was added after the transaction began, DB1 doesn't see it." );
+    $db2->{other_x} = 'foo';
+    is( $db2->{other_x}, 'foo', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
+    is( $db1->{other_x}, undef, "Since other_x was added after the transaction began, DB1 doesn't see it." );
 
 $db1->rollback;
 
@@ -45,9 +45,12 @@ is( $db2->{other_x}, 'foo', "After DB1 transaction is over, DB2 can still see ot
 
 $db1->begin_work;
 
-$db1->{x} = 'z';
-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" );
+    is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
+    is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
+
+    $db1->{x} = 'z';
+    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" );
 
 $db1->commit;
 
@@ -56,13 +59,13 @@ is( $db2->{x}, 'z', "After commit, DB2's X is Z" );
 
 $db1->begin_work;
 
-delete $db2->{other_x};
-is( $db2->{other_x}, undef, "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." );
+    delete $db2->{other_x};
+    is( $db2->{other_x}, undef, "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." );
 
-delete $db1->{x};
-is( $db1->{x}, undef, "DB1 deleted X in a transaction, so it can't see it anymore" );
-is( $db2->{x}, 'z', "But, DB2 can still see it" );
+    delete $db1->{x};
+    is( $db1->{x}, undef, "DB1 deleted X in a transaction, so it can't see it anymore" );
+    is( $db2->{x}, 'z', "But, DB2 can still see it" );
 
 $db1->rollback;
 
@@ -74,9 +77,9 @@ is( $db2->{x}, 'z', "DB2 can still see it" );
 
 $db1->begin_work;
 
-delete $db1->{x};
-is( $db1->{x}, undef, "DB1 deleted X in a transaction, so it can't see it anymore" );
-is( $db2->{x}, 'z', "But, DB2 can still see it" );
+    delete $db1->{x};
+    is( $db1->{x}, undef, "DB1 deleted X in a transaction, so it can't see it anymore" );
+    is( $db2->{x}, 'z', "But, DB2 can still see it" );
 
 $db1->commit;