use strict;
use warnings;
-our $VERSION = q(0.99_01);
+our $VERSION = q(0.99_03);
use Fcntl qw( :DEFAULT :flock );
use Scalar::Util ();
# - calculate_sizes()
# - _get_key_subloc()
# - add_bucket() - where the buckets are printed
+#
+# * Every method in here assumes that the _fileobj has been appropriately
+# safeguarded. This can be anything from flock() to some sort of manual
+# mutex. But, it's the caller's responsability to make sure that this has
+# been done.
##
# Setup file and tag signatures. These should never change.
sub SIG_KEYS () { 'K' }
sub SIG_SIZE () { 1 }
+################################################################################
+#
+# This is new code. It is a complete rewrite of the engine based on a new API
+#
+################################################################################
+
+sub write_value {
+ my $self = shift;
+ my ($offset, $key, $value, $orig_key) = @_;
+
+ my $dig_key = $self->apply_digest( $key );
+ my $tag = $self->find_blist( $offset, $dig_key, { create => 1 } );
+ return $self->add_bucket( $tag, $dig_key, $key, $value, undef, $orig_key );
+}
+
+sub read_value {
+ my $self = shift;
+ my ($offset, $key, $orig_key) = @_;
+
+ my $dig_key = $self->apply_digest( $key );
+ my $tag = $self->find_blist( $offset, $dig_key ) or return;
+ return $self->get_bucket_value( $tag, $dig_key, $orig_key );
+}
+
+sub delete_key {
+ my $self = shift;
+ my ($offset, $key, $orig_key) = @_;
+
+ my $dig_key = $self->apply_digest( $key );
+ my $tag = $self->find_blist( $offset, $dig_key ) or return;
+ my $value = $self->get_bucket_value( $tag, $dig_key, $orig_key );
+ $self->delete_bucket( $tag, $dig_key, $orig_key );
+ return $value;
+}
+
+sub key_exists {
+ my $self = shift;
+ my ($offset, $key) = @_;
+
+ my $dig_key = $self->apply_digest( $key );
+ # exists() returns the empty string, not undef
+ my $tag = $self->find_blist( $offset, $dig_key ) or return '';
+ return $self->bucket_exists( $tag, $dig_key, $key );
+}
+
+sub get_next_key {
+ my $self = shift;
+ my ($offset) = @_;
+
+ # If the previous key was not specifed, start at the top and
+ # return the first one found.
+ my $temp;
+ if ( @_ > 1 ) {
+ $temp = {
+ prev_md5 => $self->apply_digest($_[1]),
+ return_next => 0,
+ };
+ }
+ else {
+ $temp = {
+ prev_md5 => chr(0) x $self->{hash_size},
+ return_next => 1,
+ };
+ }
+
+ return $self->traverse_index( $temp, $offset, 0 );
+}
+
+################################################################################
+#
+# Below here is the old code. It will be folded into the code above as it can.
+#
+################################################################################
+
sub new {
my $class = shift;
my ($args) = @_;
data_pack => 'N',
digest => \&Digest::MD5::md5,
- hash_size => 16,
+ hash_size => 16, # In bytes
##
- # Maximum number of buckets per blist before another level of indexing is
+ # Number of buckets per blist before another level of indexing is
# done. Increase this value for slightly greater speed, but larger database
# files. DO NOT decrease this value below 16, due to risk of recursive
# reindex overrun.
sub _fileobj { return $_[0]{fileobj} }
+sub apply_digest {
+ my $self = shift;
+ return $self->{digest}->(@_);
+}
+
sub calculate_sizes {
my $self = shift;
return {
signature => $sig,
- #XXX Is this even used?
- size => $size,
+ size => $size, #XXX Is this even used?
offset => $offset + SIG_SIZE + $self->{data_size},
content => $fileobj->read_at( undef, $size ),
};
my $keytag = $self->load_tag( $keyloc );
my ($subloc, $is_deleted, $offset) = $self->find_keyloc( $keytag );
- if ( @transactions ) {
+ if ( $subloc && !$is_deleted && @transactions ) {
my $old_value = $self->read_from_loc( $subloc, $orig_key );
my $old_size = $self->_length_needed( $old_value, $plain_key );
pack($self->{long_pack}, $location2 ),
pack( 'C C', $trans_id, 0 ),
);
- $self->write_value( $location2, $plain_key, $old_value, $orig_key );
+ $self->_write_value( $location2, $plain_key, $old_value, $orig_key );
}
}
}
my $offset = 1;
for my $trans_id ( @transactions ) {
$fileobj->print_at( $keytag->{offset} + $self->{key_size} * $offset++,
- pack( $self->{long_pack}, -1 ),
+ pack( $self->{long_pack}, 0 ),
pack( 'C C', $trans_id, 1 ),
);
}
}
- $self->write_value( $location, $plain_key, $value, $orig_key );
+ $self->_write_value( $location, $plain_key, $value, $orig_key );
return 1;
}
-sub write_value {
+sub _write_value {
my $self = shift;
my ($location, $key, $value, $orig_key) = @_;
# If value is a hash or array, return new DBM::Deep object with correct offset
##
if (($signature eq SIG_HASH) || ($signature eq SIG_ARRAY)) {
+ #XXX This needs to be a singleton
my $new_obj = DBM::Deep->new({
type => $signature,
base_offset => $subloc,
else {
my $keytag = $self->load_tag( $keyloc );
my ($subloc, $is_deleted) = $self->find_keyloc( $keytag );
- if (!$subloc) {
+ if (!$subloc && !$is_deleted) {
($subloc, $is_deleted) = $self->find_keyloc( $keytag, 0 );
}
if ( $subloc && !$is_deleted ) {
if ( $fileobj->transaction_id == 0 ) {
my $keytag = $self->load_tag( $keyloc );
+
my ($subloc, $is_deleted, $offset) = $self->find_keyloc( $keytag );
+ return if !$subloc || $is_deleted;
+
my $value = $self->read_from_loc( $subloc, $orig_key );
my $size = $self->_length_needed( $value, $orig_key );
pack($self->{long_pack}, $location2 ),
pack( 'C C', $trans_id, 0 ),
);
- $self->write_value( $location2, $orig_key, $value, $orig_key );
+ $self->_write_value( $location2, $orig_key, $value, $orig_key );
}
}
}
else {
my $keytag = $self->load_tag( $keyloc );
+
my ($subloc, $is_deleted, $offset) = $self->find_keyloc( $keytag );
+
$fileobj->print_at( $keytag->{offset} + $offset,
- pack($self->{long_pack}, -1 ),
+ pack($self->{long_pack}, 0 ),
pack( 'C C', $fileobj->transaction_id, 1 ),
);
}
my ($keyloc) = $self->_find_in_buckets( $tag, $md5 );
my $keytag = $self->load_tag( $keyloc );
my ($subloc, $is_deleted, $offset) = $self->find_keyloc( $keytag );
- if ( !$subloc ) {
+ if ( !$subloc && !$is_deleted ) {
($subloc, $is_deleted, $offset) = $self->find_keyloc( $keytag, 0 );
}
return ($subloc && !$is_deleted) && 1;
my $keytag = $self->load_tag( $keyloc );
my ($subloc, $is_deleted) = $self->find_keyloc( $keytag );
- if ( $subloc == 0 ) {
+ if ( $subloc == 0 && !$is_deleted ) {
($subloc, $is_deleted) = $self->find_keyloc( $keytag, 0 );
}
next if $is_deleted;
return;
}
-sub get_next_key {
- ##
- # Locate next key, given digested previous one
- ##
- my $self = shift;
- my ($obj) = @_;
-
- ##
- # If the previous key was not specifed, start at the top and
- # return the first one found.
- ##
- my $temp;
- if ( @_ > 1 ) {
- $temp = {
- prev_md5 => $_[1],
- return_next => 0,
- };
- }
- else {
- $temp = {
- prev_md5 => chr(0) x $self->{hash_size},
- return_next => 1,
- };
- }
-
- return $self->traverse_index( $temp, $obj->_base_offset, 0 );
-}
-
# Utilities
sub _get_key_subloc {
projects / dbsrgits/DBM-Deep.git / blobdiff