# modify it under the same terms as Perl itself.
##
+use 5.6.0;
+
use strict;
+use warnings;
+
+our $VERSION = q(0.99_01);
use Fcntl qw( :DEFAULT :flock :seek );
use Digest::MD5 ();
use Scalar::Util ();
use DBM::Deep::Engine;
-
-use vars qw( $VERSION );
-$VERSION = q(0.99_01);
+use DBM::Deep::File;
##
# Setup constants for users to pass to new()
##
-sub TYPE_HASH () { DBM::Deep::Engine::SIG_HASH }
-sub TYPE_ARRAY () { DBM::Deep::Engine::SIG_ARRAY }
-sub TYPE_SCALAR () { DBM::Deep::Engine::SIG_SCALAR }
+sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH }
+sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY }
sub _get_args {
my $proto = shift;
return bless $self, $class;
}
+# This initializer is called from the various TIE* methods. new() calls tie(),
+# which allows for a single point of entry.
sub _init {
- ##
- # Setup $self and bless into this class.
- ##
my $class = shift;
- my $args = shift;
+ my ($args) = @_;
+
+ $args->{fileobj} = DBM::Deep::File->new( $args )
+ unless exists $args->{fileobj};
+
+ # locking implicitly enables autoflush
+ if ($args->{locking}) { $args->{autoflush} = 1; }
# These are the defaults to be optionally overridden below
my $self = bless {
type => TYPE_HASH,
- engine => DBM::Deep::Engine->new,
- }, $class;
+ base_offset => undef,
+
+ parent => undef,
+ parent_key => undef,
- $self->{base_offset} = length( $self->{engine}->SIG_FILE );
+ fileobj => undef,
+ }, $class;
+ $self->{engine} = DBM::Deep::Engine->new( { %{$args}, obj => $self } );
+ # Grab the parameters we want to use
foreach my $param ( keys %$self ) {
next unless exists $args->{$param};
- $self->{$param} = delete $args->{$param}
+ $self->{$param} = $args->{$param};
}
- # locking implicitly enables autoflush
- if ($args->{locking}) { $args->{autoflush} = 1; }
-
- $self->{root} = exists $args->{root}
- ? $args->{root}
- : DBM::Deep::_::Root->new( $args );
-
$self->{engine}->setup_fh( $self );
+ $self->{fileobj}->set_db( $self );
+
return $self;
}
return DBM::Deep::Array->TIEARRAY( @_ );
}
-#XXX Unneeded now ...
-#sub DESTROY {
-#}
-
sub lock {
- ##
- # If db locking is set, flock() the db file. If called multiple
- # times before unlock(), then the same number of unlocks() must
- # be called before the lock is released.
- ##
- 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);
-
- # refresh end counter in case file has changed size
- my @stats = stat($self->_root->{file});
- $self->_root->{end} = $stats[7];
-
- # double-check file inode, in case another process
- # has optimize()d our file while we were waiting.
- if ($stats[1] != $self->_root->{inode}) {
- $self->{engine}->close_fh( $self );
- $self->{engine}->setup_fh( $self );
- flock($self->_fh, $type); # re-lock
-
- # This may not be necessary after re-opening
- $self->_root->{end} = (stat($self->_fh))[7]; # re-end
- }
- }
- $self->_root->{locked}++;
-
- return 1;
- }
-
- return;
+ my $self = shift->_get_self;
+ return $self->_fileobj->lock( $self, @_ );
}
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;
-
- if (!defined($self->_fh)) { return; }
-
- if ($self->_root->{locking} && $self->_root->{locked} > 0) {
- $self->_root->{locked}--;
- if (!$self->_root->{locked}) { flock($self->_fh, LOCK_UN); }
-
- return 1;
- }
-
- return;
+ my $self = shift->_get_self;
+ return $self->_fileobj->unlock( $self, @_ );
}
sub _copy_value {
${$spot} = $value;
}
elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep' ) } ) {
- my $type = $value->_type;
- ${$spot} = $type eq TYPE_HASH ? {} : [];
+ ${$spot} = $value->_repr;
$value->_copy_node( ${$spot} );
}
else {
}
sub _copy_node {
- ##
- # Copy single level of keys or elements to new DB handle.
- # Recurse for nested structures
- ##
- 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);
- $self->_copy_value( \$db_temp->{$key}, $value );
- $key = $self->next_key($key);
- }
- }
- else {
- my $length = $self->length();
- for (my $index = 0; $index < $length; $index++) {
- my $value = $self->get($index);
- $self->_copy_value( \$db_temp->[$index], $value );
- }
- }
+ die "Must be implemented in a child class\n";
+}
- return 1;
+sub _repr {
+ die "Must be implemented in a child class\n";
}
sub export {
##
# Recursively export into standard Perl hashes and arrays.
##
- my $self = $_[0]->_get_self;
+ my $self = shift->_get_self;
- my $temp;
- if ($self->_type eq TYPE_HASH) { $temp = {}; }
- elsif ($self->_type eq TYPE_ARRAY) { $temp = []; }
+ my $temp = $self->_repr;
$self->lock();
$self->_copy_node( $temp );
##
# Recursively import Perl hash/array structure
##
- #XXX This use of ref() seems to be ok
if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
- my $self = $_[0]->_get_self;
- my $struct = $_[1];
+ my $self = shift->_get_self;
+ my ($struct) = @_;
- #XXX This use of ref() seems to be ok
+ # struct is not a reference, so just import based on our type
if (!ref($struct)) {
- ##
- # struct is not a reference, so just import based on our type
- ##
- shift @_;
-
- if ($self->_type eq TYPE_HASH) { $struct = {@_}; }
- elsif ($self->_type eq TYPE_ARRAY) { $struct = [@_]; }
+ $struct = $self->_repr( @_ );
}
- my $r = Scalar::Util::reftype($struct) || '';
- if ($r eq "HASH" && $self->_type eq TYPE_HASH) {
- foreach my $key (keys %$struct) { $self->put($key, $struct->{$key}); }
- }
- elsif ($r eq "ARRAY" && $self->_type eq TYPE_ARRAY) {
- $self->push( @$struct );
- }
- else {
- $self->_throw_error("Cannot import: type mismatch");
- }
-
- return 1;
+ return $self->_import( $struct );
}
sub optimize {
# Rebuild entire database into new file, then move
# it back on top of original.
##
- my $self = $_[0]->_get_self;
+ my $self = shift->_get_self;
#XXX Need to create a new test for this
-# if ($self->_root->{links} > 1) {
+# if ($self->_fileobj->{links} > 1) {
# $self->_throw_error("Cannot optimize: reference count is greater than 1");
# }
my $db_temp = DBM::Deep->new(
- file => $self->_root->{file} . '.tmp',
+ file => $self->_fileobj->{file} . '.tmp',
type => $self->_type
);
- if (!$db_temp) {
- $self->_throw_error("Cannot optimize: failed to open temp file: $!");
- }
$self->lock();
$self->_copy_node( $db_temp );
my $perms = $stats[2] & 07777;
my $uid = $stats[4];
my $gid = $stats[5];
- chown( $uid, $gid, $self->_root->{file} . '.tmp' );
- chmod( $perms, $self->_root->{file} . '.tmp' );
+ chown( $uid, $gid, $self->_fileobj->{file} . '.tmp' );
+ chmod( $perms, $self->_fileobj->{file} . '.tmp' );
# q.v. perlport for more information on this variable
if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
# with a soft copy.
##
$self->unlock();
- $self->{engine}->close_fh( $self );
+ $self->_fileobj->close;
}
- if (!rename $self->_root->{file} . '.tmp', $self->_root->{file}) {
- unlink $self->_root->{file} . '.tmp';
+ if (!rename $self->_fileobj->{file} . '.tmp', $self->_fileobj->{file}) {
+ unlink $self->_fileobj->{file} . '.tmp';
$self->unlock();
$self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
}
$self->unlock();
- $self->{engine}->close_fh( $self );
+ $self->_fileobj->close;
+ $self->_fileobj->open;
$self->{engine}->setup_fh( $self );
return 1;
##
# Make copy of object and return
##
- my $self = $_[0]->_get_self;
+ my $self = shift->_get_self;
return DBM::Deep->new(
type => $self->_type,
base_offset => $self->_base_offset,
- root => $self->_root
+ fileobj => $self->_fileobj,
);
}
##
# Setup filter function for storing or fetching the key or value
##
- my $self = $_[0]->_get_self;
- my $type = lc $_[1];
- my $func = $_[2] ? $_[2] : undef;
+ my $self = shift->_get_self;
+ my $type = lc shift;
+ my $func = shift;
if ( $is_legal_filter{$type} ) {
- $self->_root->{"filter_$type"} = $func;
+ $self->_fileobj->{"filter_$type"} = $func;
return 1;
}
}
}
+sub begin_work {
+ my $self = shift->_get_self;
+ $self->_fileobj->begin_transaction;
+ return 1;
+}
+
+sub rollback {
+ my $self = shift->_get_self;
+ $self->_fileobj->end_transaction;
+ return 1;
+}
+
+sub commit {
+ my $self = shift->_get_self;
+ $self->_fileobj->commit_transaction;
+ return 1;
+}
+
##
# Accessor methods
##
-sub _root {
- ##
- # Get access to the root structure
- ##
+sub _fileobj {
my $self = $_[0]->_get_self;
- return $self->{root};
-}
-
-sub _fh {
- ##
- # Get access to the raw fh
- ##
- my $self = $_[0]->_get_self;
- return $self->_root->{fh};
+ return $self->{fileobj};
}
sub _type {
- ##
- # Get type of current node (TYPE_HASH or TYPE_ARRAY)
- ##
my $self = $_[0]->_get_self;
return $self->{type};
}
sub _base_offset {
- ##
- # Get base_offset of current node (TYPE_HASH or TYPE_ARRAY)
- ##
my $self = $_[0]->_get_self;
return $self->{base_offset};
}
+sub _fh {
+ my $self = $_[0]->_get_self;
+ return $self->_fileobj->{fh};
+}
+
##
# Utility methods
##
# (O_RDONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
#}
+sub _find_parent {
+ my $self = shift;
+
+ my $base = '';
+ #XXX This if() is redundant
+ if ( my $parent = $self->{parent} ) {
+ my $child = $self;
+ while ( $parent->{parent} ) {
+ $base = (
+ $parent->_type eq TYPE_HASH
+ ? "\{$child->{parent_key}\}"
+ : "\[$child->{parent_key}\]"
+ ) . $base;
+
+ $child = $parent;
+ $parent = $parent->{parent};
+ }
+ if ( $base ) {
+ $base = "\$db->get( '$child->{parent_key}' )->" . $base;
+ }
+ else {
+ $base = "\$db->get( '$child->{parent_key}' )";
+ }
+ }
+ return $base;
+}
+
sub STORE {
##
# Store single hash key/value or array element in database.
##
my $self = shift->_get_self;
- my ($key, $value) = @_;
+ my ($key, $value, $orig_key) = @_;
- unless ( _is_writable( $self->_fh ) ) {
+
+ if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
+ #XXX The second condition needs to disappear
+ if ( defined $orig_key && !( $self->_type eq TYPE_ARRAY && $orig_key eq 'length') ) {
+ my $rhs;
+
+ my $r = Scalar::Util::reftype( $value ) || '';
+ if ( $r eq 'HASH' ) {
+ $rhs = '{}';
+ }
+ elsif ( $r eq 'ARRAY' ) {
+ $rhs = '[]';
+ }
+ elsif ( defined $value ) {
+ $rhs = "'$value'";
+ }
+ else {
+ $rhs = "undef";
+ }
+
+ if ( my $c = Scalar::Util::blessed( $value ) ) {
+ $rhs = "bless $rhs, '$c'";
+ }
+
+ my $lhs = $self->_find_parent;
+ if ( $lhs ) {
+ if ( $self->_type eq TYPE_HASH ) {
+ $lhs .= "->\{$orig_key\}";
+ }
+ else {
+ $lhs .= "->\[$orig_key\]";
+ }
+
+ $lhs .= "=$rhs;";
+ }
+ else {
+ $lhs = "\$db->put('$orig_key',$rhs);";
+ }
+
+ $self->_fileobj->audit($lhs);
+ }
+
##
# Request exclusive lock for writing
##
my $md5 = $self->{engine}{digest}->($key);
- my $tag = $self->{engine}->find_bucket_list( $self, $md5, { create => 1 } );
+ my $tag = $self->{engine}->find_bucket_list( $self->_base_offset, $md5, { create => 1 } );
# User may be storing a hash, in which case we do not want it run
# through the filtering system
- if ( !ref($value) && $self->_root->{filter_store_value} ) {
- $value = $self->_root->{filter_store_value}->( $value );
+ if ( !ref($value) && $self->_fileobj->{filter_store_value} ) {
+ $value = $self->_fileobj->{filter_store_value}->( $value );
}
##
# Add key/value to bucket list
##
- my $result = $self->{engine}->add_bucket( $self, $tag, $md5, $key, $value );
+ $self->{engine}->add_bucket( $tag, $md5, $key, $value, undef, $orig_key );
$self->unlock();
- return $result;
+ return 1;
}
sub FETCH {
# Fetch single value or element given plain key or array index
##
my $self = shift->_get_self;
- my $key = shift;
+ my ($key, $orig_key) = @_;
my $md5 = $self->{engine}{digest}->($key);
##
$self->lock( LOCK_SH );
- my $tag = $self->{engine}->find_bucket_list( $self, $md5 );
+ my $tag = $self->{engine}->find_bucket_list( $self->_base_offset, $md5 );#, { create => 1 } );
+ #XXX This needs to autovivify
if (!$tag) {
$self->unlock();
return;
##
# Get value from bucket list
##
- my $result = $self->{engine}->get_bucket_value( $self, $tag, $md5 );
+ my $result = $self->{engine}->get_bucket_value( $tag, $md5, $orig_key );
$self->unlock();
# Filters only apply to scalar values, so the ref check is making
# 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)
+ return ($result && !ref($result) && $self->_fileobj->{filter_fetch_value})
+ ? $self->_fileobj->{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 = $_[1];
+ my $self = shift->_get_self;
+ my ($key, $orig_key) = @_;
- unless ( _is_writable( $self->_fh ) ) {
+ if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
+ if ( defined $orig_key ) {
+ my $lhs = $self->_find_parent;
+ if ( $lhs ) {
+ $self->_fileobj->audit( "delete $lhs;" );
+ }
+ else {
+ $self->_fileobj->audit( "\$db->delete('$orig_key');" );
+ }
+ }
+
##
# Request exclusive lock for writing
##
my $md5 = $self->{engine}{digest}->($key);
- my $tag = $self->{engine}->find_bucket_list( $self, $md5 );
+ my $tag = $self->{engine}->find_bucket_list( $self->_base_offset, $md5 );
if (!$tag) {
$self->unlock();
return;
##
# Delete bucket
##
- my $value = $self->{engine}->get_bucket_value($self, $tag, $md5 );
+ my $value = $self->{engine}->get_bucket_value( $tag, $md5 );
- if (defined $value && !ref($value) && $self->_root->{filter_fetch_value}) {
- $value = $self->_root->{filter_fetch_value}->($value);
+ if (defined $value && !ref($value) && $self->_fileobj->{filter_fetch_value}) {
+ $value = $self->_fileobj->{filter_fetch_value}->($value);
}
- my $result = $self->{engine}->delete_bucket( $self, $tag, $md5 );
+ my $result = $self->{engine}->delete_bucket( $tag, $md5, $orig_key );
##
# If this object is an array and the key deleted was on the end of the stack,
##
# Check if a single key or element exists given plain key or array index
##
- my $self = $_[0]->_get_self;
- my $key = $_[1];
+ my $self = shift->_get_self;
+ my ($key) = @_;
my $md5 = $self->{engine}{digest}->($key);
##
$self->lock( LOCK_SH );
- my $tag = $self->{engine}->find_bucket_list( $self, $md5 );
+ my $tag = $self->{engine}->find_bucket_list( $self->_base_offset, $md5 );
if (!$tag) {
$self->unlock();
##
# Check if bucket exists and return 1 or ''
##
- my $result = $self->{engine}->bucket_exists( $self, $tag, $md5 ) || '';
+ my $result = $self->{engine}->bucket_exists( $tag, $md5 ) || '';
$self->unlock();
##
# Clear all keys from hash, or all elements from array.
##
- my $self = $_[0]->_get_self;
+ my $self = shift->_get_self;
- unless ( _is_writable( $self->_fh ) ) {
+ if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
+ {
+ my $lhs = $self->_find_parent;
+
+ if ( $self->_type eq TYPE_HASH ) {
+ $lhs = '%{' . $lhs . '}';
+ }
+ else {
+ $lhs = '@{' . $lhs . '}';
+ }
+
+ $self->_fileobj->audit( "$lhs = ();" );
+ }
+
##
# Request exclusive lock for writing
##
$self->lock( LOCK_EX );
- my $fh = $self->_fh;
-
- seek($fh, $self->_base_offset + $self->_root->{file_offset}, SEEK_SET);
- if (eof $fh) {
- $self->unlock();
- return;
- }
-
- $self->{engine}->create_tag($self, $self->_base_offset, $self->_type, chr(0) x $self->{engine}{index_size});
+#XXX This needs updating to use _release_space
+ $self->{engine}->write_tag(
+ $self->_base_offset, $self->_type,
+ chr(0)x$self->{engine}{index_size},
+ );
$self->unlock();
sub exists { (shift)->EXISTS( @_ ) }
sub clear { (shift)->CLEAR( @_ ) }
-package DBM::Deep::_::Root;
-
-sub new {
- my $class = shift;
- my ($args) = @_;
-
- my $self = bless {
- autobless => undef,
- autoflush => undef,
- #XXX It should be this in order to work with the initial create_tag(),
- #XXX but it's not ... it works out because of the stat() in setup_fh(),
- #XXX but that's not good.
- end => 0, #length(DBM::Deep->SIG_FILE),
- fh => undef,
- file => undef,
- file_offset => 0,
- locking => undef,
- locked => 0,
- filter_store_key => undef,
- filter_store_value => undef,
- filter_fetch_key => undef,
- filter_fetch_value => undef,
- %$args,
- }, $class;
-
- if ( $self->{fh} && !$self->{file_offset} ) {
- $self->{file_offset} = tell( $self->{fh} );
- }
-
- return $self;
-}
-
-sub DESTROY {
- my $self = shift;
- return unless $self;
-
- close $self->{fh} if $self->{fh};
-
- return;
-}
-
1;
-
__END__
=head1 NAME
=item * type
This parameter specifies what type of object to create, a hash or array. Use
-one of these two constants: C<DBM::Deep-E<gt>TYPE_HASH> or C<DBM::Deep-E<gt>TYPE_ARRAY>.
+one of these two constants:
+
+=over 4
+
+=item * C<DBM::Deep-E<gt>TYPE_HASH>
+
+=item * C<DBM::Deep-E<gt>TYPE_ARRAY>.
+
+=back
+
This only takes effect when beginning a new file. This is an optional
parameter, and defaults to C<DBM::Deep-E<gt>TYPE_HASH>.
=item * autobless
-If I<autobless> mode is enabled, DBM::Deep will preserve blessed hashes, and
-restore them when fetched. This is an B<experimental> feature, and does have
-side-effects. Basically, when hashes are re-blessed into their original
-classes, they are no longer blessed into the DBM::Deep class! So you won't be
-able to call any DBM::Deep methods on them. You have been warned.
-This is an optional parameter, and defaults to 0 (disabled).
+If I<autobless> mode is enabled, DBM::Deep will preserve the class something
+is blessed into, and restores it when fetched. This is an optional parameter, and defaults to 1 (enabled).
+
+B<Note:> If you use the OO-interface, you will not be able to call any methods
+of DBM::Deep on the blessed item. This is considered to be a feature.
=item * filter_*
-See L<FILTERS> below.
+See L</FILTERS> below.
=back
Data going in and out.
-=item * set_digest() / set_pack() / set_filter()
-
-q.v. adjusting the interal parameters.
-
=back
=head2 HASHES
If you have a 64-bit system, and your Perl is compiled with both LARGEFILE
and 64-bit support, you I<may> be able to create databases larger than 2 GB.
DBM::Deep by default uses 32-bit file offset tags, but these can be changed
-by calling the static C<set_pack()> method before you do anything else.
+by specifying the 'pack_size' parameter when constructing the file.
- DBM::Deep::set_pack(8, 'Q');
+ DBM::Deep->new(
+ filename => $filename,
+ pack_size => 'large',
+ );
This tells DBM::Deep to pack all file offsets with 8-byte (64-bit) quad words
instead of 32-bit longs. After setting these values your DB files have a
theoretical maximum size of 16 XB (exabytes).
+You can also use C<pack_size =E<gt> 'small'> in order to use 16-bit file
+offsets.
+
B<Note:> Changing these values will B<NOT> work for existing database files.
-Only change this for new files, and make sure it stays set consistently
-throughout the file's life. If you do set these values, you can no longer
-access 32-bit DB files. You can, however, call C<set_pack(4, 'N')> to change
-back to 32-bit mode.
+Only change this for new files. Once the value has been set, it is stored in
+the file's header and cannot be changed for the life of the file. These
+parameters are per-file, meaning you can access 32-bit and 64-bit files, as
+you chose.
-B<Note:> I have not personally tested files > 2 GB -- all my systems have
-only a 32-bit Perl. However, I have received user reports that this does
-indeed work!
+B<Note:> We have not personally tested files larger than 2 GB -- all my
+systems have only a 32-bit Perl. However, I have received user reports that
+this does indeed work!
=head1 LOW-LEVEL ACCESS
This method can be called on the root level of the datbase, or any child
hashes or arrays. All levels share a I<root> structure, which contains things
like the filehandle, a reference counter, and all the options specified
-when you created the object. You can get access to this root structure by
-calling the C<root()> method.
+when you created the object. You can get access to this file object by
+calling the C<_fileobj()> method.
- my $root = $db->_root();
+ my $file_obj = $db->_fileobj();
This is useful for changing options after the object has already been created,
such as enabling/disabling locking. You can also store your own temporary user
DBM::Deep by default uses the I<Message Digest 5> (MD5) algorithm for hashing
keys. However you can override this, and use another algorithm (such as SHA-256)
or even write your own. But please note that DBM::Deep currently expects zero
-collisions, so your algorithm has to be I<perfect>, so to speak.
-Collision detection may be introduced in a later version.
-
+collisions, so your algorithm has to be I<perfect>, so to speak. Collision
+detection may be introduced in a later version.
-
-You can specify a custom digest algorithm by calling the static C<set_digest()>
-function, passing a reference to a subroutine, and the length of the algorithm's
-hashes (in bytes). This is a global static function, which affects ALL DBM::Deep
-objects. Here is a working example that uses a 256-bit hash from the
+You can specify a custom digest algorithm by passing it into the parameter
+list for new(), passing a reference to a subroutine as the 'digest' parameter,
+and the length of the algorithm's hashes (in bytes) as the 'hash_size'
+parameter. Here is a working example that uses a 256-bit hash from the
I<Digest::SHA256> module. Please see
-L<http://search.cpan.org/search?module=Digest::SHA256> for more.
+L<http://search.cpan.org/search?module=Digest::SHA256> for more information.
use DBM::Deep;
use Digest::SHA256;
my $context = Digest::SHA256::new(256);
- DBM::Deep::set_digest( \&my_digest, 32 );
-
- my $db = DBM::Deep->new( "foo-sha.db" );
+ my $db = DBM::Deep->new(
+ filename => "foo-sha.db",
+ digest => \&my_digest,
+ hash_size => 32,
+ );
$db->{key1} = "value1";
$db->{key2} = "value2";
}
B<Note:> Your returned digest strings must be B<EXACTLY> the number
-of bytes you specify in the C<set_digest()> function (in this case 32).
+of bytes you specify in the hash_size parameter (in this case 32).
+
+B<Note:> If you do choose to use a custom digest algorithm, you must set it
+every time you access this file. Otherwise, the default (MD5) will be used.
=head1 CIRCULAR REFERENCES
$db->{foo} = "bar";
$db->{circle} = $db; # ref to self
- print $db->{foo} . "\n"; # prints "foo"
- print $db->{circle}->{foo} . "\n"; # prints "foo" again
+ print $db->{foo} . "\n"; # prints "bar"
+ print $db->{circle}->{foo} . "\n"; # prints "bar" again
-One catch is, passing the object to a function that recursively walks the
+B<Note>: Passing the object to a function that recursively walks the
object tree (such as I<Data::Dumper> or even the built-in C<optimize()> or
-C<export()> methods) will result in an infinite loop. The other catch is,
-if you fetch the I<key> of a circular reference (i.e. using the C<first_key()>
-or C<next_key()> methods), you will get the I<target object's key>, not the
-ref's key. This gets even more interesting with the above example, where
-the I<circle> key points to the base DB object, which technically doesn't
-have a key. So I made DBM::Deep return "[base]" as the key name in that
-special case.
+C<export()> methods) will result in an infinite loop. This will be fixed in
+a future release.
=head1 CAVEATS / ISSUES / BUGS
make sure there are no child references lying around. DBM::Deep keeps a reference
counter, and if it is greater than 1, optimize() will abort and return undef.
-=head2 AUTOVIVIFICATION
+=head2 REFERENCES
+
+(The reasons given assume a high level of Perl understanding, specifically of
+references. You can safely skip this section.)
-Unfortunately, autovivification doesn't work with tied hashes. This appears to
-be a bug in Perl's tie() system, as I<Jakob Schmidt> encountered the very same
-issue with his I<DWH_FIle> module (see L<http://search.cpan.org/search?module=DWH_File>),
-and it is also mentioned in the BUGS section for the I<MLDBM> module <see
-L<http://search.cpan.org/search?module=MLDBM>). Basically, on a new db file,
-this does not work:
+Currently, the only references supported are HASH and ARRAY. The other reference
+types (SCALAR, CODE, GLOB, and REF) cannot be supported for various reasons.
- $db->{foo}->{bar} = "hello";
+=over 4
-Since "foo" doesn't exist, you cannot add "bar" to it. You end up with "foo"
-being an empty hash. Try this instead, which works fine:
+=item * GLOB
- $db->{foo} = { bar => "hello" };
+These are things like filehandles and other sockets. They can't be supported
+because it's completely unclear how DBM::Deep should serialize them.
-As of Perl 5.8.7, this bug still exists. I have walked very carefully through
-the execution path, and Perl indeed passes an empty hash to the STORE() method.
-Probably a bug in Perl.
+=item * SCALAR / REF
+
+The discussion here refers to the following type of example:
+
+ my $x = 25;
+ $db->{key1} = \$x;
+
+ $x = 50;
+
+ # In some other process ...
+
+ my $val = ${ $db->{key1} };
+
+ is( $val, 50, "What actually gets stored in the DB file?" );
+
+The problem is one of synchronization. When the variable being referred to
+changes value, the reference isn't notified. This means that the new value won't
+be stored in the datafile for other processes to read. There is no TIEREF.
+
+It is theoretically possible to store references to values already within a
+DBM::Deep object because everything already is synchronized, but the change to
+the internals would be quite large. Specifically, DBM::Deep would have to tie
+every single value that is stored. This would bloat the RAM footprint of
+DBM::Deep at least twofold (if not more) and be a significant performance drain,
+all to support a feature that has never been requested.
+
+=item * CODE
+
+L<http://search.cpan.org/search?module=Data::Dump::Streamer> provides a
+mechanism for serializing coderefs, including saving off all closure state.
+However, just as for SCALAR and REF, that closure state may change without
+notifying the DBM::Deep object storing the reference.
+
+=back
=head2 FILE CORRUPTION
We use B<Devel::Cover> to test the code coverage of our 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 95.1 81.6 70.3 100.0 100.0 33.4 91.0
- blib/lib/DBM/Deep/Array.pm 100.0 91.1 100.0 100.0 n/a 27.8 98.0
- blib/lib/DBM/Deep/Engine.pm 97.8 85.6 75.0 100.0 0.0 25.8 90.8
- blib/lib/DBM/Deep/Hash.pm 100.0 87.5 100.0 100.0 n/a 13.0 97.2
- Total 97.5 85.4 76.6 100.0 46.9 100.0 92.5
- ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ ----------------------------------- ------ ------ ------ ------ ------ ------
+ File stmt bran cond sub time total
+ ----------------------------------- ------ ------ ------ ------ ------ ------
+ blib/lib/DBM/Deep.pm 94.9 80.6 73.0 100.0 37.9 90.4
+ blib/lib/DBM/Deep/Array.pm 100.0 91.1 100.0 100.0 18.2 98.1
+ blib/lib/DBM/Deep/Engine.pm 98.9 87.3 80.0 100.0 34.2 95.2
+ blib/lib/DBM/Deep/Hash.pm 100.0 87.5 100.0 100.0 9.7 97.3
+ Total 97.9 85.9 79.7 100.0 100.0 94.3
+ ----------------------------------- ------ ------ ------ ------ ------ ------
=head1 MORE INFORMATION
projects / dbsrgits/DBM-Deep.git / blobdiff