lib/DBM/Deep/Engine.pm

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