use strict;
-use FileHandle;
use Fcntl qw/:flock/;
use Digest::MD5 ();
use Scalar::Util ();
##
#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;
##
##
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;
}
my $self = {
type => TYPE_HASH,
base_offset => length(SIG_FILE),
- root => {
- file => undef,
- fh => undef,
- end => 0,
- links => 0,
- autoflush => undef,
- locking => undef,
- volatile => undef,
- debug => undef,
- mode => 'r+',
- filter_store_key => undef,
- filter_store_value => undef,
- filter_fetch_key => undef,
- filter_fetch_value => undef,
- autobless => undef,
- locked => 0,
- %$args,
- },
};
bless $self, $class;
foreach my $outer_parm ( @outer_params ) {
next unless exists $args->{$outer_parm};
- $self->{$outer_parm} = $args->{$outer_parm}
+ $self->{$outer_parm} = delete $args->{$outer_parm}
}
- if ( exists $args->{root} ) {
- $self->{root} = $args->{root};
- }
- else {
- # This is cleanup based on the fact that the $args
- # coming in is for both the root and non-root items
- delete $self->root->{$_} for @outer_params;
- }
- $self->root->{links}++;
+ $self->{root} = exists $args->{root}
+ ? $args->{root}
+ : DBM::Deep::_::Root->new( $args );
if (!defined($self->fh)) { $self->_open(); }
}
}
-sub _get_self { tied( %{$_[0]} ) || $_[0] }
+sub _get_self {
+ tied( %{$_[0]} ) || $_[0]
+}
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( @_ );
}
-sub DESTROY {
- ##
- # Class deconstructor. Close file handle if there are no more refs.
- ##
- my $self = _get_self($_[0]);
- return unless $self;
-
- $self->root->{links}--;
-
- if (!$self->root->{links}) {
- $self->_close();
- }
-}
+#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.
if (defined($self->fh)) { $self->_close(); }
-# eval {
- if (!(-e $self->root->{file}) && $self->root->{mode} eq 'r+') {
- my $temp = FileHandle->new( $self->root->{file}, 'w' );
+ eval {
+ my $filename = $self->root->{file};
+ my $mode = $translate_mode{ $self->root->{mode} };
+
+ if (!(-e $filename) && $mode eq '+<') {
+ open( FH, '>', $filename );
+ close FH;
}
- #XXX Convert to set_fh()
- $self->root->{fh} = FileHandle->new( $self->root->{file}, $self->root->{mode} );
-# }; if ($@ ) { $self->_throw_error( "Received error: $@\n" ); }
+ my $fh;
+ open( $fh, $mode, $filename )
+ 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} . ": $!");
}
binmode $fh; # for win32
if ($self->root->{autoflush}) {
-# $self->fh->autoflush();
- my $old = select( $fh );
- $|++;
+ my $old = select $fh;
+ $|=1;
select $old;
}
##
if (!$bytes_read) {
seek($fh, 0, 0);
- $fh->print(SIG_FILE);
+ print($fh SIG_FILE);
$self->root->{end} = length(SIG_FILE);
$self->_create_tag($self->base_offset, $self->type, chr(0) x $INDEX_SIZE);
my $plain_key = "[base]";
- $fh->print( pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
+ print($fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
$self->root->{end} += $DATA_LENGTH_SIZE + length($plain_key);
-# $fh->flush();
+ # Flush the filehandle
my $old_fh = select $fh;
- local $| = 1;
- print $fh q{};
+ my $old_af = $|;
+ $| = 1;
+ $| = $old_af;
select $old_fh;
return 1;
# Get our type from master index signature
##
my $tag = $self->_load_tag($self->base_offset);
+
#XXX We probably also want to store the hash algorithm name and not assume anything
+
if (!$tag) {
return $self->_throw_error("Corrupted file, no master index record");
}
# Close database FileHandle
##
my $self = _get_self($_[0]);
- undef $self->root->{fh};
+ close $self->root->{fh};
}
sub _create_tag {
my $fh = $self->fh;
seek($fh, $offset, 0);
- $fh->print( $sig . pack($DATA_LENGTH_PACK, $size) . $content );
+ print($fh $sig . pack($DATA_LENGTH_PACK, $size) . $content );
if ($offset == $self->root->{end}) {
$self->root->{end} += SIG_SIZE + $DATA_LENGTH_SIZE + $size;
: $self->root->{end};
seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
- $fh->print( $md5 . pack($LONG_PACK, $location) );
+ print($fh $md5 . pack($LONG_PACK, $location) );
last;
}
elsif ($md5 eq $key) {
if ($internal_ref) {
$location = $value->base_offset;
seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
- $fh->print( $md5 . pack($LONG_PACK, $location) );
+ print($fh $md5 . pack($LONG_PACK, $location) );
}
else {
seek($fh, $subloc + SIG_SIZE, 0);
else {
$location = $self->root->{end};
seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE, 0);
- $fh->print( pack($LONG_PACK, $location) );
+ print($fh pack($LONG_PACK, $location) );
}
}
last;
##
if (!$location) {
seek($fh, $tag->{ref_loc}, 0);
- $fh->print( pack($LONG_PACK, $self->root->{end}) );
+ print($fh pack($LONG_PACK, $self->root->{end}) );
my $index_tag = $self->_create_tag($self->root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE);
my @offsets = ();
my $subloc = unpack($LONG_PACK, substr($subkeys, ($k * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
if (!$subloc) {
seek($fh, $offset + ($k * $BUCKET_SIZE), 0);
- $fh->print( $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
+ print($fh $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
last;
}
} # k loop
else {
$offsets[$num] = $self->root->{end};
seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE), 0);
- $fh->print( pack($LONG_PACK, $self->root->{end}) );
+ 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);
- $fh->print( $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
+ print($fh $key . pack($LONG_PACK, $old_subloc || $self->root->{end}) );
}
} # key is real
} # i loop
##
my $r = Scalar::Util::reftype($value) || '';
if ($r eq 'HASH') {
- $fh->print( TYPE_HASH );
- $fh->print( pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
+ print($fh TYPE_HASH );
+ print($fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
$content_length = $INDEX_SIZE;
}
elsif ($r eq 'ARRAY') {
- $fh->print( TYPE_ARRAY );
- $fh->print( pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
+ print($fh TYPE_ARRAY );
+ print($fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
$content_length = $INDEX_SIZE;
}
elsif (!defined($value)) {
- $fh->print( SIG_NULL );
- $fh->print( pack($DATA_LENGTH_PACK, 0) );
+ print($fh SIG_NULL );
+ print($fh pack($DATA_LENGTH_PACK, 0) );
$content_length = 0;
}
else {
- $fh->print( SIG_DATA );
- $fh->print( pack($DATA_LENGTH_PACK, length($value)) . $value );
+ print($fh SIG_DATA );
+ print($fh pack($DATA_LENGTH_PACK, length($value)) . $value );
$content_length = length($value);
}
##
# Plain key is stored AFTER value, as keys are typically fetched less often.
##
- $fh->print( pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
+ print($fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
##
# If value is blessed, preserve class name
##
# Blessed ref -- will restore later
##
- $fh->print( chr(1) );
- $fh->print( pack($DATA_LENGTH_PACK, length($value_class)) . $value_class );
+ print($fh chr(1) );
+ print($fh pack($DATA_LENGTH_PACK, length($value_class)) . $value_class );
$content_length += 1;
$content_length += $DATA_LENGTH_SIZE + length($value_class);
}
else {
- $fh->print( chr(0) );
+ print($fh chr(0) );
$content_length += 1;
}
}
root => $self->root,
);
foreach my $key (keys %{$value}) {
- $branch->{$key} = $value->{$key};
+ #$branch->{$key} = $value->{$key};
+ $branch->STORE( $key, $value->{$key} );
}
}
elsif ($r eq 'ARRAY') {
);
my $index = 0;
foreach my $element (@{$value}) {
- $branch->[$index] = $element;
+ #$branch->[$index] = $element;
+ $branch->STORE( $index, $element );
$index++;
}
}
# Matched key -- delete bucket and return
##
seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), 0);
- $fh->print( substr($keys, ($i+1) * $BUCKET_SIZE ) );
- $fh->print( chr(0) x $BUCKET_SIZE );
+ print($fh substr($keys, ($i+1) * $BUCKET_SIZE ) );
+ print($fh chr(0) x $BUCKET_SIZE );
return 1;
} # i loop
if ($self->root->{locking}) {
if (!$self->root->{locked}) { flock($self->fh, $type); }
$self->root->{locked}++;
+
+ return 1;
}
+
+ return;
}
sub unlock {
if ($self->root->{locking} && $self->root->{locked} > 0) {
$self->root->{locked}--;
if (!$self->root->{locked}) { flock($self->fh, LOCK_UN); }
+
+ return 1;
}
+
+ return;
}
#XXX These uses of ref() need verified
# it back on top of original.
##
my $self = _get_self($_[0]);
- if ($self->root->{links} > 1) {
- return $self->_throw_error("Cannot optimize: reference count is greater than 1");
- }
+
+#XXX Need to create a new test for this
+# if ($self->root->{links} > 1) {
+# return $self->_throw_error("Cannot optimize: reference count is greater than 1");
+# }
my $db_temp = DBM::Deep->new(
file => $self->root->{file} . '.tmp',
if (!defined($self->fh) && !$self->_open()) {
return;
}
+ ##
my $fh = $self->fh;
if (!$new_tag) {
my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
seek($fh, $ref_loc, 0);
- $fh->print( pack($LONG_PACK, $self->root->{end}) );
+ print($fh pack($LONG_PACK, $self->root->{end}) );
$tag = $self->_create_tag($self->root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
$tag->{ref_loc} = $ref_loc;
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
+# Public method aliases
##
+*put = *store = *STORE;
+*get = *fetch = *FETCH;
+*delete = *DELETE;
+*exists = *EXISTS;
+*clear = *CLEAR;
-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;
- }
-}
+package DBM::Deep::_::Root;
-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 new {
+ my $class = shift;
+ my ($args) = @_;
+
+ my $self = bless {
+ file => undef,
+ fh => undef,
+ end => 0,
+ autoflush => undef,
+ locking => undef,
+ volatile => undef,
+ debug => undef,
+ mode => 'r+',
+ filter_store_key => undef,
+ filter_store_value => undef,
+ filter_fetch_key => undef,
+ filter_fetch_value => undef,
+ autobless => undef,
+ locked => 0,
+ %$args,
+ }, $class;
+
+ return $self;
}
-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 DESTROY {
+ my $self = shift;
+ return unless $self;
-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] );
- }
-}
+ close $self->{fh} if $self->{fh};
-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];
+ return;
}
-#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;
-
1;
__END__
---------------------------- ------ ------ ------ ------ ------ ------ ------
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 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
---------------------------- ------ ------ ------ ------ ------ ------ ------
=head1 AUTHOR
projects / dbsrgits/DBM-Deep.git / blobdiff