use vars qw( $VERSION );
$VERSION = q(0.99_01);
-##
-# Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file.
-# (Perl must be compiled with largefile support for files > 2 GB)
-#
-# Set to 8 and 'Q' for 64-bit offsets. Theoretical limit of 16 XB per file.
-# (Perl must be compiled with largefile and 64-bit long support)
-##
-#my $LONG_SIZE = 4;
-#my $LONG_PACK = 'N';
-
-##
-# Set to 4 and 'N' for 32-bit data length prefixes. Limit of 4 GB for each key/value.
-# Upgrading this is possible (see above) but probably not necessary. If you need
-# more than 4 GB for a single key or value, this module is really not for you :-)
-##
-#my $DATA_LENGTH_SIZE = 4;
-#my $DATA_LENGTH_PACK = 'N';
-our ($LONG_SIZE, $LONG_PACK, $DATA_LENGTH_SIZE, $DATA_LENGTH_PACK);
-
-##
-# Maximum number of buckets per list 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.
-##
-our $MAX_BUCKETS = 16;
-
-##
-# Better not adjust anything below here, unless you're me :-)
-##
-
-##
-# Setup digest function for keys
-##
-our ($DIGEST_FUNC, $HASH_SIZE);
-#my $DIGEST_FUNC = \&Digest::MD5::md5;
-
-##
-# Precalculate index and bucket sizes based on values above.
-##
-#my $HASH_SIZE = 16;
-our ($INDEX_SIZE, $BUCKET_SIZE, $BUCKET_LIST_SIZE);
-
-set_digest();
-#set_pack();
-#_precalc_sizes();
##
# Setup file and tag signatures. These should never change.
#sub DESTROY {
#}
-sub _delete_bucket {
- ##
- # Delete single key/value pair given tag and MD5 digested key.
- ##
- my $self = shift;
- my ($tag, $md5) = @_;
- my $keys = $tag->{content};
-
- my $fh = $self->_fh;
-
- ##
- # Iterate through buckets, looking for a key match
- ##
- BUCKET:
- for (my $i=0; $i<$MAX_BUCKETS; $i++) {
- my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
- my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
-
- if (!$subloc) {
- ##
- # Hit end of list, no match
- ##
- return;
- }
-
- if ( $md5 ne $key ) {
- next BUCKET;
- }
-
- ##
- # Matched key -- delete bucket and return
- ##
- seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $self->_root->{file_offset}, SEEK_SET);
- print( $fh substr($keys, ($i+1) * $BUCKET_SIZE ) );
- print( $fh chr(0) x $BUCKET_SIZE );
-
- return 1;
- } # i loop
-
- return;
-}
-
-sub _bucket_exists {
- ##
- # Check existence of single key given tag and MD5 digested key.
- ##
- my $self = shift;
- my ($tag, $md5) = @_;
- my $keys = $tag->{content};
-
- ##
- # Iterate through buckets, looking for a key match
- ##
- BUCKET:
- for (my $i=0; $i<$MAX_BUCKETS; $i++) {
- my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
- my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
-
- if (!$subloc) {
- ##
- # Hit end of list, no match
- ##
- return;
- }
-
- if ( $md5 ne $key ) {
- next BUCKET;
- }
-
- ##
- # Matched key -- return true
- ##
- return 1;
- } # i loop
-
- return;
-}
-
-sub _find_bucket_list {
- ##
- # Locate offset for bucket list, given digested key
- ##
- my $self = shift;
- my $md5 = shift;
-
- ##
- # Locate offset for bucket list using digest index system
- ##
- my $ch = 0;
- my $tag = $self->{engine}->load_tag($self, $self->_base_offset);
- if (!$tag) { return; }
-
- while ($tag->{signature} ne SIG_BLIST) {
- $tag = $self->{engine}->index_lookup($self, $tag, ord(substr($md5, $ch, 1)));
- if (!$tag) { return; }
- $ch++;
- }
-
- return $tag;
-}
-
-sub _traverse_index {
- ##
- # Scan index and recursively step into deeper levels, looking for next key.
- ##
- my ($self, $offset, $ch, $force_return_next) = @_;
- $force_return_next = undef unless $force_return_next;
-
- my $tag = $self->{engine}->load_tag($self, $offset );
-
- my $fh = $self->_fh;
-
- if ($tag->{signature} ne SIG_BLIST) {
- my $content = $tag->{content};
- my $start;
- if ($self->{return_next}) { $start = 0; }
- else { $start = ord(substr($self->{prev_md5}, $ch, 1)); }
-
- for (my $index = $start; $index < 256; $index++) {
- my $subloc = unpack($LONG_PACK, substr($content, $index * $LONG_SIZE, $LONG_SIZE) );
- if ($subloc) {
- my $result = $self->_traverse_index( $subloc, $ch + 1, $force_return_next );
- if (defined($result)) { return $result; }
- }
- } # index loop
-
- $self->{return_next} = 1;
- } # tag is an index
-
- elsif ($tag->{signature} eq SIG_BLIST) {
- my $keys = $tag->{content};
- if ($force_return_next) { $self->{return_next} = 1; }
-
- ##
- # Iterate through buckets, looking for a key match
- ##
- for (my $i=0; $i<$MAX_BUCKETS; $i++) {
- my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
- my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
-
- if (!$subloc) {
- ##
- # End of bucket list -- return to outer loop
- ##
- $self->{return_next} = 1;
- last;
- }
- elsif ($key eq $self->{prev_md5}) {
- ##
- # Located previous key -- return next one found
- ##
- $self->{return_next} = 1;
- next;
- }
- elsif ($self->{return_next}) {
- ##
- # Seek to bucket location and skip over signature
- ##
- seek($fh, $subloc + SIG_SIZE + $self->_root->{file_offset}, SEEK_SET);
-
- ##
- # Skip over value to get to plain key
- ##
- my $size;
- read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { seek($fh, $size, SEEK_CUR); }
-
- ##
- # Read in plain key and return as scalar
- ##
- my $plain_key;
- read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { read( $fh, $plain_key, $size); }
-
- return $plain_key;
- }
- } # bucket loop
-
- $self->{return_next} = 1;
- } # tag is a bucket list
-
- return;
-}
-
-sub _get_next_key {
- ##
- # Locate next key, given digested previous one
- ##
- my $self = $_[0]->_get_self;
-
- $self->{prev_md5} = $_[1] ? $_[1] : undef;
- $self->{return_next} = 0;
-
- ##
- # If the previous key was not specifed, start at the top and
- # return the first one found.
- ##
- if (!$self->{prev_md5}) {
- $self->{prev_md5} = chr(0) x $HASH_SIZE;
- $self->{return_next} = 1;
- }
-
- return $self->_traverse_index( $self->_base_offset, 0 );
-}
-
sub lock {
##
# If db locking is set, flock() the db file. If called multiple
die "DBM::Deep: $_[1]\n";
}
-sub _precalc_sizes {
- ##
- # Precalculate index, bucket and bucket list sizes
- ##
-
- #XXX I don't like this ...
- set_pack() unless defined $LONG_SIZE;
-
- $INDEX_SIZE = 256 * $LONG_SIZE;
- $BUCKET_SIZE = $HASH_SIZE + $LONG_SIZE;
- $BUCKET_LIST_SIZE = $MAX_BUCKETS * $BUCKET_SIZE;
-}
-
-sub set_pack {
- ##
- # Set pack/unpack modes (see file header for more)
- ##
- my ($long_s, $long_p, $data_s, $data_p) = @_;
-
- $LONG_SIZE = $long_s ? $long_s : 4;
- $LONG_PACK = $long_p ? $long_p : 'N';
-
- $DATA_LENGTH_SIZE = $data_s ? $data_s : 4;
- $DATA_LENGTH_PACK = $data_p ? $data_p : 'N';
-
- _precalc_sizes();
-}
-
-sub set_digest {
- ##
- # Set key digest function (default is MD5)
- ##
- my ($digest_func, $hash_size) = @_;
-
- $DIGEST_FUNC = $digest_func ? $digest_func : \&Digest::MD5::md5;
- $HASH_SIZE = $hash_size ? $hash_size : 16;
-
- _precalc_sizes();
-}
-
sub _is_writable {
my $fh = shift;
(O_WRONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
? $self->_root->{filter_store_value}->($_[2])
: $_[2];
- my $md5 = $DIGEST_FUNC->($key);
+ my $md5 = $DBM::Deep::Engine::DIGEST_FUNC->($key);
unless ( _is_writable( $self->_fh ) ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
##
my $tag = $self->{engine}->load_tag($self, $self->_base_offset);
if (!$tag) {
- $tag = $self->{engine}->create_tag($self, $self->_base_offset, SIG_INDEX, chr(0) x $INDEX_SIZE);
+ $tag = $self->{engine}->create_tag($self, $self->_base_offset, SIG_INDEX, chr(0) x $DBM::Deep::Engine::INDEX_SIZE);
}
my $ch = 0;
while ($tag->{signature} ne SIG_BLIST) {
my $num = ord(substr($md5, $ch, 1));
- my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
+ my $ref_loc = $tag->{offset} + ($num * $DBM::Deep::Engine::LONG_SIZE);
my $new_tag = $self->{engine}->index_lookup($self, $tag, $num);
if (!$new_tag) {
seek($fh, $ref_loc + $self->_root->{file_offset}, SEEK_SET);
- print( $fh pack($LONG_PACK, $self->_root->{end}) );
+ print( $fh pack($DBM::Deep::Engine::LONG_PACK, $self->_root->{end}) );
- $tag = $self->{engine}->create_tag($self, $self->_root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
+ $tag = $self->{engine}->create_tag($self, $self->_root->{end}, SIG_BLIST, chr(0) x $DBM::Deep::Engine::BUCKET_LIST_SIZE);
$tag->{ref_loc} = $ref_loc;
$tag->{ch} = $ch;
my $self = shift->_get_self;
my $key = shift;
- my $md5 = $DIGEST_FUNC->($key);
+ my $md5 = $DBM::Deep::Engine::DIGEST_FUNC->($key);
##
# Request shared lock for reading
##
$self->lock( LOCK_SH );
- my $tag = $self->_find_bucket_list( $md5 );
+ my $tag = $self->{engine}->find_bucket_list( $self, $md5 );
if (!$tag) {
$self->unlock();
return;
my $self = $_[0]->_get_self;
my $key = $_[1];
- my $md5 = $DIGEST_FUNC->($key);
+ my $md5 = $DBM::Deep::Engine::DIGEST_FUNC->($key);
##
# Request exclusive lock for writing
##
$self->lock( LOCK_EX );
- my $tag = $self->_find_bucket_list( $md5 );
+ my $tag = $self->{engine}->find_bucket_list( $self, $md5 );
if (!$tag) {
$self->unlock();
return;
$value = $self->_root->{filter_fetch_value}->($value);
}
- my $result = $self->_delete_bucket( $tag, $md5 );
+ my $result = $self->{engine}->delete_bucket( $self, $tag, $md5 );
##
# If this object is an array and the key deleted was on the end of the stack,
my $self = $_[0]->_get_self;
my $key = $_[1];
- my $md5 = $DIGEST_FUNC->($key);
+ my $md5 = $DBM::Deep::Engine::DIGEST_FUNC->($key);
##
# Request shared lock for reading
##
$self->lock( LOCK_SH );
- my $tag = $self->_find_bucket_list( $md5 );
+ my $tag = $self->{engine}->find_bucket_list( $self, $md5 );
##
# For some reason, the built-in exists() function returns '' for false
##
# Check if bucket exists and return 1 or ''
##
- my $result = $self->_bucket_exists( $tag, $md5 ) || '';
+ my $result = $self->{engine}->bucket_exists( $self, $tag, $md5 ) || '';
$self->unlock();
return;
}
- $self->{engine}->create_tag($self, $self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE);
+ $self->{engine}->create_tag($self, $self->_base_offset, $self->_type, chr(0) x $DBM::Deep::Engine::INDEX_SIZE);
$self->unlock();
projects / dbsrgits/DBM-Deep.git / blobdiff