my $self = shift;
my $base = '';
+ #XXX This if() is redundant
if ( my $parent = $self->{parent} ) {
my $child = $self;
while ( $parent->{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;
$base = "\$db->get( '$child->{parent_key}' )";
}
}
-# return '$db->' . $base;
-# return '$db' . $base;
return $base;
}
$lhs = "\$db->put('$orig_key',$rhs);";
}
-# $self->_fileobj->audit( "$lhs = $rhs;" );
-# $self->_fileobj->audit( "$lhs $rhs);" );
$self->_fileobj->audit($lhs);
}
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;" );
}
use strict;
use warnings;
-use Fcntl qw( :DEFAULT :flock :seek );
+use Fcntl qw( :DEFAULT :flock );
use Scalar::Util ();
# File-wide notes:
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;
$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 );
# 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 {
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 );
{ 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;
}
my $fileobj = $self->_fileobj;
- ##
- # Found match -- seek to offset and read signature
- ##
my $signature = $fileobj->read_at( $subloc, SIG_SIZE );
##
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 {
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;
# $args. They are here for documentation purposes.
transaction_id => 0,
transaction_offset => 0,
- trans_audit => undef,
+ transaction_audit => undef,
base_db_obj => undef,
}, $class;
sub set_db {
my $self = shift;
+
unless ( $self->{base_db_obj} ) {
$self->{base_db_obj} = shift;
Scalar::Util::weaken( $self->{base_db_obj} );
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;
flock( $afh, LOCK_UN );
}
- if ( $self->{trans_audit} ) {
- push @{$self->{trans_audit}}, $string;
+ if ( $self->{transaction_audit} ) {
+ push @{$self->{transaction_audit}}, $string;
}
return 1;
$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};
}
$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;
}
$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} }
sub commit_transaction {
my $self = shift;
- my @audit = @{$self->{trans_audit}};
+ my @audit = @{$self->{transaction_audit}};
$self->end_transaction;
use strict;
-use Test::More tests => 29;
+use Test::More tests => 31;
use Test::Exception;
use t::common qw( new_fh );
$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;
$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;
$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;
$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;
projects / dbsrgits/DBM-Deep.git / commitdiff