use strict;
-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.96);
##
# 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),
- };
-
- bless $self, $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 );
+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(); }
+
+ return $self;
}
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 }; }
-
- $args->{type} = TYPE_HASH;
-
- 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 }; }
-
- $args->{type} = TYPE_ARRAY;
-
- return $class->_init($args);
+ shift;
+ require DBM::Deep::Array;
+ return DBM::Deep::Array->TIEARRAY( @_ );
}
#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.
# Make sure file signature matches DeepDB spec.
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
if (defined($self->fh)) { $self->_close(); }
eval {
- my $filename = $self->root->{file};
- my $mode = $translate_mode{ $self->root->{mode} };
-
- if (!(-e $filename) && $mode eq '+<') {
- open( FH, '>', $filename );
- close FH;
+ # 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;
}
my $fh;
- open( $fh, $mode, $filename )
+ 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} . ": $!");
}
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}) {
select $old;
}
+ # Set the
+ seek($fh, 0, SEEK_SET);
+
my $signature;
- 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($fh, 0, 0);
+ 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);
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");
##
# Close database FileHandle
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
close $self->root->{fh};
+ $self->root->{fh} = undef;
}
sub _create_tag {
my $fh = $self->fh;
- seek($fh, $offset, 0);
+ seek($fh, $offset, SEEK_SET);
print($fh $sig . pack($DATA_LENGTH_PACK, $size) . $content );
if ($offset == $self->root->{end}) {
my $fh = $self->fh;
- seek($fh, $offset, 0);
+ seek($fh, $offset, SEEK_SET);
if (eof $fh) { return undef; }
my $sig;
? $value->base_offset
: $self->root->{end};
- seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), SEEK_SET);
print($fh $md5 . pack($LONG_PACK, $location) );
last;
}
if ($internal_ref) {
$location = $value->base_offset;
- seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), SEEK_SET);
print($fh $md5 . pack($LONG_PACK, $location) );
}
else {
- seek($fh, $subloc + SIG_SIZE, 0);
+ seek($fh, $subloc + SIG_SIZE, SEEK_SET);
my $size;
read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
}
else {
$location = $self->root->{end};
- seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE, 0);
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE, SEEK_SET);
print($fh pack($LONG_PACK, $location) );
}
}
# If bucket didn't fit into list, split into a new index level
##
if (!$location) {
- seek($fh, $tag->{ref_loc}, 0);
+ 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);
if ($offsets[$num]) {
my $offset = $offsets[$num] + SIG_SIZE + $DATA_LENGTH_SIZE;
- seek($fh, $offset, 0);
+ seek($fh, $offset, SEEK_SET);
my $subkeys;
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($fh, $offset + ($k * $BUCKET_SIZE), 0);
+ seek($fh, $offset + ($k * $BUCKET_SIZE), SEEK_SET);
print($fh $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
last;
}
}
else {
$offsets[$num] = $self->root->{end};
- seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE), 0);
+ 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);
- seek($fh, $blist_tag->{offset}, 0);
+ seek($fh, $blist_tag->{offset}, SEEK_SET);
print($fh $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
}
} # key is real
##
if ($location) {
my $content_length;
- seek($fh, $location, 0);
+ seek($fh, $location, SEEK_SET);
##
# Write signature based on content type, set content length and write actual value.
# Found match -- seek to offset and read signature
##
my $signature;
- seek($fh, $subloc, 0);
+ seek($fh, $subloc, SEEK_SET);
read( $fh, $signature, SIG_SIZE);
##
# Skip over value and plain key to see if object needs
# to be re-blessed
##
- seek($fh, $DATA_LENGTH_SIZE + $INDEX_SIZE, 1);
+ seek($fh, $DATA_LENGTH_SIZE + $INDEX_SIZE, SEEK_CUR);
my $size;
read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { seek($fh, $size, 1); }
+ if ($size) { seek($fh, $size, SEEK_CUR); }
my $bless_bit;
read( $fh, $bless_bit, 1);
##
# Matched key -- delete bucket and return
##
- seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), SEEK_SET);
print($fh substr($keys, ($i+1) * $BUCKET_SIZE ) );
print($fh chr(0) x $BUCKET_SIZE );
##
# Seek to bucket location and skip over signature
##
- seek($fh, $subloc + SIG_SIZE, 0);
+ seek($fh, $subloc + SIG_SIZE, SEEK_SET);
##
# Skip over value to get to plain key
##
my $size;
read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
- if ($size) { seek($fh, $size, 1); }
+ if ($size) { seek($fh, $size, SEEK_CUR); }
##
# Read in plain key and return as scalar
##
# 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;
# 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); }
$self->root->{locked}++;
# 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}--;
# 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) {
##
# 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 = {}; }
#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
# Rebuild entire database into new file, then move
# it back on top of original.
##
- my $self = _get_self($_[0]);
+ my $self = $_[0]->_get_self;
#XXX Need to create a new test for this
# if ($self->root->{links} > 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 )
: $@;
}
##
# 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];
+ my $self = $_[0]->_get_self;
+ 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 $new_tag = $self->_index_lookup($tag, $num);
if (!$new_tag) {
my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
- seek($fh, $ref_loc, 0);
+ 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);
##
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 = _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(); }
+ 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 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); }
##
# 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 = _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);
##
##
# 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
my $fh = $self->fh;
- seek($fh, $self->base_offset, 0);
+ seek($fh, $self->base_offset, SEEK_SET);
if (eof $fh) {
$self->unlock();
return;
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
-##
-
-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;
-}
-
-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 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 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] );
- }
-}
-
-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];
-}
-
-#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;
+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;
---------------------------- ------ ------ ------ ------ ------ ------ ------
File stmt bran cond sub pod time total
---------------------------- ------ ------ ------ ------ ------ ------ ------
- blib/lib/DBM/Deep.pm 94.9 84.5 77.8 100.0 11.1 100.0 89.7
- Total 94.9 84.5 77.8 100.0 11.1 100.0 89.7
+ 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
projects / dbsrgits/DBM-Deep.git / blobdiff