From: rkinyon Date: Mon, 6 Mar 2006 18:52:33 +0000 (+0000) Subject: Auditing works X-Git-Tag: 0-981_01~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7bf3680dee354534d707dd9d77b3c160e6ff6b81;p=dbsrgits%2FDBM-Deep.git Auditing works --- diff --git a/Changes b/Changes index b2f7546..3086f6b 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ Revision history for DBM::Deep. +0.981_01 Mar 06 11:00:00 2006 Pacific + - Added experimental auditlog support. This will only be released as a + developer released in the 0.x line because of the hackish nature of the + change. + 0.981 Mar 06 11:00:00 2006 Pacific - (RT#17947) - Fixed test that was failing on older Perls diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index f78a6ee..6b7197f 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -36,7 +36,7 @@ use Digest::MD5 (); use Scalar::Util (); use vars qw( $VERSION ); -$VERSION = q(0.981); +$VERSION = q(0.981_01); ## # Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file. @@ -163,7 +163,9 @@ sub _init { # These are the defaults to be optionally overridden below my $self = bless { - type => TYPE_HASH, + type => TYPE_HASH, + parent => undef, + parent_key => undef, base_offset => length(SIG_FILE), }, $class; @@ -245,6 +247,12 @@ sub _open { # 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); @@ -373,7 +381,7 @@ sub _add_bucket { # plain (undigested) key and value. ## my $self = shift; - my ($tag, $md5, $plain_key, $value) = @_; + my ($tag, $md5, $plain_key, $value, $orig_key) = @_; my $keys = $tag->{content}; my $location = 0; my $result = 2; @@ -589,6 +597,8 @@ sub _add_bucket { type => TYPE_HASH, base_offset => $location, root => $root, + parent => $self, + parent_key => $orig_key, ); foreach my $key (keys %{$value}) { $branch->STORE( $key, $value->{$key} ); @@ -599,6 +609,8 @@ sub _add_bucket { type => TYPE_ARRAY, base_offset => $location, root => $root, + parent => $self, + parent_key => $orig_key, ); my $index = 0; foreach my $element (@{$value}) { @@ -618,7 +630,7 @@ sub _get_bucket_value { # Fetch single value given tag and MD5 digested key. ## my $self = shift; - my ($tag, $md5) = @_; + my ($tag, $md5, $plain_key) = @_; my $keys = $tag->{content}; my $fh = $self->_fh; @@ -634,8 +646,7 @@ sub _get_bucket_value { if (!$subloc) { ## # Hit end of list, no match - ## - return; + ## return; } if ( $md5 ne $key ) { @@ -656,7 +667,9 @@ sub _get_bucket_value { my $obj = DBM::Deep->new( type => $signature, base_offset => $subloc, - root => $self->_root + root => $self->_root, + parent => $self, + parent_key => $plain_key, ); if ($self->_root->{autobless}) { @@ -1141,7 +1154,9 @@ sub clone { return DBM::Deep->new( type => $self->_type, base_offset => $self->_base_offset, - root => $self->_root + root => $self->_root, + parent => $self->{parent}, + parent_key => $self->{parent_key}, ); } @@ -1305,6 +1320,18 @@ sub _is_writable { # 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. @@ -1317,6 +1344,35 @@ sub STORE { 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); @@ -1376,8 +1432,8 @@ sub STORE { ## # Add key/value to bucket list ## - my $result = $self->_add_bucket( $tag, $md5, $key, $value ); - + my $result = $self->_add_bucket( $tag, $md5, $key, $value, $_[3] || $key ); + $self->unlock(); return $result; @@ -1411,7 +1467,7 @@ sub FETCH { ## # Get value from bucket list ## - my $result = $self->_get_bucket_value( $tag, $md5 ); + my $result = $self->_get_bucket_value( $tag, $md5, $key ); $self->unlock(); @@ -1451,7 +1507,7 @@ sub DELETE { ## # Delete bucket ## - my $value = $self->_get_bucket_value( $tag, $md5 ); + my $value = $self->_get_bucket_value( $tag, $md5, $key ); if ($value && !ref($value) && $self->_root->{filter_fetch_value}) { $value = $self->_root->{filter_fetch_value}->($value); } @@ -1551,6 +1607,8 @@ sub clear { (shift)->CLEAR( @_ ) } package DBM::Deep::_::Root; +use Fcntl; + sub new { my $class = shift; my ($args) = @_; @@ -1576,6 +1634,20 @@ sub new { $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; } @@ -1781,6 +1853,28 @@ not what you want. This is an optional parameter, and defaults to 0 (disabled). B: 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 diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index 4c24806..23189b9 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -76,7 +76,7 @@ sub STORE { $key = pack($DBM::Deep::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/Scalar.pm b/lib/DBM/Deep/Scalar.pm deleted file mode 100644 index 1d03e04..0000000 --- a/lib/DBM/Deep/Scalar.pm +++ /dev/null @@ -1,24 +0,0 @@ -package DBM::Deep::Scalar; - -use strict; - -use base 'DBM::Deep'; - -sub _get_self { - eval { local $SIG{'__DIE__'}; tied( ${$_[0]} ) } || $_[0] -} - -sub TIESCALAR { - ## - # Tied hash constructor method, called by Perl's tie() function. - ## - my $class = shift; - my $args = $class->_get_args( @_ ); - - $args->{type} = $class->TYPE_SCALAR; - - return $class->_init($args); -} - -1; -__END__ diff --git a/t/50_audit_trail.t b/t/50_audit_trail.t new file mode 100644 index 0000000..1042504 --- /dev/null +++ b/t/50_audit_trail.t @@ -0,0 +1,115 @@ +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" ); +}