From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Thu, 25 May 2006 18:21:43 +0000 (+0000)
Subject:  r13304@rob-kinyons-powerbook58:  rob | 2006-05-18 15:10:48 -0400
X-Git-Tag: 0-99_03~32
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c3aafc1482fc010410a0dbe2b09b95307cf9f747;p=dbsrgits%2FDBM-Deep.git

 r13304@rob-kinyons-powerbook58:  rob | 2006-05-18 15:10:48 -0400
 Worked out the new API
---

diff --git a/API_Change.txt b/API_Change.txt
new file mode 100644
index 0000000..02722fd
--- /dev/null
+++ b/API_Change.txt
@@ -0,0 +1,56 @@
+# These are the calls into ::Engine
+::Deep:
+    _init:
+        setup_fh($self)
+    optimize:
+        setup_fh($self)
+    STORE:
+        old:
+            apply_digest($key)
+            find_blist( $self->_base_offset, $md5, { create => 1 } )
+            add_bucket( $tag, $md5, $key, $value, undef, $orig_key )
+        new:
+            write_value( $key, $value );
+    FETCH:
+        old:
+            apply_digest($key)
+            find_blist( $self->_base_offset, $md5 )
+            get_bucket_value( $tag, $md5, $orig_key )
+        new:
+            read_value( $key )
+    DELETE:
+        old:
+            apply_digest($key)
+            find_blist( $self->_base_offset, $md5 )
+            get_bucket_value( $tag, $md5, $orig_key )
+            delete_bucket( $tag, $md5, $orig_key )
+        new:
+            delete_key( $key )
+    EXiSTS:
+        old:
+            apply_digest($key)
+            find_blist( $self->_base_offset, $md5 )
+            bucket_exists( $tag, $md5 )
+        new:
+            exists_key( $key )
+    CLEAR:
+        old:
+            apply_digest($key)
+            find_blist( $self->_base_offset, $md5 )
+            delete_bucket( $tag, $md5, $key )
+        new:
+            delete_key( $key )
+::Array:
+::Hash:
+    FIRSTKEY:
+        old:
+            get_next_key($self)
+        new:
+            get_next_key()
+    NEXTKEY:
+        old:
+            apply_digest($prev_key)
+            get_next_key($self, $prev_md5)
+        new:
+            get_next_key($prev_key)
+::File:
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index ccaac7f..e740135 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -134,7 +134,7 @@ sub _init {
 
     $self->_engine->setup_fh( $self );
 
-    $self->{fileobj}->set_db( $self );
+    $self->_fileobj->set_db( $self );
 
     return $self;
 }
@@ -317,9 +317,11 @@ sub clone {
     my $self = shift->_get_self;
 
     return DBM::Deep->new(
-        type => $self->_type,
+        type        => $self->_type,
         base_offset => $self->_base_offset,
-        fileobj => $self->_fileobj,
+        fileobj     => $self->_fileobj,
+        parent      => $self->{parent},
+        parent_key  => $self->{parent_key},
     );
 }
 
