use strict;
use warnings;
+our $VERSION = q(0.99_01);
+
use Fcntl qw( :DEFAULT :flock :seek );
use Digest::MD5 ();
use Scalar::Util ();
use DBM::Deep::Engine;
use DBM::Deep::File;
-use vars qw( $VERSION );
-$VERSION = q(0.99_01);
-
##
# Setup constants for users to pass to new()
##
-sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH }
-sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY }
+sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH }
+sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY }
sub _get_args {
my $proto = shift;
sub commit {
my $self = shift->_get_self;
- # At this point, we need to replay the actions taken
- $self->_fileobj->end_transaction;
+ $self->_fileobj->commit_transaction;
return 1;
}
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}\}";
+
+ my $base = '';
+ #XXX This if() is redundant
+ if ( my $parent = $self->{parent} ) {
+ my $child = $self;
+ while ( $parent->{parent} ) {
+ $base = (
+ $parent->_type eq TYPE_HASH
+ ? "\{$child->{parent_key}\}"
+ : "\[$child->{parent_key}\]"
+ ) . $base;
+
+ $child = $parent;
+ $parent = $parent->{parent};
+ }
+ if ( $base ) {
+ $base = "\$db->get( '$child->{parent_key}' )->" . $base;
+ }
+ else {
+ $base = "\$db->get( '$child->{parent_key}' )";
}
- return $base . "\[$self->{parent_key}\]";
}
- return '$db->';
+ return $base;
}
sub STORE {
my $self = shift->_get_self;
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\]";
- }
+ #XXX The second condition needs to disappear
+ if ( defined $orig_key && !( $self->_type eq TYPE_ARRAY && $orig_key eq 'length') ) {
+ my $rhs;
- 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";
+ }
- my $r = Scalar::Util::reftype( $value ) || '';
- if ( $r eq 'HASH' ) {
- $rhs = '{}';
- }
- elsif ( $r eq 'ARRAY' ) {
- $rhs = '[]';
+ 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 .= "->\{$orig_key\}";
}
else {
- $rhs = "'$value'";
+ $lhs .= "->\[$orig_key\]";
}
- 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 );
+ $lhs .= "=$rhs;";
+ }
+ else {
+ $lhs = "\$db->put('$orig_key',$rhs);";
}
+
+ $self->_fileobj->audit($lhs);
}
##
##
# Add key/value to bucket list
##
- my $result = $self->{engine}->add_bucket( $tag, $md5, $key, $value, undef, $orig_key );
+ $self->{engine}->add_bucket( $tag, $md5, $key, $value, undef, $orig_key );
$self->unlock();
- return $result;
+ return 1;
}
sub FETCH {
# Fetch single value or element given plain key or array index
##
my $self = shift->_get_self;
- my ($key) = @_;
+ my ($key, $orig_key) = @_;
my $md5 = $self->{engine}{digest}->($key);
##
$self->lock( LOCK_SH );
- my $tag = $self->{engine}->find_bucket_list( $self->_base_offset, $md5 );
+ my $tag = $self->{engine}->find_bucket_list( $self->_base_offset, $md5 );#, { create => 1 } );
+ #XXX This needs to autovivify
if (!$tag) {
$self->unlock();
return;
##
# Get value from bucket list
##
- my $result = $self->{engine}->get_bucket_value( $tag, $md5 );
+ my $result = $self->{engine}->get_bucket_value( $tag, $md5, $orig_key );
$self->unlock();
##
# Delete single key/value pair or element given plain key or array index
##
- my $self = $_[0]->_get_self;
- my $key = $_[1];
+ my $self = shift->_get_self;
+ my ($key, $orig_key) = @_;
if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
+ if ( defined $orig_key ) {
+ my $lhs = $self->_find_parent;
+ if ( $lhs ) {
+ $self->_fileobj->audit( "delete $lhs;" );
+ }
+ else {
+ $self->_fileobj->audit( "\$db->delete('$orig_key');" );
+ }
+ }
+
##
# Request exclusive lock for writing
##
$value = $self->_fileobj->{filter_fetch_value}->($value);
}
- my $result = $self->{engine}->delete_bucket( $tag, $md5 );
+ my $result = $self->{engine}->delete_bucket( $tag, $md5, $orig_key );
##
# If this object is an array and the key deleted was on the end of the stack,
##
# Check if a single key or element exists given plain key or array index
##
- my $self = $_[0]->_get_self;
- my $key = $_[1];
+ my $self = shift->_get_self;
+ my ($key) = @_;
my $md5 = $self->{engine}{digest}->($key);
##
# Clear all keys from hash, or all elements from array.
##
- my $self = $_[0]->_get_self;
+ my $self = shift->_get_self;
if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
$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->_fileobj->audit( "$lhs = ();" );
+ }
+
##
# Request exclusive lock for writing
##
$self->lock( LOCK_EX );
- my $fh = $self->_fh;
-
- seek($fh, $self->_base_offset + $self->_fileobj->{file_offset}, SEEK_SET);
- if (eof $fh) {
- $self->unlock();
- return;
- }
-
#XXX This needs updating to use _release_space
$self->{engine}->write_tag(
$self->_base_offset, $self->_type,
projects / dbsrgits/DBM-Deep.git / blobdiff