Converted to use _get_args() to make all new/tie argument handling the same

[dbsrgits/DBM-Deep.git] / lib / DBM / Deep.pm

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 349633d..bb73250 100644 (file)
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -104,6 +104,29 @@ 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 {
        ##
        # Class constructor method for Perl OO interface.
@@ -111,9 +134,7 @@ 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.
@@ -284,6 +305,7 @@ sub _close {
        ##
     my $self = $_[0]->_get_self;
     close $self->root->{fh};
+    $self->root->{fh} = undef;
 }
 
 sub _create_tag {
@@ -894,6 +916,8 @@ sub lock {
        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}++;
@@ -910,6 +934,8 @@ sub unlock {
        # 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}--;
@@ -1168,14 +1194,19 @@ sub _throw_error {
     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 {
@@ -1245,9 +1276,6 @@ sub STORE {
         ? $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);
        
        ##
@@ -1309,14 +1337,6 @@ sub STORE {
        ##
        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;
@@ -1326,27 +1346,16 @@ sub FETCH {
        ##
        # 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
        ##
@@ -1366,7 +1375,9 @@ sub FETCH {
        $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 {
@@ -1374,7 +1385,7 @@ sub DELETE {
        # Delete single key/value pair or element 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];
        
        my $unpacked_key = $key;
        if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); }
@@ -1420,9 +1431,8 @@ 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);
 
        ##
@@ -1489,11 +1499,13 @@ sub CLEAR {
 ##
 # 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;