From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Mon, 4 Dec 2006 02:40:00 +0000 (+0000)
Subject: Fixed how header_var was set during _read_file_header so that a validation is more... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b9ec359fe52ce81bf710c8dd25be0eed6d154d83;p=dbsrgits%2FDBM-Deep.git

Fixed how header_var was set during _read_file_header so that a validation is more appropriate
---

diff --git a/lib/DBM/Deep/Engine3.pm b/lib/DBM/Deep/Engine3.pm
index 002a005..19f0849 100644
--- a/lib/DBM/Deep/Engine3.pm
+++ b/lib/DBM/Deep/Engine3.pm
@@ -95,6 +95,9 @@ sub new {
         $self->{digest} = \&Digest::MD5::md5;
     }
 
+    #XXX HACK
+    $self->{chains_loc} = 15;
+
     return $self;
 }
 
@@ -309,7 +312,7 @@ sub _write_file_header {
     my $self = shift;
 
     my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
-    my $header_var = 1 + 1;
+    my $header_var = 1 + 1 + 2 * $self->byte_size;
 
     my $loc = $self->storage->request_space( $header_fixed + $header_var );
 
@@ -321,9 +324,13 @@ sub _write_file_header {
         # --- Above is $header_fixed. Below is $header_var
         pack('C', $self->byte_size),
         pack('C', $self->max_buckets),
+        pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
+        pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
     );
 
-    $self->storage->set_transaction_offset( 13 );
+    $self->set_chains_loc( $header_fixed + 2 );
+
+#    $self->storage->set_transaction_offset( $header_fixed );
 
     return;
 }
