From: rkinyon Date: Tue, 18 Apr 2006 23:27:00 +0000 (+0000) Subject: Audit trail on the way X-Git-Tag: 0-99_01~20 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=359a01ac3d83b1713bfee3a473d6959c21632d26;p=dbsrgits%2FDBM-Deep.git Audit trail on the way --- diff --git a/MANIFEST b/MANIFEST index f7c6f68..c94552a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -41,3 +41,4 @@ t/29_freespace_manager.t t/30_already_tied.t t/31_references.t t/32_dash_ell.t +t/33_transaction_commit.t diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 815cfd9..dbb9a9e 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -115,10 +115,14 @@ sub _init { # 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 ) { @@ -128,6 +132,8 @@ sub _init { $self->{engine}->setup_fh( $self ); + $self->{fileobj}->set_db( $self ); + return $self; } @@ -327,42 +333,33 @@ sub rollback { 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}; } @@ -385,17 +382,62 @@ sub _is_writable { # (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 ## @@ -414,7 +456,7 @@ sub STORE { ## # 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(); @@ -735,7 +777,16 @@ If you pass in fh and do not set this, it will be set appropriately. =item * type This parameter specifies what type of object to create, a hash or array. Use -one of these two constants: CTYPE_HASH> or CTYPE_ARRAY>. +one of these two constants: + +=over 4 + +=item * CTYPE_HASH> + +=item * CTYPE_ARRAY>. + +=back + This only takes effect when beginning a new file. This is an optional parameter, and defaults to CTYPE_HASH>. @@ -757,16 +808,15 @@ Pass any true value to enable. This is an optional parameter, and defaults to 0 =item * autobless -If I mode is enabled, DBM::Deep will preserve blessed hashes, and -restore them when fetched. This is an B 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 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 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 below. +See L below. =back diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index d95fed8..8270a22 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -73,7 +73,7 @@ sub STORE { $self->lock( $self->LOCK_EX ); - my $orig = $key; + my $orig = $key eq 'length' ? undef : $key; my $size; my $numeric_idx; @@ -90,7 +90,7 @@ sub STORE { $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; diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index 58ff7c7..983b3e9 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -6,6 +6,7 @@ use strict; 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. @@ -51,6 +52,7 @@ sub new { max_buckets => 16, fileobj => undef, + obj => undef, }, $class; if ( defined $args->{pack_size} ) { @@ -76,6 +78,7 @@ sub new { 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"; @@ -174,6 +177,8 @@ sub setup_fh { my $self = shift; my ($obj) = @_; + local($/,$\); + my $fh = $self->_fh; flock $fh, LOCK_EX; @@ -187,6 +192,12 @@ sub setup_fh { # 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} ) ); @@ -207,10 +218,14 @@ sub setup_fh { ## # 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"); } } @@ -386,7 +401,7 @@ sub add_bucket { # 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($/,$\); @@ -454,7 +469,7 @@ sub add_bucket { 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; } } @@ -464,14 +479,14 @@ sub add_bucket { $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($/,$\); @@ -547,6 +562,8 @@ sub write_value { tie %$value, 'DBM::Deep', { base_offset => $location, fileobj => $root, + parent => $self->{obj}, + parent_key => $orig_key, }; %$value = %x; } @@ -555,6 +572,8 @@ sub write_value { tie @$value, 'DBM::Deep', { base_offset => $location, fileobj => $root, + parent => $self->{obj}, + parent_key => $orig_key, }; @$value = @x; } @@ -647,7 +666,7 @@ sub split_index { sub read_from_loc { my $self = shift; - my ($subloc) = @_; + my ($subloc, $orig_key) = @_; local($/,$\); @@ -665,9 +684,11 @@ sub read_from_loc { ## 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}) { @@ -708,7 +729,7 @@ sub read_from_loc { 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; @@ -738,12 +759,12 @@ sub get_bucket_value { # 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; } diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm index 6ef0260..651ec55 100644 --- a/lib/DBM/Deep/File.pm +++ b/lib/DBM/Deep/File.pm @@ -14,7 +14,9 @@ sub new { my ($args) = @_; my $self = bless { - autobless => undef, + audit_fh => undef, + audit_file => undef, + autobless => 1, autoflush => undef, end => 0, fh => undef, @@ -27,8 +29,11 @@ sub new { 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 @@ -43,9 +48,32 @@ sub new { $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; diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index 73f3d9f..6957be8 100644 --- a/lib/DBM/Deep/Hash.pm +++ b/lib/DBM/Deep/Hash.pm @@ -47,7 +47,7 @@ sub FETCH { ? $self->_fileobj->{filter_store_key}->($_[0]) : $_[0]; - return $self->SUPER::FETCH( $key ); + return $self->SUPER::FETCH( $key, $_[0] ); } sub STORE { @@ -57,7 +57,7 @@ sub STORE { : $_[0]; my $value = $_[1]; - return $self->SUPER::STORE( $key, $value ); + return $self->SUPER::STORE( $key, $value, $_[0] ); } sub EXISTS { @@ -75,7 +75,7 @@ sub DELETE { ? $self->_fileobj->{filter_store_key}->($_[0]) : $_[0]; - return $self->SUPER::DELETE( $key ); + return $self->SUPER::DELETE( $key, $_[0] ); } sub FIRSTKEY { diff --git a/t/24_autobless.t b/t/24_autobless.t index 97aae91..9483fbd 100644 --- a/t/24_autobless.t +++ b/t/24_autobless.t @@ -121,6 +121,7 @@ my ($fh, $filename) = new_fh(); { my $db = DBM::Deep->new( file => $filename, + autobless => 0, ); my $obj = $db->{blessed}; diff --git a/t/33_transaction_commit.t b/t/33_transaction_commit.t new file mode 100644 index 0000000..a52d930 --- /dev/null +++ b/t/33_transaction_commit.t @@ -0,0 +1,47 @@ +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" ); diff --git a/t/50_audit_trail.t b/t/50_audit_trail.t new file mode 100644 index 0000000..4824226 --- /dev/null +++ b/t/50_audit_trail.t @@ -0,0 +1,201 @@ +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" ); +} +}