lib/DBM/Deep/Engine.pm

   1 package DBM::Deep::Engine;
   2
   3 use 5.6.0;
   4
   5 use strict;
   6
   7 our $VERSION = q(0.99_03);
   8
   9 use Scalar::Util ();
  10
  11 # File-wide notes:
  12 # * Every method in here assumes that the storage has been appropriately
  13 #   safeguarded. This can be anything from flock() to some sort of manual
  14 #   mutex. But, it's the caller's responsability to make sure that this has
  15 #   been done.
  16
  17 # Setup file and tag signatures.  These should never change.
  18 sub SIG_FILE     () { 'DPDB' }
  19 sub SIG_HEADER   () { 'h'    }
  20 sub SIG_INTERNAL () { 'i'    }
  21 sub SIG_HASH     () { 'H'    }
  22 sub SIG_ARRAY    () { 'A'    }
  23 sub SIG_NULL     () { 'N'    }
  24 sub SIG_DATA     () { 'D'    }
  25 sub SIG_INDEX    () { 'I'    }
  26 sub SIG_BLIST    () { 'B'    }
  27 sub SIG_FREE     () { 'F'    }
  28 sub SIG_KEYS     () { 'K'    }
  29 sub SIG_SIZE     () {  1     }
  30 sub STALE_SIZE   () {  1     }
  31
  32 # Please refer to the pack() documentation for further information
  33 my %StP = (
  34     1 => 'C', # Unsigned char value (no order specified, presumably ASCII)
  35     2 => 'n', # Unsigned short in "network" (big-endian) order
  36     4 => 'N', # Unsigned long in "network" (big-endian) order
  37     8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
  38 );
  39
  40 ################################################################################
  41
  42 sub new {
  43     my $class = shift;
  44     my ($args) = @_;
  45
  46     my $self = bless {
  47         byte_size   => 4,
  48
  49         digest      => undef,
  50         hash_size   => 16,  # In bytes
  51         hash_chars  => 256, # Number of chars the algorithm uses per byte
  52         max_buckets => 16,
  53         num_txns    => 2,   # HEAD plus 1 additional transaction for importing
  54         trans_id    => 0,   # Default to the HEAD
  55
  56         entries => {}, # This is the list of entries for transactions
  57         storage => undef,
  58     }, $class;
  59
  60     if ( defined $args->{pack_size} ) {
  61         if ( lc $args->{pack_size} eq 'small' ) {
  62             $args->{byte_size} = 2;
  63         }
  64         elsif ( lc $args->{pack_size} eq 'medium' ) {
  65             $args->{byte_size} = 4;
  66         }
  67         elsif ( lc $args->{pack_size} eq 'large' ) {
  68             $args->{byte_size} = 8;
  69         }
  70         else {
  71             DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
  72         }
  73     }
  74
  75     # Grab the parameters we want to use
  76     foreach my $param ( keys %$self ) {
  77         next unless exists $args->{$param};
  78         $self->{$param} = $args->{$param};
  79     }
  80
  81     ##
  82     # Number of buckets per blist before another level of indexing is
  83     # done. Increase this value for slightly greater speed, but larger database
  84     # files. DO NOT decrease this value below 16, due to risk of recursive
  85     # reindex overrun.
  86     ##
  87     if ( $self->{max_buckets} < 16 ) {
  88         warn "Floor of max_buckets is 16. Setting it to 16 from '$self->{max_buckets}'\n";
  89         $self->{max_buckets} = 16;
  90     }
  91
  92     if ( !$self->{digest} ) {
  93         require Digest::MD5;
  94         $self->{digest} = \&Digest::MD5::md5;
  95     }
  96
  97     return $self;
  98 }
  99
 100 ################################################################################
 101
 102 sub read_value {
 103     my $self = shift;
 104     my ($obj, $key) = @_;
 105
 106     # This will be a Reference sector
 107     my $sector = $self->_load_sector( $obj->_base_offset )
 108         or return;
 109
 110     if ( $sector->staleness != $obj->_staleness ) {
 111         return;
 112     }
 113
 114     my $key_md5 = $self->_apply_digest( $key );
 115
 116     my $value_sector = $sector->get_data_for({
 117         key_md5    => $key_md5,
 118         allow_head => 1,
 119     });
 120
 121     unless ( $value_sector ) {
 122         $value_sector = DBM::Deep::Engine::Sector::Null->new({
 123             engine => $self,
 124             data   => undef,
 125         });
 126
 127         $sector->write_data({
 128             key_md5 => $key_md5,
 129             key     => $key,
 130             value   => $value_sector,
 131         });
 132     }
 133
 134     return $value_sector->data;
 135 }
 136
 137 sub get_classname {
 138     my $self = shift;
 139     my ($obj) = @_;
 140
 141     # This will be a Reference sector
 142     my $sector = $self->_load_sector( $obj->_base_offset )
 143         or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
 144
 145     if ( $sector->staleness != $obj->_staleness ) {
 146         return;
 147     }
 148
 149     return $sector->get_classname;
 150 }
 151
 152 sub key_exists {
 153     my $self = shift;
 154     my ($obj, $key) = @_;
 155
 156     # This will be a Reference sector
 157     my $sector = $self->_load_sector( $obj->_base_offset )
 158         or return '';
 159
 160     if ( $sector->staleness != $obj->_staleness ) {
 161         return '';
 162     }
 163
 164     my $data = $sector->get_data_for({
 165         key_md5    => $self->_apply_digest( $key ),
 166         allow_head => 1,
 167     });
 168
 169     # exists() returns 1 or '' for true/false.
 170     return $data ? 1 : '';
 171 }
 172
 173 sub delete_key {
 174     my $self = shift;
 175     my ($obj, $key) = @_;
 176
 177     my $sector = $self->_load_sector( $obj->_base_offset )
 178         or return;
 179
 180     if ( $sector->staleness != $obj->_staleness ) {
 181         return;
 182     }
 183
 184     return $sector->delete_key({
 185         key_md5    => $self->_apply_digest( $key ),
 186         allow_head => 0,
 187     });
 188 }
 189
 190 sub write_value {
 191     my $self = shift;
 192     my ($obj, $key, $value) = @_;
 193
 194     my $r = Scalar::Util::reftype( $value ) || '';
 195     {
 196         last if $r eq '';
 197         last if $r eq 'HASH';
 198         last if $r eq 'ARRAY';
 199
 200         DBM::Deep->_throw_error(
 201             "Storage of references of type '$r' is not supported."
 202         );
 203     }
 204
 205     my ($class, $type);
 206     if ( !defined $value ) {
 207         $class = 'DBM::Deep::Engine::Sector::Null';
 208     }
 209     elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
 210         if ( $r eq 'ARRAY' && tied(@$value) ) {
 211             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 212         }
 213         if ( $r eq 'HASH' && tied(%$value) ) {
 214             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 215         }
 216         $class = 'DBM::Deep::Engine::Sector::Reference';
 217         $type = substr( $r, 0, 1 );
 218     }
 219     else {
 220         $class = 'DBM::Deep::Engine::Sector::Scalar';
 221     }
 222
 223     # This will be a Reference sector
 224     my $sector = $self->_load_sector( $obj->_base_offset )
 225         or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
 226
 227     if ( $sector->staleness != $obj->_staleness ) {
 228         DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep.n" );
 229     }
 230
 231     # Create this after loading the reference sector in case something bad happens.
 232     # This way, we won't allocate value sector(s) needlessly.
 233     my $value_sector = $class->new({
 234         engine => $self,
 235         data   => $value,
 236         type   => $type,
 237     });
 238
 239     $sector->write_data({
 240         key     => $key,
 241         key_md5 => $self->_apply_digest( $key ),
 242         value   => $value_sector,
 243     });
 244
 245     # This code is to make sure we write all the values in the $value to the disk
 246     # and to make sure all changes to $value after the assignment are reflected
 247     # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
 248     #   NOTE - simply tying $value won't perform a STORE on each value. Hence, the
 249     # copy to a temp value.
 250     if ( $r eq 'ARRAY' ) {
 251         my @temp = @$value;
 252         tie @$value, 'DBM::Deep', {
 253             base_offset => $value_sector->offset,
 254             staleness   => $value_sector->staleness,
 255             storage     => $self->storage,
 256             engine      => $self,
 257         };
 258         @$value = @temp;
 259         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
 260     }
 261     elsif ( $r eq 'HASH' ) {
 262         my %temp = %$value;
 263         tie %$value, 'DBM::Deep', {
 264             base_offset => $value_sector->offset,
 265             staleness   => $value_sector->staleness,
 266             storage     => $self->storage,
 267             engine      => $self,
 268         };
 269
 270         %$value = %temp;
 271         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
 272     }
 273
 274     return 1;
 275 }
 276
 277 # XXX Add staleness here
 278 sub get_next_key {
 279     my $self = shift;
 280     my ($obj, $prev_key) = @_;
 281
 282     # XXX Need to add logic about resetting the iterator if any key in the reference has changed
 283     unless ( $prev_key ) {
 284         $obj->{iterator} = DBM::Deep::Iterator->new({
 285             base_offset => $obj->_base_offset,
 286             engine      => $self,
 287         });
 288     }
 289
 290     return $obj->{iterator}->get_next_key( $obj );
 291 }
 292
 293 ################################################################################
 294
 295 sub setup_fh {
 296     my $self = shift;
 297     my ($obj) = @_;
 298
 299     # We're opening the file.
 300     unless ( $obj->_base_offset ) {
 301         my $bytes_read = $self->_read_file_header;
 302
 303         # Creating a new file
 304         unless ( $bytes_read ) {
 305             $self->_write_file_header;
 306
 307             # 1) Create Array/Hash entry
 308             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 309                 engine => $self,
 310                 type   => $obj->_type,
 311             });
 312             $obj->{base_offset} = $initial_reference->offset;
 313             $obj->{staleness} = $initial_reference->staleness;
 314
 315             $self->storage->flush;
 316         }
 317         # Reading from an existing file
 318         else {
 319             $obj->{base_offset} = $bytes_read;
 320             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 321                 engine => $self,
 322                 offset => $obj->_base_offset,
 323             });
 324             unless ( $initial_reference ) {
 325                 DBM::Deep->_throw_error("Corrupted file, no master index record");
 326             }
 327
 328             unless ($obj->_type eq $initial_reference->type) {
 329                 DBM::Deep->_throw_error("File type mismatch");
 330             }
 331
 332             $obj->{staleness} = $initial_reference->staleness;
 333         }
 334     }
 335
 336     return 1;
 337 }
 338
 339 sub begin_work {
 340     my $self = shift;
 341     my ($obj) = @_;
 342
 343     if ( $self->trans_id ) {
 344         DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
 345     }
 346
 347     my @slots = $self->read_txn_slots;
 348     for my $i ( 1 .. @slots ) {
 349         next if $slots[$i];
 350         $slots[$i] = 1;
 351         $self->set_trans_id( $i );
 352         last;
 353     }
 354     $self->write_txn_slots( @slots );
 355
 356     if ( !$self->trans_id ) {
 357         DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
 358     }
 359
 360     return;
 361 }
 362
 363 sub rollback {
 364     my $self = shift;
 365     my ($obj) = @_;
 366
 367     if ( !$self->trans_id ) {
 368         DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
 369     }
 370
 371     # Each entry is the file location for a bucket that has a modification for
 372     # this transaction. The entries need to be expunged.
 373     foreach my $entry (@{ $self->get_entries } ) {
 374         # Remove the entry here
 375         my $read_loc = $entry
 376           + $self->hash_size
 377           + $self->byte_size
 378           + $self->trans_id * ( $self->byte_size + 4 );
 379
 380         my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
 381         $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
 382         $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
 383
 384         if ( $data_loc > 1 ) {
 385             $self->_load_sector( $data_loc )->free;
 386         }
 387     }
 388
 389     $self->clear_entries;
 390
 391     my @slots = $self->read_txn_slots;
 392     $slots[$self->trans_id] = 0;
 393     $self->write_txn_slots( @slots );
 394     $self->inc_txn_staleness_counter( $self->trans_id );
 395     $self->set_trans_id( 0 );
 396
 397     return 1;
 398 }
 399
 400 sub commit {
 401     my $self = shift;
 402     my ($obj) = @_;
 403
 404     if ( !$self->trans_id ) {
 405         DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
 406     }
 407
 408     foreach my $entry (@{ $self->get_entries } ) {
 409         # Overwrite the entry in head with the entry in trans_id
 410         my $base = $entry
 411           + $self->hash_size
 412           + $self->byte_size;
 413
 414         my $head_loc = $self->storage->read_at( $base, $self->byte_size );
 415         $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
 416         my $trans_loc = $self->storage->read_at(
 417             $base + $self->trans_id * ( $self->byte_size + 4 ), $self->byte_size,
 418         );
 419
 420         $self->storage->print_at( $base, $trans_loc );
 421         $self->storage->print_at(
 422             $base + $self->trans_id * ( $self->byte_size + 4 ),
 423             pack( $StP{$self->byte_size} . ' N', (0) x 2 ),
 424         );
 425
 426         if ( $head_loc > 1 ) {
 427             $self->_load_sector( $head_loc )->free;
 428         }
 429     }
 430
 431     $self->clear_entries;
 432
 433     my @slots = $self->read_txn_slots;
 434     $slots[$self->trans_id] = 0;
 435     $self->write_txn_slots( @slots );
 436     $self->inc_txn_staleness_counter( $self->trans_id );
 437     $self->set_trans_id( 0 );
 438
 439     return 1;
 440 }
 441
 442 sub read_txn_slots {
 443     my $self = shift;
 444     return split '', unpack( 'b32',
 445         $self->storage->read_at(
 446             $self->trans_loc, 4,
 447         )
 448     );
 449 }
 450
 451 sub write_txn_slots {
 452     my $self = shift;
 453     $self->storage->print_at( $self->trans_loc,
 454         pack( 'b32', join('', @_) ),
 455     );
 456 }
 457
 458 sub get_running_txn_ids {
 459     my $self = shift;
 460     my @transactions = $self->read_txn_slots;
 461     my @trans_ids = grep { $transactions[$_] } 0 .. $#transactions;
 462 }
 463
 464 sub get_txn_staleness_counter {
 465     my $self = shift;
 466     my ($trans_id) = @_;
 467
 468     # Hardcode staleness of 0 for the HEAD
 469     return 0 unless $trans_id;
 470
 471     my $x = unpack( 'N',
 472         $self->storage->read_at(
 473             $self->trans_loc + 4 * $trans_id,
 474             4,
 475         )
 476     );
 477     return $x;
 478 }
 479
 480 sub inc_txn_staleness_counter {
 481     my $self = shift;
 482     my ($trans_id) = @_;
 483
 484     # Hardcode staleness of 0 for the HEAD
 485     return unless $trans_id;
 486
 487     $self->storage->print_at(
 488         $self->trans_loc + 4 * $trans_id,
 489         pack( 'N', $self->get_txn_staleness_counter( $trans_id ) + 1 ),
 490     );
 491 }
 492
 493 sub get_entries {
 494     my $self = shift;
 495     return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
 496 }
 497
 498 sub add_entry {
 499     my $self = shift;
 500     my ($trans_id, $loc) = @_;
 501
 502     $self->{entries}{$trans_id} ||= {};
 503     $self->{entries}{$trans_id}{$loc} = undef;
 504 }
 505
 506 # If the buckets are being relocated because of a reindexing, the entries
 507 # mechanism needs to be made aware of it.
 508 sub reindex_entry {
 509     my $self = shift;
 510     my ($old_loc, $new_loc) = @_;
 511
 512     TRANS:
 513     while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
 514         foreach my $orig_loc ( keys %{ $locs } ) {
 515             if ( $orig_loc == $old_loc ) {
 516                 delete $locs->{orig_loc};
 517                 $locs->{$new_loc} = undef;
 518                 next TRANS;
 519             }
 520         }
 521     }
 522 }
 523
 524 sub clear_entries {
 525     my $self = shift;
 526     delete $self->{entries}{$self->trans_id};
 527 }
 528
 529 ################################################################################
 530
 531 {
 532     my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
 533
 534     sub _write_file_header {
 535         my $self = shift;
 536
 537         my $header_var = 1 + 1 + 1 + 4 + 4 * $self->num_txns + 3 * $self->byte_size;
 538
 539         my $loc = $self->storage->request_space( $header_fixed + $header_var );
 540
 541         $self->storage->print_at( $loc,
 542             SIG_FILE,
 543             SIG_HEADER,
 544             pack('N', 1),           # header version - at this point, we're at 9 bytes
 545             pack('N', $header_var), # header size
 546             # --- Above is $header_fixed. Below is $header_var
 547             pack('C', $self->byte_size),
 548             pack('C', $self->max_buckets),
 549             pack('C', $self->num_txns),
 550             pack('N', 0 ),                   # Transaction activeness bitfield
 551             pack('N' . $self->num_txns, 0 x $self->num_txns ), # Transaction staleness counters
 552             pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
 553             pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
 554             pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
 555         );
 556
 557         $self->set_trans_loc( $header_fixed + 3 );
 558         $self->set_chains_loc( $header_fixed + 3 + 4 + 4 * $self->num_txns );
 559
 560         return;
 561     }
 562
 563     sub _read_file_header {
 564         my $self = shift;
 565
 566         my $buffer = $self->storage->read_at( 0, $header_fixed );
 567         return unless length($buffer);
 568
 569         my ($file_signature, $sig_header, $header_version, $size) = unpack(
 570             'A4 A N N', $buffer
 571         );
 572
 573         unless ( $file_signature eq SIG_FILE ) {
 574             $self->storage->close;
 575             DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
 576         }
 577
 578         unless ( $sig_header eq SIG_HEADER ) {
 579             $self->storage->close;
 580             DBM::Deep->_throw_error( "Old file version found." );
 581         }
 582
 583         my $buffer2 = $self->storage->read_at( undef, $size );
 584         my @values = unpack( 'C C C', $buffer2 );
 585
 586         if ( @values != 3 || grep { !defined } @values ) {
 587             $self->storage->close;
 588             DBM::Deep->_throw_error("Corrupted file - bad header");
 589         }
 590
 591         $self->set_trans_loc( $header_fixed + scalar(@values) );
 592         $self->set_chains_loc( $header_fixed + scalar(@values) + 4 + 4 * $self->num_txns );
 593
 594         #XXX Add warnings if values weren't set right
 595         @{$self}{qw(byte_size max_buckets num_txns)} = @values;
 596
 597         my $header_var = scalar(@values) + 4 + 4 * $self->num_txns + 3 * $self->byte_size;
 598         unless ( $size == $header_var ) {
 599             $self->storage->close;
 600             DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
 601         }
 602
 603         return length($buffer) + length($buffer2);
 604     }
 605 }
 606
 607 sub _load_sector {
 608     my $self = shift;
 609     my ($offset) = @_;
 610
 611     # Add a catch for offset of 0 or 1
 612     return if $offset <= 1;
 613
 614     my $type = $self->storage->read_at( $offset, 1 );
 615     return if $type eq chr(0);
 616
 617     if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
 618         return DBM::Deep::Engine::Sector::Reference->new({
 619             engine => $self,
 620             type   => $type,
 621             offset => $offset,
 622         });
 623     }
 624     # XXX Don't we need key_md5 here?
 625     elsif ( $type eq $self->SIG_BLIST ) {
 626         return DBM::Deep::Engine::Sector::BucketList->new({
 627             engine => $self,
 628             type   => $type,
 629             offset => $offset,
 630         });
 631     }
 632     elsif ( $type eq $self->SIG_INDEX ) {
 633         return DBM::Deep::Engine::Sector::Index->new({
 634             engine => $self,
 635             type   => $type,
 636             offset => $offset,
 637         });
 638     }
 639     elsif ( $type eq $self->SIG_NULL ) {
 640         return DBM::Deep::Engine::Sector::Null->new({
 641             engine => $self,
 642             type   => $type,
 643             offset => $offset,
 644         });
 645     }
 646     elsif ( $type eq $self->SIG_DATA ) {
 647         return DBM::Deep::Engine::Sector::Scalar->new({
 648             engine => $self,
 649             type   => $type,
 650             offset => $offset,
 651         });
 652     }
 653     # This was deleted from under us, so just return and let the caller figure it out.
 654     elsif ( $type eq $self->SIG_FREE ) {
 655         return;
 656     }
 657
 658     DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
 659 }
 660
 661 sub _apply_digest {
 662     my $self = shift;
 663     return $self->{digest}->(@_);
 664 }
 665
 666 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
 667 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
 668 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
 669
 670 sub _add_free_sector {
 671     my $self = shift;
 672     my ($multiple, $offset, $size) = @_;
 673
 674     my $chains_offset = $multiple * $self->byte_size;
 675
 676     my $storage = $self->storage;
 677
 678     # Increment staleness.
 679     # XXX Can this increment+modulo be done by "&= 0x1" ?
 680     my $staleness = unpack( $StP{STALE_SIZE()}, $storage->read_at( $offset + SIG_SIZE, STALE_SIZE ) );
 681     $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * STALE_SIZE ) );
 682     $storage->print_at( $offset + SIG_SIZE, pack( $StP{STALE_SIZE()}, $staleness ) );
 683
 684     my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 685
 686     $storage->print_at( $self->chains_loc + $chains_offset,
 687         pack( $StP{$self->byte_size}, $offset ),
 688     );
 689
 690     # Record the old head in the new sector after the signature and staleness counter
 691     $storage->print_at( $offset + SIG_SIZE + STALE_SIZE, $old_head );
 692 }
 693
 694 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
 695 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
 696 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
 697
 698 sub _request_sector {
 699     my $self = shift;
 700     my ($multiple, $size) = @_;
 701
 702     my $chains_offset = $multiple * $self->byte_size;
 703
 704     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 705     my $loc = unpack( $StP{$self->byte_size}, $old_head );
 706
 707     # We don't have any free sectors of the right size, so allocate a new one.
 708     unless ( $loc ) {
 709         my $offset = $self->storage->request_space( $size );
 710
 711         # Zero out the new sector. This also guarantees correct increases
 712         # in the filesize.
 713         $self->storage->print_at( $offset, chr(0) x $size );
 714
 715         return $offset;
 716     }
 717
 718     # Read the new head after the signature and the staleness counter
 719     my $new_head = $self->storage->read_at( $loc + SIG_SIZE + STALE_SIZE, $self->byte_size );
 720     $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
 721     $self->storage->print_at(
 722         $loc + SIG_SIZE + STALE_SIZE,
 723         pack( $StP{$self->byte_size}, 0 ),
 724     );
 725
 726     return $loc;
 727 }
 728
 729 ################################################################################
 730
 731 sub storage     { $_[0]{storage} }
 732 sub byte_size   { $_[0]{byte_size} }
 733 sub hash_size   { $_[0]{hash_size} }
 734 sub hash_chars  { $_[0]{hash_chars} }
 735 sub num_txns    { $_[0]{num_txns} }
 736 sub max_buckets { $_[0]{max_buckets} }
 737 sub blank_md5   { chr(0) x $_[0]->hash_size }
 738
 739 sub trans_id     { $_[0]{trans_id} }
 740 sub set_trans_id { $_[0]{trans_id} = $_[1] }
 741
 742 sub trans_loc     { $_[0]{trans_loc} }
 743 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
 744
 745 sub chains_loc     { $_[0]{chains_loc} }
 746 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
 747
 748 ################################################################################
 749
 750 package DBM::Deep::Iterator;
 751
 752 sub new {
 753     my $class = shift;
 754     my ($args) = @_;
 755
 756     my $self = bless {
 757         breadcrumbs => [],
 758         engine      => $args->{engine},
 759         base_offset => $args->{base_offset},
 760     }, $class;
 761
 762     Scalar::Util::weaken( $self->{engine} );
 763
 764     return $self;
 765 }
 766
 767 sub reset { $_[0]{breadcrumbs} = [] }
 768
 769 sub get_sector_iterator {
 770     my $self = shift;
 771     my ($loc) = @_;
 772
 773     my $sector = $self->{engine}->_load_sector( $loc )
 774         or return;
 775
 776     if ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) {
 777         return DBM::Deep::Iterator::Index->new({
 778             iterator => $self,
 779             sector   => $sector,
 780         });
 781     }
 782     elsif ( $sector->isa( 'DBM::Deep::Engine::Sector::BucketList' ) ) {
 783         return DBM::Deep::Iterator::BucketList->new({
 784             iterator => $self,
 785             sector   => $sector,
 786         });
 787     }
 788
 789     DBM::Deep->_throw_error( "get_sector_iterator(): Why did $loc make a $sector?" );
 790 }
 791
 792 sub get_next_key {
 793     my $self = shift;
 794     my ($obj) = @_;
 795
 796     my $crumbs = $self->{breadcrumbs};
 797     my $e = $self->{engine};
 798
 799     unless ( @$crumbs ) {
 800         # This will be a Reference sector
 801         my $sector = $e->_load_sector( $self->{base_offset} )
 802             # If no sector is found, thist must have been deleted from under us.
 803             or return;
 804
 805         if ( $sector->staleness != $obj->_staleness ) {
 806             return;
 807         }
 808
 809         my $loc = $sector->get_blist_loc
 810             or return;
 811
 812         push @$crumbs, $self->get_sector_iterator( $loc );
 813     }
 814
 815     FIND_NEXT_KEY: {
 816         # We're at the end.
 817         unless ( @$crumbs ) {
 818             $self->reset;
 819             return;
 820         }
 821
 822         my $iterator = $crumbs->[-1];
 823
 824         # This level is done.
 825         if ( $iterator->at_end ) {
 826             pop @$crumbs;
 827             redo FIND_NEXT_KEY;
 828         }
 829
 830         if ( $iterator->isa( 'DBM::Deep::Iterator::Index' ) ) {
 831             # If we don't have any more, it will be caught at the
 832             # prior check.
 833             if ( my $next = $iterator->get_next_iterator ) {
 834                 push @$crumbs, $next;
 835             }
 836             redo FIND_NEXT_KEY;
 837         }
 838
 839         unless ( $iterator->isa( 'DBM::Deep::Iterator::BucketList' ) ) {
 840             DBM::Deep->_throw_error(
 841                 "Should have a bucketlist iterator here - instead have $iterator"
 842             );
 843         }
 844
 845         # At this point, we have a BucketList iterator
 846         my $key = $iterator->get_next_key;
 847         if ( defined $key ) {
 848             return $key;
 849         }
 850         #XXX else { $iterator->set_to_end() } ?
 851
 852         # We hit the end of the bucketlist iterator, so redo
 853         redo FIND_NEXT_KEY;
 854     }
 855
 856     DBM::Deep->_throw_error( "get_next_key(): How did we get here?" );
 857 }
 858
 859 package DBM::Deep::Iterator::Index;
 860
 861 sub new {
 862     my $self = bless $_[1] => $_[0];
 863     $self->{curr_index} = 0;
 864     return $self;
 865 }
 866
 867 sub at_end {
 868     my $self = shift;
 869     return $self->{curr_index} >= $self->{iterator}{engine}->hash_chars;
 870 }
 871
 872 sub get_next_iterator {
 873     my $self = shift;
 874
 875     my $loc;
 876     while ( !$loc ) {
 877         return if $self->at_end;
 878         $loc = $self->{sector}->get_entry( $self->{curr_index}++ );
 879     }
 880
 881     return $self->{iterator}->get_sector_iterator( $loc );
 882 }
 883
 884 package DBM::Deep::Iterator::BucketList;
 885
 886 sub new {
 887     my $self = bless $_[1] => $_[0];
 888     $self->{curr_index} = 0;
 889     return $self;
 890 }
 891
 892 sub at_end {
 893     my $self = shift;
 894     return $self->{curr_index} >= $self->{iterator}{engine}->max_buckets;
 895 }
 896
 897 sub get_next_key {
 898     my $self = shift;
 899
 900     return if $self->at_end;
 901
 902     my $idx = $self->{curr_index}++;
 903
 904     my $data_loc = $self->{sector}->get_data_location_for({
 905         allow_head => 1,
 906         idx        => $idx,
 907     }) or return;
 908
 909     #XXX Do we want to add corruption checks here?
 910     return $self->{sector}->get_key_for( $idx )->data;
 911 }
 912
 913 package DBM::Deep::Engine::Sector;
 914
 915 sub new {
 916     my $self = bless $_[1], $_[0];
 917     Scalar::Util::weaken( $self->{engine} );
 918     $self->_init;
 919     return $self;
 920 }
 921
 922 #sub _init {}
 923 #sub clone { DBM::Deep->_throw_error( "Must be implemented in the child class" ); }
 924
 925 sub engine { $_[0]{engine} }
 926 sub offset { $_[0]{offset} }
 927 sub type   { $_[0]{type} }
 928
 929 sub base_size {
 930    my $self = shift;
 931    return $self->engine->SIG_SIZE + $self->engine->STALE_SIZE;
 932 }
 933
 934 sub free {
 935     my $self = shift;
 936
 937     my $e = $self->engine;
 938
 939     $e->storage->print_at( $self->offset, $e->SIG_FREE );
 940     # Skip staleness counter
 941     $e->storage->print_at( $self->offset + $self->base_size,
 942         chr(0) x ($self->size - $self->base_size),
 943     );
 944
 945     my $free_meth = $self->free_meth;
 946     $e->$free_meth( $self->offset, $self->size );
 947
 948     return;
 949 }
 950
 951 package DBM::Deep::Engine::Sector::Data;
 952
 953 our @ISA = qw( DBM::Deep::Engine::Sector );
 954
 955 # This is in bytes
 956 sub size { return 256 }
 957 sub free_meth { return '_add_free_data_sector' }
 958
 959 sub clone {
 960     my $self = shift;
 961     return ref($self)->new({
 962         engine => $self->engine,
 963         data   => $self->data,
 964         type   => $self->type,
 965     });
 966 }
 967
 968 package DBM::Deep::Engine::Sector::Scalar;
 969
 970 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
 971
 972 sub free {
 973     my $self = shift;
 974
 975     my $chain_loc = $self->chain_loc;
 976
 977     $self->SUPER::free();
 978
 979     if ( $chain_loc ) {
 980         $self->engine->_load_sector( $chain_loc )->free;
 981     }
 982
 983     return;
 984 }
 985
 986 sub type { $_[0]{engine}->SIG_DATA }
 987 sub _init {
 988     my $self = shift;
 989
 990     my $engine = $self->engine;
 991
 992     unless ( $self->offset ) {
 993         my $data_section = $self->size - $self->base_size - 1 * $engine->byte_size - 1;
 994
 995         $self->{offset} = $engine->_request_data_sector( $self->size );
 996
 997         my $data = delete $self->{data};
 998         my $dlen = length $data;
 999         my $continue = 1;
1000         my $curr_offset = $self->offset;
1001         while ( $continue ) {
1002
1003             my $next_offset = 0;
1004
1005             my ($leftover, $this_len, $chunk);
1006             if ( $dlen > $data_section ) {
1007                 $leftover = 0;
1008                 $this_len = $data_section;
1009                 $chunk = substr( $data, 0, $this_len );
1010
1011                 $dlen -= $data_section;
1012                 $next_offset = $engine->_request_data_sector( $self->size );
1013                 $data = substr( $data, $this_len );
1014             }
1015             else {
1016                 $leftover = $data_section - $dlen;
1017                 $this_len = $dlen;
1018                 $chunk = $data;
1019
1020                 $continue = 0;
1021             }
1022
1023             $engine->storage->print_at( $curr_offset, $self->type ); # Sector type
1024             # Skip staleness
1025             $engine->storage->print_at( $curr_offset + $self->base_size,
1026                 pack( $StP{$engine->byte_size}, $next_offset ),  # Chain loc
1027                 pack( $StP{1}, $this_len ),                      # Data length
1028                 $chunk,                                          # Data to be stored in this sector
1029                 chr(0) x $leftover,                              # Zero-fill the rest
1030             );
1031
1032             $curr_offset = $next_offset;
1033         }
1034
1035         return;
1036     }
1037 }
1038
1039 sub data_length {
1040     my $self = shift;
1041
1042     my $buffer = $self->engine->storage->read_at(
1043         $self->offset + $self->base_size + $self->engine->byte_size, 1
1044     );
1045
1046     return unpack( $StP{1}, $buffer );
1047 }
1048
1049 sub chain_loc {
1050     my $self = shift;
1051     return unpack(
1052         $StP{$self->engine->byte_size},
1053         $self->engine->storage->read_at(
1054             $self->offset + $self->base_size,
1055             $self->engine->byte_size,
1056         ),
1057     );
1058 }
1059
1060 sub data {
1061     my $self = shift;
1062
1063     my $data;
1064     while ( 1 ) {
1065         my $chain_loc = $self->chain_loc;
1066
1067         $data .= $self->engine->storage->read_at(
1068             $self->offset + $self->base_size + $self->engine->byte_size + 1, $self->data_length,
1069         );
1070
1071         last unless $chain_loc;
1072
1073         $self = $self->engine->_load_sector( $chain_loc );
1074     }
1075
1076     return $data;
1077 }
1078
1079 package DBM::Deep::Engine::Sector::Null;
1080
1081 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
1082
1083 sub type { $_[0]{engine}->SIG_NULL }
1084 sub data_length { 0 }
1085 sub data { return }
1086
1087 sub _init {
1088     my $self = shift;
1089
1090     my $engine = $self->engine;
1091
1092     unless ( $self->offset ) {
1093         my $leftover = $self->size - $self->base_size - 1 * $engine->byte_size - 1;
1094
1095         $self->{offset} = $engine->_request_data_sector( $self->size );
1096         $engine->storage->print_at( $self->offset, $self->type ); # Sector type
1097         # Skip staleness counter
1098         $engine->storage->print_at( $self->offset + $self->base_size,
1099             pack( $StP{$engine->byte_size}, 0 ),  # Chain loc
1100             pack( $StP{1}, $self->data_length ),  # Data length
1101             chr(0) x $leftover,                   # Zero-fill the rest
1102         );
1103
1104         return;
1105     }
1106 }
1107
1108 package DBM::Deep::Engine::Sector::Reference;
1109
1110 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
1111
1112 sub _init {
1113     my $self = shift;
1114
1115     my $e = $self->engine;
1116
1117     unless ( $self->offset ) {
1118         my $classname = Scalar::Util::blessed( delete $self->{data} );
1119         my $leftover = $self->size - $self->base_size - 2 * $e->byte_size;
1120
1121         my $class_offset = 0;
1122         if ( defined $classname ) {
1123             my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
1124                 engine => $e,
1125                 data   => $classname,
1126             });
1127             $class_offset = $class_sector->offset;
1128         }
1129
1130         $self->{offset} = $e->_request_data_sector( $self->size );
1131         $e->storage->print_at( $self->offset, $self->type ); # Sector type
1132         # Skip staleness counter
1133         $e->storage->print_at( $self->offset + $self->base_size,
1134             pack( $StP{$e->byte_size}, 0 ),             # Index/BList loc
1135             pack( $StP{$e->byte_size}, $class_offset ), # Classname loc
1136             chr(0) x $leftover,                         # Zero-fill the rest
1137         );
1138     }
1139     else {
1140         $self->{type} = $e->storage->read_at( $self->offset, 1 );
1141     }
1142
1143     $self->{staleness} = unpack(
1144         $StP{$e->STALE_SIZE},
1145         $e->storage->read_at( $self->offset + $e->SIG_SIZE, $e->STALE_SIZE ),
1146     );
1147
1148     return;
1149 }
1150
1151 sub free {
1152     my $self = shift;
1153
1154     my $blist_loc = $self->get_blist_loc;
1155     $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
1156
1157     my $class_loc = $self->get_class_offset;
1158     $self->engine->_load_sector( $class_loc )->free if $class_loc;
1159
1160     $self->SUPER::free();
1161 }
1162
1163 sub staleness { $_[0]{staleness} }
1164
1165 sub get_data_for {
1166     my $self = shift;
1167     my ($args) = @_;
1168
1169     # Assume that the head is not allowed unless otherwise specified.
1170     $args->{allow_head} = 0 unless exists $args->{allow_head};
1171
1172     # Assume we don't create a new blist location unless otherwise specified.
1173     $args->{create} = 0 unless exists $args->{create};
1174
1175     my $blist = $self->get_bucket_list({
1176         key_md5 => $args->{key_md5},
1177         key => $args->{key},
1178         create  => $args->{create},
1179     });
1180     return unless $blist && $blist->{found};
1181
1182     # At this point, $blist knows where the md5 is. What it -doesn't- know yet
1183     # is whether or not this transaction has this key. That's part of the next
1184     # function call.
1185     my $location = $blist->get_data_location_for({
1186         allow_head => $args->{allow_head},
1187     }) or return;
1188
1189     return $self->engine->_load_sector( $location );
1190 }
1191
1192 sub write_data {
1193     my $self = shift;
1194     my ($args) = @_;
1195
1196     my $blist = $self->get_bucket_list({
1197         key_md5 => $args->{key_md5},
1198         key => $args->{key},
1199         create  => 1,
1200     }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
1201
1202     # Handle any transactional bookkeeping.
1203     if ( $self->engine->trans_id ) {
1204         if ( ! $blist->has_md5 ) {
1205             $blist->mark_deleted({
1206                 trans_id => 0,
1207             });
1208         }
1209     }
1210     else {
1211         my @trans_ids = $self->engine->get_running_txn_ids;
1212         if ( $blist->has_md5 ) {
1213             if ( @trans_ids ) {
1214                 my $old_value = $blist->get_data_for;
1215                 foreach my $other_trans_id ( @trans_ids ) {
1216                     next if $blist->get_data_location_for({
1217                         trans_id   => $other_trans_id,
1218                         allow_head => 0,
1219                     });
1220                     $blist->write_md5({
1221                         trans_id => $other_trans_id,
1222                         key      => $args->{key},
1223                         key_md5  => $args->{key_md5},
1224                         value    => $old_value->clone,
1225                     });
1226                 }
1227             }
1228         }
1229         else {
1230             if ( @trans_ids ) {
1231                 foreach my $other_trans_id ( @trans_ids ) {
1232                     #XXX This doesn't seem to possible to ever happen . . .
1233                     next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
1234                     $blist->mark_deleted({
1235                         trans_id => $other_trans_id,
1236                     });
1237                 }
1238             }
1239         }
1240     }
1241
1242     #XXX Is this safe to do transactionally?
1243     # Free the place we're about to write to.
1244     if ( $blist->get_data_location_for({ allow_head => 0 }) ) {
1245         $blist->get_data_for({ allow_head => 0 })->free;
1246     }
1247
1248     $blist->write_md5({
1249         key      => $args->{key},
1250         key_md5  => $args->{key_md5},
1251         value    => $args->{value},
1252     });
1253 }
1254
1255 sub delete_key {
1256     my $self = shift;
1257     my ($args) = @_;
1258
1259     # XXX What should happen if this fails?
1260     my $blist = $self->get_bucket_list({
1261         key_md5 => $args->{key_md5},
1262     }) or DBM::Deep->_throw_error( "How did delete_key fail (no blist)?!" );
1263
1264     # Save the location so that we can free the data
1265     my $location = $blist->get_data_location_for({
1266         allow_head => 0,
1267     });
1268     my $old_value = $location && $self->engine->_load_sector( $location );
1269
1270     my @trans_ids = $self->engine->get_running_txn_ids;
1271
1272     if ( $self->engine->trans_id == 0 ) {
1273         if ( @trans_ids ) {
1274             foreach my $other_trans_id ( @trans_ids ) {
1275                 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
1276                 $blist->write_md5({
1277                     trans_id => $other_trans_id,
1278                     key      => $args->{key},
1279                     key_md5  => $args->{key_md5},
1280                     value    => $old_value->clone,
1281                 });
1282             }
1283         }
1284     }
1285
1286     my $data;
1287     if ( @trans_ids ) {
1288         $blist->mark_deleted( $args );
1289
1290         if ( $old_value ) {
1291             $data = $old_value->data;
1292             $old_value->free;
1293         }
1294     }
1295     else {
1296         $data = $blist->delete_md5( $args );
1297     }
1298
1299     return $data;
1300 }
1301
1302 sub get_blist_loc {
1303     my $self = shift;
1304
1305     my $e = $self->engine;
1306     my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size );
1307     return unpack( $StP{$e->byte_size}, $blist_loc );
1308 }
1309
1310 sub get_bucket_list {
1311     my $self = shift;
1312     my ($args) = @_;
1313     $args ||= {};
1314
1315     # XXX Add in check here for recycling?
1316
1317     my $engine = $self->engine;
1318
1319     my $blist_loc = $self->get_blist_loc;
1320
1321     # There's no index or blist yet
1322     unless ( $blist_loc ) {
1323         return unless $args->{create};
1324
1325         my $blist = DBM::Deep::Engine::Sector::BucketList->new({
1326             engine  => $engine,
1327             key_md5 => $args->{key_md5},
1328         });
1329
1330         $engine->storage->print_at( $self->offset + $self->base_size,
1331             pack( $StP{$engine->byte_size}, $blist->offset ),
1332         );
1333
1334         return $blist;
1335     }
1336
1337     my $sector = $engine->_load_sector( $blist_loc )
1338         or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
1339     my $i = 0;
1340     my $last_sector = undef;
1341     while ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) {
1342         $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
1343         $last_sector = $sector;
1344         if ( $blist_loc ) {
1345             $sector = $engine->_load_sector( $blist_loc )
1346                 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
1347         }
1348         else {
1349             $sector = undef;
1350             last;
1351         }
1352     }
1353
1354     # This means we went through the Index sector(s) and found an empty slot
1355     unless ( $sector ) {
1356         return unless $args->{create};
1357
1358         DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
1359             unless $last_sector;
1360
1361         my $blist = DBM::Deep::Engine::Sector::BucketList->new({
1362             engine  => $engine,
1363             key_md5 => $args->{key_md5},
1364         });
1365
1366         $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
1367
1368         return $blist;
1369     }
1370
1371     $sector->find_md5( $args->{key_md5} );
1372
1373     # See whether or not we need to reindex the bucketlist
1374     if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {
1375         my $new_index = DBM::Deep::Engine::Sector::Index->new({
1376             engine => $engine,
1377         });
1378
1379         my %blist_cache;
1380         #XXX q.v. the comments for this function.
1381         foreach my $entry ( $sector->chopped_up ) {
1382             my ($spot, $md5) = @{$entry};
1383             my $idx = ord( substr( $md5, $i, 1 ) );
1384
1385             # XXX This is inefficient
1386             my $blist = $blist_cache{$idx}
1387                 ||= DBM::Deep::Engine::Sector::BucketList->new({
1388                     engine => $engine,
1389                 });
1390
1391             $new_index->set_entry( $idx => $blist->offset );
1392
1393             my $new_spot = $blist->write_at_next_open( $md5 );
1394             $engine->reindex_entry( $spot => $new_spot );
1395         }
1396
1397         # Handle the new item separately.
1398         {
1399             my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
1400             my $blist = $blist_cache{$idx}
1401                 ||= DBM::Deep::Engine::Sector::BucketList->new({
1402                     engine => $engine,
1403                 });
1404
1405             $new_index->set_entry( $idx => $blist->offset );
1406
1407             #XXX THIS IS HACKY!
1408             $blist->find_md5( $args->{key_md5} );
1409             $blist->write_md5({
1410                 key     => $args->{key},
1411                 key_md5 => $args->{key_md5},
1412                 value   => DBM::Deep::Engine::Sector::Null->new({
1413                     engine => $engine,
1414                     data   => undef,
1415                 }),
1416             });
1417         }
1418
1419         if ( $last_sector ) {
1420             $last_sector->set_entry(
1421                 ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
1422                 $new_index->offset,
1423             );
1424         } else {
1425             $engine->storage->print_at( $self->offset + $self->base_size,
1426                 pack( $StP{$engine->byte_size}, $new_index->offset ),
1427             );
1428         }
1429
1430         $sector->free;
1431
1432         $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
1433         $sector->find_md5( $args->{key_md5} );
1434     }
1435
1436     return $sector;
1437 }
1438
1439 sub get_class_offset {
1440     my $self = shift;
1441
1442     my $e = $self->engine;
1443     return unpack(
1444         $StP{$e->byte_size},
1445         $e->storage->read_at(
1446             $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size,
1447         ),
1448     );
1449 }
1450
1451 sub get_classname {
1452     my $self = shift;
1453
1454     my $class_offset = $self->get_class_offset;
1455
1456     return unless $class_offset;
1457
1458     return $self->engine->_load_sector( $class_offset )->data;
1459 }
1460
1461 #XXX Add singleton handling here
1462 sub data {
1463     my $self = shift;
1464
1465     my $new_obj = DBM::Deep->new({
1466         type        => $self->type,
1467         base_offset => $self->offset,
1468         staleness   => $self->staleness,
1469         storage     => $self->engine->storage,
1470         engine      => $self->engine,
1471     });
1472
1473     if ( $self->engine->storage->{autobless} ) {
1474         my $classname = $self->get_classname;
1475         if ( defined $classname ) {
1476             bless $new_obj, $classname;
1477         }
1478     }
1479
1480     return $new_obj;
1481 }
1482
1483 package DBM::Deep::Engine::Sector::BucketList;
1484
1485 our @ISA = qw( DBM::Deep::Engine::Sector );
1486
1487 sub _init {
1488     my $self = shift;
1489
1490     my $engine = $self->engine;
1491
1492     unless ( $self->offset ) {
1493         my $leftover = $self->size - $self->base_size;
1494
1495         $self->{offset} = $engine->_request_blist_sector( $self->size );
1496         $engine->storage->print_at( $self->offset, $engine->SIG_BLIST ); # Sector type
1497         # Skip staleness counter
1498         $engine->storage->print_at( $self->offset + $self->base_size,
1499             chr(0) x $leftover, # Zero-fill the data
1500         );
1501     }
1502
1503     if ( $self->{key_md5} ) {
1504         $self->find_md5;
1505     }
1506
1507     return $self;
1508 }
1509
1510 sub size {
1511     my $self = shift;
1512     unless ( $self->{size} ) {
1513         my $e = $self->engine;
1514         # Base + numbuckets * bucketsize
1515         $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size;
1516     }
1517     return $self->{size};
1518 }
1519
1520 sub free_meth { return '_add_free_blist_sector' }
1521
1522 sub bucket_size {
1523     my $self = shift;
1524     unless ( $self->{bucket_size} ) {
1525         my $e = $self->engine;
1526         # Key + head (location) + transactions (location + staleness-counter)
1527         my $location_size = $e->byte_size + $e->num_txns * ( $e->byte_size + 4 );
1528         $self->{bucket_size} = $e->hash_size + $location_size;
1529     }
1530     return $self->{bucket_size};
1531 }
1532
1533 # XXX This is such a poor hack. I need to rethink this code.
1534 sub chopped_up {
1535     my $self = shift;
1536
1537     my $e = $self->engine;
1538
1539     my @buckets;
1540     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
1541         my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size;
1542         my $md5 = $e->storage->read_at( $spot, $e->hash_size );
1543
1544         #XXX If we're chopping, why would we ever have the blank_md5?
1545         last if $md5 eq $e->blank_md5;
1546
1547         my $rest = $e->storage->read_at( undef, $self->bucket_size - $e->hash_size );
1548         push @buckets, [ $spot, $md5 . $rest ];
1549     }
1550
1551     return @buckets;
1552 }
1553
1554 sub write_at_next_open {
1555     my $self = shift;
1556     my ($entry) = @_;
1557
1558     #XXX This is such a hack!
1559     $self->{_next_open} = 0 unless exists $self->{_next_open};
1560
1561     my $spot = $self->offset + $self->base_size + $self->{_next_open}++ * $self->bucket_size;
1562     $self->engine->storage->print_at( $spot, $entry );
1563
1564     return $spot;
1565 }
1566
1567 sub has_md5 {
1568     my $self = shift;
1569     unless ( exists $self->{found} ) {
1570         $self->find_md5;
1571     }
1572     return $self->{found};
1573 }
1574
1575 sub find_md5 {
1576     my $self = shift;
1577
1578     $self->{found} = undef;
1579     $self->{idx}   = -1;
1580
1581     if ( @_ ) {
1582         $self->{key_md5} = shift;
1583     }
1584
1585     # If we don't have an MD5, then what are we supposed to do?
1586     unless ( exists $self->{key_md5} ) {
1587         DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" );
1588     }
1589
1590     my $e = $self->engine;
1591     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
1592         my $potential = $e->storage->read_at(
1593             $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size,
1594         );
1595
1596         if ( $potential eq $e->blank_md5 ) {
1597             $self->{idx} = $idx;
1598             return;
1599         }
1600
1601         if ( $potential eq $self->{key_md5} ) {
1602             $self->{found} = 1;
1603             $self->{idx} = $idx;
1604             return;
1605         }
1606     }
1607
1608     return;
1609 }
1610
1611 sub write_md5 {
1612     my $self = shift;
1613     my ($args) = @_;
1614
1615     DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key};
1616     DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5};
1617     DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value};
1618
1619     my $engine = $self->engine;
1620
1621     $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id};
1622
1623     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
1624     $engine->add_entry( $args->{trans_id}, $spot );
1625
1626     unless ($self->{found}) {
1627         my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({
1628             engine => $engine,
1629             data   => $args->{key},
1630         });
1631
1632         $engine->storage->print_at( $spot,
1633             $args->{key_md5},
1634             pack( $StP{$engine->byte_size}, $key_sector->offset ),
1635         );
1636     }
1637
1638     my $loc = $spot
1639       + $engine->hash_size
1640       + $engine->byte_size
1641       + $args->{trans_id} * ( $engine->byte_size + 4 );
1642
1643     $engine->storage->print_at( $loc,
1644         pack( $StP{$engine->byte_size}, $args->{value}->offset ),
1645         pack( 'N', $engine->get_txn_staleness_counter( $args->{trans_id} ) ),
1646     );
1647 }
1648
1649 sub mark_deleted {
1650     my $self = shift;
1651     my ($args) = @_;
1652     $args ||= {};
1653
1654     my $engine = $self->engine;
1655
1656     $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id};
1657
1658     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
1659     $engine->add_entry( $args->{trans_id}, $spot );
1660
1661     my $loc = $spot
1662       + $engine->hash_size
1663       + $engine->byte_size
1664       + $args->{trans_id} * ( $engine->byte_size + 4 );
1665
1666     $engine->storage->print_at( $loc,
1667         pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted
1668         pack( 'N', $engine->get_txn_staleness_counter( $args->{trans_id} ) ),
1669     );
1670 }
1671
1672 sub delete_md5 {
1673     my $self = shift;
1674     my ($args) = @_;
1675
1676     my $engine = $self->engine;
1677     return undef unless $self->{found};
1678
1679     # Save the location so that we can free the data
1680     my $location = $self->get_data_location_for({
1681         allow_head => 0,
1682     });
1683     my $key_sector = $self->get_key_for;
1684
1685     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
1686     $engine->storage->print_at( $spot,
1687         $engine->storage->read_at(
1688             $spot + $self->bucket_size,
1689             $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ),
1690         ),
1691         chr(0) x $self->bucket_size,
1692     );
1693
1694     $key_sector->free;
1695
1696     my $data_sector = $self->engine->_load_sector( $location );
1697     my $data = $data_sector->data;
1698     $data_sector->free;
1699
1700     return $data;
1701 }
1702
1703 sub get_data_location_for {
1704     my $self = shift;
1705     my ($args) = @_;
1706     $args ||= {};
1707
1708     $args->{allow_head} = 0 unless exists $args->{allow_head};
1709     $args->{trans_id}   = $self->engine->trans_id unless exists $args->{trans_id};
1710     $args->{idx}        = $self->{idx} unless exists $args->{idx};
1711
1712     my $e = $self->engine;
1713
1714     my $spot = $self->offset + $self->base_size
1715       + $args->{idx} * $self->bucket_size
1716       + $e->hash_size
1717       + $e->byte_size
1718       + $args->{trans_id} * ( $e->byte_size + 4 );
1719
1720     my $buffer = $e->storage->read_at(
1721         $spot,
1722         $e->byte_size + 4,
1723     );
1724     my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' N', $buffer );
1725
1726     # We have found an entry that is old, so get rid of it
1727     if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) {
1728         $e->storage->print_at(
1729             $spot,
1730             pack( $StP{$e->byte_size} . ' N', (0) x 2 ),
1731         );
1732         $loc = 0;
1733     }
1734
1735     # If we're in a transaction and we never wrote to this location, try the
1736     # HEAD instead.
1737     if ( $args->{trans_id} && !$loc && $args->{allow_head} ) {
1738         return $self->get_data_location_for({
1739             trans_id   => 0,
1740             allow_head => 1,
1741             idx        => $args->{idx},
1742         });
1743     }
1744     return $loc <= 1 ? 0 : $loc;
1745 }
1746
1747 sub get_data_for {
1748     my $self = shift;
1749     my ($args) = @_;
1750     $args ||= {};
1751
1752     return unless $self->{found};
1753     my $location = $self->get_data_location_for({
1754         allow_head => $args->{allow_head},
1755     });
1756     return $self->engine->_load_sector( $location );
1757 }
1758
1759 sub get_key_for {
1760     my $self = shift;
1761     my ($idx) = @_;
1762     $idx = $self->{idx} unless defined $idx;
1763
1764     if ( $idx >= $self->engine->max_buckets ) {
1765         DBM::Deep->_throw_error( "get_key_for(): Attempting to retrieve $idx" );
1766     }
1767
1768     my $location = $self->engine->storage->read_at(
1769         $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size,
1770         $self->engine->byte_size,
1771     );
1772     $location = unpack( $StP{$self->engine->byte_size}, $location );
1773     DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location;
1774
1775     return $self->engine->_load_sector( $location );
1776 }
1777
1778 package DBM::Deep::Engine::Sector::Index;
1779
1780 our @ISA = qw( DBM::Deep::Engine::Sector );
1781
1782 sub _init {
1783     my $self = shift;
1784
1785     my $engine = $self->engine;
1786
1787     unless ( $self->offset ) {
1788         my $leftover = $self->size - $self->base_size;
1789
1790         $self->{offset} = $engine->_request_index_sector( $self->size );
1791         $engine->storage->print_at( $self->offset, $engine->SIG_INDEX ); # Sector type
1792         # Skip staleness counter
1793         $engine->storage->print_at( $self->offset + $self->base_size,
1794             chr(0) x $leftover, # Zero-fill the rest
1795         );
1796     }
1797
1798     return $self;
1799 }
1800
1801 sub size {
1802     my $self = shift;
1803     unless ( $self->{size} ) {
1804         my $e = $self->engine;
1805         $self->{size} = $self->base_size + $e->byte_size * $e->hash_chars;
1806     }
1807     return $self->{size};
1808 }
1809
1810 sub free_meth { return '_add_free_index_sector' }
1811
1812 sub free {
1813     my $self = shift;
1814     my $e = $self->engine;
1815
1816     for my $i ( 0 .. $e->hash_chars - 1 ) {
1817         my $l = $self->get_entry( $i ) or next;
1818         $e->_load_sector( $l )->free;
1819     }
1820
1821     $self->SUPER::free();
1822 }
1823
1824 sub _loc_for {
1825     my $self = shift;
1826     my ($idx) = @_;
1827     return $self->offset + $self->base_size + $idx * $self->engine->byte_size;
1828 }
1829
1830 sub get_entry {
1831     my $self = shift;
1832     my ($idx) = @_;
1833
1834     my $e = $self->engine;
1835
1836     DBM::Deep->_throw_error( "get_entry: Out of range ($idx)" )
1837         if $idx < 0 || $idx >= $e->hash_chars;
1838
1839     return unpack(
1840         $StP{$e->byte_size},
1841         $e->storage->read_at( $self->_loc_for( $idx ), $e->byte_size ),
1842     );
1843 }
1844
1845 sub set_entry {
1846     my $self = shift;
1847     my ($idx, $loc) = @_;
1848
1849     my $e = $self->engine;
1850
1851     DBM::Deep->_throw_error( "set_entry: Out of range ($idx)" )
1852         if $idx < 0 || $idx >= $e->hash_chars;
1853
1854     $self->engine->storage->print_at(
1855         $self->_loc_for( $idx ),
1856         pack( $StP{$e->byte_size}, $loc ),
1857     );
1858 }
1859
1860 1;
1861 __END__