X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBM%2FDeep%2FEngine.pm;h=663a0f09ed14814538637eee875dce5c75941ef1;hb=e9b0b5f026035a56f53cecda0126cb62bc1da3da;hp=fccd820e2a88763941b820c5040ddd8573aba726;hpb=69c949803c6f2cc07ba31a687b860dd9d899ff3f;p=dbsrgits%2FDBM-Deep.git diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index fccd820..663a0f0 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -1,929 +1,1946 @@ package DBM::Deep::Engine; +use 5.006_000; + use strict; +use warnings; + +our $VERSION = q(1.0000); -use Fcntl qw( :DEFAULT :flock :seek ); +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_INTERNAL () { 'i' } +sub SIG_HEADER () { 'h' } sub SIG_HASH () { 'H' } sub SIG_ARRAY () { 'A' } -sub SIG_SCALAR () { 'S' } sub SIG_NULL () { 'N' } sub SIG_DATA () { 'D' } sub SIG_INDEX () { 'I' } sub SIG_BLIST () { 'B' } +sub SIG_FREE () { 'F' } sub SIG_SIZE () { 1 } -sub precalc_sizes { - ## - # Precalculate index, bucket and bucket list sizes - ## - my $self = shift; +my $STALE_SIZE = 2; - $self->{index_size} = (2**8) * $self->{long_size}; - $self->{bucket_size} = $self->{hash_size} + $self->{long_size}; - $self->{bucket_list_size} = $self->{max_buckets} * $self->{bucket_size}; +# Please refer to the pack() documentation for further information +my %StP = ( + 1 => 'C', # Unsigned char value (no order needed as it's just one byte) + 2 => 'n', # Unsigned short in "network" (big-endian) order + 4 => 'N', # Unsigned long in "network" (big-endian) order + 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) +); - return 1; -} +################################################################################ -sub set_pack { - ## - # Set pack/unpack modes (see file header for more) - ## - my $self = shift; - my ($long_s, $long_p, $data_s, $data_p) = @_; +sub new { + my $class = shift; + my ($args) = @_; - ## - # Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 - # GB per file. - # (Perl must be compiled with largefile support for files > 2 GB) - # - # Set to 8 and 'Q' for 64-bit offsets. Theoretical limit of 16 XB per file. - # (Perl must be compiled with largefile and 64-bit long support) - ## - $self->{long_size} = $long_s ? $long_s : 4; - $self->{long_pack} = $long_p ? $long_p : 'N'; + my $self = bless { + byte_size => 4, - ## - # Set to 4 and 'N' for 32-bit data length prefixes. Limit of 4 GB for each - # key/value. Upgrading this is possible (see above) but probably not necessary. - # If you need more than 4 GB for a single key or value, this module is really - # not for you :-) - ## - $self->{data_size} = $data_s ? $data_s : 4; - $self->{data_pack} = $data_p ? $data_p : 'N'; + digest => undef, + hash_size => 16, # In bytes + hash_chars => 256, # Number of chars the algorithm uses per byte + max_buckets => 16, + num_txns => 1, # The HEAD + trans_id => 0, # Default to the HEAD - return $self->precalc_sizes(); -} + data_sector_size => 64, # Size in bytes of each data sector -sub set_digest { - ## - # Set key digest function (default is MD5) - ## - my $self = shift; - my ($digest_func, $hash_size) = @_; + entries => {}, # This is the list of entries for transactions + storage => undef, + }, $class; - $self->{digest} = $digest_func ? $digest_func : \&Digest::MD5::md5; - $self->{hash_size} = $hash_size ? $hash_size : 16; + # Never allow byte_size to be set directly. + delete $args->{byte_size}; + if ( defined $args->{pack_size} ) { + if ( lc $args->{pack_size} eq 'small' ) { + $args->{byte_size} = 2; + } + elsif ( lc $args->{pack_size} eq 'medium' ) { + $args->{byte_size} = 4; + } + elsif ( lc $args->{pack_size} eq 'large' ) { + $args->{byte_size} = 8; + } + else { + DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" ); + } + } - return $self->precalc_sizes(); -} + # Grab the parameters we want to use + foreach my $param ( keys %$self ) { + next unless exists $args->{$param}; + $self->{$param} = $args->{$param}; + } -sub new { - my $class = shift; - my ($args) = @_; + my %validations = ( + max_buckets => { floor => 16, ceil => 256 }, + num_txns => { floor => 1, ceil => 255 }, + data_sector_size => { floor => 32, ceil => 256 }, + ); - my $self = bless { - long_size => 4, - long_pack => 'N', - data_size => 4, - data_pack => 'N', - - digest => \&Digest::MD5::md5, - hash_size => 16, - - ## - # Maximum number of buckets per list 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. - ## - max_buckets => 16, - }, $class; + while ( my ($attr, $c) = each %validations ) { + if ( !defined $self->{$attr} + || !length $self->{$attr} + || $self->{$attr} =~ /\D/ + || $self->{$attr} < $c->{floor} + ) { + $self->{$attr} = '(undef)' if !defined $self->{$attr}; + warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n"; + $self->{$attr} = $c->{floor}; + } + elsif ( $self->{$attr} > $c->{ceil} ) { + warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n"; + $self->{$attr} = $c->{ceil}; + } + } - $self->precalc_sizes; + if ( !$self->{digest} ) { + require Digest::MD5; + $self->{digest} = \&Digest::MD5::md5; + } return $self; } -sub setup_fh { +################################################################################ + +sub read_value { my $self = shift; - my ($obj) = @_; + my ($obj, $key) = @_; - $self->open( $obj ) if !defined $obj->_fh; + # This will be a Reference sector + my $sector = $self->_load_sector( $obj->_base_offset ) + or return; - #XXX We have to make sure we don't mess up when autoflush isn't turned on - unless ( $obj->_root->{inode} ) { - my @stats = stat($obj->_fh); - $obj->_root->{inode} = $stats[1]; - $obj->_root->{end} = $stats[7]; + if ( $sector->staleness != $obj->_staleness ) { + return; } - return 1; + my $key_md5 = $self->_apply_digest( $key ); + + my $value_sector = $sector->get_data_for({ + key_md5 => $key_md5, + allow_head => 1, + }); + + unless ( $value_sector ) { + $value_sector = DBM::Deep::Engine::Sector::Null->new({ + engine => $self, + data => undef, + }); + + $sector->write_data({ + key_md5 => $key_md5, + key => $key, + value => $value_sector, + }); + } + + return $value_sector->data; } -sub open { - ## - # Open a fh to the database, create if nonexistent. - # Make sure file signature matches DBM::Deep spec. - ## +sub get_classname { my $self = shift; my ($obj) = @_; - if (defined($obj->_fh)) { $self->close_fh( $obj ); } + # This will be a Reference sector + my $sector = $self->_load_sector( $obj->_base_offset ) + or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" ); + + if ( $sector->staleness != $obj->_staleness ) { + return; + } - # Theoretically, adding O_BINARY should remove the need for the binmode - # Of course, testing it is going to be ... interesting. - my $flags = O_RDWR | O_CREAT | O_BINARY; + return $sector->get_classname; +} - my $fh; - sysopen( $fh, $obj->_root->{file}, $flags ) - or $obj->_throw_error("Cannot sysopen file: " . $obj->_root->{file} . ": $!"); - $obj->_root->{fh} = $fh; +sub key_exists { + my $self = shift; + my ($obj, $key) = @_; - #XXX Can we remove this by using the right sysopen() flags? - # Maybe ... q.v. above - binmode $fh; # for win32 + # This will be a Reference sector + my $sector = $self->_load_sector( $obj->_base_offset ) + or return ''; - if ($obj->_root->{autoflush}) { - my $old = select $fh; - $|=1; - select $old; + if ( $sector->staleness != $obj->_staleness ) { + return ''; } - seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET); + my $data = $sector->get_data_for({ + key_md5 => $self->_apply_digest( $key ), + allow_head => 1, + }); + + # exists() returns 1 or '' for true/false. + return $data ? 1 : ''; +} + +sub delete_key { + my $self = shift; + my ($obj, $key) = @_; + + my $sector = $self->_load_sector( $obj->_base_offset ) + or return; - my $signature; - my $bytes_read = read( $fh, $signature, length(SIG_FILE)); + if ( $sector->staleness != $obj->_staleness ) { + return; + } - ## - # File is empty -- write signature and master index - ## - if (!$bytes_read) { - seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET); - print( $fh SIG_FILE); + return $sector->delete_key({ + key_md5 => $self->_apply_digest( $key ), + allow_head => 0, + }); +} - $self->create_tag($obj, $obj->_base_offset, $obj->_type, chr(0) x $self->{index_size}); +sub write_value { + my $self = shift; + my ($obj, $key, $value) = @_; - # Flush the filehandle - my $old_fh = select $fh; - my $old_af = $|; $| = 1; $| = $old_af; - select $old_fh; + my $r = Scalar::Util::reftype( $value ) || ''; + { + last if $r eq ''; + last if $r eq 'HASH'; + last if $r eq 'ARRAY'; - return 1; + DBM::Deep->_throw_error( + "Storage of references of type '$r' is not supported." + ); } - ## - # Check signature was valid - ## - unless ($signature eq SIG_FILE) { - $self->close_fh( $obj ); - $obj->_throw_error("Signature not found -- file is not a Deep DB"); + my ($class, $type); + if ( !defined $value ) { + $class = 'DBM::Deep::Engine::Sector::Null'; + } + elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) { + if ( $r eq 'ARRAY' && tied(@$value) ) { + DBM::Deep->_throw_error( "Cannot store something that is tied." ); + } + if ( $r eq 'HASH' && tied(%$value) ) { + DBM::Deep->_throw_error( "Cannot store something that is tied." ); + } + $class = 'DBM::Deep::Engine::Sector::Reference'; + $type = substr( $r, 0, 1 ); + } + else { + $class = 'DBM::Deep::Engine::Sector::Scalar'; } - ## - # Get our type from master index signature - ## - my $tag = $self->load_tag($obj, $obj->_base_offset) - or $obj->_throw_error("Corrupted file, no master index record"); + # This will be a Reference sector + my $sector = $self->_load_sector( $obj->_base_offset ) + or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." ); - unless ($obj->{type} eq $tag->{signature}) { - $obj->_throw_error("File type mismatch"); + if ( $sector->staleness != $obj->_staleness ) { + DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep.n" ); } -#XXX We probably also want to store the hash algorithm name and not assume anything -#XXX The cool thing would be to allow a different hashing algorithm at every level + # Create this after loading the reference sector in case something bad happens. + # This way, we won't allocate value sector(s) needlessly. + my $value_sector = $class->new({ + engine => $self, + data => $value, + type => $type, + }); + + $sector->write_data({ + key => $key, + key_md5 => $self->_apply_digest( $key ), + value => $value_sector, + }); + + # 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 after the assignment are reflected + # on disk. This may be counter-intuitive at first, but it is correct dwimmery. + # NOTE - simply tying $value won't perform a STORE on each value. Hence, the + # copy to a temp value. + if ( $r eq 'ARRAY' ) { + my @temp = @$value; + tie @$value, 'DBM::Deep', { + base_offset => $value_sector->offset, + staleness => $value_sector->staleness, + storage => $self->storage, + engine => $self, + }; + @$value = @temp; + bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value ); + } + elsif ( $r eq 'HASH' ) { + my %temp = %$value; + tie %$value, 'DBM::Deep', { + base_offset => $value_sector->offset, + staleness => $value_sector->staleness, + storage => $self->storage, + engine => $self, + }; + + %$value = %temp; + bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value ); + } return 1; } -sub close_fh { +# XXX Add staleness here +sub get_next_key { + my $self = shift; + my ($obj, $prev_key) = @_; + + # XXX Need to add logic about resetting the iterator if any key in the reference has changed + unless ( $prev_key ) { + $obj->{iterator} = DBM::Deep::Iterator->new({ + base_offset => $obj->_base_offset, + engine => $self, + }); + } + + return $obj->{iterator}->get_next_key( $obj ); +} + +################################################################################ + +sub setup_fh { my $self = shift; my ($obj) = @_; - if ( my $fh = $obj->_root->{fh} ) { - close $fh; + # We're opening the file. + unless ( $obj->_base_offset ) { + my $bytes_read = $self->_read_file_header; + + # Creating a new file + unless ( $bytes_read ) { + $self->_write_file_header; + + # 1) Create Array/Hash entry + my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({ + engine => $self, + type => $obj->_type, + }); + $obj->{base_offset} = $initial_reference->offset; + $obj->{staleness} = $initial_reference->staleness; + + $self->storage->flush; + } + # Reading from an existing file + else { + $obj->{base_offset} = $bytes_read; + 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 $initial_reference->type) { + DBM::Deep->_throw_error("File type mismatch"); + } + + $obj->{staleness} = $initial_reference->staleness; + } } - $obj->_root->{fh} = undef; return 1; } -sub create_tag { - ## - # Given offset, signature and content, create tag and write to disk - ## +sub begin_work { my $self = shift; - my ($obj, $offset, $sig, $content) = @_; - my $size = length($content); + my ($obj) = @_; + + if ( $self->trans_id ) { + DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" ); + } - my $fh = $obj->_fh; + my @slots = $self->read_txn_slots; + my $found; + for my $i ( 0 .. $#slots ) { + next if $slots[$i]; - seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET); - print( $fh $sig . pack($self->{data_pack}, $size) . $content ); + $slots[$i] = 1; + $self->set_trans_id( $i + 1 ); + $found = 1; + last; + } + unless ( $found ) { + DBM::Deep->_throw_error( "Cannot allocate transaction ID" ); + } + $self->write_txn_slots( @slots ); - if ($offset == $obj->_root->{end}) { - $obj->_root->{end} += SIG_SIZE + $self->{data_size} + $size; + if ( !$self->trans_id ) { + DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" ); } - return { - signature => $sig, - size => $size, - offset => $offset + SIG_SIZE + $self->{data_size}, - content => $content - }; + return; } -sub load_tag { - ## - # Given offset, load single tag and return signature, size and data - ## +sub rollback { my $self = shift; - my ($obj, $offset) = @_; - - my $fh = $obj->_fh; + my ($obj) = @_; - seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET); + if ( !$self->trans_id ) { + DBM::Deep->_throw_error( "Cannot rollback without an active transaction" ); + } - #XXX I'm not sure this check will work if autoflush isn't enabled ... - return if eof $fh; + # Each entry is the file location for a bucket that has a modification for + # this transaction. The entries need to be expunged. + foreach my $entry (@{ $self->get_entries } ) { + # Remove the entry here + my $read_loc = $entry + + $self->hash_size + + $self->byte_size + + $self->byte_size + + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE ); + + my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size ); + $data_loc = unpack( $StP{$self->byte_size}, $data_loc ); + $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) ); + + if ( $data_loc > 1 ) { + $self->_load_sector( $data_loc )->free; + } + } - my $b; - read( $fh, $b, SIG_SIZE + $self->{data_size} ); - my ($sig, $size) = unpack( "A $self->{data_pack}", $b ); + $self->clear_entries; - my $buffer; - read( $fh, $buffer, $size); + my @slots = $self->read_txn_slots; + $slots[$self->trans_id-1] = 0; + $self->write_txn_slots( @slots ); + $self->inc_txn_staleness_counter( $self->trans_id ); + $self->set_trans_id( 0 ); - return { - signature => $sig, - size => $size, - offset => $offset + SIG_SIZE + $self->{data_size}, - content => $buffer - }; + return 1; } -sub add_bucket { - ## - # Adds one key/value pair to bucket list, given offset, MD5 digest of key, - # plain (undigested) key and value. - ## +sub commit { my $self = shift; - my ($obj, $tag, $md5, $plain_key, $value) = @_; + my ($obj) = @_; - my $keys = $tag->{content}; - my $location = 0; - my $result = 2; + if ( !$self->trans_id ) { + DBM::Deep->_throw_error( "Cannot commit without an active transaction" ); + } - my $root = $obj->_root; + foreach my $entry (@{ $self->get_entries } ) { + # Overwrite the entry in head with the entry in trans_id + my $base = $entry + + $self->hash_size + + $self->byte_size; - my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep' ) }; - my $internal_ref = $is_dbm_deep && ($value->_root eq $root); + my $head_loc = $self->storage->read_at( $base, $self->byte_size ); + $head_loc = unpack( $StP{$self->byte_size}, $head_loc ); - my $fh = $obj->_fh; + my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE ); + my $trans_loc = $self->storage->read_at( + $spot, $self->byte_size, + ); - ## - # Iterate through buckets, seeing if this is a new entry or a replace. - ## - BUCKET: - for (my $i = 0; $i < $self->{max_buckets}; $i++) { - my ($key, $subloc) = $self->_get_key_subloc( $keys, $i ); + $self->storage->print_at( $base, $trans_loc ); + $self->storage->print_at( + $spot, + pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ), + ); - if (!$subloc) { - ## - # Found empty bucket (end of list). Populate and exit loop. - ## - $result = 2; + if ( $head_loc > 1 ) { + $self->_load_sector( $head_loc )->free; + } + } - $location = $root->{end}; + $self->clear_entries; - seek( - $fh, - $tag->{offset} + ($i * $self->{bucket_size}) + $root->{file_offset}, - SEEK_SET, - ); + my @slots = $self->read_txn_slots; + $slots[$self->trans_id-1] = 0; + $self->write_txn_slots( @slots ); + $self->inc_txn_staleness_counter( $self->trans_id ); + $self->set_trans_id( 0 ); - print( $fh $md5 . pack($self->{long_pack}, $location) ); - last; - } + return 1; +} - if ( $md5 ne $key ) { - next BUCKET; - } +sub read_txn_slots { + my $self = shift; + my $bl = $self->txn_bitfield_len; + my $num_bits = $bl * 8; + return split '', unpack( 'b'.$num_bits, + $self->storage->read_at( + $self->trans_loc, $bl, + ) + ); +} - ## - # Found existing bucket with same key. Replace with new value. - ## - $result = 1; +sub write_txn_slots { + my $self = shift; + my $num_bits = $self->txn_bitfield_len * 8; + $self->storage->print_at( $self->trans_loc, + pack( 'b'.$num_bits, join('', @_) ), + ); +} - seek($fh, $subloc + SIG_SIZE + $root->{file_offset}, SEEK_SET); - my $size; - read( $fh, $size, $self->{data_size}); - $size = unpack($self->{data_pack}, $size); +sub get_running_txn_ids { + my $self = shift; + my @transactions = $self->read_txn_slots; + my @trans_ids = map { $_+1} grep { $transactions[$_] } 0 .. $#transactions; +} - ## - # If value is a hash, array, or raw value with equal or less size, we can - # reuse the same content area of the database. Otherwise, we have to create - # a new content area at the EOF. - ## - my $actual_length; - if ( $internal_ref ) { - $actual_length = $self->{long_size}; - } - else { - my $r = Scalar::Util::reftype( $value ) || ''; - if ( $r eq 'HASH' || $r eq 'ARRAY' ) { - $actual_length = $self->{index_size}; - - # if autobless is enabled, must also take into consideration - # the class name, as it is stored along with key/value. - if ( $root->{autobless} ) { - my $value_class = Scalar::Util::blessed($value); - if ( defined $value_class && !$value->isa('DBM::Deep') ) { - $actual_length += length($value_class); - } - } - } - else { $actual_length = length($value); } - } +sub get_txn_staleness_counter { + my $self = shift; + my ($trans_id) = @_; - if ($actual_length <= $size) { - $location = $subloc; - } - else { - $location = $root->{end}; - seek( - $fh, - $tag->{offset} + ($i * $self->{bucket_size}) + $self->{hash_size} + $root->{file_offset}, - SEEK_SET, - ); - print( $fh pack($self->{long_pack}, $location) ); - } + # Hardcode staleness of 0 for the HEAD + return 0 unless $trans_id; - last; - } + return unpack( $StP{$STALE_SIZE}, + $self->storage->read_at( + $self->trans_loc + 4 + $STALE_SIZE * ($trans_id - 1), + 4, + ) + ); +} - ## - # If bucket didn't fit into list, split into a new index level - ## - if (!$location) { - $self->split_index( $obj, $md5, $tag ); +sub inc_txn_staleness_counter { + my $self = shift; + my ($trans_id) = @_; - $location = $root->{end}; - } + # Hardcode staleness of 0 for the HEAD + return unless $trans_id; - ## - # Seek to content area and store signature, value and plaintext key - ## - if ($location) { - seek($fh, $location + $root->{file_offset}, SEEK_SET); + $self->storage->print_at( + $self->trans_loc + 4 + $STALE_SIZE * ($trans_id - 1), + pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ), + ); +} - ## - # Write signature based on content type, set content length and write - # actual value. - ## - my $r = Scalar::Util::reftype($value) || ''; - my $content_length; - if ( $internal_ref ) { - print( $fh SIG_INTERNAL ); - print( $fh pack($self->{data_pack}, $self->{long_size}) ); - print( $fh pack($self->{long_pack}, $value->_base_offset) ); - $content_length = $self->{long_size}; - } - else { - if ($r eq 'HASH') { - print( $fh SIG_HASH ); - print( $fh pack($self->{data_pack}, $self->{index_size}) . chr(0) x $self->{index_size} ); - $content_length = $self->{index_size}; - } - elsif ($r eq 'ARRAY') { - print( $fh SIG_ARRAY ); - print( $fh pack($self->{data_pack}, $self->{index_size}) . chr(0) x $self->{index_size} ); - $content_length = $self->{index_size}; - } - elsif (!defined($value)) { - print( $fh SIG_NULL ); - print( $fh pack($self->{data_pack}, 0) ); - $content_length = 0; - } - else { - print( $fh SIG_DATA ); - print( $fh pack($self->{data_pack}, length($value)) . $value ); - $content_length = length($value); - } - } +sub get_entries { + my $self = shift; + return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ]; +} - ## - # Plain key is stored AFTER value, as keys are typically fetched less often. - ## - print( $fh pack($self->{data_pack}, length($plain_key)) . $plain_key ); - - ## - # If value is blessed, preserve class name - ## - if ( $root->{autobless} ) { - my $value_class = Scalar::Util::blessed($value); - if ( defined $value_class && !$value->isa( 'DBM::Deep' ) ) { - ## - # Blessed ref -- will restore later - ## - print( $fh chr(1) ); - print( $fh pack($self->{data_pack}, length($value_class)) . $value_class ); - $content_length += 1; - $content_length += $self->{data_size} + length($value_class); - } - else { - print( $fh chr(0) ); - $content_length += 1; - } - } +sub add_entry { + my $self = shift; + my ($trans_id, $loc) = @_; - ## - # If this is a new content area, advance EOF counter - ## - if ($location == $root->{end}) { - $root->{end} += SIG_SIZE; - $root->{end} += $self->{data_size} + $content_length; - $root->{end} += $self->{data_size} + length($plain_key); - } - - ## - # If content is a hash or array, create new child DBM::Deep object and - # pass each key or element to it. - ## - if ( ! $internal_ref ) { - if ($r eq 'HASH') { - my $branch = DBM::Deep->new( - type => DBM::Deep->TYPE_HASH, - base_offset => $location, - root => $root, - ); - foreach my $key (keys %{$value}) { - $branch->STORE( $key, $value->{$key} ); - } - } - elsif ($r eq 'ARRAY') { - my $branch = DBM::Deep->new( - type => DBM::Deep->TYPE_ARRAY, - base_offset => $location, - root => $root, - ); - my $index = 0; - foreach my $element (@{$value}) { - $branch->STORE( $index, $element ); - $index++; - } + $self->{entries}{$trans_id} ||= {}; + $self->{entries}{$trans_id}{$loc} = undef; +} + +# If the buckets are being relocated because of a reindexing, the entries +# mechanism needs to be made aware of it. +sub reindex_entry { + my $self = shift; + my ($old_loc, $new_loc) = @_; + + TRANS: + while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) { + foreach my $orig_loc ( keys %{ $locs } ) { + if ( $orig_loc == $old_loc ) { + delete $locs->{orig_loc}; + $locs->{$new_loc} = undef; + next TRANS; } } - - return $result; } - - $obj->_throw_error("Fatal error: indexing failed -- possibly due to corruption in file"); } -sub split_index { +sub clear_entries { my $self = shift; - my ($obj, $md5, $tag) = @_; + delete $self->{entries}{$self->trans_id}; +} - my $fh = $obj->_fh; - my $root = $obj->_root; - my $keys = $tag->{content}; +################################################################################ - seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET); - print( $fh pack($self->{long_pack}, $root->{end}) ); +{ + my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4; + my $this_file_version = 2; - my $index_tag = $self->create_tag( - $obj, - $root->{end}, - SIG_INDEX, - chr(0) x $self->{index_size}, - ); + sub _write_file_header { + my $self = shift; - my @offsets = (); + my $nt = $self->num_txns; + my $bl = $self->txn_bitfield_len; - $keys .= $md5 . pack($self->{long_pack}, 0); + my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size; - BUCKET: - for (my $i = 0; $i <= $self->{max_buckets}; $i++) { - my ($key, $old_subloc) = $self->_get_key_subloc( $keys, $i ); + my $loc = $self->storage->request_space( $header_fixed + $header_var ); - next BUCKET unless $key; + $self->storage->print_at( $loc, + SIG_FILE, + SIG_HEADER, + pack('N', $this_file_version), # At this point, we're at 9 bytes + pack('N', $header_var), # header size + # --- Above is $header_fixed. Below is $header_var + pack('C', $self->byte_size), - my $num = ord(substr($key, $tag->{ch} + 1, 1)); + # These shenanigans are to allow a 256 within a C + pack('C', $self->max_buckets - 1), + pack('C', $self->data_sector_size - 1), - if ($offsets[$num]) { - my $offset = $offsets[$num] + SIG_SIZE + $self->{data_size}; - seek($fh, $offset + $root->{file_offset}, SEEK_SET); - my $subkeys; - read( $fh, $subkeys, $self->{bucket_list_size}); + pack('C', $nt), + pack('C' . $bl, 0 ), # Transaction activeness bitfield + pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters + pack($StP{$self->byte_size}, 0), # Start of free chain (blist size) + pack($StP{$self->byte_size}, 0), # Start of free chain (data size) + pack($StP{$self->byte_size}, 0), # Start of free chain (index size) + ); - for (my $k=0; $k<$self->{max_buckets}; $k++) { - my ($temp, $subloc) = $self->_get_key_subloc( $subkeys, $k ); + #XXX Set these less fragilely + $self->set_trans_loc( $header_fixed + 4 ); + $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) ); - if (!$subloc) { - seek($fh, $offset + ($k * $self->{bucket_size}) + $root->{file_offset}, SEEK_SET); - print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) ); - last; - } - } # k loop + return; + } + + sub _read_file_header { + my $self = shift; + + my $buffer = $self->storage->read_at( 0, $header_fixed ); + return unless length($buffer); + + my ($file_signature, $sig_header, $file_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" ); } - else { - $offsets[$num] = $root->{end}; - seek($fh, $index_tag->{offset} + ($num * $self->{long_size}) + $root->{file_offset}, SEEK_SET); - print( $fh pack($self->{long_pack}, $root->{end}) ); - my $blist_tag = $self->create_tag($obj, $root->{end}, SIG_BLIST, chr(0) x $self->{bucket_list_size}); + unless ( $sig_header eq SIG_HEADER ) { + $self->storage->close; + DBM::Deep->_throw_error( "Pre-1.00 file version found" ); + } - seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET); - print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) ); + unless ( $file_version == $this_file_version ) { + $self->storage->close; + DBM::Deep->_throw_error( + "Wrong file version found - " . $file_version . + " - expected " . $this_file_version + ); } - } # i loop - return; -} + my $buffer2 = $self->storage->read_at( undef, $size ); + my @values = unpack( 'C C C C', $buffer2 ); -sub read_from_loc { - my $self = shift; - my ($obj, $subloc) = @_; + if ( @values != 4 || grep { !defined } @values ) { + $self->storage->close; + DBM::Deep->_throw_error("Corrupted file - bad header"); + } - my $fh = $obj->_fh; + #XXX Add warnings if values weren't set right + @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values; - ## - # Found match -- seek to offset and read signature - ## - my $signature; - seek($fh, $subloc + $obj->_root->{file_offset}, SEEK_SET); - read( $fh, $signature, SIG_SIZE); + # These shenangians are to allow a 256 within a C + $self->{max_buckets} += 1; + $self->{data_sector_size} += 1; - ## - # If value is a hash or array, return new DBM::Deep object with correct offset - ## - if (($signature eq SIG_HASH) || ($signature eq SIG_ARRAY)) { - my $obj = DBM::Deep->new( - type => $signature, - base_offset => $subloc, - root => $obj->_root, - ); + my $bl = $self->txn_bitfield_len; - if ($obj->_root->{autobless}) { - ## - # Skip over value and plain key to see if object needs - # to be re-blessed - ## - seek($fh, $self->{data_size} + $self->{index_size}, SEEK_CUR); - - my $size; - read( $fh, $size, $self->{data_size}); $size = unpack($self->{data_pack}, $size); - if ($size) { seek($fh, $size, SEEK_CUR); } - - my $bless_bit; - read( $fh, $bless_bit, 1); - if (ord($bless_bit)) { - ## - # Yes, object needs to be re-blessed - ## - my $class_name; - read( $fh, $size, $self->{data_size}); $size = unpack($self->{data_pack}, $size); - if ($size) { read( $fh, $class_name, $size); } - if ($class_name) { $obj = bless( $obj, $class_name ); } - } + my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size; + unless ( $size == $header_var ) { + $self->storage->close; + DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." ); } - return $obj; + $self->set_trans_loc( $header_fixed + scalar(@values) ); + $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) ); + + return length($buffer) + length($buffer2); } - elsif ( $signature eq SIG_INTERNAL ) { - my $size; - read( $fh, $size, $self->{data_size}); - $size = unpack($self->{data_pack}, $size); +} - if ( $size ) { - my $new_loc; - read( $fh, $new_loc, $size ); - $new_loc = unpack( $self->{long_pack}, $new_loc ); +sub _load_sector { + my $self = shift; + my ($offset) = @_; - return $self->read_from_loc( $obj, $new_loc ); - } - else { - return; - } - } - ## - # Otherwise return actual value - ## - elsif ($signature eq SIG_DATA) { - my $size; - read( $fh, $size, $self->{data_size}); - $size = unpack($self->{data_pack}, $size); + # Add a catch for offset of 0 or 1 + return if $offset <= 1; - my $value = ''; - if ($size) { read( $fh, $value, $size); } - return $value; + 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, + type => $type, + offset => $offset, + }); + } + # XXX Don't we need key_md5 here? + elsif ( $type eq $self->SIG_BLIST ) { + return DBM::Deep::Engine::Sector::BucketList->new({ + engine => $self, + type => $type, + offset => $offset, + }); + } + elsif ( $type eq $self->SIG_INDEX ) { + return DBM::Deep::Engine::Sector::Index->new({ + engine => $self, + type => $type, + offset => $offset, + }); + } + elsif ( $type eq $self->SIG_NULL ) { + return DBM::Deep::Engine::Sector::Null->new({ + engine => $self, + type => $type, + offset => $offset, + }); + } + elsif ( $type eq $self->SIG_DATA ) { + return DBM::Deep::Engine::Sector::Scalar->new({ + engine => $self, + type => $type, + 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; } - ## - # Key exists, but content is null - ## - return; + DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" ); } -sub get_bucket_value { - ## - # Fetch single value given tag and MD5 digested key. - ## +sub _apply_digest { my $self = shift; - my ($obj, $tag, $md5) = @_; - my $keys = $tag->{content}; + return $self->{digest}->(@_); +} - my $fh = $obj->_fh; +sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) } +sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) } +sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) } - ## - # Iterate through buckets, looking for a key match - ## - BUCKET: - for (my $i = 0; $i < $self->{max_buckets}; $i++) { - my ($key, $subloc) = $self->_get_key_subloc( $keys, $i ); +sub _add_free_sector { + my $self = shift; + my ($multiple, $offset, $size) = @_; - if (!$subloc) { - ## - # Hit end of list, no match - ## - return; - } + my $chains_offset = $multiple * $self->byte_size; - if ( $md5 ne $key ) { - next BUCKET; - } + my $storage = $self->storage; - return $self->read_from_loc( $obj, $subloc ); - } # i loop + # Increment staleness. + # XXX Can this increment+modulo be done by "&= 0x1" ? + my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + SIG_SIZE, $STALE_SIZE ) ); + $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) ); + $storage->print_at( $offset + SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) ); - return; + my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); + + $storage->print_at( $self->chains_loc + $chains_offset, + pack( $StP{$self->byte_size}, $offset ), + ); + + # Record the old head in the new sector after the signature and staleness counter + $storage->print_at( $offset + SIG_SIZE + $STALE_SIZE, $old_head ); } -sub delete_bucket { - ## - # Delete single key/value pair given tag and MD5 digested key. - ## +sub _request_blist_sector { shift->_request_sector( 0, @_ ) } +sub _request_data_sector { shift->_request_sector( 1, @_ ) } +sub _request_index_sector { shift->_request_sector( 2, @_ ) } + +sub _request_sector { my $self = shift; - my ($obj, $tag, $md5) = @_; - my $keys = $tag->{content}; + my ($multiple, $size) = @_; - my $fh = $obj->_fh; + my $chains_offset = $multiple * $self->byte_size; - ## - # Iterate through buckets, looking for a key match - ## - BUCKET: - for (my $i=0; $i<$self->{max_buckets}; $i++) { - my ($key, $subloc) = $self->_get_key_subloc( $keys, $i ); + my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); + my $loc = unpack( $StP{$self->byte_size}, $old_head ); - if (!$subloc) { - ## - # Hit end of list, no match - ## - return; - } + # We don't have any free sectors of the right size, so allocate a new one. + unless ( $loc ) { + my $offset = $self->storage->request_space( $size ); - if ( $md5 ne $key ) { - next BUCKET; - } + # Zero out the new sector. This also guarantees correct increases + # in the filesize. + $self->storage->print_at( $offset, chr(0) x $size ); - ## - # Matched key -- delete bucket and return - ## - seek($fh, $tag->{offset} + ($i * $self->{bucket_size}) + $obj->_root->{file_offset}, SEEK_SET); - print( $fh substr($keys, ($i+1) * $self->{bucket_size} ) ); - print( $fh chr(0) x $self->{bucket_size} ); + return $offset; + } - return 1; - } # i loop + # Read the new head after the signature and the staleness counter + my $new_head = $self->storage->read_at( $loc + SIG_SIZE + $STALE_SIZE, $self->byte_size ); + $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head ); + $self->storage->print_at( + $loc + SIG_SIZE + $STALE_SIZE, + pack( $StP{$self->byte_size}, 0 ), + ); - return; + return $loc; } -sub bucket_exists { - ## - # Check existence of single key given tag and MD5 digested key. - ## - my $self = shift; - my ($obj, $tag, $md5) = @_; - my $keys = $tag->{content}; +################################################################################ - ## - # Iterate through buckets, looking for a key match - ## - BUCKET: - for (my $i=0; $i<$self->{max_buckets}; $i++) { - my ($key, $subloc) = $self->_get_key_subloc( $keys, $i ); +sub storage { $_[0]{storage} } +sub byte_size { $_[0]{byte_size} } +sub hash_size { $_[0]{hash_size} } +sub hash_chars { $_[0]{hash_chars} } +sub num_txns { $_[0]{num_txns} } +sub max_buckets { $_[0]{max_buckets} } +sub blank_md5 { chr(0) x $_[0]->hash_size } +sub data_sector_size { $_[0]{data_sector_size} } - if (!$subloc) { - ## - # Hit end of list, no match - ## - return; +# This is a calculated value +sub txn_bitfield_len { + my $self = shift; + unless ( exists $self->{txn_bitfield_len} ) { + my $temp = ($self->num_txns) / 8; + if ( $temp > int( $temp ) ) { + $temp = int( $temp ) + 1; } + $self->{txn_bitfield_len} = $temp; + } + return $self->{txn_bitfield_len}; +} - if ( $md5 ne $key ) { - next BUCKET; - } +sub trans_id { $_[0]{trans_id} } +sub set_trans_id { $_[0]{trans_id} = $_[1] } - ## - # Matched key -- return true - ## - return 1; - } # i loop +sub trans_loc { $_[0]{trans_loc} } +sub set_trans_loc { $_[0]{trans_loc} = $_[1] } - return; -} +sub chains_loc { $_[0]{chains_loc} } +sub set_chains_loc { $_[0]{chains_loc} = $_[1] } -sub find_bucket_list { - ## - # Locate offset for bucket list, given digested key - ## - my $self = shift; - my ($obj, $md5, $args) = @_; - $args = {} unless $args; +################################################################################ - ## - # Locate offset for bucket list using digest index system - ## - my $tag = $self->load_tag($obj, $obj->_base_offset) - or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" ); +package DBM::Deep::Iterator; - my $ch = 0; - while ($tag->{signature} ne SIG_BLIST) { - my $num = ord substr($md5, $ch, 1); +sub new { + my $class = shift; + my ($args) = @_; - my $ref_loc = $tag->{offset} + ($num * $self->{long_size}); - $tag = $self->index_lookup( $obj, $tag, $num ); + my $self = bless { + breadcrumbs => [], + engine => $args->{engine}, + base_offset => $args->{base_offset}, + }, $class; - if (!$tag) { - if ( $args->{create} ) { - my $fh = $obj->_fh; - seek($fh, $ref_loc + $obj->_root->{file_offset}, SEEK_SET); - print( $fh pack($self->{long_pack}, $obj->_root->{end}) ); + Scalar::Util::weaken( $self->{engine} ); - $tag = $self->create_tag( - $obj, $obj->_root->{end}, - SIG_BLIST, - chr(0) x $self->{bucket_list_size}, - ); + return $self; +} - $tag->{ref_loc} = $ref_loc; - $tag->{ch} = $ch; +sub reset { $_[0]{breadcrumbs} = [] } - last; - } - else { - return; - } - } +sub get_sector_iterator { + my $self = shift; + my ($loc) = @_; - $tag->{ch} = $ch; - $tag->{ref_loc} = $ref_loc; + my $sector = $self->{engine}->_load_sector( $loc ) + or return; - $ch++; + if ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) { + return DBM::Deep::Iterator::Index->new({ + iterator => $self, + sector => $sector, + }); + } + elsif ( $sector->isa( 'DBM::Deep::Engine::Sector::BucketList' ) ) { + return DBM::Deep::Iterator::BucketList->new({ + iterator => $self, + sector => $sector, + }); } - return $tag; + DBM::Deep->_throw_error( "get_sector_iterator(): Why did $loc make a $sector?" ); } -sub index_lookup { - ## - # Given index tag, lookup single entry in index and return . - ## +sub get_next_key { my $self = shift; - my ($obj, $tag, $index) = @_; - - my $location = unpack( - $self->{long_pack}, - substr( - $tag->{content}, - $index * $self->{long_size}, - $self->{long_size}, - ), - ); + my ($obj) = @_; - if (!$location) { return; } + my $crumbs = $self->{breadcrumbs}; + my $e = $self->{engine}; - return $self->load_tag( $obj, $location ); -} + unless ( @$crumbs ) { + # This will be a Reference sector + my $sector = $e->_load_sector( $self->{base_offset} ) + # If no sector is found, thist must have been deleted from under us. + or return; -sub traverse_index { - ## - # Scan index and recursively step into deeper levels, looking for next key. - ## - my $self = shift; - my ($obj, $offset, $ch, $force_return_next) = @_; + if ( $sector->staleness != $obj->_staleness ) { + return; + } - my $tag = $self->load_tag($obj, $offset ); + my $loc = $sector->get_blist_loc + or return; - my $fh = $obj->_fh; + push @$crumbs, $self->get_sector_iterator( $loc ); + } - if ($tag->{signature} ne SIG_BLIST) { - my $content = $tag->{content}; - my $start = $obj->{return_next} ? 0 : ord(substr($obj->{prev_md5}, $ch, 1)); + FIND_NEXT_KEY: { + # We're at the end. + unless ( @$crumbs ) { + $self->reset; + return; + } - for (my $index = $start; $index < 256; $index++) { - my $subloc = unpack( - $self->{long_pack}, - substr($content, $index * $self->{long_size}, $self->{long_size}), - ); + my $iterator = $crumbs->[-1]; - if ($subloc) { - my $result = $self->traverse_index( - $obj, $subloc, $ch + 1, $force_return_next, - ); + # This level is done. + if ( $iterator->at_end ) { + pop @$crumbs; + redo FIND_NEXT_KEY; + } - if (defined($result)) { return $result; } + if ( $iterator->isa( 'DBM::Deep::Iterator::Index' ) ) { + # If we don't have any more, it will be caught at the + # prior check. + if ( my $next = $iterator->get_next_iterator ) { + push @$crumbs, $next; } - } # index loop + redo FIND_NEXT_KEY; + } - $obj->{return_next} = 1; - } # tag is an index + unless ( $iterator->isa( 'DBM::Deep::Iterator::BucketList' ) ) { + DBM::Deep->_throw_error( + "Should have a bucketlist iterator here - instead have $iterator" + ); + } - else { - my $keys = $tag->{content}; - if ($force_return_next) { $obj->{return_next} = 1; } - - ## - # Iterate through buckets, looking for a key match - ## - for (my $i = 0; $i < $self->{max_buckets}; $i++) { - my ($key, $subloc) = $self->_get_key_subloc( $keys, $i ); - - # End of bucket list -- return to outer loop - if (!$subloc) { - $obj->{return_next} = 1; - last; - } - # Located previous key -- return next one found - elsif ($key eq $obj->{prev_md5}) { - $obj->{return_next} = 1; - next; - } - # Seek to bucket location and skip over signature - elsif ($obj->{return_next}) { - seek($fh, $subloc + $obj->_root->{file_offset}, SEEK_SET); - - # Skip over value to get to plain key - my $sig; - read( $fh, $sig, SIG_SIZE ); - - my $size; - read( $fh, $size, $self->{data_size}); - $size = unpack($self->{data_pack}, $size); - if ($size) { seek($fh, $size, SEEK_CUR); } - - # Read in plain key and return as scalar - my $plain_key; - read( $fh, $size, $self->{data_size}); - $size = unpack($self->{data_pack}, $size); - if ($size) { read( $fh, $plain_key, $size); } - - return $plain_key; - } + # At this point, we have a BucketList iterator + my $key = $iterator->get_next_key; + if ( defined $key ) { + return $key; } + #XXX else { $iterator->set_to_end() } ? - $obj->{return_next} = 1; - } # tag is a bucket list + # We hit the end of the bucketlist iterator, so redo + redo FIND_NEXT_KEY; + } - return; + DBM::Deep->_throw_error( "get_next_key(): How did we get here?" ); } -sub get_next_key { - ## - # Locate next key, given digested previous one - ## - my $self = shift; - my ($obj) = @_; +package DBM::Deep::Iterator::Index; - $obj->{prev_md5} = $_[1] ? $_[1] : undef; - $obj->{return_next} = 0; +sub new { + my $self = bless $_[1] => $_[0]; + $self->{curr_index} = 0; + return $self; +} - ## - # If the previous key was not specifed, start at the top and - # return the first one found. - ## - if (!$obj->{prev_md5}) { - $obj->{prev_md5} = chr(0) x $self->{hash_size}; - $obj->{return_next} = 1; +sub at_end { + my $self = shift; + return $self->{curr_index} >= $self->{iterator}{engine}->hash_chars; +} + +sub get_next_iterator { + my $self = shift; + + my $loc; + while ( !$loc ) { + return if $self->at_end; + $loc = $self->{sector}->get_entry( $self->{curr_index}++ ); + } + + return $self->{iterator}->get_sector_iterator( $loc ); +} + +package DBM::Deep::Iterator::BucketList; + +sub new { + my $self = bless $_[1] => $_[0]; + $self->{curr_index} = 0; + return $self; +} + +sub at_end { + my $self = shift; + return $self->{curr_index} >= $self->{iterator}{engine}->max_buckets; +} + +sub get_next_key { + my $self = shift; + + return if $self->at_end; + + my $idx = $self->{curr_index}++; + + my $data_loc = $self->{sector}->get_data_location_for({ + allow_head => 1, + idx => $idx, + }) or return; + + #XXX Do we want to add corruption checks here? + return $self->{sector}->get_key_for( $idx )->data; +} + +package DBM::Deep::Engine::Sector; + +sub new { + my $self = bless $_[1], $_[0]; + Scalar::Util::weaken( $self->{engine} ); + $self->_init; + return $self; +} + +#sub _init {} +#sub clone { DBM::Deep->_throw_error( "Must be implemented in the child class" ); } + +sub engine { $_[0]{engine} } +sub offset { $_[0]{offset} } +sub type { $_[0]{type} } + +sub base_size { + my $self = shift; + return $self->engine->SIG_SIZE + $STALE_SIZE; +} + +sub free { + my $self = shift; + + my $e = $self->engine; + + $e->storage->print_at( $self->offset, $e->SIG_FREE ); + # Skip staleness counter + $e->storage->print_at( $self->offset + $self->base_size, + chr(0) x ($self->size - $self->base_size), + ); + + my $free_meth = $self->free_meth; + $e->$free_meth( $self->offset, $self->size ); + + return; +} + +package DBM::Deep::Engine::Sector::Data; + +our @ISA = qw( DBM::Deep::Engine::Sector ); + +# This is in bytes +sub size { $_[0]{engine}->data_sector_size } +sub free_meth { return '_add_free_data_sector' } + +sub clone { + my $self = shift; + return ref($self)->new({ + engine => $self->engine, + type => $self->type, + data => $self->data, + }); +} + +package DBM::Deep::Engine::Sector::Scalar; + +our @ISA = qw( DBM::Deep::Engine::Sector::Data ); + +sub free { + my $self = shift; + + my $chain_loc = $self->chain_loc; + + $self->SUPER::free(); + + if ( $chain_loc ) { + $self->engine->_load_sector( $chain_loc )->free; + } + + return; +} + +sub type { $_[0]{engine}->SIG_DATA } +sub _init { + my $self = shift; + + my $engine = $self->engine; + + unless ( $self->offset ) { + my $data_section = $self->size - $self->base_size - $engine->byte_size - 1; + + $self->{offset} = $engine->_request_data_sector( $self->size ); + + my $data = delete $self->{data}; + my $dlen = length $data; + my $continue = 1; + my $curr_offset = $self->offset; + while ( $continue ) { + + my $next_offset = 0; + + my ($leftover, $this_len, $chunk); + if ( $dlen > $data_section ) { + $leftover = 0; + $this_len = $data_section; + $chunk = substr( $data, 0, $this_len ); + + $dlen -= $data_section; + $next_offset = $engine->_request_data_sector( $self->size ); + $data = substr( $data, $this_len ); + } + else { + $leftover = $data_section - $dlen; + $this_len = $dlen; + $chunk = $data; + + $continue = 0; + } + + $engine->storage->print_at( $curr_offset, $self->type ); # Sector type + # Skip staleness + $engine->storage->print_at( $curr_offset + $self->base_size, + pack( $StP{$engine->byte_size}, $next_offset ), # Chain loc + pack( $StP{1}, $this_len ), # Data length + $chunk, # Data to be stored in this sector + chr(0) x $leftover, # Zero-fill the rest + ); + + $curr_offset = $next_offset; + } + + return; + } +} + +sub data_length { + my $self = shift; + + my $buffer = $self->engine->storage->read_at( + $self->offset + $self->base_size + $self->engine->byte_size, 1 + ); + + return unpack( $StP{1}, $buffer ); +} + +sub chain_loc { + my $self = shift; + return unpack( + $StP{$self->engine->byte_size}, + $self->engine->storage->read_at( + $self->offset + $self->base_size, + $self->engine->byte_size, + ), + ); +} + +sub data { + my $self = shift; + + my $data; + while ( 1 ) { + my $chain_loc = $self->chain_loc; + + $data .= $self->engine->storage->read_at( + $self->offset + $self->base_size + $self->engine->byte_size + 1, $self->data_length, + ); + + last unless $chain_loc; + + $self = $self->engine->_load_sector( $chain_loc ); + } + + return $data; +} + +package DBM::Deep::Engine::Sector::Null; + +our @ISA = qw( DBM::Deep::Engine::Sector::Data ); + +sub type { $_[0]{engine}->SIG_NULL } +sub data_length { 0 } +sub data { return } + +sub _init { + my $self = shift; + + my $engine = $self->engine; + + unless ( $self->offset ) { + my $leftover = $self->size - $self->base_size - 1 * $engine->byte_size - 1; + + $self->{offset} = $engine->_request_data_sector( $self->size ); + $engine->storage->print_at( $self->offset, $self->type ); # Sector type + # Skip staleness counter + $engine->storage->print_at( $self->offset + $self->base_size, + pack( $StP{$engine->byte_size}, 0 ), # Chain loc + pack( $StP{1}, $self->data_length ), # Data length + chr(0) x $leftover, # Zero-fill the rest + ); + + return; + } +} + +package DBM::Deep::Engine::Sector::Reference; + +our @ISA = qw( DBM::Deep::Engine::Sector::Data ); + +sub _init { + my $self = shift; + + my $e = $self->engine; + + unless ( $self->offset ) { + my $classname = Scalar::Util::blessed( delete $self->{data} ); + my $leftover = $self->size - $self->base_size - 2 * $e->byte_size; + + my $class_offset = 0; + if ( defined $classname ) { + my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({ + engine => $e, + data => $classname, + }); + $class_offset = $class_sector->offset; + } + + $self->{offset} = $e->_request_data_sector( $self->size ); + $e->storage->print_at( $self->offset, $self->type ); # Sector type + # Skip staleness counter + $e->storage->print_at( $self->offset + $self->base_size, + pack( $StP{$e->byte_size}, 0 ), # Index/BList loc + pack( $StP{$e->byte_size}, $class_offset ), # Classname loc + chr(0) x $leftover, # Zero-fill the rest + ); + } + else { + $self->{type} = $e->storage->read_at( $self->offset, 1 ); + } + + $self->{staleness} = unpack( + $StP{$STALE_SIZE}, + $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ), + ); + + return; +} + +sub free { + my $self = shift; + + my $blist_loc = $self->get_blist_loc; + $self->engine->_load_sector( $blist_loc )->free if $blist_loc; + + my $class_loc = $self->get_class_offset; + $self->engine->_load_sector( $class_loc )->free if $class_loc; + + $self->SUPER::free(); +} + +sub staleness { $_[0]{staleness} } + +sub get_data_for { + my $self = shift; + my ($args) = @_; + + # Assume that the head is not allowed unless otherwise specified. + $args->{allow_head} = 0 unless exists $args->{allow_head}; + + # Assume we don't create a new blist location unless otherwise specified. + $args->{create} = 0 unless exists $args->{create}; + + my $blist = $self->get_bucket_list({ + key_md5 => $args->{key_md5}, + key => $args->{key}, + create => $args->{create}, + }); + return unless $blist && $blist->{found}; + + # At this point, $blist knows where the md5 is. What it -doesn't- know yet + # is whether or not this transaction has this key. That's part of the next + # function call. + my $location = $blist->get_data_location_for({ + allow_head => $args->{allow_head}, + }) or return; + + return $self->engine->_load_sector( $location ); +} + +sub write_data { + my $self = shift; + my ($args) = @_; + + my $blist = $self->get_bucket_list({ + key_md5 => $args->{key_md5}, + key => $args->{key}, + create => 1, + }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" ); + + # Handle any transactional bookkeeping. + if ( $self->engine->trans_id ) { + if ( ! $blist->has_md5 ) { + $blist->mark_deleted({ + trans_id => 0, + }); + } + } + else { + my @trans_ids = $self->engine->get_running_txn_ids; + if ( $blist->has_md5 ) { + if ( @trans_ids ) { + my $old_value = $blist->get_data_for; + foreach my $other_trans_id ( @trans_ids ) { + next if $blist->get_data_location_for({ + trans_id => $other_trans_id, + allow_head => 0, + }); + $blist->write_md5({ + trans_id => $other_trans_id, + key => $args->{key}, + key_md5 => $args->{key_md5}, + value => $old_value->clone, + }); + } + } + } + else { + if ( @trans_ids ) { + foreach my $other_trans_id ( @trans_ids ) { + #XXX This doesn't seem to possible to ever happen . . . + next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); + $blist->mark_deleted({ + trans_id => $other_trans_id, + }); + } + } + } + } + + #XXX Is this safe to do transactionally? + # Free the place we're about to write to. + if ( $blist->get_data_location_for({ allow_head => 0 }) ) { + $blist->get_data_for({ allow_head => 0 })->free; + } + + $blist->write_md5({ + key => $args->{key}, + key_md5 => $args->{key_md5}, + value => $args->{value}, + }); +} + +sub delete_key { + my $self = shift; + my ($args) = @_; + + # XXX What should happen if this fails? + my $blist = $self->get_bucket_list({ + key_md5 => $args->{key_md5}, + }) or DBM::Deep->_throw_error( "How did delete_key fail (no blist)?!" ); + + # Save the location so that we can free the data + my $location = $blist->get_data_location_for({ + allow_head => 0, + }); + my $old_value = $location && $self->engine->_load_sector( $location ); + + my @trans_ids = $self->engine->get_running_txn_ids; + + if ( $self->engine->trans_id == 0 ) { + if ( @trans_ids ) { + foreach my $other_trans_id ( @trans_ids ) { + next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); + $blist->write_md5({ + trans_id => $other_trans_id, + key => $args->{key}, + key_md5 => $args->{key_md5}, + value => $old_value->clone, + }); + } + } + } + + my $data; + if ( @trans_ids ) { + $blist->mark_deleted( $args ); + + if ( $old_value ) { + $data = $old_value->data; + $old_value->free; + } + } + else { + $data = $blist->delete_md5( $args ); + } + + return $data; +} + +sub get_blist_loc { + my $self = shift; + + my $e = $self->engine; + my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size ); + return unpack( $StP{$e->byte_size}, $blist_loc ); +} + +sub get_bucket_list { + my $self = shift; + my ($args) = @_; + $args ||= {}; + + # XXX Add in check here for recycling? + + my $engine = $self->engine; + + my $blist_loc = $self->get_blist_loc; + + # There's no index or blist yet + unless ( $blist_loc ) { + return unless $args->{create}; + + my $blist = DBM::Deep::Engine::Sector::BucketList->new({ + engine => $engine, + key_md5 => $args->{key_md5}, + }); + + $engine->storage->print_at( $self->offset + $self->base_size, + pack( $StP{$engine->byte_size}, $blist->offset ), + ); + + return $blist; + } + + my $sector = $engine->_load_sector( $blist_loc ) + or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); + my $i = 0; + my $last_sector = undef; + while ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) { + $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) ); + $last_sector = $sector; + if ( $blist_loc ) { + $sector = $engine->_load_sector( $blist_loc ) + or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); + } + else { + $sector = undef; + last; + } + } + + # This means we went through the Index sector(s) and found an empty slot + unless ( $sector ) { + return unless $args->{create}; + + DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" ) + unless $last_sector; + + my $blist = DBM::Deep::Engine::Sector::BucketList->new({ + engine => $engine, + key_md5 => $args->{key_md5}, + }); + + $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset ); + + return $blist; + } + + $sector->find_md5( $args->{key_md5} ); + + # See whether or not we need to reindex the bucketlist + if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) { + my $new_index = DBM::Deep::Engine::Sector::Index->new({ + engine => $engine, + }); + + my %blist_cache; + #XXX q.v. the comments for this function. + foreach my $entry ( $sector->chopped_up ) { + my ($spot, $md5) = @{$entry}; + my $idx = ord( substr( $md5, $i, 1 ) ); + + # XXX This is inefficient + my $blist = $blist_cache{$idx} + ||= DBM::Deep::Engine::Sector::BucketList->new({ + engine => $engine, + }); + + $new_index->set_entry( $idx => $blist->offset ); + + my $new_spot = $blist->write_at_next_open( $md5 ); + $engine->reindex_entry( $spot => $new_spot ); + } + + # Handle the new item separately. + { + my $idx = ord( substr( $args->{key_md5}, $i, 1 ) ); + my $blist = $blist_cache{$idx} + ||= DBM::Deep::Engine::Sector::BucketList->new({ + engine => $engine, + }); + + $new_index->set_entry( $idx => $blist->offset ); + + #XXX THIS IS HACKY! + $blist->find_md5( $args->{key_md5} ); + $blist->write_md5({ + key => $args->{key}, + key_md5 => $args->{key_md5}, + value => DBM::Deep::Engine::Sector::Null->new({ + engine => $engine, + data => undef, + }), + }); + } + + if ( $last_sector ) { + $last_sector->set_entry( + ord( substr( $args->{key_md5}, $i - 1, 1 ) ), + $new_index->offset, + ); + } else { + $engine->storage->print_at( $self->offset + $self->base_size, + pack( $StP{$engine->byte_size}, $new_index->offset ), + ); + } + + $sector->free; + + $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) }; + $sector->find_md5( $args->{key_md5} ); + } + + return $sector; +} + +sub get_class_offset { + my $self = shift; + + my $e = $self->engine; + return unpack( + $StP{$e->byte_size}, + $e->storage->read_at( + $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size, + ), + ); +} + +sub get_classname { + my $self = shift; + + my $class_offset = $self->get_class_offset; + + return unless $class_offset; + + return $self->engine->_load_sector( $class_offset )->data; +} + +#XXX Add singleton handling here +sub data { + my $self = shift; + + my $new_obj = DBM::Deep->new({ + type => $self->type, + base_offset => $self->offset, + staleness => $self->staleness, + storage => $self->engine->storage, + engine => $self->engine, + }); + + if ( $self->engine->storage->{autobless} ) { + my $classname = $self->get_classname; + if ( defined $classname ) { + bless $new_obj, $classname; + } + } + + return $new_obj; +} + +package DBM::Deep::Engine::Sector::BucketList; + +our @ISA = qw( DBM::Deep::Engine::Sector ); + +sub _init { + my $self = shift; + + my $engine = $self->engine; + + unless ( $self->offset ) { + my $leftover = $self->size - $self->base_size; + + $self->{offset} = $engine->_request_blist_sector( $self->size ); + $engine->storage->print_at( $self->offset, $engine->SIG_BLIST ); # Sector type + # Skip staleness counter + $engine->storage->print_at( $self->offset + $self->base_size, + chr(0) x $leftover, # Zero-fill the data + ); + } + + if ( $self->{key_md5} ) { + $self->find_md5; + } + + return $self; +} + +sub size { + my $self = shift; + unless ( $self->{size} ) { + my $e = $self->engine; + # Base + numbuckets * bucketsize + $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; + } + return $self->{size}; +} + +sub free_meth { return '_add_free_blist_sector' } + +sub bucket_size { + my $self = shift; + unless ( $self->{bucket_size} ) { + my $e = $self->engine; + # Key + head (location) + transactions (location + staleness-counter) + my $location_size = $e->byte_size + $e->byte_size + ($e->num_txns - 1) * ($e->byte_size + $STALE_SIZE); + $self->{bucket_size} = $e->hash_size + $location_size; + } + return $self->{bucket_size}; +} + +# XXX This is such a poor hack. I need to rethink this code. +sub chopped_up { + my $self = shift; + + my $e = $self->engine; + + my @buckets; + foreach my $idx ( 0 .. $e->max_buckets - 1 ) { + my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size; + my $md5 = $e->storage->read_at( $spot, $e->hash_size ); + + #XXX If we're chopping, why would we ever have the blank_md5? + last if $md5 eq $e->blank_md5; + + my $rest = $e->storage->read_at( undef, $self->bucket_size - $e->hash_size ); + push @buckets, [ $spot, $md5 . $rest ]; + } + + return @buckets; +} + +sub write_at_next_open { + my $self = shift; + my ($entry) = @_; + + #XXX This is such a hack! + $self->{_next_open} = 0 unless exists $self->{_next_open}; + + my $spot = $self->offset + $self->base_size + $self->{_next_open}++ * $self->bucket_size; + $self->engine->storage->print_at( $spot, $entry ); + + return $spot; +} + +sub has_md5 { + my $self = shift; + unless ( exists $self->{found} ) { + $self->find_md5; + } + return $self->{found}; +} + +sub find_md5 { + my $self = shift; + + $self->{found} = undef; + $self->{idx} = -1; + + if ( @_ ) { + $self->{key_md5} = shift; + } + + # If we don't have an MD5, then what are we supposed to do? + unless ( exists $self->{key_md5} ) { + DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" ); + } + + my $e = $self->engine; + foreach my $idx ( 0 .. $e->max_buckets - 1 ) { + my $potential = $e->storage->read_at( + $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size, + ); + + if ( $potential eq $e->blank_md5 ) { + $self->{idx} = $idx; + return; + } + + if ( $potential eq $self->{key_md5} ) { + $self->{found} = 1; + $self->{idx} = $idx; + return; + } + } + + return; +} + +sub write_md5 { + my $self = shift; + my ($args) = @_; + + DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key}; + DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5}; + DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value}; + + my $engine = $self->engine; + + $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; + + my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; + $engine->add_entry( $args->{trans_id}, $spot ); + + unless ($self->{found}) { + my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({ + engine => $engine, + data => $args->{key}, + }); + + $engine->storage->print_at( $spot, + $args->{key_md5}, + pack( $StP{$engine->byte_size}, $key_sector->offset ), + ); } - return $self->traverse_index( $obj, $obj->_base_offset, 0 ); + my $loc = $spot + + $engine->hash_size + + $engine->byte_size; + + if ( $args->{trans_id} ) { + $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $STALE_SIZE ); + + $engine->storage->print_at( $loc, + pack( $StP{$engine->byte_size}, $args->{value}->offset ), + pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ), + ); + } + else { + $engine->storage->print_at( $loc, + pack( $StP{$engine->byte_size}, $args->{value}->offset ), + ); + } } -# Utilities +sub mark_deleted { + my $self = shift; + my ($args) = @_; + $args ||= {}; + + my $engine = $self->engine; + + $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; + + my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; + $engine->add_entry( $args->{trans_id}, $spot ); + + my $loc = $spot + + $engine->hash_size + + $engine->byte_size; + + if ( $args->{trans_id} ) { + $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $STALE_SIZE ); + + $engine->storage->print_at( $loc, + pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted + pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ), + ); + } + else { + $engine->storage->print_at( $loc, + pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted + ); + } + +} -sub _get_key_subloc { +sub delete_md5 { my $self = shift; - my ($keys, $idx) = @_; + my ($args) = @_; - my ($key, $subloc) = unpack( - "a$self->{hash_size} $self->{long_pack}", - substr( - $keys, - ($idx * $self->{bucket_size}), - $self->{bucket_size}, + my $engine = $self->engine; + return undef unless $self->{found}; + + # Save the location so that we can free the data + my $location = $self->get_data_location_for({ + allow_head => 0, + }); + my $key_sector = $self->get_key_for; + + my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; + $engine->storage->print_at( $spot, + $engine->storage->read_at( + $spot + $self->bucket_size, + $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ), ), + chr(0) x $self->bucket_size, + ); + + $key_sector->free; + + my $data_sector = $self->engine->_load_sector( $location ); + my $data = $data_sector->data; + $data_sector->free; + + return $data; +} + +sub get_data_location_for { + my $self = shift; + my ($args) = @_; + $args ||= {}; + + $args->{allow_head} = 0 unless exists $args->{allow_head}; + $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id}; + $args->{idx} = $self->{idx} unless exists $args->{idx}; + + my $e = $self->engine; + + my $spot = $self->offset + $self->base_size + + $args->{idx} * $self->bucket_size + + $e->hash_size + + $e->byte_size; + + if ( $args->{trans_id} ) { + $spot += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $STALE_SIZE ); + } + + my $buffer = $e->storage->read_at( + $spot, + $e->byte_size + $STALE_SIZE, ); + my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, $buffer ); + + if ( $args->{trans_id} ) { + # We have found an entry that is old, so get rid of it + if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) { + $e->storage->print_at( + $spot, + pack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ), + ); + $loc = 0; + } + } + + # If we're in a transaction and we never wrote to this location, try the + # HEAD instead. + if ( $args->{trans_id} && !$loc && $args->{allow_head} ) { + return $self->get_data_location_for({ + trans_id => 0, + allow_head => 1, + idx => $args->{idx}, + }); + } + return $loc <= 1 ? 0 : $loc; +} - return ($key, $subloc); +sub get_data_for { + my $self = shift; + my ($args) = @_; + $args ||= {}; + + return unless $self->{found}; + my $location = $self->get_data_location_for({ + allow_head => $args->{allow_head}, + }); + return $self->engine->_load_sector( $location ); +} + +sub get_key_for { + my $self = shift; + my ($idx) = @_; + $idx = $self->{idx} unless defined $idx; + + if ( $idx >= $self->engine->max_buckets ) { + DBM::Deep->_throw_error( "get_key_for(): Attempting to retrieve $idx" ); + } + + my $location = $self->engine->storage->read_at( + $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size, + $self->engine->byte_size, + ); + $location = unpack( $StP{$self->engine->byte_size}, $location ); + DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location; + + return $self->engine->_load_sector( $location ); +} + +package DBM::Deep::Engine::Sector::Index; + +our @ISA = qw( DBM::Deep::Engine::Sector ); + +sub _init { + my $self = shift; + + my $engine = $self->engine; + + unless ( $self->offset ) { + my $leftover = $self->size - $self->base_size; + + $self->{offset} = $engine->_request_index_sector( $self->size ); + $engine->storage->print_at( $self->offset, $engine->SIG_INDEX ); # Sector type + # Skip staleness counter + $engine->storage->print_at( $self->offset + $self->base_size, + chr(0) x $leftover, # Zero-fill the rest + ); + } + + return $self; +} + +#XXX Change here +sub size { + my $self = shift; + unless ( $self->{size} ) { + my $e = $self->engine; + $self->{size} = $self->base_size + $e->byte_size * $e->hash_chars; + } + return $self->{size}; +} + +sub free_meth { return '_add_free_index_sector' } + +sub free { + my $self = shift; + my $e = $self->engine; + + for my $i ( 0 .. $e->hash_chars - 1 ) { + my $l = $self->get_entry( $i ) or next; + $e->_load_sector( $l )->free; + } + + $self->SUPER::free(); +} + +sub _loc_for { + my $self = shift; + my ($idx) = @_; + return $self->offset + $self->base_size + $idx * $self->engine->byte_size; +} + +sub get_entry { + my $self = shift; + my ($idx) = @_; + + my $e = $self->engine; + + DBM::Deep->_throw_error( "get_entry: Out of range ($idx)" ) + if $idx < 0 || $idx >= $e->hash_chars; + + return unpack( + $StP{$e->byte_size}, + $e->storage->read_at( $self->_loc_for( $idx ), $e->byte_size ), + ); +} + +sub set_entry { + my $self = shift; + my ($idx, $loc) = @_; + + my $e = $self->engine; + + DBM::Deep->_throw_error( "set_entry: Out of range ($idx)" ) + if $idx < 0 || $idx >= $e->hash_chars; + + $self->engine->storage->print_at( + $self->_loc_for( $idx ), + pack( $StP{$e->byte_size}, $loc ), + ); } 1;