use Scalar::Util ();
use vars qw( $VERSION );
-$VERSION = q(0.96);
+$VERSION = q(0.97);
##
# Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file.
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.
# 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.
return $self->_throw_error("Signature not found -- file is not a Deep DB");
}
- $self->root->{end} = (stat($fh))[7];
+ my @stats = stat($fh);
+ $self->root->{inode} = $stats[1];
+ $self->root->{end} = $stats[7];
##
# Get our type from master index signature
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;
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;
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
+ # 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];
return;
}
##
-
- my $fh = $self->fh;
##
# Request exclusive lock for writing
##
$self->lock( LOCK_EX );
+
+ my $fh = $self->fh;
##
# If locking is enabled, set 'end' parameter again, in case another
$self->unlock();
#XXX What is ref() checking here?
+ #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;
# 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); }
my $md5 = $DIGEST_FUNC->($key);
##
##
# Delete bucket
##
- my $value = $self->FETCH( $unpacked_key );
+ 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();
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 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.
+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.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
- ---------------------------- ------ ------ ------ ------ ------ ------ ------
+---------------------------- ------ ------ ------ ------ ------ ------ ------
+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 AUTHOR
+=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