use Scalar::Util ();
use vars qw( $VERSION );
-$VERSION = "0.96";
+$VERSION = q(0.96);
##
# Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file.
##
# 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 new {
##
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;
-
- # These are the defaults to be optionally overridden below
- my $self = {
- type => TYPE_HASH,
- base_offset => length(SIG_FILE),
- };
+sub _init {
+ ##
+ # Setup $self and bless into this class.
+ ##
+ my $class = shift;
+ my $args = shift;
- bless $self, $class;
+ # These are the defaults to be optionally overridden below
+ my $self = bless {
+ type => TYPE_HASH,
+ base_offset => length(SIG_FILE),
+ }, $class;
- foreach my $outer_parm ( @outer_params ) {
- next unless exists $args->{$outer_parm};
- $self->{$outer_parm} = delete $args->{$outer_parm}
- }
-
- $self->{root} = exists $args->{root}
- ? $args->{root}
- : DBM::Deep::_::Root->new( $args );
+ 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 );
- if (!defined($self->fh)) { $self->_open(); }
+ if (!defined($self->fh)) { $self->_open(); }
- return $self;
- }
+ return $self;
}
sub TIEHASH {
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");
##
my $self = $_[0]->_get_self;
close $self->root->{fh};
+ $self->root->{fh} = undef;
}
sub _create_tag {
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); }
$self->root->{locked}++;
# regarding calling lock() multiple times.
##
my $self = $_[0]->_get_self;
+
+ if (!defined($self->fh)) { return; }
if ($self->root->{locking} && $self->root->{locked} > 0) {
$self->root->{locked}--;
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 {
# Store single hash key/value or array element in database.
##
my $self = $_[0]->_get_self;
- my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1];
+ my $key = $_[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 $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);
##
##
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 );
- }
-
$self->unlock();
return $result;
##
# Fetch single value or element given plain key or array index
##
- my $self = $_[0]->_get_self;
-
- 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(); }
+ my $md5 = $DIGEST_FUNC->($key);
+
##
# Request shared lock for reading
##
$self->unlock();
#XXX What is ref() checking here?
- return ($result && !ref($result) && $self->root->{filter_fetch_value}) ? $self->root->{filter_fetch_value}->($result) : $result;
+ return ($result && !ref($result) && $self->root->{filter_fetch_value})
+ ? $self->root->{filter_fetch_value}->($result)
+ : $result;
}
sub DELETE {
##
# Delete bucket
##
+ my $value = $self->FETCH( $unpacked_key );
my $result = $self->_delete_bucket( $tag, $md5 );
##
$self->unlock();
- return $result;
+ return $value;
}
sub EXISTS {
# Check if a single key or element exists given plain key or array index
##
my $self = $_[0]->_get_self;
- my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1];
+ my $key = $_[1];
- if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); }
my $md5 = $DIGEST_FUNC->($key);
##
##
# Public method aliases
##
-*put = *store = *STORE;
-*get = *fetch = *FETCH;
-*delete = *DELETE;
-*exists = *EXISTS;
-*clear = *CLEAR;
+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( @_ ) }
package DBM::Deep::_::Root;
projects / dbsrgits/DBM-Deep.git / blobdiff