@@ -332,7 +339,6 @@ sub _read_file_header {
     my $self = shift;
 
     my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
-    my $header_var = 1 + 1;
 
     my $buffer = $self->storage->read_at( 0, $header_fixed );
     return unless length($buffer);
@@ -351,16 +357,13 @@ sub _read_file_header {
         DBM::Deep->_throw_error( "Old file version found." );
     }
 
-    unless ( $size eq $header_var ) {
-        $self->storage->close;
-        DBM::Deep->_throw_error( "Unexpected size found." );
-    }
-
     my $buffer2 = $self->storage->read_at( undef, $size );
     my @values = unpack( 'C C', $buffer2 );
 
+    $self->set_chains_loc( $header_fixed + 2 );
+
     # The transaction offset is the first thing after the fixed header section
-    $self->storage->set_transaction_offset( $header_fixed );
+    #$self->storage->set_transaction_offset( $header_fixed );
 
     if ( @values < 2 || grep { !defined } @values ) {
         $self->storage->close;
@@ -370,6 +373,12 @@ sub _read_file_header {
     #XXX Add warnings if values weren't set right
     @{$self}{qw(byte_size max_buckets)} = @values;
 
+    my $header_var = 1 + 1 + 2 * $self->byte_size;
+    unless ( $size eq $header_var ) {
+        $self->storage->close;
+        DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
+    }
+
     return length($buffer) + length($buffer2);
 }
 
@@ -378,6 +387,8 @@ sub _load_sector {
     my ($offset) = @_;
 
     my $type = $self->storage->read_at( $offset, 1 );
+    return if $type eq chr(0);
+
     if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
         return DBM::Deep::Engine::Sector::Reference->new({
             engine => $self,
@@ -406,6 +417,10 @@ sub _load_sector {
             offset => $offset,
         });
     }
+    # This was deleted from under us, so just return and let the caller figure it out.
+    elsif ( $type eq $self->SIG_FREE ) {
+        return;
+    }
 
     die "'$offset': Don't know what to do with type '$type'\n";
 }
@@ -418,6 +433,53 @@ sub _apply_digest {
 sub _add_free_sector {
     my $self = shift;
     my ($offset, $size) = @_;
+
+    my $chains_offset;
+    # Data sector
+    if ( $size == 256 ) {
+        $chains_offset = $self->byte_size;
+    }
+    # Blist sector
+    else {
+        $chains_offset = 0;
+    }
+
+    my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
+
+    $self->storage->print_at( $self->chains_loc + $offset,
+        pack( $StP{$self->byte_size}, $offset ),
+    );
+
+    # Record the old head in the new sector after the signature
+    $self->storage->print_at( $offset + 1, $old_head );
+}
+
+sub _request_sector {
+    my $self = shift;
+    my ($size) = @_;
+
+    my $chains_offset;
+    # Data sector
+    if ( $size == 256 ) {
+        $chains_offset = $self->byte_size;
+    }
+    # Blist sector
+    else {
+        $chains_offset = 0;
+    }
+
+    my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
+    my $loc = unpack( $StP{$self->byte_size}, $old_head );
+
+    # We don't have any free sectors of the right size, so allocate a new one.
+    unless ( $loc ) {
+        return $self->storage->request_space( $size );
+    }
+
+    my $new_head = $self->storage->read_at( $loc + 1, $self->byte_size );
+    $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
+
+    return $loc;
 }
 
 ################################################################################
@@ -430,6 +492,9 @@ sub max_buckets { $_[0]{max_buckets} }
 sub iterator    { $_[0]{iterator} }
 sub blank_md5   { chr(0) x $_[0]->hash_size }
 
+sub chains_loc     { $_[0]{chains_loc} }
+sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
+
 ################################################################################
 
 package DBM::Deep::Engine::Iterator;
@@ -463,7 +528,9 @@ sub get_next_key {
     unless ( @$crumbs ) {
         # This will be a Reference sector
         my $sector = $self->{engine}->_load_sector( $self->{base_offset} )
-            or die "Iterator: How did this fail (no sector for '$self->{base_offset}')?!\n";
+            # or die "Iterator: How did this fail (no ref sector for '$self->{base_offset}')?!\n";
+            # If no sector is found, thist must have been deleted from under us.
+            or return;
         push @$crumbs, [ $sector->get_blist_loc, 0 ];
     }
 
@@ -476,7 +543,7 @@ sub get_next_key {
         }
 
         my $sector = $self->{engine}->_load_sector( $offset )
-            or die "Iterator: How did this fail (no sector for '$offset')?!\n";
+            or die "Iterator: How did this fail (no blist sector for '$offset')?!\n";
 
         my $key_sector = $sector->get_key_for( $idx );
         unless ( $key_sector ) {
@@ -509,14 +576,16 @@ sub type   { $_[0]{type} }
 sub free {
     my $self = shift;
 
-    return;
+    $self->engine->storage->print_at( $self->offset,
+        $self->engine->SIG_FREE,
+        chr(0) x ($self->size - 1),
+    );
+
     $self->engine->_add_free_sector(
         $self->offset, $self->size,
     );
 
-    $self->engine->storage->print_at( $self->offset,
-        chr(0) x $self->size,
-    );
+    return;
 }
 
 package DBM::Deep::Engine::Sector::Data;
@@ -545,7 +614,7 @@ sub _init {
         #XXX This assumes that length($data) > $leftover
         $leftover -= length( $data );
 
-        $self->{offset} = $engine->storage->request_space( $self->size );
+        $self->{offset} = $engine->_request_sector( $self->size );
         $engine->storage->print_at( $self->offset,
             $self->type,                          # Sector type
             pack( $StP{1}, 0 ),                   # Recycled counter
@@ -592,7 +661,7 @@ sub _init {
     unless ( $self->offset ) {
         my $leftover = $self->size - 3 - 1 * $engine->byte_size;
 
-        $self->{offset} = $engine->storage->request_space( $self->size );
+        $self->{offset} = $engine->_request_sector( $self->size );
         $engine->storage->print_at( $self->offset,
             $self->type,                          # Sector type
             pack( $StP{1}, 0 ),                   # Recycled counter
@@ -617,7 +686,7 @@ sub _init {
     unless ( $self->offset ) {
         my $leftover = $self->size - 4 - 2 * $engine->byte_size;
 
-        $self->{offset} = $engine->storage->request_space( $self->size );
+        $self->{offset} = $engine->_request_sector( $self->size );
         $engine->storage->print_at( $self->offset,
             $self->type,                         # Sector type
             pack( $StP{1}, 0 ),                  # Recycled counter
@@ -700,7 +769,7 @@ sub _init {
     unless ( $self->offset ) {
         my $leftover = $self->size - $self->base_size;
 
-        $self->{offset} = $engine->storage->request_space( $self->size );
+        $self->{offset} = $engine->_request_sector( $self->size );
         $engine->storage->print_at( $self->offset,
             $engine->SIG_BLIST, # Sector type
             pack( $StP{1}, 0 ), # Recycled counter
diff --git a/t/37_delete_edge_cases.t b/t/37_delete_edge_cases.t
index 6638372..82d95ea 100644
--- a/t/37_delete_edge_cases.t
+++ b/t/37_delete_edge_cases.t
@@ -27,6 +27,6 @@ delete $db->{foo};
 
 TODO: {
     local $TODO = "Delete isn't working right";
-ok( !tied(%$x), "\$x is NOT tied" );
-cmp_deeply( $x, $x_save, "When it's deleted, it's untied" );
+    ok( !tied(%$x), "\$x is NOT tied" );
+    cmp_deeply( $x, $x_save, "When it's deleted, it's untied" );
 }
diff --git a/t/lib/Test1.pm b/t/lib/Test1.pm
deleted file mode 100644
index adfe9ba..0000000
--- a/t/lib/Test1.pm
+++ /dev/null
@@ -1,20 +0,0 @@
-package Test1;
-
-use 5.6.0;
-
-use strict;
-use warnings;
-
-use base 'TestBase';
-use base 'TestSimpleHash';
-
-#sub setup : Test(startup) {
-#    my $self = shift;
-#
-#    $self->{db} = DBM::Deep->new( $self->new_file );
-#
-#    return;
-#}
-
-1;
-__END__
diff --git a/t/lib/Test2.pm b/t/lib/Test2.pm
deleted file mode 100644
index b4cde50..0000000
--- a/t/lib/Test2.pm
+++ /dev/null
@@ -1,20 +0,0 @@
-package Test2;
-
-use 5.6.0;
-
-use strict;
-use warnings;
-
-use base 'TestBase';
-use base 'TestSimpleArray';
-
-#sub setup : Test(startup) {
-#    my $self = shift;
-#
-#    $self->{db} = DBM::Deep->new( $self->new_file );
-#
-#    return;
-#}
-
-1;
-__END__
diff --git a/t/lib/TestBase.pm b/t/lib/TestBase.pm
deleted file mode 100644
index 95ee9fb..0000000
--- a/t/lib/TestBase.pm
+++ /dev/null
@@ -1,63 +0,0 @@
-package TestBase;
-
-use 5.6.0;
-
-use strict;
-use warnings;
-
-use Fcntl qw( :flock );
-use File::Path ();
-use File::Temp ();
-use Scalar::Util ();
-
-use base 'Test::Class';
-
-use DBM::Deep;
-
-sub setup_db : Test(startup) {
-    my $self = shift;
-
-    my $data = ($self->{data} ||= {});
-
-    my $r = Scalar::Util::reftype( $data );
-    my $type = $r eq 'HASH' ? DBM::Deep->TYPE_HASH : DBM::Deep->TYPE_ARRAY;
-
-    $self->{db} = DBM::Deep->new({
-        file => $self->new_file,
-        type => $type,
-    });
-
-    return;
-}
-
-sub setup_dir : Test(startup) {
-    my $self = shift;
-
-    $self->{workdir} ||= File::Temp::tempdir();
-
-    return;
-}
-
-sub new_file {
-    my $self = shift;
-
-    $self->setup_dir;
-
-    my ($fh, $filename) = File::Temp::tempfile(
-        'tmpXXXX', DIR => $self->{workdir}, CLEANUP => 1,
-    );
-    flock( $fh, LOCK_UN );
-
-    return $filename;
-}
-
-sub remove_dir : Test(shutdown) {
-    my $self = shift;
-
-    File::Path::rmtree( $self->{workdir} );
-
-    return;
-}
-
-1;
-__END__
diff --git a/t/lib/TestSimpleArray.pm b/t/lib/TestSimpleArray.pm
deleted file mode 100644
index 1c0d55b..0000000
--- a/t/lib/TestSimpleArray.pm
+++ /dev/null
@@ -1,51 +0,0 @@
-package TestSimpleArray;
-
-use 5.6.0;
-
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Exception;
-
-use base 'TestBase';
-
-sub A_assignment : Test( 37 ) {
-    my $self = shift;
-    my $db = $self->{db};
-
-    my @keys = 0 .. $#{$self->{data}};
-
-    push @keys, $keys[0] while @keys < 5;
-
-    cmp_ok( @$db, '==', 0 );
-
-    foreach my $k ( @keys[0..4] ) {
-        ok( !exists $db->[$k] );
-        ok( !$db->exists( $k ) );
-    }
-
-    $db->[$keys[0]] = $self->{data}[$keys[1]];
-    $db->push( $self->{data}[$keys[2]] );
-    $db->put( $keys[2] => $self->{data}[$keys[3]] );
-    $db->store( $keys[3] => $self->{data}[$keys[4]] );
-    $db->unshift( $self->{data}[$keys[0]] );
-
-    foreach my $k ( @keys[0..4] ) {
-        ok( $db->exists( $k ) );
-        ok( exists $db->[$k] );
-
-        is( $db->[$k], $self->{data}[$k] );
-        is( $db->get($k), $self->{data}[$k] );
-        is( $db->fetch($k), $self->{data}[$k] );
-    }
-
-    if ( @keys > 5 ) {
-        $db->[$_] = $self->{data}[$_] for @keys[5..$#keys];
-    }
-
-    cmp_ok( @$db, '==', @keys );
-}
-
-1;
-__END__
diff --git a/t/lib/TestSimpleHash.pm b/t/lib/TestSimpleHash.pm
deleted file mode 100644
index fdfbeb0..0000000
--- a/t/lib/TestSimpleHash.pm
+++ /dev/null
@@ -1,150 +0,0 @@
-package TestSimpleHash;
-
-use 5.6.0;
-
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Exception;
-
-use base 'TestBase';
-
-sub A_assignment : Test( 23 ) {
-    my $self = shift;
-    my $db = $self->{db};
-
-    my @keys = keys %{$self->{data}};
-
-    push @keys, $keys[0] while @keys < 3;
-
-    cmp_ok( keys %$db, '==', 0 );
-
-    foreach my $k ( @keys[0..2] ) {
-        ok( !exists $db->{$k} );
-        ok( !$db->exists( $k ) );
-    }
-
-    $db->{$keys[0]} = $self->{data}{$keys[0]};
-    $db->put( $keys[1] => $self->{data}{$keys[1]} );
-    $db->store( $keys[2] => $self->{data}{$keys[2]} );
-
-    foreach my $k ( @keys[0..2] ) {
-        ok( $db->exists( $k ) );
-        ok( exists $db->{$k} );
-
-        is( $db->{$k}, $self->{data}{$k} );
-        is( $db->get($k), $self->{data}{$k} );
-        is( $db->fetch($k), $self->{data}{$k} );
-    }
-
-    if ( @keys > 3 ) {
-        $db->{$_} = $self->{data}{$_} for @keys[3..$#keys];
-    }
-
-    cmp_ok( keys %$db, '==', @keys );
-}
-
-sub B_check_keys : Test( 1 ) {
-    my $self = shift;
-    my $db = $self->{db};
-
-    my @control = sort keys %{$self->{data}};
-    my @test1 = sort keys %$db;
-    is_deeply( \@test1, \@control );
-}
-
-sub C_each : Test( 1 ) {
-    my $self = shift;
-    my $db = $self->{db};
-
-    my $temp = {};
-    while ( my ($k,$v) = each %$db ) {
-        $temp->{$k} = $v;
-    }
-
-    is_deeply( $temp, $self->{data} );
-}
-
-sub D_firstkey : Test( 1 ) {
-    my $self = shift;
-    my $db = $self->{db};
-
-    my $temp = {};
-
-    my $key = $db->first_key;
-    while ( $key ) {
-        $temp->{$key} = $db->get( $key );
-        $key = $db->next_key( $key );
-    }
-
-    is_deeply( $temp, $self->{data} );
-}
-
-sub E_delete : Test( 12 ) {
-    my $self = shift;
-    my $db = $self->{db};
-
-    my @keys = keys %{$self->{data}};
-    cmp_ok( keys %$db, '==', @keys );
-
-    my $key1 = $keys[0];
-    ok( exists $db->{$key1} );
-    is( $db->{$key1}, $self->{data}{$key1} );
-    is( delete $db->{$key1}, $self->{data}{$key1} );
-    ok( !exists $db->{$key1} );
-    cmp_ok( keys %$db, '==', @keys - 1 );
-
-    my $key2 = $keys[1];
-    ok( exists $db->{$key2} );
-    is( $db->{$key2}, $self->{data}{$key2} );
-    is( $db->delete( $key2 ), $self->{data}{$key2} );
-    ok( !exists $db->{$key2} );
-    cmp_ok( keys %$db, '==', @keys - 2 );
-
-    @{$db}{ @keys[0,1] } = @{$self->{data}}{@keys[0,1]};
-
-    cmp_ok( keys %$db, '==', @keys );
-}
-
-sub F_clear : Test( 3 ) {
-    my $self = shift;
-    my $db = $self->{db};
-
-    my @keys = keys %{$self->{data}};
-    cmp_ok( keys %$db, '==', @keys );
-
-    %$db = ();
-
-    cmp_ok( keys %$db, '==', 0 );
-
-    %$db = %{$self->{data}};
-    cmp_ok( keys %$db, '==', @keys );
-}
-
-sub G_reassign_and_close : Test( 4 ) {
-    my $self = shift;
-
-    my @keys = keys %{$self->{data}};
-
-    my $key1 = $keys[0];
-
-    my $long_value = 'long value' x 100;
-    $self->{db}{$key1} = $long_value;
-    is( $self->{db}{$key1}, $long_value );
-
-    my $filename = $self->{db}->_root->{file};
-    undef $self->{db};
-
-    $self->{db} = DBM::Deep->new( $filename );
-
-    is( $self->{db}{$key1}, $long_value );
-
-    $self->{db}{$key1} = $self->{data}{$key1};
-    is( $self->{db}{$key1}, $self->{data}{$key1} );
-
-    cmp_ok( keys %{$self->{db}}, '==', @keys );
-}
-
-1;
-__END__
diff --git a/t/run.t b/t/run.t
deleted file mode 100644
index cdd89f3..0000000
--- a/t/run.t
+++ /dev/null
@@ -1,37 +0,0 @@
-use 5.6.0;
-
-use strict;
-use warnings;
-
-use lib 't/lib';
-
-use DBM::Deep;
-
-use Test1;
-use Test2;
-
-my $test1 = Test1->new(
-    data => {
-        key1 => 'value1',
-        key2 => undef,
-        key3 => 1.23,
-    },
-);
-
-my %test2;
-$test2{"key $_"} = "value $_" for 1 .. 4000;
-
-my $test2 = Test1->new(
-    data => \%test2,
-);
-
-my $test3 = Test2->new(
-    data => [
-        1 .. 5,
-    ],
-);
-
-Test::Class->runtests(
-    $test1,
-    $test3,
-);