# print "This module " . $db->{my_complex}->[1]->{perl} . "!\n";
#
# Copyright:
-# (c) 2002-2005 Joseph Huckaby. All Rights Reserved.
+# (c) 2002-2006 Joseph Huckaby. All Rights Reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
##
select $old;
}
- # Set the
- seek($fh, 0, SEEK_SET);
+ seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET);
my $signature;
my $bytes_read = read( $fh, $signature, length(SIG_FILE));
# File is empty -- write signature and master index
##
if (!$bytes_read) {
- seek($fh, 0, SEEK_SET);
- print($fh SIG_FILE);
+ seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET);
+ print( $fh SIG_FILE);
$self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE);
my $plain_key = "[base]";
- print($fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
+ print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
# Flush the filehandle
my $old_fh = select $fh;
- my $old_af = $|;
- $| = 1;
- $| = $old_af;
+ my $old_af = $|; $| = 1; $| = $old_af;
select $old_fh;
my @stats = stat($fh);
my $fh = $self->_fh;
- seek($fh, $offset, SEEK_SET);
- print($fh $sig . pack($DATA_LENGTH_PACK, $size) . $content );
+ seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET);
+ print( $fh $sig . pack($DATA_LENGTH_PACK, $size) . $content );
if ($offset == $self->_root->{end}) {
$self->_root->{end} += SIG_SIZE + $DATA_LENGTH_SIZE + $size;
my $fh = $self->_fh;
- seek($fh, $offset, SEEK_SET);
+ seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET);
if (eof $fh) { return undef; }
- my $sig;
- read( $fh, $sig, SIG_SIZE);
-
- my $size;
- read( $fh, $size, $DATA_LENGTH_SIZE);
- $size = unpack($DATA_LENGTH_PACK, $size);
+ my $b;
+ read( $fh, $b, SIG_SIZE + $DATA_LENGTH_SIZE );
+ my ($sig, $size) = unpack( "A $DATA_LENGTH_PACK", $b );
my $buffer;
read( $fh, $buffer, $size);
my $location = 0;
my $result = 2;
- # added ref() check first to avoid eval and runtime exception for every
- # scalar value being stored. performance tweak.
+ my $root = $self->_root;
+
my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep' ) };
-
- my $internal_ref = $is_dbm_deep && ($value->_root eq $self->_root);
+ my $internal_ref = $is_dbm_deep && ($value->_root eq $root);
my $fh = $self->_fh;
# Iterate through buckets, seeing if this is a new entry or a replace.
##
for (my $i=0; $i<$MAX_BUCKETS; $i++) {
- my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
if (!$subloc) {
##
$location = $internal_ref
? $value->_base_offset
- : $self->_root->{end};
+ : $root->{end};
- seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), SEEK_SET);
- print($fh $md5 . pack($LONG_PACK, $location) );
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
+ print( $fh $md5 . pack($LONG_PACK, $location) );
last;
}
- elsif ($md5 eq $key) {
+
+ my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
+ if ($md5 eq $key) {
##
# Found existing bucket with same key. Replace with new value.
##
if ($internal_ref) {
$location = $value->_base_offset;
- seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE), SEEK_SET);
- print($fh $md5 . pack($LONG_PACK, $location) );
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
+ print( $fh $md5 . pack($LONG_PACK, $location) );
+ return $result;
}
- else {
- seek($fh, $subloc + SIG_SIZE, SEEK_SET);
- my $size;
- read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
-
- ##
- # If value is a hash, array, or raw value with equal or less size, we can
- # reuse the same content area of the database. Otherwise, we have to create
- # a new content area at the EOF.
- ##
- my $actual_length;
- my $r = Scalar::Util::reftype( $value ) || '';
- if ( $r eq 'HASH' || $r eq 'ARRAY' ) {
- $actual_length = $INDEX_SIZE;
-
- # if autobless is enabled, must also take into consideration
- # the class name, as it is stored along with key/value.
- if ( $self->_root->{autobless} ) {
- my $value_class = Scalar::Util::blessed($value);
- if ( defined $value_class && $value_class ne 'DBM::Deep' ) {
- $actual_length += length($value_class);
- }
- } # autobless
+
+ seek($fh, $subloc + SIG_SIZE + $root->{file_offset}, SEEK_SET);
+ my $size;
+ read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+
+ ##
+ # If value is a hash, array, or raw value with equal or less size, we can
+ # reuse the same content area of the database. Otherwise, we have to create
+ # a new content area at the EOF.
+ ##
+ my $actual_length;
+ my $r = Scalar::Util::reftype( $value ) || '';
+ if ( $r eq 'HASH' || $r eq 'ARRAY' ) {
+ $actual_length = $INDEX_SIZE;
+
+ # if autobless is enabled, must also take into consideration
+ # the class name, as it is stored along with key/value.
+ if ( $root->{autobless} ) {
+ my $value_class = Scalar::Util::blessed($value);
+ if ( defined $value_class && !$value->isa('DBM::Deep') ) {
+ $actual_length += length($value_class);
+ }
}
- else { $actual_length = length($value); }
-
- if ($actual_length <= $size) {
- $location = $subloc;
- }
- else {
- $location = $self->_root->{end};
- seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE, SEEK_SET);
- print($fh pack($LONG_PACK, $location) );
- }
- }
+ }
+ else { $actual_length = length($value); }
+
+ if ($actual_length <= $size) {
+ $location = $subloc;
+ }
+ else {
+ $location = $root->{end};
+ seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE + $root->{file_offset}, SEEK_SET);
+ print( $fh pack($LONG_PACK, $location) );
+ }
+
last;
}
- } # i loop
+ }
##
# If this is an internal reference, return now.
# If bucket didn't fit into list, split into a new index level
##
if (!$location) {
- seek($fh, $tag->{ref_loc}, SEEK_SET);
- print($fh pack($LONG_PACK, $self->_root->{end}) );
+ seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET);
+ print( $fh pack($LONG_PACK, $root->{end}) );
- my $index_tag = $self->_create_tag($self->_root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE);
+ my $index_tag = $self->_create_tag($root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE);
my @offsets = ();
$keys .= $md5 . pack($LONG_PACK, 0);
if ($offsets[$num]) {
my $offset = $offsets[$num] + SIG_SIZE + $DATA_LENGTH_SIZE;
- seek($fh, $offset, SEEK_SET);
+ seek($fh, $offset + $root->{file_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), SEEK_SET);
- print($fh $key . pack($LONG_PACK, $old_subloc || $self->_root->{end}) );
+ seek($fh, $offset + ($k * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
+ print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) );
last;
}
} # k loop
}
else {
- $offsets[$num] = $self->_root->{end};
- seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE), SEEK_SET);
- print($fh pack($LONG_PACK, $self->_root->{end}) );
+ $offsets[$num] = $root->{end};
+ seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE) + $root->{file_offset}, SEEK_SET);
+ print( $fh pack($LONG_PACK, $root->{end}) );
- my $blist_tag = $self->_create_tag($self->_root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
+ my $blist_tag = $self->_create_tag($root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
- seek($fh, $blist_tag->{offset}, SEEK_SET);
- print($fh $key . pack($LONG_PACK, $old_subloc || $self->_root->{end}) );
+ seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET);
+ print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) );
}
} # key is real
} # i loop
- $location ||= $self->_root->{end};
+ $location ||= $root->{end};
} # re-index bucket list
##
##
if ($location) {
my $content_length;
- seek($fh, $location, SEEK_SET);
+ seek($fh, $location + $root->{file_offset}, SEEK_SET);
##
# Write signature based on content type, set content length and write actual value.
##
my $r = Scalar::Util::reftype($value) || '';
if ($r eq 'HASH') {
- print($fh TYPE_HASH );
- print($fh 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') {
- print($fh TYPE_ARRAY );
- print($fh 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)) {
- print($fh SIG_NULL );
- print($fh pack($DATA_LENGTH_PACK, 0) );
+ print( $fh SIG_NULL );
+ print( $fh pack($DATA_LENGTH_PACK, 0) );
$content_length = 0;
}
else {
- print($fh SIG_DATA );
- print($fh 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.
##
- print($fh 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
##
- if ( $self->_root->{autobless} ) {
+ if ( $root->{autobless} ) {
my $value_class = Scalar::Util::blessed($value);
if ( defined $value_class && $value_class ne 'DBM::Deep' ) {
##
# Blessed ref -- will restore later
##
- print($fh chr(1) );
- print($fh 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 {
- print($fh chr(0) );
+ print( $fh chr(0) );
$content_length += 1;
}
}
##
# If this is a new content area, advance EOF counter
##
- if ($location == $self->_root->{end}) {
- $self->_root->{end} += SIG_SIZE;
- $self->_root->{end} += $DATA_LENGTH_SIZE + $content_length;
- $self->_root->{end} += $DATA_LENGTH_SIZE + length($plain_key);
+ if ($location == $root->{end}) {
+ $root->{end} += SIG_SIZE;
+ $root->{end} += $DATA_LENGTH_SIZE + $content_length;
+ $root->{end} += $DATA_LENGTH_SIZE + length($plain_key);
}
##
my $branch = DBM::Deep->new(
type => TYPE_HASH,
base_offset => $location,
- root => $self->_root,
+ root => $root,
);
foreach my $key (keys %{$value}) {
$branch->STORE( $key, $value->{$key} );
my $branch = DBM::Deep->new(
type => TYPE_ARRAY,
base_offset => $location,
- root => $self->_root,
+ root => $root,
);
my $index = 0;
foreach my $element (@{$value}) {
# Found match -- seek to offset and read signature
##
my $signature;
- seek($fh, $subloc, SEEK_SET);
+ seek($fh, $subloc + $self->_root->{file_offset}, SEEK_SET);
read( $fh, $signature, SIG_SIZE);
##
##
# Matched key -- delete bucket and return
##
- 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($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $self->_root->{file_offset}, SEEK_SET);
+ print( $fh substr($keys, ($i+1) * $BUCKET_SIZE ) );
+ print( $fh chr(0) x $BUCKET_SIZE );
return 1;
} # i loop
##
# Seek to bucket location and skip over signature
##
- seek($fh, $subloc + SIG_SIZE, SEEK_SET);
+ seek($fh, $subloc + SIG_SIZE + $self->_root->{file_offset}, SEEK_SET);
##
# Skip over value to get to plain key
return;
}
-#XXX These uses of ref() need verified
+sub _copy_value {
+ my $self = shift->_get_self;
+ my ($spot, $value) = @_;
+
+ if ( !ref $value ) {
+ ${$spot} = $value;
+ }
+ elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep' ) } ) {
+ my $type = $value->_type;
+ ${$spot} = $type eq TYPE_HASH ? {} : [];
+ $value->_copy_node( ${$spot} );
+ }
+ else {
+ my $r = Scalar::Util::reftype( $value );
+ my $c = Scalar::Util::blessed( $value );
+ if ( $r eq 'ARRAY' ) {
+ ${$spot} = [ @{$value} ];
+ }
+ else {
+ ${$spot} = { %{$value} };
+ }
+ ${$spot} = bless ${$spot}, $c
+ if defined $c;
+ }
+
+ return 1;
+}
+
sub _copy_node {
##
# Copy single level of keys or elements to new DB handle.
# Recurse for nested structures
##
- my $self = $_[0]->_get_self;
- my $db_temp = $_[1];
+ my $self = shift->_get_self;
+ my ($db_temp) = @_;
if ($self->_type eq TYPE_HASH) {
my $key = $self->first_key();
while ($key) {
my $value = $self->get($key);
-#XXX This doesn't work with autobless
- if (!ref($value)) { $db_temp->{$key} = $value; }
- else {
- my $type = $value->_type;
- if ($type eq TYPE_HASH) { $db_temp->{$key} = {}; }
- else { $db_temp->{$key} = []; }
- $value->_copy_node( $db_temp->{$key} );
- }
+ $self->_copy_value( \$db_temp->{$key}, $value );
$key = $self->next_key($key);
}
}
my $length = $self->length();
for (my $index = 0; $index < $length; $index++) {
my $value = $self->get($index);
- if (!ref($value)) { $db_temp->[$index] = $value; }
- #XXX NO tests for this code
- else {
- my $type = $value->_type;
- if ($type eq TYPE_HASH) { $db_temp->[$index] = {}; }
- else { $db_temp->[$index] = []; }
- $value->_copy_node( $db_temp->[$index] );
- }
+ $self->_copy_value( \$db_temp->[$index], $value );
}
}
+
+ return 1;
}
sub export {
# Get last error string, or undef if no error
##
return $_[0]
- #? ( _get_self($_[0])->{root}->{error} or undef )
? ( $_[0]->_get_self->{root}->{error} or undef )
: $@;
}
_precalc_sizes();
}
+sub _is_writable {
+ my $fh = shift;
+ (O_WRONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
+}
+
+sub _is_readable {
+ my $fh = shift;
+ (O_RDONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
+}
+
##
# tie() methods (hashes and arrays)
##
if (!defined($self->_fh) && !$self->_open()) {
return;
}
- ##
+
+ unless ( _is_writable( $self->_fh ) ) {
+ $self->_throw_error( 'Cannot write to a readonly filehandle' );
+ }
##
# Request exclusive lock for writing
my $ch = 0;
while ($tag->{signature} ne SIG_BLIST) {
my $num = ord(substr($md5, $ch, 1));
+
+ my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
my $new_tag = $self->_index_lookup($tag, $num);
+
if (!$new_tag) {
- my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
- seek($fh, $ref_loc, SEEK_SET);
- print($fh pack($LONG_PACK, $self->_root->{end}) );
+ seek($fh, $ref_loc + $self->_root->{file_offset}, 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);
+
$tag->{ref_loc} = $ref_loc;
$tag->{ch} = $ch;
+
last;
}
else {
- my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
$tag = $new_tag;
+
$tag->{ref_loc} = $ref_loc;
$tag->{ch} = $ch;
}
my $fh = $self->_fh;
- seek($fh, $self->_base_offset, SEEK_SET);
+ seek($fh, $self->_base_offset + $self->_root->{file_offset}, SEEK_SET);
if (eof $fh) {
$self->unlock();
return;
my $self = bless {
file => undef,
fh => undef,
+ file_offset => 0,
end => 0,
autoflush => undef,
locking => undef,
%$args,
}, $class;
+ if ( $self->{fh} && !$self->{file_offset} ) {
+ $self->{file_offset} = tell( $self->{fh} );
+ }
+
return $self;
}
Filename of the DB file to link the handle to. You can pass a full absolute
filesystem path, partial path, or a plain filename if the file is in the
-current working directory. This is a required parameter.
+current working directory. This is a required parameter (though q.v. fh).
+
+=item * fh
+
+If you want, you can pass in the fh instead of the file. This is most useful for doing
+something like:
+
+ my $db = DBM::Deep->new( { fh => \*DATA } );
+
+You are responsible for making sure that the fh has been opened appropriately for your
+needs. If you open it read-only and attempt to write, an exception will be thrown. If you
+open it write-only or append-only, an exception will be thrown immediately as DBM::Deep
+needs to read from the fh.
+
+=item * file_offset
+
+This is the offset within the file that the DBM::Deep db starts. Most of the time, you will
+not need to set this. However, it's there if you want it.
+
+If you pass in fh and do not set this, it will be set appropriately.
=item * type
STDERR, and continue on. This is for debugging purposes only, and probably
not what you want. This is an optional parameter, and defaults to 0 (disabled).
-=item * fh
-
-Instead of passing a file path, you can instead pass a handle to an pre-opened
-filehandle. Note: Beware of using the magick *DATA handle, as this actually
-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. Also please note optimize() will NOT work when passing in only a
-handle. Pass in a real filename in order to use optimize().
+B<NOTE>: This parameter is considered deprecated and should not be used anymore.
=back
=item * error() / clear_error()
-Error handling methods (may be deprecated).
+Error handling methods. These are deprecated and will be removed in 1.00.
.
=back
be used for debugging purposes and not production work. DBM::Deep expects errors
to be thrown, not propagated back up the stack.
+B<NOTE>: error() and clear_error() are considered deprecated and I<will> be removed
+in 1.00. Please don't use them. Instead, wrap all your functions with in eval-blocks.
+
=head1 LARGEFILE SUPPORT
If you have a 64-bit system, and your Perl is compiled with both LARGEFILE
---------------------------- ------ ------ ------ ------ ------ ------ ------
File stmt bran cond sub pod time total
---------------------------- ------ ------ ------ ------ ------ ------ ------
- blib/lib/DBM/Deep.pm 94.1 82.5 68.7 98.1 100.0 58.0 89.9
- blib/lib/DBM/Deep/Array.pm 98.9 88.9 87.5 100.0 n/a 28.9 96.4
- blib/lib/DBM/Deep/Hash.pm 95.3 80.0 100.0 100.0 n/a 13.2 92.4
- Total 95.1 83.4 72.8 98.8 100.0 100.0 91.3
+ blib/lib/DBM/Deep.pm 95.0 83.2 68.7 98.2 100.0 57.8 90.7
+ blib/lib/DBM/Deep/Array.pm 98.9 88.9 87.5 100.0 n/a 27.4 96.4
+ blib/lib/DBM/Deep/Hash.pm 95.3 80.0 100.0 100.0 n/a 14.8 92.4
+ Total 95.8 83.9 72.8 98.8 100.0 100.0 91.8
---------------------------- ------ ------ ------ ------ ------ ------ ------
=head1 MORE INFORMATION
projects / dbsrgits/DBM-Deep.git / blobdiff