X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBM%2FDeep.pm;h=75aee67487b725716c521253bc1d4f5cdbe55b07;hb=86867f3a6f23efdf7c7290f5a0b7a69f5f39834f;hp=dbb9a9e2b2cd7a0d24f02f7877cad7cc42bae4c4;hpb=359a01ac3d83b1713bfee3a473d6959c21632d26;p=dbsrgits%2FDBM-Deep.git

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index dbb9a9e..75aee67 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -34,6 +34,8 @@ use 5.6.0;
 use strict;
 use warnings;
 
+our $VERSION = q(0.99_01);
+
 use Fcntl qw( :DEFAULT :flock :seek );
 use Digest::MD5 ();
 use Scalar::Util ();
@@ -41,14 +43,11 @@ 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;
@@ -335,8 +334,7 @@ sub rollback {
 
 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;
 }
 
@@ -384,14 +382,29 @@ sub _is_writable {
 
 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 {
@@ -401,41 +414,49 @@ 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);
     }
 
     ##
@@ -456,11 +477,11 @@ sub STORE {
     ##
     # 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 {
@@ -468,7 +489,7 @@ 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);
 
@@ -477,7 +498,8 @@ sub FETCH {
     ##
     $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;
@@ -486,7 +508,7 @@ sub FETCH {
     ##
     # 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();
 
@@ -501,13 +523,23 @@ sub DELETE {
     ##
     # 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
     ##
@@ -530,7 +562,7 @@ sub DELETE {
         $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,
@@ -546,8 +578,8 @@ sub EXISTS {
     ##
     # 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);
 
@@ -580,25 +612,30 @@ sub CLEAR {
     ##
     # 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,