t/30_already_tied.t
t/31_references.t
t/32_dash_ell.t
+t/33_transaction_commit.t
# These are the defaults to be optionally overridden below
my $self = bless {
type => TYPE_HASH,
- engine => DBM::Deep::Engine->new( $args ),
base_offset => undef,
+
+ parent => undef,
+ parent_key => undef,
+
fileobj => undef,
}, $class;
+ $self->{engine} = DBM::Deep::Engine->new( { %{$args}, obj => $self } );
# Grab the parameters we want to use
foreach my $param ( keys %$self ) {
$self->{engine}->setup_fh( $self );
+ $self->{fileobj}->set_db( $self );
+
return $self;
}
return 1;
}
-#sub commit {
-# my $self = shift->_get_self;
-#}
+sub commit {
+ my $self = shift->_get_self;
+ # At this point, we need to replay the actions taken
+ $self->_fileobj->end_transaction;
+ return 1;
+}
##
# Accessor methods
##
sub _fileobj {
- ##
- # Get access to the root structure
- ##
my $self = $_[0]->_get_self;
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 {
- ##
- # Get access to the raw fh
- ##
my $self = $_[0]->_get_self;
return $self->_fileobj->{fh};
}
# (O_RDONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
#}
+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 $self = shift->_get_self;
- my ($key, $value) = @_;
+ my ($key, $value, $orig_key) = @_;
if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
+ if ( my $afh = $self->_fileobj->{audit_fh} ) {
+ unless ( $self->_type eq TYPE_ARRAY && $orig_key eq 'length' ) {
+ my $lhs = $self->_find_parent;
+ if ( $self->_type eq TYPE_HASH ) {
+ $lhs .= "\{$orig_key\}";
+ }
+ else {
+ $lhs .= "\[$orig_key\]";
+ }
+
+ my $rhs;
+
+ my $r = Scalar::Util::reftype( $value ) || '';
+ if ( $r eq 'HASH' ) {
+ $rhs = '{}';
+ }
+ elsif ( $r eq 'ARRAY' ) {
+ $rhs = '[]';
+ }
+ else {
+ $rhs = "'$value'";
+ }
+
+ if ( my $c = Scalar::Util::blessed( $value ) ) {
+ $rhs = "bless $rhs, '$c'";
+ }
+
+ flock( $afh, LOCK_EX );
+ print( $afh "$lhs = $rhs; # " . localtime(time) . "\n" );
+ flock( $afh, LOCK_UN );
+ }
+ }
+
##
# Request exclusive lock for writing
##
##
# Add key/value to bucket list
##
- my $result = $self->{engine}->add_bucket( $tag, $md5, $key, $value );
+ my $result = $self->{engine}->add_bucket( $tag, $md5, $key, $value, undef, $orig_key );
$self->unlock();
=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
$self->lock( $self->LOCK_EX );
- my $orig = $key;
+ my $orig = $key eq 'length' ? undef : $key;
my $size;
my $numeric_idx;
$key = pack($self->{engine}{long_pack}, $key);
}
- my $rv = $self->SUPER::STORE( $key, $value );
+ my $rv = $self->SUPER::STORE( $key, $value, $orig );
if ( $numeric_idx && $rv == 2 ) {
$size = $self->FETCHSIZE unless defined $size;
use warnings;
use Fcntl qw( :DEFAULT :flock :seek );
+use Scalar::Util ();
# File-wide notes:
# * All the local($/,$\); are to protect read() and print() from -l.
max_buckets => 16,
fileobj => undef,
+ obj => undef,
}, $class;
if ( defined $args->{pack_size} ) {
next unless exists $args->{$param};
$self->{$param} = $args->{$param};
}
+ Scalar::Util::weaken( $self->{obj} ) if $self->{obj};
if ( $self->{max_buckets} < 16 ) {
warn "Floor of max_buckets is 16. Setting it to 16 from '$self->{max_buckets}'\n";
my $self = shift;
my ($obj) = @_;
+ local($/,$\);
+
my $fh = $self->_fh;
flock $fh, LOCK_EX;
# File is empty -- write header and master index
##
if (!$bytes_read) {
+ if ( my $afh = $self->_fileobj->{audit_fh} ) {
+ flock( $afh, LOCK_EX );
+ print( $afh "# Database created on " . localtime(time) . "\n" );
+ flock( $afh, LOCK_UN );
+ }
+
$self->write_file_header;
$obj->{base_offset} = $self->_request_space( $self->tag_size( $self->{index_size} ) );
##
# Get our type from master index header
##
- my $tag = $self->load_tag($obj->_base_offset)
- or $self->_throw_error("Corrupted file, no master index record");
+ my $tag = $self->load_tag($obj->_base_offset);
+ unless ( $tag ) {
+ flock $fh, LOCK_UN;
+ $self->_throw_error("Corrupted file, no master index record");
+ }
unless ($obj->_type eq $tag->{signature}) {
+ flock $fh, LOCK_UN;
$self->_throw_error("File type mismatch");
}
}
# plain (undigested) key and value.
##
my $self = shift;
- my ($tag, $md5, $plain_key, $value, $deleted) = @_;
+ my ($tag, $md5, $plain_key, $value, $deleted, $orig_key) = @_;
$deleted ||= 0;
local($/,$\);
for ( @transactions ) {
my $tag2 = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
$self->_fileobj->{transaction_id} = $_;
- $self->add_bucket( $tag2, $md5, '', '', 1 );
+ $self->add_bucket( $tag2, $md5, '', '', 1, $orig_key );
$self->_fileobj->{transaction_id} = 0;
}
}
$location = $self->split_index( $md5, $tag );
}
- $self->write_value( $location, $plain_key, $value );
+ $self->write_value( $location, $plain_key, $value, $orig_key );
return $result;
}
sub write_value {
my $self = shift;
- my ($location, $key, $value) = @_;
+ my ($location, $key, $value, $orig_key) = @_;
local($/,$\);
tie %$value, 'DBM::Deep', {
base_offset => $location,
fileobj => $root,
+ parent => $self->{obj},
+ parent_key => $orig_key,
};
%$value = %x;
}
tie @$value, 'DBM::Deep', {
base_offset => $location,
fileobj => $root,
+ parent => $self->{obj},
+ parent_key => $orig_key,
};
@$value = @x;
}
sub read_from_loc {
my $self = shift;
- my ($subloc) = @_;
+ my ($subloc, $orig_key) = @_;
local($/,$\);
##
if (($signature eq SIG_HASH) || ($signature eq SIG_ARRAY)) {
my $new_obj = DBM::Deep->new({
- type => $signature,
+ type => $signature,
base_offset => $subloc,
fileobj => $self->_fileobj,
+ parent => $self->{obj},
+ parent_key => $orig_key,
});
if ($new_obj->_fileobj->{autobless}) {
read( $fh, $new_loc, $size );
$new_loc = unpack( $self->{long_pack}, $new_loc );
- return $self->read_from_loc( $new_loc );
+ return $self->read_from_loc( $new_loc, $orig_key );
}
else {
return;
# Fetch single value given tag and MD5 digested key.
##
my $self = shift;
- my ($tag, $md5) = @_;
+ my ($tag, $md5, $orig_key) = @_;
#ACID - This is a read. Can find exact or HEAD
my ($subloc, $offset, $size,$is_deleted) = $self->_find_in_buckets( $tag, $md5 );
if ( $subloc && !$is_deleted ) {
- return $self->read_from_loc( $subloc );
+ return $self->read_from_loc( $subloc, $orig_key );
}
return;
}
my ($args) = @_;
my $self = bless {
- autobless => undef,
+ audit_fh => undef,
+ audit_file => undef,
+ autobless => 1,
autoflush => undef,
end => 0,
fh => undef,
filter_fetch_key => undef,
filter_fetch_value => undef,
- transaction_id => 0,
- transaction_offset => 0,
+ # These are values that are not expected to be passed in through
+ # $args. They are here for documentation purposes.
+ transaction_id => 0,
+ transaction_offset => 0,
+ base_db_obj => undef,
}, $class;
# Grab the parameters we want to use
$self->open unless $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 '$self->{audit_file}' for read/write: $!";
+
+ # Set the audit_fh to autoflush
+ my $old = select $fh;
+ $|=1;
+ select $old;
+
+ $self->{audit_fh} = $fh;
+ }
+
+
return $self;
}
+sub set_db {
+ unless ( $_[0]{base_db_obj} ) {
+ $_[0]{base_db_obj} = $_[1];
+ Scalar::Util::weaken( $_[0]{base_db_obj} );
+ }
+}
+
sub open {
my $self = shift;
? $self->_fileobj->{filter_store_key}->($_[0])
: $_[0];
- return $self->SUPER::FETCH( $key );
+ return $self->SUPER::FETCH( $key, $_[0] );
}
sub STORE {
: $_[0];
my $value = $_[1];
- return $self->SUPER::STORE( $key, $value );
+ return $self->SUPER::STORE( $key, $value, $_[0] );
}
sub EXISTS {
? $self->_fileobj->{filter_store_key}->($_[0])
: $_[0];
- return $self->SUPER::DELETE( $key );
+ return $self->SUPER::DELETE( $key, $_[0] );
}
sub FIRSTKEY {
{
my $db = DBM::Deep->new(
file => $filename,
+ autobless => 0,
);
my $obj = $db->{blessed};
--- /dev/null
+use strict;
+use Test::More tests => 13;
+use Test::Exception;
+use t::common qw( new_fh );
+
+use_ok( 'DBM::Deep' );
+
+my ($fh, $filename) = new_fh();
+my $db1 = DBM::Deep->new(
+ file => $filename,
+ locking => 1,
+ autoflush => 1,
+);
+
+my $db2 = DBM::Deep->new(
+ file => $filename,
+ locking => 1,
+ autoflush => 1,
+);
+
+$db1->{x} = 'y';
+is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
+is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
+
+$db1->begin_work;
+
+is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
+is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
+
+$db1->{x} = 'z';
+is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
+is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is still Y" );
+
+$db2->{other_x} = 'foo';
+is( $db2->{other_x}, 'foo', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
+is( $db1->{other_x}, undef, "Since other_x was added after the transaction began, DB1 doesn't see it." );
+
+$db1->commit;
+
+TODO: {
+ local $TODO = 'Need to finish auditing first before commit will work.';
+ is( $db1->{x}, 'z', "After commit, DB1's X is Y" );
+ is( $db2->{x}, 'z', "After commit, DB2's X is Y" );
+}
+
+is( $db1->{other_x}, 'foo', "After DB1 transaction is over, DB1 can see other_x" );
+is( $db2->{other_x}, 'foo', "After DB1 transaction is over, DB2 can still see other_x" );
--- /dev/null
+use strict;
+use warnings;
+
+{
+ # 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 => 24;
+use t::common qw( new_fh );
+
+use_ok( 'DBM::Deep' );
+
+my ($audit_fh, $audit_file) = new_fh();
+
+my @audit;
+tie @audit, 'My::Tie::File', $audit_file;
+
+my ($fh, $filename) = new_fh();
+my $db = DBM::Deep->new({
+ file => $filename,
+ audit_file => $audit_file,
+ #autuflush => 1,
+});
+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" );
+
+SKIP: {
+ skip 'Not done yet', 20;
+$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 => $filename,
+ 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;
+
+{
+ my ($fh2, $file2) = new_fh();
+ my $db = DBM::Deep->new({
+ file => $file2,
+ });
+
+ for ( @audit ) {
+ eval "$_";
+ }
+
+ my $export2 = $db->export;
+
+ is_deeply( $export2, $export, "And recovery works" );
+}
+
+{
+ $db = DBM::Deep->new({
+ file => $filename,
+ audit_file => $audit_file,
+ });
+
+ delete $db->{baz};
+ like( $audit[13], qr{delete \$db->{baz};}, "Deleting works" );
+
+ $export = $db->export;
+}
+
+{
+ my ($fh2, $file2) = new_fh();
+ my $db = DBM::Deep->new({
+ file => $file2,
+ });
+
+ for ( @audit ) {
+ eval "$_";
+ }
+
+ my $export2 = $db->export;
+
+ is_deeply( $export2, $export, "And recovery works" );
+}
+
+{
+ $db = DBM::Deep->new({
+ file => $filename,
+ audit_file => $audit_file,
+ });
+
+ $db->{bar}->clear;
+ like( $audit[14], qr{\$db->{bar} = \{\};}, "Clearing works" );
+
+ $export = $db->export;
+}
+
+{
+ my ($fh2, $file2) = new_fh();
+ my $db = DBM::Deep->new({
+ file => $file2,
+ });
+
+ for ( @audit ) {
+ eval "$_";
+ }
+
+ my $export2 = $db->export;
+
+ is_deeply( $export2, $export, "And recovery works" );
+}
+
+{
+ $db = DBM::Deep->new({
+ file => $filename,
+ audit_file => $audit_file,
+ });
+
+ $db->{blessed} = bless { a => 5, b => 3 }, 'Floober';
+ like( $audit[15], qr{\$db->{blessed} = bless {}, 'Floober';},
+ "Assignment of a blessed reference works" );
+ like( $audit[16], qr{\$db->{blessed}{a} = '5';}, "... child 1" );
+ like( $audit[17], qr{\$db->{blessed}{b} = '3';}, "... child 2" );
+
+ $export = $db->export;
+}
+
+{
+ my ($fh2, $file2) = new_fh();
+ my $db = DBM::Deep->new({
+ file => $file2,
+ });
+
+ for ( @audit ) {
+ eval "$_";
+ }
+
+ my $export2 = $db->export;
+
+ is_deeply( $export2, $export, "And recovery works" );
+}
+}
projects / dbsrgits/DBM-Deep.git / commitdiff