use strict;
-use FileHandle;
-use Fcntl qw/:flock/;
+use Fcntl qw( :DEFAULT :flock :seek );
use Digest::MD5 ();
use Scalar::Util ();
-use vars qw/$VERSION/;
-$VERSION = "0.96";
+use vars qw( $VERSION );
+$VERSION = q(0.97);
##
# Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file.
##
#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;
##
##
# Setup file and tag signatures. These should never change.
##
-sub SIG_FILE () { 'DPDB' }
-sub SIG_HASH () { 'H' }
-sub SIG_ARRAY () { 'A' }
-sub SIG_NULL () { 'N' }
-sub SIG_DATA () { 'D' }
-sub SIG_INDEX () { 'I' }
-sub SIG_BLIST () { 'B' }
-sub SIG_SIZE () { 1 }
+sub SIG_FILE () { 'DPDB' }
+sub SIG_HASH () { 'H' }
+sub SIG_ARRAY () { 'A' }
+sub SIG_SCALAR () { 'S' }
+sub SIG_NULL () { 'N' }
+sub SIG_DATA () { 'D' }
+sub SIG_INDEX () { 'I' }
+sub SIG_BLIST () { 'B' }
+sub SIG_SIZE () { 1 }
##
# Setup constants for users to pass to new()
##
-sub TYPE_HASH () { return SIG_HASH; }
-sub TYPE_ARRAY () { return SIG_ARRAY; }
+sub TYPE_HASH () { return SIG_HASH; }
+sub TYPE_ARRAY () { return SIG_ARRAY; }
+sub TYPE_SCALAR () { return SIG_SCALAR; }
+
+sub _get_args {
+ my $proto = shift;
+
+ my $args;
+ if (scalar(@_) > 1) {
+ if ( @_ % 2 ) {
+ $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] );
+ }
+ $args = {@_};
+ }
+ elsif ( my $type = Scalar::Util::reftype($_[0]) ) {
+ if ( $type ne 'HASH' ) {
+ $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] );
+ }
+ $args = $_[0];
+ }
+ else {
+ $args = { file => shift };
+ }
+
+ return $args;
+}
sub new {
##
# providing a hybrid OO/tie interface.
##
my $class = shift;
- my $args;
- if (scalar(@_) > 1) { $args = {@_}; }
- else { $args = { file => shift }; }
+ my $args = $class->_get_args( @_ );
##
# Check if we want a tied hash or array.
##
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;
}
return bless $self, $class;
}
-{
- my @outer_params = qw( type base_offset );
- sub _init {
- ##
- # Setup $self and bless into this class.
- ##
- my $class = shift;
- my $args = shift;
-
- 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}
- }
-
- 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}++;
+sub _init {
+ ##
+ # Setup $self and bless into this class.
+ ##
+ my $class = shift;
+ my $args = shift;
- if (!defined($self->fh)) { $self->open(); }
+ # These are the defaults to be optionally overridden below
+ my $self = bless {
+ type => TYPE_HASH,
+ base_offset => length(SIG_FILE),
+ }, $class;
- return $self;
+ foreach my $param ( keys %$self ) {
+ next unless exists $args->{$param};
+ $self->{$param} = delete $args->{$param}
}
-}
+
+ $self->{root} = exists $args->{root}
+ ? $args->{root}
+ : DBM::Deep::_::Root->new( $args );
-sub _get_self { tied( %{$_[0]} ) || $_[0] }
+ if (!defined($self->fh)) { $self->_open(); }
-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 $self;
+}
- return $class->_init($args);
+sub TIEHASH {
+ 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 {
+#}
-sub open {
+sub _open {
##
# Open a FileHandle to the database, create if nonexistent.
# Make sure file signature matches DeepDB spec.
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
- 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 {
+ # Theoretically, adding O_BINARY should remove the need for the binmode
+ # Of course, testing it is going to be ... interesting.
+ my $flags = O_RDWR | O_CREAT | O_BINARY;
+
+ #XXX Can the mode be anything but r+, w+, or a+??
+ #XXX ie, it has to be in read-write mode
+ #XXX So, should we verify that the mode is legitimate?
+
+ #XXX Maybe the mode thingy should just go away. There's no good
+ #XXX reason for it ...
+ if ( $self->root->{mode} eq 'w+' ) {
+ $flags |= O_TRUNC;
+ }
- #XXX Convert to set_fh()
- $self->root->{fh} = FileHandle->new( $self->root->{file}, $self->root->{mode} );
+ my $fh;
+ sysopen( $fh, $self->root->{file}, $flags )
+ 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 sysopen file: " . $self->root->{file} . ": $!");
}
- binmode $self->fh; # for win32
+ my $fh = $self->fh;
+
+ #XXX Can we remove this by using the right sysopen() flags?
+ # Maybe ... q.v. above
+ binmode $fh; # for win32
+
if ($self->root->{autoflush}) {
- $self->fh->autoflush();
+ my $old = select $fh;
+ $|=1;
+ select $old;
}
+ # Set the
+ seek($fh, 0, SEEK_SET);
+
my $signature;
- seek($self->fh, 0, 0);
- my $bytes_read = $self->fh->read($signature, length(SIG_FILE));
+ 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, SEEK_SET);
+ 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];
+ my @stats = stat($fh);
+ $self->root->{inode} = $stats[1];
+ $self->root->{end} = $stats[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
+#XXX The cool thing would be to allow a different hashing algorithm at every level
+
+ 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};
+ my $self = $_[0]->_get_self;
+ close $self->root->{fh};
+ $self->root->{fh} = undef;
}
-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, SEEK_SET);
+ 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, SEEK_SET);
+ 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 $location = 0;
my $result = 2;
- my $is_dbm_deep = eval { $value->isa( 'DBM::Deep' ) };
+ # added ref() check first to avoid eval and runtime exception for every
+ # scalar value being stored. performance tweak.
+ my $is_dbm_deep = ref($value) && 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), SEEK_SET);
+ 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), SEEK_SET);
+ print($fh $md5 . pack($LONG_PACK, $location) );
}
else {
- seek($self->fh, $subloc + SIG_SIZE, 0);
+ seek($fh, $subloc + SIG_SIZE, SEEK_SET);
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, SEEK_SET);
+ 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}, SEEK_SET);
+ 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, SEEK_SET);
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), SEEK_SET);
+ 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), SEEK_SET);
+ 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}, SEEK_SET);
+ 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, SEEK_SET);
##
# 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, SEEK_SET);
+ 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, SEEK_CUR);
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, SEEK_CUR); }
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), 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 {
+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, SEEK_SET);
##
# 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, SEEK_CUR); }
##
# 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
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
$self->{prev_md5} = $_[1] ? $_[1] : undef;
$self->{return_next} = 0;
$self->{return_next} = 1;
}
- return $self->traverse_index( $self->base_offset, 0 );
+ return $self->_traverse_index( $self->base_offset, 0 );
}
sub lock {
# times before unlock(), then the same number of unlocks() must
# be called before the lock is released.
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $type = $_[1];
$type = LOCK_EX unless defined $type;
+ if (!defined($self->fh)) { return; }
+
if ($self->root->{locking}) {
- if (!$self->root->{locked}) { flock($self->fh, $type); }
+ if (!$self->root->{locked}) {
+ flock($self->fh, $type);
+
+ # double-check file inode, in case another process
+ # has optimize()d our file while we were waiting.
+ if ((stat($self->root->{file}))[1] != $self->root->{inode}) {
+ $self->_open(); # re-open
+ flock($self->fh, $type); # re-lock
+ }
+ }
$self->root->{locked}++;
+
+ return 1;
}
+
+ return;
}
sub unlock {
# If db locking is set, unlock the db file. See note in lock()
# regarding calling lock() multiple times.
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
+
+ if (!defined($self->fh)) { return; }
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 $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $db_temp = $_[1];
if ($self->type eq TYPE_HASH) {
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] );
}
}
}
##
# Recursively export into standard Perl hashes and arrays.
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $temp;
if ($self->type eq TYPE_HASH) { $temp = {}; }
elsif ($self->type eq TYPE_ARRAY) { $temp = []; }
$self->lock();
- $self->copy_node( $temp );
+ $self->_copy_node( $temp );
$self->unlock();
return $temp;
#XXX This use of ref() seems to be ok
if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $struct = $_[1];
#XXX This use of ref() seems to be ok
$self->push( @$struct );
}
else {
- return $self->throw_error("Cannot import: type mismatch");
+ return $self->_throw_error("Cannot import: type mismatch");
}
return 1;
# Rebuild entire database into new file, then move
# 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");
- }
+ my $self = $_[0]->_get_self;
+
+#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->open();
+ $self->_close();
+ $self->_open();
return 1;
}
##
# Make copy of object and return
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
return DBM::Deep->new(
type => $self->type,
##
# Setup filter function for storing or fetching the key or value
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $type = lc $_[1];
my $func = $_[2] ? $_[2] : undef;
##
# Get access to the root structure
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
return $self->{root};
}
# Get access to the raw FileHandle
##
#XXX It will be useful, though, when we split out HASH and ARRAY
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
return $self->root->{fh};
}
##
# Get type of current node (TYPE_HASH or TYPE_ARRAY)
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
return $self->{type};
}
##
# Get base_offset of current node (TYPE_HASH or TYPE_ARRAY)
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
return $self->{base_offset};
}
# Get last error string, or undef if no error
##
return $_[0]
- ? ( _get_self($_[0])->{root}->{error} or undef )
+ #? ( _get_self($_[0])->{root}->{error} or undef )
+ ? ( $_[0]->_get_self->{root}->{error} or undef )
: $@;
}
# Utility methods
##
-sub throw_error {
+sub _throw_error {
##
# Store error string in self
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $error_text = $_[1];
- $self->root->{error} = $error_text;
+ if ( Scalar::Util::blessed $self ) {
+ $self->root->{error} = $error_text;
- unless ($self->root->{debug}) {
+ unless ($self->root->{debug}) {
+ die "DBM::Deep: $error_text\n";
+ }
+
+ warn "DBM::Deep: $error_text\n";
+ return;
+ }
+ else {
die "DBM::Deep: $error_text\n";
}
-
- warn "DBM::Deep: $error_text\n";
- return;
}
sub clear_error {
##
# Clear error state
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
undef $self->root->{error};
}
##
# Store single hash key/value or array element in database.
##
- 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?
- my $value = ($self->root->{filter_store_value} && !ref($_[2])) ? $self->root->{filter_store_value}->($_[2]) : $_[2];
+ my $self = $_[0]->_get_self;
+ my $key = $_[1];
+
+ # User may be storing a hash, in which case we do not want it run
+ # 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 (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); }
my $md5 = $DIGEST_FUNC->($key);
##
# Make sure file is open
##
- if (!defined($self->fh) && !$self->open()) {
+ if (!defined($self->fh) && !$self->_open()) {
return;
}
+ ##
##
# Request exclusive lock for writing
##
$self->lock( LOCK_EX );
+
+ my $fh = $self->fh;
##
# If locking is enabled, set 'end' parameter again, in case another
# 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, SEEK_SET);
+ 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 );
-
- ##
- # If this object is an array, and bucket was not a replace, and key is numerical,
- # and index is equal or greater than current length, advance length variable.
- ##
- if (($result == 2) && ($self->type eq TYPE_ARRAY) && ($unpacked_key =~ /^\d+$/) && ($unpacked_key >= $self->FETCHSIZE())) {
- $self->STORESIZE( $unpacked_key + 1 );
- }
+ my $result = $self->_add_bucket( $tag, $md5, $key, $value );
$self->unlock();
##
# Fetch single value or element given plain key or array index
##
- my $self = _get_self($_[0]);
-
- my $key = $_[1];
- if ( $self->type eq TYPE_HASH ) {
- if ( my $filter = $self->root->{filter_store_key} ) {
- $key = $filter->( $key );
- }
- }
- elsif ( $self->type eq TYPE_ARRAY ) {
- if ( $key =~ /^\d+$/ ) {
- $key = pack($LONG_PACK, $key);
- }
- }
-
- my $md5 = $DIGEST_FUNC->($key);
+ my $self = shift->_get_self;
+ my $key = shift;
##
# Make sure file is open
##
- if (!defined($self->fh)) { $self->open(); }
+ if (!defined($self->fh)) { $self->_open(); }
+ my $md5 = $DIGEST_FUNC->($key);
+
##
# Request shared lock for reading
##
$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();
#XXX What is ref() checking here?
- return ($result && !ref($result) && $self->root->{filter_fetch_value}) ? $self->root->{filter_fetch_value}->($result) : $result;
+ #YYY Filters only apply on scalar values, so the ref check is making
+ #YYY sure the fetched bucket is a scalar, not a child hash or array.
+ return ($result && !ref($result) && $self->root->{filter_fetch_value})
+ ? $self->root->{filter_fetch_value}->($result)
+ : $result;
}
sub DELETE {
##
# Delete single key/value pair or element given plain key or array index
##
- my $self = _get_self($_[0]);
- my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1];
+ my $self = $_[0]->_get_self;
+ my $key = $_[1];
- my $unpacked_key = $key;
- if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); }
my $md5 = $DIGEST_FUNC->($key);
##
# Make sure file is open
##
- if (!defined($self->fh)) { $self->open(); }
+ if (!defined($self->fh)) { $self->_open(); }
##
# Request exclusive lock for writing
##
$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 $value = $self->_get_bucket_value( $tag, $md5 );
+ if ($value && !ref($value) && $self->root->{filter_fetch_value}) {
+ $value = $self->root->{filter_fetch_value}->($value);
+ }
+
+ my $result = $self->_delete_bucket( $tag, $md5 );
##
# If this object is an array and the key deleted was on the end of the stack,
# decrement the length variable.
##
- if ($result && ($self->type eq TYPE_ARRAY) && ($unpacked_key == $self->FETCHSIZE() - 1)) {
- $self->STORESIZE( $unpacked_key );
- }
$self->unlock();
- return $result;
+ return $value;
}
sub EXISTS {
##
# Check if a single key or element exists given plain key or array index
##
- my $self = _get_self($_[0]);
- my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1];
+ my $self = $_[0]->_get_self;
+ my $key = $_[1];
- if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); }
my $md5 = $DIGEST_FUNC->($key);
##
# Make sure file is open
##
- if (!defined($self->fh)) { $self->open(); }
+ if (!defined($self->fh)) { $self->_open(); }
##
# Request shared lock for reading
##
$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();
##
# Clear all keys from hash, or all elements from array.
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
##
# Make sure file is open
##
- if (!defined($self->fh)) { $self->open(); }
+ if (!defined($self->fh)) { $self->_open(); }
##
# Request exclusive lock for writing
##
$self->lock( LOCK_EX );
- seek($self->fh, $self->base_offset, 0);
- if ($self->fh->eof()) {
+ my $fh = $self->fh;
+
+ seek($fh, $self->base_offset, SEEK_SET);
+ 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
##
+sub put { (shift)->STORE( @_ ) }
+sub store { (shift)->STORE( @_ ) }
+sub get { (shift)->FETCH( @_ ) }
+sub fetch { (shift)->FETCH( @_ ) }
+sub delete { (shift)->DELETE( @_ ) }
+sub exists { (shift)->EXISTS( @_ ) }
+sub clear { (shift)->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__
contains your entire Perl script, as well as the data following the __DATA__
marker. This will not work, because DBM::Deep uses absolute seek()s into the
file. Instead, consider reading *DATA into an IO::Scalar handle, then passing
-in that.
+in that. Also please note optimize() will NOT work when passing in only a
+handle. Pass in a real filename in order to use optimize().
=back
=head1 TIE INTERFACE
With DBM::Deep you can access your databases using Perl's standard hash/array
-syntax. Because all Deep objects are I<tied> to hashes or arrays, you can treat
-them as such. Deep will intercept all reads/writes and direct them to the right
+syntax. Because all DBM::Deep objects are I<tied> to hashes or arrays, you can treat
+them as such. DBM::Deep will intercept all reads/writes and direct them to the right
place -- the DB file. This has nothing to do with the L<TIE CONSTRUCTION>
section above. This simply tells you how to use DBM::Deep using regular hashes
and arrays, rather than calling functions like C<get()> and C<put()> (although those
locking => 1
);
-This causes Deep to C<flock()> the underlying FileHandle object with exclusive
+This causes DBM::Deep to C<flock()> the underlying FileHandle object with exclusive
mode for writes, and shared mode for reads. This is required if you have
multiple processes accessing the same database file, to avoid file corruption.
Please note that C<flock()> does NOT work for files over NFS. See L<DB OVER
$db->unlock();
If you want to implement your own file locking scheme, be sure to create your
-DBM::Deep objects setting the C<volatile> option to true. This hints to Deep
+DBM::Deep objects setting the C<volatile> option to true. This hints to DBM::Deep
that the DB file may change between transactions. See L<LOW-LEVEL ACCESS>
below for more.
=head1 LOW-LEVEL ACCESS
-If you require low-level access to the underlying FileHandle that Deep uses,
+If you require low-level access to the underlying FileHandle that DBM::Deep uses,
you can call the C<fh()> method, which returns the handle:
my $fh = $db->fh();
DBM::Deep by default uses the I<Message Digest 5> (MD5) algorithm for hashing
keys. However you can override this, and use another algorithm (such as SHA-256)
-or even write your own. But please note that Deep currently expects zero
+or even write your own. But please note that DBM::Deep currently expects zero
collisions, so your algorithm has to be I<perfect>, so to speak.
Collision detection may be introduced in a later version.
You can specify a custom digest algorithm by calling the static C<set_digest()>
function, passing a reference to a subroutine, and the length of the algorithm's
-hashes (in bytes). This is a global static function, which affects ALL Deep
+hashes (in bytes). This is a global static function, which affects ALL DBM::Deep
objects. Here is a working example that uses a 256-bit hash from the
I<Digest::SHA256> module. Please see
L<http://search.cpan.org/search?module=Digest::SHA256> for more.
=head2 UNUSED SPACE RECOVERY
-One major caveat with Deep is that space occupied by existing keys and
+One major caveat with DBM::Deep is that space occupied by existing keys and
values is not recovered when they are deleted. Meaning if you keep deleting
and adding new keys, your file will continuously grow. I am working on this,
but in the meantime you can call the built-in C<optimize()> method from time to
B<WARNING:> Only call optimize() on the top-level node of the database, and
-make sure there are no child references lying around. Deep keeps a reference
+make sure there are no child references lying around. DBM::Deep keeps a reference
counter, and if it is greater than 1, optimize() will abort and return undef.
=head2 AUTOVIVIFICATION
=head2 FILE CORRUPTION
-The current level of error handling in Deep is minimal. Files I<are> checked
-for a 32-bit signature on open(), but other corruption in files can cause
-segmentation faults. Deep may try to seek() past the end of a file, or get
+The current level of error handling in DBM::Deep is minimal. Files I<are> checked
+for a 32-bit signature when opened, but other corruption in files can cause
+segmentation faults. DBM::Deep may try to seek() past the end of a file, or get
stuck in an infinite loop depending on the level of corruption. File write
operations are not checked for failure (for speed), so if you happen to run
-out of disk space, Deep will probably fail in a bad way. These things will
+out of disk space, DBM::Deep will probably fail in a bad way. These things will
be addressed in a later version of DBM::Deep.
=head2 DB OVER NFS
-Beware of using DB files over NFS. Deep uses flock(), which works well on local
+Beware of using DB files over NFS. DBM::Deep uses flock(), which works well on local
filesystems, but will NOT protect you from file corruption over NFS. I've heard
about setting up your NFS server with a locking daemon, then using lockf() to
lock your files, but your milage may vary there as well. From what I
understand, there is no real way to do it. However, if you need access to the
-underlying FileHandle in Deep for using some other kind of locking scheme like
+underlying FileHandle in DBM::Deep for using some other kind of locking scheme like
lockf(), see the L<LOW-LEVEL ACCESS> section above.
=head2 COPYING OBJECTS
Beware of copying tied objects in Perl. Very strange things can happen.
-Instead, use Deep's C<clone()> method which safely copies the object and
+Instead, use DBM::Deep's C<clone()> method which safely copies the object and
returns a new, blessed, tied hash or array to the same level in the DB.
my $copy = $db->clone();
One of the great things about DBM::Deep is that it uses very little memory.
Even with huge databases (1,000,000+ keys) you will not see much increased
-memory on your process. Deep relies solely on the filesystem for storing
+memory on your process. DBM::Deep relies solely on the filesystem for storing
and fetching data. Here is output from I</usr/bin/top> before even opening a
database handle:
DBM::Deep files always start with a 32-bit signature to identify the file type.
This is at offset 0. The signature is "DPDB" in network byte order. This is
-checked upon each file open().
+checked when the file is opened.
=head2 TAG
so it's pretty much undefined how the keys will come out -- just like Perl's
built-in hashes.
-=head1 AUTHOR
+=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 93.7 82.5 71.9 96.5 25.9 82.8 87.9
+blib/lib/DBM/Deep/Array.pm 98.8 88.0 90.9 100.0 n/a 12.8 96.3
+blib/lib/DBM/Deep/Hash.pm 95.2 80.0 100.0 100.0 n/a 4.4 92.3
+Total 94.8 83.2 76.5 97.6 25.9 100.0 89.7
+---------------------------- ------ ------ ------ ------ ------ ------ ------
+
+=head1 AUTHORS
Joseph Huckaby, L<jhuckaby@cpan.org>
+Rob Kinyon, L<rkinyon@cpan.org>
Special thanks to Adam Sah and Rich Gaushell! You know why :-)
=head1 LICENSE
-Copyright (c) 2002-2005 Joseph Huckaby. All Rights Reserved.
+Copyright (c) 2002-2006 Joseph Huckaby. All Rights Reserved.
This is free software, you may use it and distribute it under the
same terms as Perl itself.
projects / dbsrgits/DBM-Deep.git / blobdiff