@@ -350,20 +352,17 @@ sub clone {
 
 sub begin_work {
     my $self = shift->_get_self;
-    $self->_fileobj->begin_transaction;
-    return 1;
+    return $self->_fileobj->begin_transaction;
 }
 
 sub rollback {
     my $self = shift->_get_self;
-    $self->_fileobj->end_transaction;
-    return 1;
+    return $self->_fileobj->end_transaction;
 }
 
 sub commit {
     my $self = shift->_get_self;
-    $self->_fileobj->commit_transaction;
-    return 1;
+    return $self->_fileobj->commit_transaction;
 }
 
 ##
@@ -436,13 +435,14 @@ sub STORE {
     ##
     my $self = shift->_get_self;
     my ($key, $value, $orig_key) = @_;
+    $orig_key = $key unless defined $orig_key;
 
     if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
         $self->_throw_error( 'Cannot write to a readonly filehandle' );
     }
 
     #XXX The second condition needs to disappear
-    if ( defined $orig_key && !( $self->_type eq TYPE_ARRAY && $orig_key eq 'length') ) {
+    if ( !( $self->_type eq TYPE_ARRAY && $orig_key eq 'length') ) {
         my $rhs;
 
         my $r = Scalar::Util::reftype( $value ) || '';
@@ -486,10 +486,6 @@ sub STORE {
     ##
     $self->lock( LOCK_EX );
 
-    my $md5 = $self->_engine->{digest}->($key);
-
-    my $tag = $self->_engine->find_blist( $self->_base_offset, $md5, { create => 1 } );
-
     # User may be storing a hash, in which case we do not want it run
     # through the filtering system
     if ( !ref($value) && $self->_fileobj->{filter_store_value} ) {
@@ -499,7 +495,10 @@ sub STORE {
     ##
     # Add key/value to bucket list
     ##
-    $self->_engine->add_bucket( $tag, $md5, $key, $value, undef, $orig_key ); 
+#    my $md5 = $self->_engine->apply_digest($key);
+#    my $tag = $self->_engine->find_blist( $self->_base_offset, $md5, { create => 1 } );
+#    $self->_engine->add_bucket( $tag, $md5, $key, $value, undef, $orig_key ); 
+    $self->_engine->write_value( $self->_base_offset, $key, $value, $orig_key );
 
     $self->unlock();
 
@@ -512,8 +511,9 @@ sub FETCH {
     ##
     my $self = shift->_get_self;
     my ($key, $orig_key) = @_;
+    $orig_key = $key unless @_ > 1;
 
-    my $md5 = $self->_engine->{digest}->($key);
+    my $md5 = $self->_engine->apply_digest($key);
 
     ##
     # Request shared lock for reading
@@ -547,6 +547,7 @@ sub DELETE {
     ##
     my $self = shift->_get_self;
     my ($key, $orig_key) = @_;
+    $orig_key = $key unless defined $orig_key;
 
     if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
         $self->_throw_error( 'Cannot write to a readonly filehandle' );
@@ -567,7 +568,7 @@ sub DELETE {
     ##
     $self->lock( LOCK_EX );
 
-    my $md5 = $self->_engine->{digest}->($key);
+    my $md5 = $self->_engine->apply_digest($key);
 
     my $tag = $self->_engine->find_blist( $self->_base_offset, $md5 );
     if (!$tag) {
@@ -603,7 +604,7 @@ sub EXISTS {
     my $self = shift->_get_self;
     my ($key) = @_;
 
-    my $md5 = $self->_engine->{digest}->($key);
+    my $md5 = $self->_engine->apply_digest($key);
 
     ##
     # Request shared lock for reading
@@ -662,7 +663,7 @@ sub CLEAR {
         my $key = $self->first_key;
         while ( $key ) {
             my $next_key = $self->next_key( $key );
-            my $md5 = $self->_engine->{digest}->($key);
+            my $md5 = $self->_engine->apply_digest($key);
             my $tag = $self->_engine->find_blist( $self->_base_offset, $md5 );
             $self->_engine->delete_bucket( $tag, $md5, $key );
             $key = $next_key;
@@ -670,8 +671,8 @@ sub CLEAR {
     }
     else {
         my $size = $self->FETCHSIZE;
-        for my $key ( map { pack ( $self->_engine->{long_pack}, $_ ) } 0 .. $size - 1 ) {
-            my $md5 = $self->_engine->{digest}->($key);
+        for my $key ( 0 .. $size - 1 ) {
+            my $md5 = $self->_engine->apply_digest($key);
             my $tag = $self->_engine->find_blist( $self->_base_offset, $md5 );
             $self->_engine->delete_bucket( $tag, $md5, $key );
         }
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index ae8dba8..74dad6c 100644
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -5,7 +5,7 @@ use 5.6.0;
 use strict;
 use warnings;
 
-our $VERSION = '0.99_01';
+our $VERSION = '0.99_03';
 
 # This is to allow DBM::Deep::Array to handle negative indices on
 # its own. Otherwise, Perl would intercept the call to negative
@@ -50,8 +50,7 @@ sub FETCH {
 
     $self->lock( $self->LOCK_SH );
 
-#    my $orig_key = $key eq 'length' ? undef : $key;
-    my $orig_key = $key;
+    my $orig_key;
     if ( $key =~ /^-?\d+$/ ) {
         if ( $key < 0 ) {
             $key += $self->FETCHSIZE;
@@ -60,8 +59,10 @@ sub FETCH {
                 return;
             }
         }
-
-        $key = pack($self->_engine->{long_pack}, $key);
+        $orig_key = $key;
+    }
+    else {
+        $orig_key = undef;
     }
 
     my $rv = $self->SUPER::FETCH( $key, $orig_key );
@@ -77,30 +78,25 @@ sub STORE {
 
     $self->lock( $self->LOCK_EX );
 
-#    my $orig = $key eq 'length' ? undef : $key;
-    my $orig_key = $key;
-
     my $size;
-    my $numeric_idx;
+    my $idx_is_numeric;
     if ( $key =~ /^\-?\d+$/ ) {
-        $numeric_idx = 1;
+        $idx_is_numeric = 1;
         if ( $key < 0 ) {
             $size = $self->FETCHSIZE;
-            $key += $size;
-            if ( $key < 0 ) {
-                die( "Modification of non-creatable array value attempted, subscript $orig_key" );
+            if ( $key + $size < 0 ) {
+                die( "Modification of non-creatable array value attempted, subscript $key" );
             }
+            $key += $size
         }
-
-        $key = pack($self->_engine->{long_pack}, $key);
     }
 
-    my $rv = $self->SUPER::STORE( $key, $value, $orig_key );
+    my $rv = $self->SUPER::STORE( $key, $value, ($key eq 'length' ? undef : $key) );
 
-    if ( $numeric_idx ) {
+    if ( $idx_is_numeric ) {
         $size = $self->FETCHSIZE unless defined $size;
-        if ( $orig_key >= $size ) {
-            $self->STORESIZE( $orig_key + 1 );
+        if ( $key >= $size ) {
+            $self->STORESIZE( $key + 1 );
         }
     }
 
@@ -123,8 +119,6 @@ sub EXISTS {
                 return;
             }
         }
-
-        $key = pack($self->_engine->{long_pack}, $key);
     }
 
     my $rv = $self->SUPER::EXISTS( $key );
@@ -138,9 +132,6 @@ sub DELETE {
     my $self = shift->_get_self;
     my ($key) = @_;
 
-    my $unpacked_key = $key;
-    my $orig = $key eq 'length' ? undef : $key;
-
     $self->lock( $self->LOCK_EX );
 
     my $size = $self->FETCHSIZE;
@@ -152,14 +143,12 @@ sub DELETE {
                 return;
             }
         }
-
-        $key = pack($self->_engine->{long_pack}, $key);
     }
 
-    my $rv = $self->SUPER::DELETE( $key, $orig );
+    my $rv = $self->SUPER::DELETE( $key );
 
-    if ($rv && $unpacked_key == $size - 1) {
-        $self->STORESIZE( $unpacked_key );
+    if ($rv && $key == $size - 1) {
+        $self->STORESIZE( $key, ($key eq 'length' ? undef : $key) );
     }
 
     $self->unlock;
diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index 94be351..13976e8 100644
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -5,7 +5,7 @@ use 5.6.0;
 use strict;
 use warnings;
 
-our $VERSION = q(0.99_01);
+our $VERSION = q(0.99_03);
 
 use Fcntl qw( :DEFAULT :flock );
 use Scalar::Util ();
@@ -15,6 +15,11 @@ use Scalar::Util ();
 #   - calculate_sizes()
 #   - _get_key_subloc()
 #   - add_bucket() - where the buckets are printed
+#
+# * Every method in here assumes that the _fileobj has been appropriately
+#   safeguarded. This can be anything from flock() to some sort of manual
+#   mutex. But, it's the caller's responsability to make sure that this has
+#   been done.
 
 ##
 # Setup file and tag signatures.  These should never change.
@@ -32,6 +37,61 @@ sub SIG_FREE     () { 'F'    }
 sub SIG_KEYS     () { 'K'    }
 sub SIG_SIZE     () {  1     }
 
+################################################################################
+#
+# This is new code. It is a complete rewrite of the engine based on a new API
+#
+################################################################################
+
+sub write_value {
+    my $self = shift;
+    my ($offset, $key, $value, $orig_key) = @_;
+
+    my $dig_key = $self->apply_digest( $key );
+    my $tag = $self->find_blist( $offset, $dig_key, { create => 1 } );
+    return $self->add_bucket( $tag, $dig_key, $key, $value, undef, $orig_key );
+}
+
+sub read_value {
+    my $self = shift;
+    my ($offset, $key) = @_;
+
+    my $dig_key = $self->apply_digest( $key );
+    my $tag = $self->find_blist( $offset, $dig_key );
+    return $self->get_bucket_value( $tag, $dig_key, $key );
+}
+
+sub delete_key {
+    my $self = shift;
+    my ($offset, $key) = @_;
+
+    my $dig_key = $self->apply_digest( $key );
+    my $tag = $self->find_blist( $offset, $dig_key );
+    return $self->delete_bucket( $tag, $dig_key, $key );
+}
+
+sub key_exists {
+    my $self = shift;
+    my ($offset, $key) = @_;
+
+    my $dig_key = $self->apply_digest( $key );
+    my $tag = $self->find_blist( $offset, $dig_key );
+    return $self->bucket_exists( $tag, $dig_key, $key );
+}
+
+sub XXXget_next_key {
+    my $self = shift;
+    my ($offset, $prev_key) = @_;
+
+#    my $dig_key = $self->apply_digest( $key );
+}
+
+################################################################################
+#
+# Below here is the old code. It will be folded into the code above as it can.
+#
+################################################################################
+
 sub new {
     my $class = shift;
     my ($args) = @_;
@@ -43,10 +103,10 @@ sub new {
         data_pack => 'N',
 
         digest    => \&Digest::MD5::md5,
-        hash_size => 16,
+        hash_size => 16, # In bytes
 
         ##
-        # Maximum number of buckets per blist before another level of indexing is
+        # Number of buckets per blist before another level of indexing is
         # done. Increase this value for slightly greater speed, but larger database
         # files. DO NOT decrease this value below 16, due to risk of recursive
         # reindex overrun.
@@ -92,6 +152,11 @@ sub new {
 
 sub _fileobj { return $_[0]{fileobj} }
 
+sub apply_digest {
+    my $self = shift;
+    return $self->{digest}->(@_);
+}
+
 sub calculate_sizes {
     my $self = shift;
 
@@ -281,8 +346,7 @@ sub load_tag {
 
     return {
         signature => $sig,
-        #XXX Is this even used?
-        size      => $size,
+        size      => $size,   #XXX Is this even used?
         offset    => $offset + SIG_SIZE + $self->{data_size},
         content   => $fileobj->read_at( undef, $size ),
     };
@@ -366,7 +430,7 @@ sub add_bucket {
                         pack($self->{long_pack}, $location2 ),
                         pack( 'C C', $trans_id, 0 ),
                     );
-                    $self->write_value( $location2, $plain_key, $old_value, $orig_key );
+                    $self->_write_value( $location2, $plain_key, $old_value, $orig_key );
                 }
             }
         }
@@ -412,12 +476,12 @@ sub add_bucket {
         }
     }
 
-    $self->write_value( $location, $plain_key, $value, $orig_key );
+    $self->_write_value( $location, $plain_key, $value, $orig_key );
 
     return 1;
 }
 
-sub write_value {
+sub _write_value {
     my $self = shift;
     my ($location, $key, $value, $orig_key) = @_;
 
@@ -594,6 +658,7 @@ sub read_from_loc {
     # If value is a hash or array, return new DBM::Deep object with correct offset
     ##
     if (($signature eq SIG_HASH) || ($signature eq SIG_ARRAY)) {
+        #XXX This needs to be a singleton
         my $new_obj = DBM::Deep->new({
             type        => $signature,
             base_offset => $subloc,
@@ -726,7 +791,7 @@ sub delete_bucket {
                     pack($self->{long_pack}, $location2 ),
                     pack( 'C C', $trans_id, 0 ),
                 );
-                $self->write_value( $location2, $orig_key, $value, $orig_key );
+                $self->_write_value( $location2, $orig_key, $value, $orig_key );
             }
         }
 
diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index be03615..6b70adb 100644
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -5,7 +5,7 @@ use 5.6.0;
 use strict;
 use warnings;
 
-our $VERSION = q(0.99_01);
+our $VERSION = q(0.99_03);
 
 use Fcntl qw( :DEFAULT :flock :seek );
 
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index b9a00cd..a50be1c 100644
--- a/lib/DBM/Deep/Hash.pm
+++ b/lib/DBM/Deep/Hash.pm
@@ -5,7 +5,7 @@ use 5.6.0;
 use strict;
 use warnings;
 
-our $VERSION = q(0.99_01);
+our $VERSION = q(0.99_03);
 
 use base 'DBM::Deep';
 
@@ -111,7 +111,7 @@ sub NEXTKEY {
         ? $self->_fileobj->{filter_store_key}->($_[0])
         : $_[0];
 
-	my $prev_md5 = $self->_engine->{digest}->($prev_key);
+	my $prev_md5 = $self->_engine->apply_digest($prev_key);
 
 	##
 	# Request shared lock for reading