type => TYPE_HASH,
base_offset => undef,
- parent => undef,
- parent_key => undef,
-
storage => undef,
engine => undef,
}, $class;
base_offset => $self->_base_offset,
storage => $self->_storage,
engine => $self->_engine,
- parent => $self->{parent},
- parent_key => $self->{parent_key},
);
}
die "DBM::Deep: $_[1]\n";
}
-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
- ? "\{q{$child->{parent_key}}\}"
- : "\[$child->{parent_key}\]"
- ) . $base;
-
- $child = $parent;
- $parent = $parent->{parent};
- }
-
- if ( $base ) {
- $base = "\$db->get( q{$child->{parent_key}} )->" . $base;
- }
- else {
- $base = "\$db->get( q{$child->{parent_key}} )";
- }
- }
- return $base;
-}
-
sub STORE {
##
# Store single hash key/value or array element in database.
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
- #XXX The second condition needs to disappear
- if ( !( $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 .= "->\{q{$orig_key}\}";
- }
- else {
- $lhs .= "->\[$orig_key\]";
- }
-
- $lhs .= "=$rhs;";
- }
- else {
- $lhs = "\$db->put(q{$orig_key},$rhs);";
- }
-
- $self->_storage->audit($lhs);
- }
-
##
# Request exclusive lock for writing
##
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
- if ( defined $orig_key ) {
- my $lhs = $self->_find_parent;
- if ( $lhs ) {
- $self->_storage->audit( "delete $lhs;" );
- }
- else {
- $self->_storage->audit( "\$db->delete('$orig_key');" );
- }
- }
-
##
# Request exclusive lock for writing
##
$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->_storage->audit( "$lhs = ();" );
- }
-
##
# Request exclusive lock for writing
##
open it write-only or append-only, an exception will be thrown immediately as DBM::Deep
needs to read from the fh.
-=item * audit_file / audit_fh
-
-These are just like file/fh, except for auditing. Please see L</AUDITING> for
-more information.
-
=item * file_offset
This is the offset within the file that the DBM::Deep db starts. Most of the time, you will
C<export()> methods) will result in an infinite loop. This will be fixed in
a future release.
-=head1 AUDITING
-
-New in 0.99_01 is the ability to audit your databases actions. By passing in
-audit_file (or audit_fh) to the constructor, all actions will be logged to
-that file. The format is one that is suitable for eval'ing against the
-database to replay the actions. Please see t/33_audit_trail.t for an example
-of how to do this.
-
=head1 TRANSACTIONS
New in 0.99_01 is ACID transactions. Every DBM::Deep object is completely
my ($args) = @_;
my $self = bless {
- audit_fh => undef,
- audit_file => undef,
autobless => 1,
autoflush => undef,
end => 0,
filter_store_value => undef,
filter_fetch_key => undef,
filter_fetch_value => undef,
-
- # 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,
- transaction_audit => undef,
- 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 {
- my $self = shift;
-
- unless ( $self->{base_db_obj} ) {
- $self->{base_db_obj} = shift;
- Scalar::Util::weaken( $self->{base_db_obj} );
- }
-
- return;
-}
-
sub open {
my $self = shift;
my $self = shift;
my ($obj, $type) = @_;
- #XXX This may not always be the correct thing to do
- $obj = $self->{base_db_obj} unless defined $obj;
-
$type = LOCK_EX unless defined $type;
if (!defined($self->{fh})) { return; }
return 1;
}
-sub set_transaction_offset {
- my $self = shift;
- $self->{transaction_offset} = shift;
-}
-
-sub audit {
- my $self = shift;
- my ($string) = @_;
-
- if ( my $afh = $self->{audit_fh} ) {
- flock( $afh, LOCK_EX );
-
- if ( $string =~ /^#/ ) {
- print( $afh "$string " . localtime(time) . "\n" );
- }
- else {
- print( $afh "$string # " . localtime(time) . "\n" );
- }
-
- flock( $afh, LOCK_UN );
- }
-
- if ( $self->{transaction_audit} ) {
- push @{$self->{transaction_audit}}, $string;
- }
-
- return 1;
-}
-
-sub begin_transaction {
- my $self = shift;
-
- my $fh = $self->{fh};
-
- $self->lock;
-
- my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
- my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
-
- $self->{transaction_id} = ++$next;
-
- die if $trans[-1] != 0;
-
- for ( my $i = 0; $i <= $#trans; $i++ ) {
- next if $trans[$i] != 0;
- $trans[$i] = $next;
- last;
- }
-
- $self->print_at(
- $self->{transaction_offset},
- pack( 'C C C C C C C C C C C C C C C C', $next, @trans),
- );
-
- $self->unlock;
-
- $self->{transaction_audit} = [];
-
- return $self->{transaction_id};
-}
-
-sub end_transaction {
- my $self = shift;
-
- my $fh = $self->{fh};
-
- $self->lock;
-
- my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
- my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
-
- @trans = grep { $_ != $self->{transaction_id} } @trans;
-
- $self->print_at(
- $self->{transaction_offset},
- pack( 'C C C C C C C C C C C C C C C C', $next, @trans),
- );
-
- #XXX Need to free the space used by the current transaction
-
- $self->unlock;
-
- $self->{transaction_id} = 0;
- $self->{transaction_audit} = undef;
-
-# $self->{base_db_obj}->optimize;
-# $self->{inode} = undef;
-# $self->set_inode;
-
- return 1;
-}
-
-sub current_transactions {
- my $self = shift;
-
- my $fh = $self->{fh};
-
- $self->lock;
-
- my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
- my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
-
- $self->unlock;
-
- return grep { $_ && $_ != $self->{transaction_id} } @trans;
-}
-
-sub transaction_id { return $_[0]->{transaction_id} }
-
-sub commit_transaction {
- my $self = shift;
-
- my @audit = @{$self->{transaction_audit}};
-
- $self->end_transaction;
-
- {
- my $db = $self->{base_db_obj};
- for ( @audit ) {
- eval "$_;";
- warn "$_: $@\n" if $@;
- }
- }
-
- return 1;
-}
-
1;
__END__
-
projects / dbsrgits/DBM-Deep.git / commitdiff