Autovivification of references now works

diff --git a/lib/DBM/Deep/Engine3.pm b/lib/DBM/Deep/Engine3.pm
index 6013ce4..8193daf 100644 (file)
--- a/lib/DBM/Deep/Engine3.pm
+++ b/lib/DBM/Deep/Engine3.pm
@@ -5,6 +5,7 @@ use 5.6.0;
 use strict;
 
 our $VERSION = q(0.99_03);
+our $DEBUG = 0;
 
 use Scalar::Util ();
 
@@ -102,17 +103,18 @@ sub new {
 sub read_value {
     my $self = shift;
     my ($trans_id, $base_offset, $key) = @_;
+    print "read_value( $trans_id, $base_offset, $key )\n" if $DEBUG;
 
     # This will be a Reference sector
     my $sector = $self->_load_sector( $base_offset )
-        or die "How did this fail (no sector for '$base_offset')?!\n";
+        or die "How did read_value fail (no sector for '$base_offset')?!\n";
 
     my $key_md5 = $self->_apply_digest( $key );
 
     # XXX What should happen if this fails?
     my $blist = $sector->get_bucket_list({
         key_md5 => $key_md5,
-    }) or die "How did this fail (no blist)?!\n";
+    }) or die "How did read_value fail (no blist)?!\n";
 
     my $value_sector = $blist->get_data_for( $key_md5 );
     if ( !$value_sector ) {
@@ -131,17 +133,18 @@ sub read_value {
 sub key_exists {
     my $self = shift;
     my ($trans_id, $base_offset, $key) = @_;
+    print "key_exists( $trans_id, $base_offset, $key )\n" if $DEBUG;
 
     # This will be a Reference sector
     my $sector = $self->_load_sector( $base_offset )
-        or die "How did this fail (no sector for '$base_offset')?!\n";
+        or die "How did key_exists fail (no sector for '$base_offset')?!\n";
 
     my $key_md5 = $self->_apply_digest( $key );
 
     # XXX What should happen if this fails?
     my $blist = $sector->get_bucket_list({
         key_md5 => $key_md5,
-    }) or die "How did this fail (no blist)?!\n";
+    }) or die "How did key_exists fail (no blist)?!\n";
 
     # exists() returns 1 or '' for true/false.
     return $blist->has_md5( $key_md5 ) ? 1 : '';
@@ -150,16 +153,17 @@ sub key_exists {
 sub delete_key {
     my $self = shift;
     my ($trans_id, $base_offset, $key) = @_;
+    print "delete_key( $trans_id, $base_offset, $key )\n" if $DEBUG;
 
     my $sector = $self->_load_sector( $base_offset )
-        or die "How did this fail (no sector for '$base_offset')?!\n";
+        or die "How did delete_key fail (no sector for '$base_offset')?!\n";
 
     my $key_md5 = $self->_apply_digest( $key );
 
     # XXX What should happen if this fails?
     my $blist = $sector->get_bucket_list({
         key_md5 => $key_md5,
-    }) or die "How did this fail (no blist)?!\n";
+    }) or die "How did delete_key fail (no blist)?!\n";
 
     return $blist->delete_md5( $key_md5 );
 }
@@ -167,10 +171,11 @@ sub delete_key {
 sub write_value {
     my $self = shift;
     my ($trans_id, $base_offset, $key, $value) = @_;
+    print "write_value( $trans_id, $base_offset, $key, $value )\n" if $DEBUG;
 
     # This will be a Reference sector
     my $sector = $self->_load_sector( $base_offset )
-        or die "How did this fail (no sector for '$base_offset')?!\n";
+        or die "How did write_value fail (no sector for '$base_offset')?!\n";
 
     my $key_md5 = $self->_apply_digest( $key );
 
@@ -178,12 +183,17 @@ sub write_value {
     my $blist = $sector->get_bucket_list({
         key_md5 => $key_md5,
         create  => 1,
-    }) or die "How did this fail (no blist)?!\n";
+    }) or die "How did write_value fail (no blist)?!\n";
 
-    my $class;
+    my $r = Scalar::Util::reftype( $value ) || '';
+    my ($class, $type);
     if ( !defined $value ) {
         $class = 'DBM::Deep::Engine::Sector::Null';
     }
+    elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
+        $class = 'DBM::Deep::Engine::Sector::Reference';
+        $type = $r eq 'ARRAY' ? 'A' : 'H';
+    }
     else {
         $class = 'DBM::Deep::Engine::Sector::Scalar';
     }
