use Scalar::Util ();
use vars qw( $VERSION );
-$VERSION = q(0.981_01);
+$VERSION = q(0.981);
##
# Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file.
# These are the defaults to be optionally overridden below
my $self = bless {
- type => TYPE_HASH,
- parent => undef,
- parent_key => undef,
+ type => TYPE_HASH,
base_offset => length(SIG_FILE),
}, $class;
# File is empty -- write signature and master index
##
if (!$bytes_read) {
- if ( my $afh = $self->_root->{audit_fh} ) {
- flock( $afh, LOCK_EX );
- print( $afh "# Database created on " . localtime(time) . $/ );
- flock( $afh, LOCK_UN );
- }
-
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);
# plain (undigested) key and value.
##
my $self = shift;
- my ($tag, $md5, $plain_key, $value, $orig_key) = @_;
+ my ($tag, $md5, $plain_key, $value) = @_;
my $keys = $tag->{content};
my $location = 0;
my $result = 2;
type => TYPE_HASH,
base_offset => $location,
root => $root,
- parent => $self,
- parent_key => $orig_key,
);
foreach my $key (keys %{$value}) {
$branch->STORE( $key, $value->{$key} );
type => TYPE_ARRAY,
base_offset => $location,
root => $root,
- parent => $self,
- parent_key => $orig_key,
);
my $index = 0;
foreach my $element (@{$value}) {
# Fetch single value given tag and MD5 digested key.
##
my $self = shift;
- my ($tag, $md5, $plain_key) = @_;
+ my ($tag, $md5) = @_;
my $keys = $tag->{content};
my $fh = $self->_fh;
if (!$subloc) {
##
# Hit end of list, no match
- ## return;
+ ##
+ return;
}
if ( $md5 ne $key ) {
my $obj = DBM::Deep->new(
type => $signature,
base_offset => $subloc,
- root => $self->_root,
- parent => $self,
- parent_key => $plain_key,
+ root => $self->_root
);
if ($self->_root->{autobless}) {
return DBM::Deep->new(
type => $self->_type,
base_offset => $self->_base_offset,
- root => $self->_root,
- parent => $self->{parent},
- parent_key => $self->{parent_key},
+ root => $self->_root
);
}
# tie() methods (hashes and arrays)
##
-sub _find_parent {
- my $self = shift;
- if ( $self->{parent} ) {
- my $base = $self->{parent}->_find_parent();
- if ( $self->{parent}->_type eq TYPE_HASH ) {
- return $base . "\{$self->{parent_key}\}";
- }
- return $base . "\[$self->{parent_key}\]";
- }
- return '$db->';
-}
-
sub STORE {
##
# Store single hash key/value or array element in database.
my $value = ($self->_root->{filter_store_value} && !ref($_[2]))
? $self->_root->{filter_store_value}->($_[2])
: $_[2];
-
- if ( my $afh = $self->_root->{audit_fh} ) {
- unless ( $self->_type eq SIG_ARRAY && $key eq 'length' ) {
- my $lhs = $self->_find_parent;
- if ( $self->_type eq SIG_HASH ) {
- $lhs .= "\{$key\}";
- }
- else {
- $lhs .= "\[$_[3]\]";
- }
-
- my $rhs;
-
- my $r = Scalar::Util::reftype( $_[2] ) || '';
- if ( $r eq 'HASH' ) {
- $rhs = '{}';
- }
- elsif ( $r eq 'ARRAY' ) {
- $rhs = '[]';
- }
- else {
- $rhs = "'$_[2]'";
- }
-
- flock( $afh, LOCK_EX );
- print( $afh "$lhs = $rhs; # " . localtime(time) . "\n" );
- flock( $afh, LOCK_UN );
- }
- }
my $md5 = $DIGEST_FUNC->($key);
##
# Add key/value to bucket list
##
- my $result = $self->_add_bucket( $tag, $md5, $key, $value, $_[3] || $key );
-
+ my $result = $self->_add_bucket( $tag, $md5, $key, $value );
+
$self->unlock();
return $result;
##
# Get value from bucket list
##
- my $result = $self->_get_bucket_value( $tag, $md5, $key );
+ my $result = $self->_get_bucket_value( $tag, $md5 );
$self->unlock();
##
# Delete bucket
##
- my $value = $self->_get_bucket_value( $tag, $md5, $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);
}
package DBM::Deep::_::Root;
-use Fcntl;
-
sub new {
my $class = shift;
my ($args) = @_;
$self->{file_offset} = tell( $self->{fh} );
}
- if ( $self->{audit_file} && !$self->{audit_fh} ) {
- my $flags = O_WRONLY | O_APPEND | O_CREAT;
-
- my $fh;
- sysopen( $fh, $self->{audit_file}, $flags )
- or die "Cannot open audit file: $!";
-
- my $old = select $fh;
- $|=1;
- select $old;
-
- $self->{audit_fh} = $fh;
- }
-
return $self;
}
B<NOTE>: This parameter is considered deprecated and should not be used anymore.
-=item * audit_file / audit_fh
-
-If you set either of these, an auditlog will be written to. If you set
-audit_file, audit_fh will be set to the open() on the audit_file.
-
-The auditing information will look something like:
-
- $db->{foo} = 'floober';
- $db->{bar} = {};
- $db->{bar}{a} = [];
- $db->{bar}{a}[0] = '5';
-
-The idea is that if your DB file is corrupted, you can recover it by doing
-something like:
-
- my $db = DBM::Deep->new( $new_filename );
- do( $audit_file );
-
-It is your responsability to make sure that the same auditlog is opened with the
-same DB file every time the DB file is opened. This will change when 1.00 is
-released.
-
=back
=head1 TIE INTERFACE
+++ /dev/null
-use strict;
-$|=1;
-
-{
- # This is here because Tie::File is STOOPID.
-
- package My::Tie::File;
- sub TIEARRAY {
- my $class = shift;
- my ($filename) = @_;
-
- return bless {
- filename => $filename,
- }, $class;
- }
-
- sub FETCH {
- my $self = shift;
- my ($idx) = @_;
-
- open( my $fh, $self->{filename} );
- my @x = <$fh>;
- close $fh;
-
- return $x[$idx];
- }
-
- sub FETCHSIZE {
- my $self = shift;
-
- open( my $fh, $self->{filename} );
- my @x = <$fh>;
- close $fh;
-
- return scalar @x;
- }
-
- sub STORESIZE {}
-}
-
-use Test::More tests => 16;
-
-use_ok( 'DBM::Deep' );
-
-my $audit_file = 't/audit.txt';
-
-unlink 't/test.db';
-unlink $audit_file;
-
-my @audit;
-tie @audit, 'My::Tie::File', $audit_file;
-
-my $db = DBM::Deep->new({
- file => 't/test.db',
-# audit_fh => $afh,
- audit_file => $audit_file,
-});
-isa_ok( $db, 'DBM::Deep' );
-
-like(
- $audit[0], qr/^\# Database created on/,
- "Audit file header written to",
-);
-
-$db->{foo} = 'bar';
-like( $audit[1], qr{^\$db->{foo} = 'bar';}, "Basic assignment correct" );
-
-$db->{foo} = 'baz';
-like( $audit[2], qr{^\$db->{foo} = 'baz';}, "Basic update correct" );
-
-$db->{bar} = { a => 1 };
-like( $audit[3], qr{\$db->\{bar\} = \{\};}, "Hash assignment correct" );
-like( $audit[4], qr{\$db->\{bar\}\{a\} = '1';}, "... child 1 good" );
-
-$db->{baz} = [ 1 .. 2 ];
-like( $audit[5], qr{\$db->{baz} = \[\];}, "Array assignment correct" );
-like( $audit[6], qr{\$db->{baz}\[0\] = '1';}, "... child 1 good" );
-like( $audit[7], qr{\$db->{baz}\[1\] = '2';}, "... child 2 good" );
-
-{
- my $v = $db->{baz};
- $v->[5] = [ 3 .. 5 ];
- like( $audit[8], qr{\$db->{baz}\[5\] = \[\];}, "Child array assignment correct" );
- like( $audit[9], qr{\$db->{baz}\[5\]\[0\] = '3';}, "... child 1 good" );
- like( $audit[10], qr{\$db->{baz}\[5]\[1] = '4';}, "... child 2 good" );
- like( $audit[11], qr{\$db->{baz}\[5]\[2] = '5';}, "... child 3 good" );
-}
-
-undef $db;
-
-$db = DBM::Deep->new({
- file => 't/test.db',
- audit_file => $audit_file,
-});
-
-$db->{new} = 9;
-like( $audit[12], qr{\$db->{new} = '9';}, "Writing after closing the file works" );
-
-my $export = $db->export;
-undef $db;
-
-{
- unlink 't/test2.db';
- my $db = DBM::Deep->new({
- file => 't/test2.db',
- });
-
- for ( @audit ) {
- eval "$_";
- }
-
- my $export2 = $db->export;
-
- is_deeply( $export2, $export, "And recovery works" );
-}