From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Mon, 20 Feb 2006 03:55:19 +0000 (+0000)
Subject: Fixed the pseudohash bug and tested against 5.9.3
X-Git-Tag: 0-97~37
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2ac020421a5a06ac144cfe6650ff0a2738c74448;p=dbsrgits%2FDBM-Deep.git
Fixed the pseudohash bug and tested against 5.9.3
---
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 8260a48..797a2b4 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -102,7 +102,6 @@ sub SIG_SIZE () { 1 }
sub TYPE_HASH () { return SIG_HASH; }
sub TYPE_ARRAY () { return SIG_ARRAY; }
-sub _get_self { $_[0] }
sub new {
##
# Class constructor method for Perl OO interface.
@@ -141,6 +140,7 @@ sub new {
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),
@@ -184,7 +184,7 @@ sub _open {
# Open a FileHandle to the database, create if nonexistent.
# Make sure file signature matches DeepDB spec.
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
if (defined($self->fh)) { $self->_close(); }
@@ -284,7 +284,7 @@ sub _close {
##
# Close database FileHandle
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
close $self->root->{fh};
}
@@ -869,7 +869,7 @@ sub _get_next_key {
##
# Locate next key, given digested previous one
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
$self->{prev_md5} = $_[1] ? $_[1] : undef;
$self->{return_next} = 0;
@@ -892,7 +892,7 @@ sub lock {
# times before unlock(), then the same number of unlocks() must
# be called before the lock is released.
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $type = $_[1];
$type = LOCK_EX unless defined $type;
@@ -911,7 +911,7 @@ sub unlock {
# If db locking is set, unlock the db file. See note in lock()
# regarding calling lock() multiple times.
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
if ($self->root->{locking} && $self->root->{locked} > 0) {
$self->root->{locked}--;
@@ -929,7 +929,7 @@ sub _copy_node {
# Copy single level of keys or elements to new DB handle.
# Recurse for nested structures
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $db_temp = $_[1];
if ($self->type eq TYPE_HASH) {
@@ -967,7 +967,7 @@ sub export {
##
# Recursively export into standard Perl hashes and arrays.
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $temp;
if ($self->type eq TYPE_HASH) { $temp = {}; }
@@ -987,7 +987,7 @@ sub import {
#XXX This use of ref() seems to be ok
if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $struct = $_[1];
#XXX This use of ref() seems to be ok
@@ -1020,7 +1020,7 @@ sub optimize {
# Rebuild entire database into new file, then move
# it back on top of original.
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
#XXX Need to create a new test for this
# if ($self->root->{links} > 1) {
@@ -1078,7 +1078,7 @@ sub clone {
##
# Make copy of object and return
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
return DBM::Deep->new(
type => $self->type,
@@ -1099,7 +1099,7 @@ sub clone {
##
# Setup filter function for storing or fetching the key or value
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $type = lc $_[1];
my $func = $_[2] ? $_[2] : undef;
@@ -1120,7 +1120,7 @@ sub root {
##
# Get access to the root structure
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
return $self->{root};
}
@@ -1129,7 +1129,7 @@ sub fh {
# Get access to the raw FileHandle
##
#XXX It will be useful, though, when we split out HASH and ARRAY
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
return $self->root->{fh};
}
@@ -1137,7 +1137,7 @@ sub type {
##
# Get type of current node (TYPE_HASH or TYPE_ARRAY)
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
return $self->{type};
}
@@ -1145,7 +1145,7 @@ sub base_offset {
##
# Get base_offset of current node (TYPE_HASH or TYPE_ARRAY)
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
return $self->{base_offset};
}
@@ -1167,7 +1167,7 @@ sub _throw_error {
##
# Store error string in self
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $error_text = $_[1];
$self->root->{error} = $error_text;
@@ -1184,7 +1184,7 @@ sub clear_error {
##
# Clear error state
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
undef $self->root->{error};
}
@@ -1237,7 +1237,7 @@ sub STORE {
##
# Store single hash key/value or array element in database.
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
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
@@ -1324,7 +1324,7 @@ sub FETCH {
##
# Fetch single value or element given plain key or array index
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $key = $_[1];
if ( $self->type eq TYPE_HASH ) {
@@ -1371,7 +1371,7 @@ sub DELETE {
##
# Delete single key/value pair or element given plain key or array index
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ 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 $unpacked_key = $key;
@@ -1416,7 +1416,7 @@ sub EXISTS {
##
# Check if a single key or element exists given plain key or array index
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1];
if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); }
@@ -1456,7 +1456,7 @@ sub CLEAR {
##
# Clear all keys from hash, or all elements from array.
##
- my $self = $_[0]->_get_self;#_get_self($_[0]);
+ my $self = $_[0]->_get_self;
##
# Make sure file is open
@@ -2664,10 +2664,10 @@ 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
+ blib/lib/DBM/Deep.pm 93.9 82.4 74.7 97.9 10.5 85.7 88.0
+ blib/lib/DBM/Deep/Array.pm 97.8 84.6 50.0 100.0 n/a 9.0 94.6
+ blib/lib/DBM/Deep/Hash.pm 93.9 87.5 100.0 100.0 n/a 5.3 93.4
+ Total 94.4 82.9 75.8 98.5 10.5 100.0 89.0
---------------------------- ------ ------ ------ ------ ------ ------ ------
=head1 AUTHOR
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index c15adfa..9f11127 100644
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -32,7 +32,7 @@ sub FETCHSIZE {
##
# Return the length of the array
##
- my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $SAVE_FILTER = $self->root->{filter_fetch_value};
$self->root->{filter_fetch_value} = undef;
@@ -49,7 +49,7 @@ sub STORESIZE {
##
# Set the length of the array
##
- my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $new_length = $_[1];
my $SAVE_FILTER = $self->root->{filter_store_value};
@@ -66,7 +66,7 @@ sub POP {
##
# Remove and return the last element on the array
##
- my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $length = $self->FETCHSIZE();
if ($length) {
@@ -83,7 +83,7 @@ sub PUSH {
##
# Add new element(s) to the end of the array
##
- my $self = (shift(@_))->_get_self;#DBM::Deep::_get_self(shift);
+ my $self = shift->_get_self;
my $length = $self->FETCHSIZE();
while (my $content = shift @_) {
@@ -97,7 +97,7 @@ sub SHIFT {
# Remove and return first element on the array.
# Shift over remaining elements to take up space.
##
- my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $length = $self->FETCHSIZE();
if ($length) {
@@ -123,7 +123,7 @@ sub UNSHIFT {
# Insert new element(s) at beginning of array.
# Shift over other elements to make space.
##
- my $self = $_[0]->_get_self;shift;#DBM::Deep::_get_self($_[0]);shift @_;
+ my $self = shift->_get_self;
my @new_elements = @_;
my $length = $self->FETCHSIZE();
my $new_size = scalar @new_elements;
@@ -144,7 +144,7 @@ sub SPLICE {
# Splices section of array with optional new section.
# Returns deleted section, or last element deleted in scalar context.
##
- my $self = $_[0]->_get_self;shift;#DBM::Deep::_get_self($_[0]);shift @_;
+ my $self = shift->_get_self;
my $length = $self->FETCHSIZE();
##
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index eeeffab..30f4e90 100644
--- a/lib/DBM/Deep/Hash.pm
+++ b/lib/DBM/Deep/Hash.pm
@@ -5,7 +5,7 @@ use strict;
use base 'DBM::Deep';
sub _get_self {
- tied( %{$_[0]} ) || $_[0]
+ eval { tied( %{$_[0]} ) } || $_[0]
}
sub TIEHASH {
@@ -28,7 +28,7 @@ sub FIRSTKEY {
##
# Locate and return first key (in no particular order)
##
- my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]);
+ my $self = $_[0]->_get_self;
##
# Make sure file is open
@@ -53,7 +53,7 @@ sub NEXTKEY {
##
# Return next key (in no particular order), given previous one
##
- my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]);
+ my $self = $_[0]->_get_self;
my $prev_key = ($self->root->{filter_store_key})
? $self->root->{filter_store_key}->($_[1])