@@ -191,9 +201,33 @@ sub write_value {
     my $value_sector = $class->new({
         engine => $self,
         data   => $value,
+        type   => $type,
     });
 
     $blist->write_md5( $key_md5, $key, $value_sector->offset );
+
+    # This code is to make sure we write all the values in the $value to the disk
+    # and to make sure all changes to $value are reflected on disk.
+    if ( $r eq 'ARRAY' ) {
+        my @x = @$value;
+        tie @$value, 'DBM::Deep', {
+            base_offset => $value_sector->offset,
+            storage     => $self->storage,
+        };
+        @$value = @x;
+        bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
+    }
+    elsif ( $r eq 'HASH' ) {
+        my %x = %$value;
+        tie %$value, 'DBM::Deep', {
+            base_offset => $value_sector->offset,
+            storage     => $self->storage,
+        };
+        %$value = %x;
+        bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
+    }
+
+    return 1;
 }
 
 sub get_next_key {
@@ -261,12 +295,15 @@ sub setup_fh {
         # Reading from an existing file
         else {
             $obj->{base_offset} = $bytes_read;
-            my $tag = $self->_load_tag($obj->_base_offset);
-            unless ( $tag ) {
+            my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
+                engine => $self,
+                offset => $obj->_base_offset,
+            });
+            unless ( $initial_reference ) {
                 DBM::Deep->_throw_error("Corrupted file, no master index record");
             }
 
-            unless ($obj->_type eq $tag->{signature}) {
+            unless ($obj->_type eq $initial_reference->type) {
                 DBM::Deep->_throw_error("File type mismatch");
             }
         }
@@ -284,7 +321,7 @@ sub _write_file_header {
     my $self = shift;
 
     my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
-    my $header_var = 16 + 1 + 1;
+    my $header_var = 1 + 1;
 
     my $loc = $self->storage->request_space( $header_fixed + $header_var );
 
@@ -294,9 +331,8 @@ sub _write_file_header {
         pack('N', 1),  # header version - at this point, we're at 9 bytes
         pack('N', $header_var), # header size
         # --- Above is $header_fixed. Below is $header_var
-        pack('N4', 0, 0, 0, 0),  # currently running transaction IDs
-        pack('n', $self->byte_size),
-        pack('n', $self->max_buckets),
+        pack('C', $self->byte_size),
+        pack('C', $self->max_buckets),
     );
 
     $self->storage->set_transaction_offset( 13 );
@@ -308,7 +344,7 @@ sub _read_file_header {
     my $self = shift;
 
     my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
-    my $header_var = 16 + 1 + 1;
+    my $header_var = 1 + 1;
 
     my $buffer = $self->storage->read_at( 0, $header_fixed );
     return unless length($buffer);
@@ -333,8 +369,7 @@ sub _read_file_header {
     }
 
     my $buffer2 = $self->storage->read_at( undef, $size );
-    # $a1-4 are the transaction IDs
-    my ($a1, $a2, $a3, $a4, @values) = unpack( 'N4 n n', $buffer2 );
+    my @values = unpack( 'C C', $buffer2 );
 
     # The transaction offset is the first thing after the fixed header section
     $self->storage->set_transaction_offset( $header_fixed );
@@ -528,6 +563,10 @@ sub _init {
 
         return;
     }
+
+    $self->{type} = $engine->storage->read_at( $self->offset, 1 );
+
+    return;
 }
 
 sub get_blist_loc {
@@ -577,6 +616,18 @@ sub get_first_key {
 sub get_key_after {
 }
 
+sub data {
+    my $self = shift;
+
+    my $new_obj = DBM::Deep->new({
+        type        => $self->type,
+        base_offset => $self->offset,
+        storage     => $self->engine->storage,
+    });
+
+    return $new_obj;
+}
+
 package DBM::Deep::Engine::Sector::BucketList;
 
 our @ISA = qw( DBM::Deep::Engine::Sector );

diff --git a/t/02_hash.t b/t/02_hash.t
index 89a421b..83ba854 100644 (file)
--- a/t/02_hash.t
+++ b/t/02_hash.t
@@ -81,7 +81,7 @@ is( $db->delete("key1"), 'value1', "delete through OO inteface works" );
 is( $db->{key3}, 'value3', "The other key is still there" );
 ok( !exists $db->{key1}, "key1 doesn't exist" );
 ok( !exists $db->{key2}, "key2 doesn't exist" );
-__END__
+=pod
 is( scalar keys %$db, 1, "After deleting two keys, 1 remains" );
 
 ##
@@ -90,7 +90,7 @@ is( scalar keys %$db, 1, "After deleting two keys, 1 remains" );
 ok( $db->clear(), "clear() returns true" );
 
 is( scalar keys %$db, 0, "After clear(), everything is removed" );
-
+=cut
 ##
 # replace key
 ##
@@ -101,7 +101,6 @@ $db->put("key1", "value2");
 is( $db->get("key1"), "value2", "... and replacement works" );
 
 $db->put("key1", "value222222222222222222222222");
-
 is( $db->get("key1"), "value222222222222222222222222", "We set a value before closing the file" );
 
 ##
@@ -110,7 +109,7 @@ is( $db->get("key1"), "value222222222222222222222222", "We set a value before cl
 undef $db;
 $db = DBM::Deep->new( $filename );
 is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" );
-
+=pod
 ##
 # Make sure keys are still fetchable after replacing values
 # with smaller ones (bug found by John Cardenas, DBM::Deep 0.93)
@@ -131,9 +130,9 @@ ok(
     ($first_key ne $next_key)
     ,"keys() still works if you replace long values with shorter ones"
 );
-
+=cut
 # Test autovivification
 
 $db->{unknown}{bar} = 1;
-ok( $db->{unknown}, 'Autovivified value exists' );
+ok( $db->{unknown}, 'Autovivified hash exists' );
 cmp_ok( $db->{unknown}{bar}, '==', 1, 'And the value stored is there' );