use strict;
-use FileHandle;
use Fcntl qw/:flock/;
use Digest::MD5 ();
use Scalar::Util ();
##
#my $DATA_LENGTH_SIZE = 4;
#my $DATA_LENGTH_PACK = 'N';
-my ($LONG_SIZE, $LONG_PACK, $DATA_LENGTH_SIZE, $DATA_LENGTH_PACK);
+our ($LONG_SIZE, $LONG_PACK, $DATA_LENGTH_SIZE, $DATA_LENGTH_PACK);
##
# Maximum number of buckets per list before another level of indexing is done.
##
# Setup digest function for keys
##
-my ($DIGEST_FUNC, $HASH_SIZE);
+our ($DIGEST_FUNC, $HASH_SIZE);
#my $DIGEST_FUNC = \&Digest::MD5::md5;
##
##
my $self;
if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
+ $class = 'DBM::Deep::Array';
+ require DBM::Deep::Array;
tie @$self, $class, %$args;
}
else {
+ $class = 'DBM::Deep::Hash';
+ require DBM::Deep::Hash;
tie %$self, $class, %$args;
}
my $self = {
type => TYPE_HASH,
base_offset => length(SIG_FILE),
- root => {
- file => undef,
- fh => undef,
- end => 0,
- links => 0,
- autoflush => undef,
- locking => undef,
- volatile => undef,
- debug => undef,
- mode => 'r+',
- filter_store_key => undef,
- filter_store_value => undef,
- filter_fetch_key => undef,
- filter_fetch_value => undef,
- autobless => undef,
- locked => 0,
- %$args,
- },
};
bless $self, $class;
foreach my $outer_parm ( @outer_params ) {
next unless exists $args->{$outer_parm};
- $self->{$outer_parm} = $args->{$outer_parm}
+ $self->{$outer_parm} = delete $args->{$outer_parm}
}
- if ( exists $args->{root} ) {
- $self->{root} = $args->{root};
- }
- else {
- # This is cleanup based on the fact that the $args
- # coming in is for both the root and non-root items
- delete $self->root->{$_} for @outer_params;
- }
- $self->root->{links}++;
+ $self->{root} = exists $args->{root}
+ ? $args->{root}
+ : DBM::Deep::_::Root->new( $args );
if (!defined($self->fh)) { $self->_open(); }
}
}
-sub _get_self { tied( %{$_[0]} ) || $_[0] }
+sub _get_self {
+ tied( %{$_[0]} ) || $_[0]
+}
sub TIEHASH {
- ##
- # Tied hash constructor method, called by Perl's tie() function.
- ##
- my $class = shift;
- my $args;
- if (scalar(@_) > 1) { $args = {@_}; }
- #XXX This use of ref() is bad and is a bug
- elsif (ref($_[0])) { $args = $_[0]; }
- else { $args = { file => shift }; }
-
- return $class->_init($args);
+ shift;
+ require DBM::Deep::Hash;
+ return DBM::Deep::Hash->TIEHASH( @_ );
}
sub TIEARRAY {
-##
-# Tied array constructor method, called by Perl's tie() function.
-##
-my $class = shift;
-my $args;
-if (scalar(@_) > 1) { $args = {@_}; }
- #XXX This use of ref() is bad and is a bug
- elsif (ref($_[0])) { $args = $_[0]; }
- else { $args = { file => shift }; }
-
- return $class->_init($args);
+ shift;
+ require DBM::Deep::Array;
+ return DBM::Deep::Array->TIEARRAY( @_ );
}
-sub DESTROY {
- ##
- # Class deconstructor. Close file handle if there are no more refs.
- ##
- my $self = _get_self($_[0]);
- return unless $self;
-
- $self->root->{links}--;
-
- if (!$self->root->{links}) {
- $self->close();
- }
-}
+#XXX Unneeded now ...
+#sub DESTROY {
+#}
+my %translate_mode = (
+ 'r' => '<',
+ 'r+' => '+<',
+ 'w' => '>',
+ 'w+' => '+>',
+ 'a' => '>>',
+ 'a+' => '+>>',
+);
sub _open {
##
# Open a FileHandle to the database, create if nonexistent.
##
my $self = _get_self($_[0]);
- if (defined($self->fh)) { $self->close(); }
+ if (defined($self->fh)) { $self->_close(); }
- if (!(-e $self->root->{file}) && $self->root->{mode} eq 'r+') {
- my $temp = FileHandle->new( $self->root->{file}, 'w' );
- undef $temp;
- }
+ eval {
+ my $filename = $self->root->{file};
+ my $mode = $translate_mode{ $self->root->{mode} };
+
+ if (!(-e $filename) && $mode eq '+<') {
+ open( FH, '>', $filename );
+ close FH;
+ }
- #XXX Convert to set_fh()
- $self->root->{fh} = FileHandle->new( $self->root->{file}, $self->root->{mode} );
+ my $fh;
+ open( $fh, $mode, $filename )
+ or $fh = undef;
+ $self->root->{fh} = $fh;
+ }; if ($@ ) { $self->_throw_error( "Received error: $@\n" ); }
if (! defined($self->fh)) {
- return $self->throw_error("Cannot open file: " . $self->root->{file} . ": $!");
+ return $self->_throw_error("Cannot open file: " . $self->root->{file} . ": $!");
}
- binmode $self->fh; # for win32
+ my $fh = $self->fh;
+
+ #XXX Can we remove this by using the right sysopen() flags?
+ binmode $fh; # for win32
+
if ($self->root->{autoflush}) {
- $self->fh->autoflush();
+ my $old = select $fh;
+ $|=1;
+ select $old;
}
my $signature;
- seek($self->fh, 0, 0);
- my $bytes_read = $self->fh->read($signature, length(SIG_FILE));
+ seek($fh, 0, 0);
+ my $bytes_read = read( $fh, $signature, length(SIG_FILE));
##
# File is empty -- write signature and master index
##
if (!$bytes_read) {
- seek($self->fh, 0, 0);
- $self->fh->print(SIG_FILE);
+ seek($fh, 0, 0);
+ print($fh SIG_FILE);
$self->root->{end} = length(SIG_FILE);
- $self->create_tag($self->base_offset, $self->type, chr(0) x $INDEX_SIZE);
+ $self->_create_tag($self->base_offset, $self->type, chr(0) x $INDEX_SIZE);
my $plain_key = "[base]";
- $self->fh->print( pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
+ print($fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
$self->root->{end} += $DATA_LENGTH_SIZE + length($plain_key);
- $self->fh->flush();
+
+ # Flush the filehandle
+ my $old_fh = select $fh;
+ my $old_af = $|;
+ $| = 1;
+ $| = $old_af;
+ select $old_fh;
return 1;
}
# Check signature was valid
##
unless ($signature eq SIG_FILE) {
- $self->close();
- return $self->throw_error("Signature not found -- file is not a Deep DB");
+ $self->_close();
+ return $self->_throw_error("Signature not found -- file is not a Deep DB");
}
- $self->root->{end} = (stat($self->fh))[7];
+ $self->root->{end} = (stat($fh))[7];
##
# Get our type from master index signature
##
- my $tag = $self->load_tag($self->base_offset);
-#XXX This is a problem - need to verify type, not override it!
-#XXX We probably also want to store the hash algorithm name, not assume anything
-#XXX Convert to set_type() when one is written
- $self->{type} = $tag->{signature};
-
+ my $tag = $self->_load_tag($self->base_offset);
+
+#XXX We probably also want to store the hash algorithm name and not assume anything
+
+ if (!$tag) {
+ return $self->_throw_error("Corrupted file, no master index record");
+ }
+ if ($self->{type} ne $tag->{signature}) {
+ return $self->_throw_error("File type mismatch");
+ }
+
return 1;
}
-sub close {
+sub _close {
##
# Close database FileHandle
##
my $self = _get_self($_[0]);
- undef $self->root->{fh};
+ close $self->root->{fh};
}
-sub create_tag {
+sub _create_tag {
##
# Given offset, signature and content, create tag and write to disk
##
my ($self, $offset, $sig, $content) = @_;
my $size = length($content);
- seek($self->fh, $offset, 0);
- $self->fh->print( $sig . pack($DATA_LENGTH_PACK, $size) . $content );
+ my $fh = $self->fh;
+
+ seek($fh, $offset, 0);
+ print($fh $sig . pack($DATA_LENGTH_PACK, $size) . $content );
if ($offset == $self->root->{end}) {
$self->root->{end} += SIG_SIZE + $DATA_LENGTH_SIZE + $size;
};
}
-sub load_tag {
+sub _load_tag {
##
# Given offset, load single tag and return signature, size and data
##
my $self = shift;
my $offset = shift;
- seek($self->fh, $offset, 0);
- if ($self->fh->eof()) { return; }
+ my $fh = $self->fh;
+
+ seek($fh, $offset, 0);
+ if (eof $fh) { return undef; }
my $sig;
- $self->fh->read($sig, SIG_SIZE);
+ read( $fh, $sig, SIG_SIZE);
my $size;
- $self->fh->read($size, $DATA_LENGTH_SIZE);
+ read( $fh, $size, $DATA_LENGTH_SIZE);
$size = unpack($DATA_LENGTH_PACK, $size);
my $buffer;
- $self->fh->read($buffer, $size);
+ read( $fh, $buffer, $size);
return {
signature => $sig,
};
}
-sub index_lookup {
+sub _index_lookup {
##
# Given index tag, lookup single entry in index and return .
##
my $location = unpack($LONG_PACK, substr($tag->{content}, $index * $LONG_SIZE, $LONG_SIZE) );
if (!$location) { return; }
- return $self->load_tag( $location );
+ return $self->_load_tag( $location );
}
-sub add_bucket {
+sub _add_bucket {
##
# Adds one key/value pair to bucket list, given offset, MD5 digest of key,
# plain (undigested) key and value.
my $is_dbm_deep = eval { $value->isa( 'DBM::Deep' ) };
my $internal_ref = $is_dbm_deep && ($value->root eq $self->root);
+ my $fh = $self->fh;
+
##
# Iterate through buckets, seeing if this is a new entry or a replace.
##
##
$result = 2;
- if ($internal_ref) { $location = $value->base_offset; }
- else { $location = $self->root->{end}; }
+ $location = $internal_ref
+ ? $value->base_offset
+ : $self->root->{end};
- seek($self->fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
- $self->fh->print( $md5 . pack($LONG_PACK, $location) );
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
+ print($fh $md5 . pack($LONG_PACK, $location) );
last;
}
elsif ($md5 eq $key) {
if ($internal_ref) {
$location = $value->base_offset;
- seek($self->fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
- $self->fh->print( $md5 . pack($LONG_PACK, $location) );
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
+ print($fh $md5 . pack($LONG_PACK, $location) );
}
else {
- seek($self->fh, $subloc + SIG_SIZE, 0);
+ seek($fh, $subloc + SIG_SIZE, 0);
my $size;
- $self->fh->read($size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+ read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
##
# If value is a hash, array, or raw value with equal or less size, we can
}
else {
$location = $self->root->{end};
- seek($self->fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE, 0);
- $self->fh->print( pack($LONG_PACK, $location) );
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE, 0);
+ print($fh pack($LONG_PACK, $location) );
}
}
last;
# If bucket didn't fit into list, split into a new index level
##
if (!$location) {
- seek($self->fh, $tag->{ref_loc}, 0);
- $self->fh->print( pack($LONG_PACK, $self->root->{end}) );
+ seek($fh, $tag->{ref_loc}, 0);
+ print($fh pack($LONG_PACK, $self->root->{end}) );
- my $index_tag = $self->create_tag($self->root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE);
+ my $index_tag = $self->_create_tag($self->root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE);
my @offsets = ();
$keys .= $md5 . pack($LONG_PACK, 0);
if ($offsets[$num]) {
my $offset = $offsets[$num] + SIG_SIZE + $DATA_LENGTH_SIZE;
- seek($self->fh, $offset, 0);
+ seek($fh, $offset, 0);
my $subkeys;
- $self->fh->read($subkeys, $BUCKET_LIST_SIZE);
+ read( $fh, $subkeys, $BUCKET_LIST_SIZE);
for (my $k=0; $k<$MAX_BUCKETS; $k++) {
my $subloc = unpack($LONG_PACK, substr($subkeys, ($k * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
if (!$subloc) {
- seek($self->fh, $offset + ($k * $BUCKET_SIZE), 0);
- $self->fh->print( $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
+ seek($fh, $offset + ($k * $BUCKET_SIZE), 0);
+ print($fh $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
last;
}
} # k loop
}
else {
$offsets[$num] = $self->root->{end};
- seek($self->fh, $index_tag->{offset} + ($num * $LONG_SIZE), 0);
- $self->fh->print( pack($LONG_PACK, $self->root->{end}) );
+ seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE), 0);
+ print($fh pack($LONG_PACK, $self->root->{end}) );
- my $blist_tag = $self->create_tag($self->root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
+ my $blist_tag = $self->_create_tag($self->root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
- seek($self->fh, $blist_tag->{offset}, 0);
- $self->fh->print( $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
+ seek($fh, $blist_tag->{offset}, 0);
+ print($fh $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
}
} # key is real
} # i loop
##
if ($location) {
my $content_length;
- seek($self->fh, $location, 0);
+ seek($fh, $location, 0);
##
# Write signature based on content type, set content length and write actual value.
##
my $r = Scalar::Util::reftype($value) || '';
if ($r eq 'HASH') {
- $self->fh->print( TYPE_HASH );
- $self->fh->print( pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
+ print($fh TYPE_HASH );
+ print($fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
$content_length = $INDEX_SIZE;
}
elsif ($r eq 'ARRAY') {
- $self->fh->print( TYPE_ARRAY );
- $self->fh->print( pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
+ print($fh TYPE_ARRAY );
+ print($fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
$content_length = $INDEX_SIZE;
}
elsif (!defined($value)) {
- $self->fh->print( SIG_NULL );
- $self->fh->print( pack($DATA_LENGTH_PACK, 0) );
+ print($fh SIG_NULL );
+ print($fh pack($DATA_LENGTH_PACK, 0) );
$content_length = 0;
}
else {
- $self->fh->print( SIG_DATA );
- $self->fh->print( pack($DATA_LENGTH_PACK, length($value)) . $value );
+ print($fh SIG_DATA );
+ print($fh pack($DATA_LENGTH_PACK, length($value)) . $value );
$content_length = length($value);
}
##
# Plain key is stored AFTER value, as keys are typically fetched less often.
##
- $self->fh->print( pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
+ print($fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
##
# If value is blessed, preserve class name
##
- my $value_class = Scalar::Util::blessed($value);
- if ($self->root->{autobless} && defined $value_class && $value_class ne 'DBM::Deep' ) {
- ##
- # Blessed ref -- will restore later
- ##
- $self->fh->print( chr(1) );
- $self->fh->print( pack($DATA_LENGTH_PACK, length($value_class)) . $value_class );
- $content_length += 1;
- $content_length += $DATA_LENGTH_SIZE + length($value_class);
- }
-
+ if ( $self->root->{autobless} ) {
+ my $value_class = Scalar::Util::blessed($value);
+ if ( defined $value_class && $value_class ne 'DBM::Deep' ) {
+ ##
+ # Blessed ref -- will restore later
+ ##
+ print($fh chr(1) );
+ print($fh pack($DATA_LENGTH_PACK, length($value_class)) . $value_class );
+ $content_length += 1;
+ $content_length += $DATA_LENGTH_SIZE + length($value_class);
+ }
+ else {
+ print($fh chr(0) );
+ $content_length += 1;
+ }
+ }
+
##
# If this is a new content area, advance EOF counter
##
root => $self->root,
);
foreach my $key (keys %{$value}) {
- $branch->{$key} = $value->{$key};
+ #$branch->{$key} = $value->{$key};
+ $branch->STORE( $key, $value->{$key} );
}
}
elsif ($r eq 'ARRAY') {
);
my $index = 0;
foreach my $element (@{$value}) {
- $branch->[$index] = $element;
+ #$branch->[$index] = $element;
+ $branch->STORE( $index, $element );
$index++;
}
}
return $result;
}
- return $self->throw_error("Fatal error: indexing failed -- possibly due to corruption in file");
+ return $self->_throw_error("Fatal error: indexing failed -- possibly due to corruption in file");
}
-sub get_bucket_value {
+sub _get_bucket_value {
##
# Fetch single value 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
# Found match -- seek to offset and read signature
##
my $signature;
- seek($self->fh, $subloc, 0);
- $self->fh->read($signature, SIG_SIZE);
+ seek($fh, $subloc, 0);
+ read( $fh, $signature, SIG_SIZE);
##
# If value is a hash or array, return new DeepDB object with correct offset
# Skip over value and plain key to see if object needs
# to be re-blessed
##
- seek($self->fh, $DATA_LENGTH_SIZE + $INDEX_SIZE, 1);
+ seek($fh, $DATA_LENGTH_SIZE + $INDEX_SIZE, 1);
my $size;
- $self->fh->read($size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { seek($self->fh, $size, 1); }
+ read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+ if ($size) { seek($fh, $size, 1); }
my $bless_bit;
- $self->fh->read($bless_bit, 1);
+ read( $fh, $bless_bit, 1);
if (ord($bless_bit)) {
##
# Yes, object needs to be re-blessed
##
my $class_name;
- $self->fh->read($size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { $self->fh->read($class_name, $size); }
+ read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+ if ($size) { read( $fh, $class_name, $size); }
if ($class_name) { $obj = bless( $obj, $class_name ); }
}
}
elsif ($signature eq SIG_DATA) {
my $size;
my $value = '';
- $self->fh->read($size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { $self->fh->read($value, $size); }
+ read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+ if ($size) { read( $fh, $value, $size); }
return $value;
}
return;
}
-sub delete_bucket {
+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
##
# Matched key -- delete bucket and return
##
- seek($self->fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
- $self->fh->print( substr($keys, ($i+1) * $BUCKET_SIZE ) );
- $self->fh->print( chr(0) x $BUCKET_SIZE );
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
+ print($fh substr($keys, ($i+1) * $BUCKET_SIZE ) );
+ print($fh chr(0) x $BUCKET_SIZE );
return 1;
} # i loop
return;
}
-sub bucket_exists {
+sub _bucket_exists {
##
# Check existence of single key given tag and MD5 digested key.
##
return;
}
-sub find_bucket_list {
+sub _find_bucket_list {
##
# Locate offset for bucket list, given digested key
##
# Locate offset for bucket list using digest index system
##
my $ch = 0;
- my $tag = $self->load_tag($self->base_offset);
+ my $tag = $self->_load_tag($self->base_offset);
if (!$tag) { return; }
while ($tag->{signature} ne SIG_BLIST) {
- $tag = $self->index_lookup($tag, ord(substr($md5, $ch, 1)));
+ $tag = $self->_index_lookup($tag, ord(substr($md5, $ch, 1)));
if (!$tag) { return; }
$ch++;
}
return $tag;
}
-sub traverse_index {
+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->load_tag( $offset );
+ my $tag = $self->_load_tag( $offset );
+
+ my $fh = $self->fh;
if ($tag->{signature} ne SIG_BLIST) {
my $content = $tag->{content};
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 );
+ my $result = $self->_traverse_index( $subloc, $ch + 1, $force_return_next );
if (defined($result)) { return $result; }
}
} # index loop
##
# Seek to bucket location and skip over signature
##
- seek($self->fh, $subloc + SIG_SIZE, 0);
+ seek($fh, $subloc + SIG_SIZE, 0);
##
# Skip over value to get to plain key
##
my $size;
- $self->fh->read($size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { seek($self->fh, $size, 1); }
+ read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+ if ($size) { seek($fh, $size, 1); }
##
# Read in plain key and return as scalar
##
my $plain_key;
- $self->fh->read($size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { $self->fh->read($plain_key, $size); }
+ read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+ if ($size) { read( $fh, $plain_key, $size); }
return $plain_key;
}
return;
}
-sub get_next_key {
+sub _get_next_key {
##
# Locate next key, given digested previous one
##
$self->{return_next} = 1;
}
- return $self->traverse_index( $self->base_offset, 0 );
+ return $self->_traverse_index( $self->base_offset, 0 );
}
sub lock {
if ($self->root->{locking}) {
if (!$self->root->{locked}) { flock($self->fh, $type); }
$self->root->{locked}++;
+
+ return 1;
}
+
+ return;
}
sub unlock {
if ($self->root->{locking} && $self->root->{locked} > 0) {
$self->root->{locked}--;
if (!$self->root->{locked}) { flock($self->fh, LOCK_UN); }
+
+ return 1;
}
+
+ return;
}
#XXX These uses of ref() need verified
-sub copy_node {
+sub _copy_node {
##
# Copy single level of keys or elements to new DB handle.
# Recurse for nested structures
my $key = $self->first_key();
while ($key) {
my $value = $self->get($key);
+#XXX This doesn't work with autobless
if (!ref($value)) { $db_temp->{$key} = $value; }
else {
my $type = $value->type;
if ($type eq TYPE_HASH) { $db_temp->{$key} = {}; }
else { $db_temp->{$key} = []; }
- $value->copy_node( $db_temp->{$key} );
+ $value->_copy_node( $db_temp->{$key} );
}
$key = $self->next_key($key);
}
my $type = $value->type;
if ($type eq TYPE_HASH) { $db_temp->[$index] = {}; }
else { $db_temp->[$index] = []; }
- $value->copy_node( $db_temp->[$index] );
+ $value->_copy_node( $db_temp->[$index] );
}
}
}
elsif ($self->type eq TYPE_ARRAY) { $temp = []; }
$self->lock();
- $self->copy_node( $temp );
+ $self->_copy_node( $temp );
$self->unlock();
return $temp;
$self->push( @$struct );
}
else {
- return $self->throw_error("Cannot import: type mismatch");
+ return $self->_throw_error("Cannot import: type mismatch");
}
return 1;
# it back on top of original.
##
my $self = _get_self($_[0]);
- if ($self->root->{links} > 1) {
- return $self->throw_error("Cannot optimize: reference count is greater than 1");
- }
+
+#XXX Need to create a new test for this
+# if ($self->root->{links} > 1) {
+# return $self->_throw_error("Cannot optimize: reference count is greater than 1");
+# }
my $db_temp = DBM::Deep->new(
file => $self->root->{file} . '.tmp',
type => $self->type
);
if (!$db_temp) {
- return $self->throw_error("Cannot optimize: failed to open temp file: $!");
+ return $self->_throw_error("Cannot optimize: failed to open temp file: $!");
}
$self->lock();
- $self->copy_node( $db_temp );
+ $self->_copy_node( $db_temp );
undef $db_temp;
##
# with a soft copy.
##
$self->unlock();
- $self->close();
+ $self->_close();
}
if (!rename $self->root->{file} . '.tmp', $self->root->{file}) {
unlink $self->root->{file} . '.tmp';
$self->unlock();
- return $self->throw_error("Optimize failed: Cannot copy temp file over original: $!");
+ return $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
}
$self->unlock();
- $self->close();
+ $self->_close();
$self->_open();
return 1;
# Utility methods
##
-sub throw_error {
+sub _throw_error {
##
# Store error string in self
##
my $self = _get_self($_[0]);
my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1];
#XXX What is ref() checking here?
+ #YYY User may be storing a hash, in which case we do not want it run
+ #YYY through the filtering system
my $value = ($self->root->{filter_store_value} && !ref($_[2])) ? $self->root->{filter_store_value}->($_[2]) : $_[2];
my $unpacked_key = $key;
if (!defined($self->fh) && !$self->_open()) {
return;
}
+ ##
+
+ my $fh = $self->fh;
##
# Request exclusive lock for writing
# DB instance appended to our file while we were unlocked.
##
if ($self->root->{locking} || $self->root->{volatile}) {
- $self->root->{end} = (stat($self->fh))[7];
+ $self->root->{end} = (stat($fh))[7];
}
##
# Locate offset for bucket list using digest index system
##
- my $tag = $self->load_tag($self->base_offset);
+ my $tag = $self->_load_tag($self->base_offset);
if (!$tag) {
- $tag = $self->create_tag($self->base_offset, SIG_INDEX, chr(0) x $INDEX_SIZE);
+ $tag = $self->_create_tag($self->base_offset, SIG_INDEX, chr(0) x $INDEX_SIZE);
}
my $ch = 0;
while ($tag->{signature} ne SIG_BLIST) {
my $num = ord(substr($md5, $ch, 1));
- my $new_tag = $self->index_lookup($tag, $num);
+ my $new_tag = $self->_index_lookup($tag, $num);
if (!$new_tag) {
my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
- seek($self->fh, $ref_loc, 0);
- $self->fh->print( pack($LONG_PACK, $self->root->{end}) );
+ seek($fh, $ref_loc, 0);
+ print($fh pack($LONG_PACK, $self->root->{end}) );
- $tag = $self->create_tag($self->root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
+ $tag = $self->_create_tag($self->root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
$tag->{ref_loc} = $ref_loc;
$tag->{ch} = $ch;
last;
##
# Add key/value to bucket list
##
- my $result = $self->add_bucket( $tag, $md5, $key, $value );
+ my $result = $self->_add_bucket( $tag, $md5, $key, $value );
##
# If this object is an array, and bucket was not a replace, and key is numerical,
##
$self->lock( LOCK_SH );
- my $tag = $self->find_bucket_list( $md5 );
+ my $tag = $self->_find_bucket_list( $md5 );
if (!$tag) {
$self->unlock();
return;
##
# Get value from bucket list
##
- my $result = $self->get_bucket_value( $tag, $md5 );
+ my $result = $self->_get_bucket_value( $tag, $md5 );
$self->unlock();
##
$self->lock( LOCK_EX );
- my $tag = $self->find_bucket_list( $md5 );
+ my $tag = $self->_find_bucket_list( $md5 );
if (!$tag) {
$self->unlock();
return;
##
# Delete bucket
##
- my $result = $self->delete_bucket( $tag, $md5 );
+ my $result = $self->_delete_bucket( $tag, $md5 );
##
# If this object is an array and the key deleted was on the end of the stack,
##
$self->lock( LOCK_SH );
- my $tag = $self->find_bucket_list( $md5 );
+ my $tag = $self->_find_bucket_list( $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->_bucket_exists( $tag, $md5 ) || '';
$self->unlock();
##
$self->lock( LOCK_EX );
- seek($self->fh, $self->base_offset, 0);
- if ($self->fh->eof()) {
+ my $fh = $self->fh;
+
+ seek($fh, $self->base_offset, 0);
+ if (eof $fh) {
$self->unlock();
return;
}
- $self->create_tag($self->base_offset, $self->type, chr(0) x $INDEX_SIZE);
+ $self->_create_tag($self->base_offset, $self->type, chr(0) x $INDEX_SIZE);
$self->unlock();
return 1;
}
-sub FIRSTKEY {
- ##
- # Locate and return first key (in no particular order)
- ##
- my $self = _get_self($_[0]);
- if ($self->type ne TYPE_HASH) {
- return $self->throw_error("FIRSTKEY method only supported for hashes");
- }
-
- ##
- # Make sure file is open
- ##
- if (!defined($self->fh)) { $self->_open(); }
-
- ##
- # Request shared lock for reading
- ##
- $self->lock( LOCK_SH );
-
- my $result = $self->get_next_key();
-
- $self->unlock();
-
- return ($result && $self->root->{filter_fetch_key}) ? $self->root->{filter_fetch_key}->($result) : $result;
-}
-
-sub NEXTKEY {
- ##
- # Return next key (in no particular order), given previous one
- ##
- my $self = _get_self($_[0]);
- if ($self->type ne TYPE_HASH) {
- return $self->throw_error("NEXTKEY method only supported for hashes");
- }
- my $prev_key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1];
- my $prev_md5 = $DIGEST_FUNC->($prev_key);
-
- ##
- # Make sure file is open
- ##
- if (!defined($self->fh)) { $self->_open(); }
-
- ##
- # Request shared lock for reading
- ##
- $self->lock( LOCK_SH );
-
- my $result = $self->get_next_key( $prev_md5 );
-
- $self->unlock();
-
- return ($result && $self->root->{filter_fetch_key}) ? $self->root->{filter_fetch_key}->($result) : $result;
-}
-
##
-# The following methods are for arrays only
+# Public method aliases
##
+*put = *store = *STORE;
+*get = *fetch = *FETCH;
+*delete = *DELETE;
+*exists = *EXISTS;
+*clear = *CLEAR;
-sub FETCHSIZE {
- ##
- # Return the length of the array
- ##
- my $self = _get_self($_[0]);
- if ($self->type ne TYPE_ARRAY) {
- return $self->throw_error("FETCHSIZE method only supported for arrays");
- }
-
- my $SAVE_FILTER = $self->root->{filter_fetch_value};
- $self->root->{filter_fetch_value} = undef;
-
- my $packed_size = $self->FETCH('length');
-
- $self->root->{filter_fetch_value} = $SAVE_FILTER;
-
- if ($packed_size) { return int(unpack($LONG_PACK, $packed_size)); }
- else { return 0; }
-}
-
-sub STORESIZE {
- ##
- # Set the length of the array
- ##
- my $self = _get_self($_[0]);
- if ($self->type ne TYPE_ARRAY) {
- return $self->throw_error("STORESIZE method only supported for arrays");
- }
- my $new_length = $_[1];
-
- my $SAVE_FILTER = $self->root->{filter_store_value};
- $self->root->{filter_store_value} = undef;
-
- my $result = $self->STORE('length', pack($LONG_PACK, $new_length));
-
- $self->root->{filter_store_value} = $SAVE_FILTER;
-
- return $result;
-}
+package DBM::Deep::_::Root;
-sub POP {
- ##
- # Remove and return the last element on the array
- ##
- my $self = _get_self($_[0]);
- if ($self->type ne TYPE_ARRAY) {
- return $self->throw_error("POP method only supported for arrays");
- }
- my $length = $self->FETCHSIZE();
-
- if ($length) {
- my $content = $self->FETCH( $length - 1 );
- $self->DELETE( $length - 1 );
- return $content;
- }
- else {
- return;
- }
-}
-
-sub PUSH {
- ##
- # Add new element(s) to the end of the array
- ##
- my $self = _get_self(shift);
- if ($self->type ne TYPE_ARRAY) {
- return $self->throw_error("PUSH method only supported for arrays");
- }
- my $length = $self->FETCHSIZE();
-
- while (my $content = shift @_) {
- $self->STORE( $length, $content );
- $length++;
- }
+sub new {
+ my $class = shift;
+ my ($args) = @_;
+
+ my $self = bless {
+ file => undef,
+ fh => undef,
+ end => 0,
+ autoflush => undef,
+ locking => undef,
+ volatile => undef,
+ debug => undef,
+ mode => 'r+',
+ filter_store_key => undef,
+ filter_store_value => undef,
+ filter_fetch_key => undef,
+ filter_fetch_value => undef,
+ autobless => undef,
+ locked => 0,
+ %$args,
+ }, $class;
+
+ return $self;
}
-sub SHIFT {
- ##
- # Remove and return first element on the array.
- # Shift over remaining elements to take up space.
- ##
- my $self = _get_self($_[0]);
- if ($self->type ne TYPE_ARRAY) {
- return $self->throw_error("SHIFT method only supported for arrays");
- }
- my $length = $self->FETCHSIZE();
-
- if ($length) {
- my $content = $self->FETCH( 0 );
-
- ##
- # Shift elements over and remove last one.
- ##
- for (my $i = 0; $i < $length - 1; $i++) {
- $self->STORE( $i, $self->FETCH($i + 1) );
- }
- $self->DELETE( $length - 1 );
-
- return $content;
- }
- else {
- return;
- }
-}
+sub DESTROY {
+ my $self = shift;
+ return unless $self;
-sub UNSHIFT {
- ##
- # Insert new element(s) at beginning of array.
- # Shift over other elements to make space.
- ##
- my $self = _get_self($_[0]);shift @_;
- if ($self->type ne TYPE_ARRAY) {
- return $self->throw_error("UNSHIFT method only supported for arrays");
- }
- my @new_elements = @_;
- 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] );
- }
-}
+ close $self->{fh} if $self->{fh};
-sub SPLICE {
- ##
- # Splices section of array with optional new section.
- # Returns deleted section, or last element deleted in scalar context.
- ##
- my $self = _get_self($_[0]);shift @_;
- if ($self->type ne TYPE_ARRAY) {
- return $self->throw_error("SPLICE method only supported for arrays");
- }
- my $length = $self->FETCHSIZE();
-
- ##
- # Calculate offset and length of splice
- ##
- my $offset = shift || 0;
- 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 = ();
- for (my $i = $offset; $i < $offset + $splice_length; $i++) {
- push @old_elements, $self->FETCH( $i );
- }
-
- ##
- # 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--) {
- $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
- }
- }
- else {
- for (my $i = $offset + $splice_length; $i < $length; $i++) {
- $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
- }
- for (my $i = 0; $i < $splice_length - $new_size; $i++) {
- $self->DELETE( $length - 1 );
- $length--;
- }
- }
- }
-
- ##
- # Insert new elements into array
- ##
- for (my $i = $offset; $i < $offset + $new_size; $i++) {
- $self->STORE( $i, shift @new_elements );
- }
-
- ##
- # Return deleted section, or last element in scalar context.
- ##
- return wantarray ? @old_elements : $old_elements[-1];
+ return;
}
-#XXX We don't need to define it.
-#XXX 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 for compatibility.
- ##
-#}
-
-##
-# Public method aliases
-##
-*put = *store = *STORE;
-*get = *fetch = *FETCH;
-*delete = *DELETE;
-*exists = *EXISTS;
-*clear = *CLEAR;
-*first_key = *FIRSTKEY;
-*next_key = *NEXTKEY;
-*length = *FETCHSIZE;
-*pop = *POP;
-*push = *PUSH;
-*shift = *SHIFT;
-*unshift = *UNSHIFT;
-*splice = *SPLICE;
-
1;
__END__
so it's pretty much undefined how the keys will come out -- just like Perl's
built-in hashes.
+=head1 CODE COVERAGE
+
+I use B<Devel::Cover> to test the code coverage of my tests, below is the B<Devel::Cover> report on this
+module's test suite.
+
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ File stmt bran cond sub pod time total
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ blib/lib/DBM/Deep.pm 94.1 82.9 74.5 98.0 10.5 98.1 88.2
+ blib/lib/DBM/Deep/Array.pm 97.8 83.3 50.0 100.0 n/a 1.6 94.4
+ blib/lib/DBM/Deep/Hash.pm 93.3 85.7 100.0 100.0 n/a 0.3 92.7
+ Total 94.5 83.1 75.5 98.4 10.5 100.0 89.0
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+
=head1 AUTHOR
Joseph Huckaby, L<jhuckaby@cpan.org>
projects / dbsrgits/DBM-Deep.git / blobdiff