From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Sat, 18 Nov 2006 05:24:04 +0000 (+0000)
Subject: We pass test 1 for a new engine
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=696cadb7b9526d0b215a30e41a7c03c122e3914c;p=dbsrgits%2FDBM-Deep.git

We pass test 1 for a new engine
---

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 29ead30..de806c3 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -43,15 +43,16 @@ use Digest::MD5 ();
 use FileHandle::Fmode ();
 use Scalar::Util ();
 
-use DBM::Deep::Engine2;
+use DBM::Deep::Engine3;
 use DBM::Deep::File;
 
 ##
 # Setup constants for users to pass to new()
 ##
-sub TYPE_HASH   () { DBM::Deep::Engine2->SIG_HASH  }
-sub TYPE_ARRAY  () { DBM::Deep::Engine2->SIG_ARRAY }
+sub TYPE_HASH   () { DBM::Deep::Engine3->SIG_HASH  }
+sub TYPE_ARRAY  () { DBM::Deep::Engine3->SIG_ARRAY }
 
+# This is used in all the children of this class in their TIE<type> methods.
 sub _get_args {
     my $proto = shift;
 
@@ -124,7 +125,7 @@ sub _init {
 
         storage     => undef,
     }, $class;
-    $self->{engine} = DBM::Deep::Engine2->new( { %{$args}, obj => $self } );
+    $self->{engine} = DBM::Deep::Engine3->new( { %{$args}, obj => $self } );
 
     # Grab the parameters we want to use
     foreach my $param ( keys %$self ) {
@@ -132,9 +133,16 @@ sub _init {
         $self->{$param} = $args->{$param};
     }
 
-    $self->_engine->setup_fh( $self );
-
-    $self->_storage->set_db( $self );
+    eval {
+      local $SIG{'__DIE__'};
+      $self->lock;
+      $self->_engine->setup_fh( $self );
+      $self->unlock;
+    }; if ( $@ ) {
+      my $e = $@;
+      eval { local $SIG{'__DIE__'}; $self->unlock; };
+      die $e;
+    }
 
     return $self;
 }
diff --git a/lib/DBM/Deep/Engine3.pm b/lib/DBM/Deep/Engine3.pm
new file mode 100644
index 0000000..8f89364
--- /dev/null
+++ b/lib/DBM/Deep/Engine3.pm
@@ -0,0 +1,301 @@
+package DBM::Deep::Engine3;
+
+use 5.6.0;
+
+use strict;
+
+our $VERSION = q(0.99_03);
+
+use Digest::MD5 ();
+use Scalar::Util ();
+
+# File-wide notes:
+# * Every method in here assumes that the _storage 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.
+sub SIG_FILE     () { 'DPDB' }
+sub SIG_HEADER   () { 'h'    }
+sub SIG_INTERNAL () { 'i'    }
+sub SIG_HASH     () { 'H'    }
+sub SIG_ARRAY    () { 'A'    }
+sub SIG_NULL     () { 'N'    }
+sub SIG_DATA     () { 'D'    }
+sub SIG_INDEX    () { 'I'    }
+sub SIG_BLIST    () { 'B'    }
+sub SIG_FREE     () { 'F'    }
+sub SIG_KEYS     () { 'K'    }
+sub SIG_SIZE     () {  1     }
+
+# This is the transaction ID for the HEAD
+sub HEAD () { 0 }
+
+################################################################################
+
+sub new {
+    my $class = shift;
+    my ($args) = @_;
+
+    my $self = bless {
+        long_size   => 4,
+        long_pack   => 'N',
+        data_size   => 4,
+        data_pack   => 'N',
+
+        digest      => \&Digest::MD5::md5,
+        hash_size   => 16, # In bytes
+        max_buckets => 16,
+
+        storage => undef,
+        obj     => undef,
+    }, $class;
+
+    if ( defined $args->{pack_size} ) {
+        if ( lc $args->{pack_size} eq 'small' ) {
+            $args->{long_size} = 2;
+            $args->{long_pack} = 'n';
+        }
+        elsif ( lc $args->{pack_size} eq 'medium' ) {
+            $args->{long_size} = 4;
+            $args->{long_pack} = 'N';
+        }
+        elsif ( lc $args->{pack_size} eq 'large' ) {
+            $args->{long_size} = 8;
+            $args->{long_pack} = 'Q';
+        }
+        else {
+            die "Unknown pack_size value: '$args->{pack_size}'\n";
+        }
+    }
+
+    # Grab the parameters we want to use
+    foreach my $param ( keys %$self ) {
+        next unless exists $args->{$param};
+        $self->{$param} = $args->{$param};
+    }
+    Scalar::Util::weaken( $self->{obj} ) if $self->{obj};
+
+    ##
+    # 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.
+    ##
+    if ( $self->{max_buckets} < 16 ) {
+        warn "Floor of max_buckets is 16. Setting it to 16 from '$self->{max_buckets}'\n";
+        $self->{max_buckets} = 16;
+    }
+
+    return $self;
+}
+
+################################################################################
+
+sub read_value {
+    my $self = shift;
+    my ($trans_id, $base_offset, $key) = @_;
+}
+
+sub key_exists {
+    my $self = shift;
+    my ($trans_id, $base_offset, $key) = @_;
+}
+
+sub delete_key {
+    my $self = shift;
+    my ($trans_id, $base_offset, $key) = @_;
+}
+
+sub write_value {
+    my $self = shift;
+    my ($trans_id, $base_offset, $key, $value) = @_;
+}
+
+sub get_next_key {
+    my $self = shift;
+    my ($trans_id, $base_offset) = @_;
+}
+
+################################################################################
+
+sub setup_fh {
+    my $self = shift;
+    my ($obj) = @_;
+
+    # We're opening the file.
+    unless ( $obj->_base_offset ) {
+        print "1\n";
+        my $bytes_read = $self->_read_file_header;
+        $self->_calculate_sizes;
+
+        # Creating a new file
+        unless ( $bytes_read ) {
+            $self->_write_file_header;
+            $obj->{base_offset} = $self->_storage->request_space(
+                $self->_tag_size( $self->{index_size} ),
+            );
+
+            $self->_write_tag(
+                $obj->_base_offset, $obj->_type,
+                chr(0) x $self->{index_size},
+            );
+
+            $self->_storage->flush;
+        }
+        # Reading from an existing file
+        else {
+            $obj->{base_offset} = $bytes_read;
+            my $tag = $self->_load_tag($obj->_base_offset);
+            unless ( $tag ) {
+                DBM::Deep->_throw_error("Corrupted file, no master index record");
+            }
+
+            unless ($obj->_type eq $tag->{signature}) {
+                DBM::Deep->_throw_error("File type mismatch");
+            }
+        }
+    }
+    else {
+        $self->_calculate_sizes;
+    }
+
+    #XXX We have to make sure we don't mess up when autoflush isn't turned on
+    $self->_storage->set_inode;
+
+    return 1;
+}
+
+################################################################################
+
+sub _calculate_sizes {
+    my $self = shift;
+
+    # The 2**8 here indicates the number of different characters in the
+    # current hashing algorithm
+    #XXX Does this need to be updated with different hashing algorithms?
+    $self->{hash_chars_used}  = (2**8);
+    $self->{index_size}       = $self->{hash_chars_used} * $self->{long_size};
+
+    $self->{bucket_size}      = $self->{hash_size} + $self->{long_size} * 2;
+    $self->{bucket_list_size} = $self->{max_buckets} * $self->{bucket_size};
+
+    $self->{key_size}         = $self->{long_size} * 2;
+    $self->{keyloc_size}      = $self->{max_buckets} * $self->{key_size};
+
+    return;
+}
+
+sub _write_file_header {
+    my $self = shift;
+
+    my $loc = $self->_storage->request_space( length( SIG_FILE ) + 33 );
+
+    $self->_storage->print_at( $loc,
+        SIG_FILE,
+        SIG_HEADER,
+        pack('N', 1),  # header version
+        pack('N', 24), # header size
+        pack('N4', 0, 0, 0, 0),  # currently running transaction IDs
+        pack('n', $self->{long_size}),
+        pack('A', $self->{long_pack}),
+        pack('n', $self->{data_size}),
+        pack('A', $self->{data_pack}),
+        pack('n', $self->{max_buckets}),
+    );
+
+    $self->_storage->set_transaction_offset( 13 );
+
+    return;
+}
+
+sub _read_file_header {
+    my $self = shift;
+
+    my $buffer = $self->_storage->read_at( 0, length(SIG_FILE) + 9 );
+    return unless length($buffer);
+
+    my ($file_signature, $sig_header, $header_version, $size) = unpack(
+        'A4 A N N', $buffer
+    );
+
+    unless ( $file_signature eq SIG_FILE ) {
+        $self->_storage->close;
+        DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
+    }
+
+    unless ( $sig_header eq SIG_HEADER ) {
+        $self->_storage->close;
+        DBM::Deep->_throw_error( "Old file version found." );
+    }
+
+    my $buffer2 = $self->_storage->read_at( undef, $size );
+    # $a1-4 are the transaction IDs
+    my ($a1, $a2, $a3, $a4, @values) = unpack( 'N4 n A n A n', $buffer2 );
+
+    $self->_storage->set_transaction_offset( 13 );
+
+    if ( @values < 5 || grep { !defined } @values ) {
+        $self->_storage->close;
+        DBM::Deep->_throw_error("Corrupted file - bad header");
+    }
+
+    #XXX Add warnings if values weren't set right
+    @{$self}{qw(long_size long_pack data_size data_pack max_buckets)} = @values;
+
+    return length($buffer) + length($buffer2);
+}
+
+sub _write_tag {
+    my $self = shift;
+    my ($offset, $sig, $content) = @_;
+    my $size = length( $content );
+
+    $self->_storage->print_at(
+        $offset, 
+        $sig, pack($self->{data_pack}, $size), $content,
+    );
+
+    return unless defined $offset;
+
+    return {
+        signature => $sig,
+        start     => $offset,
+        offset    => $offset + SIG_SIZE + $self->{data_size},
+        content   => $content,
+        is_new    => 1,
+    };
+}
+
+sub _load_tag {
+    my $self = shift;
+    my ($offset) = @_;
+    my $storage = $self->_storage;
+
+    my ($sig, $size) = unpack(
+        "A $self->{data_pack}",
+        $storage->read_at( $offset, SIG_SIZE + $self->{data_size} ),
+    );
+
+    return {
+        signature => $sig,
+        start     => $offset,
+        offset    => $offset + SIG_SIZE + $self->{data_size},
+        content   => $storage->read_at( undef, $size ),
+        is_new    => 0,
+    };
+}
+
+sub _tag_size {
+    my $self = shift;
+    my ($size) = @_;
+    return SIG_SIZE + $self->{data_size} + $size;
+}
+
+################################################################################
+
+sub _storage { $_[0]{storage} }
+
+1;
+__END__
diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index 2edf202..8303834 100644
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -276,6 +276,17 @@ sub unlock {
     return;
 }
 
+sub flush {
+    my $self = shift;
+
+    # Flush the filehandle
+    my $old_fh = select $self->{fh};
+    my $old_af = $|; $| = 1; $| = $old_af;
+    select $old_fh;
+
+    return 1;
+}
+
 sub set_transaction_offset {
     my $self = shift;
     $self->{transaction_offset} = shift;
diff --git a/t/01_basic.t b/t/01_basic.t
index 3c7e88d..7025ea9 100644
--- a/t/01_basic.t
+++ b/t/01_basic.t
@@ -20,7 +20,7 @@ my $db = eval {
 };
 if ( $@ ) {
 	diag "ERROR: $@";
-    Test::More->builder->BAIL_OUT( "Opening a new file fails" );
+    Test::More->builder->BAIL_OUT( "Opening a new file fails." );
 }
 
 isa_ok( $db, 'DBM::Deep' );