--- /dev/null
+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__
projects / dbsrgits/DBM-Deep.git / commitdiff