lib/DBM/Deep/Engine.pm

   1 package DBM::Deep::Engine;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 use DBM::Deep::Engine::Sector::BucketList;
   9 use DBM::Deep::Engine::Sector::Index;
  10 use DBM::Deep::Engine::Sector::Null;
  11 use DBM::Deep::Engine::Sector::Reference;
  12 use DBM::Deep::Engine::Sector::Scalar;
  13 use DBM::Deep::Iterator;
  14
  15 # Never import symbols into our namespace. We are a class, not a library.
  16 # -RobK, 2008-05-27
  17 use Scalar::Util ();
  18
  19 #use Data::Dumper ();
  20
  21 # File-wide notes:
  22 # * Every method in here assumes that the storage has been appropriately
  23 #   safeguarded. This can be anything from flock() to some sort of manual
  24 #   mutex. But, it's the caller's responsability to make sure that this has
  25 #   been done.
  26
  27 # Setup file and tag signatures.  These should never change.
  28 sub SIG_FILE     () { 'DPDB' }
  29 sub SIG_HEADER   () { 'h'    }
  30 sub SIG_HASH     () { 'H'    }
  31 sub SIG_ARRAY    () { 'A'    }
  32 sub SIG_NULL     () { 'N'    }
  33 sub SIG_DATA     () { 'D'    }
  34 sub SIG_INDEX    () { 'I'    }
  35 sub SIG_BLIST    () { 'B'    }
  36 sub SIG_FREE     () { 'F'    }
  37 sub SIG_SIZE     () {  1     }
  38
  39 our $STALE_SIZE = 2;
  40
  41 # Please refer to the pack() documentation for further information
  42 my %StP = (
  43     1 => 'C', # Unsigned char value (no order needed as it's just one byte)
  44     2 => 'n', # Unsigned short in "network" (big-endian) order
  45     4 => 'N', # Unsigned long in "network" (big-endian) order
  46     8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
  47 );
  48 sub StP { $StP{$_[1]} }
  49
  50 ################################################################################
  51
  52 sub new {
  53     my $class = shift;
  54     my ($args) = @_;
  55
  56     $args->{storage} = DBM::Deep::File->new( $args )
  57         unless exists $args->{storage};
  58
  59     my $self = bless {
  60         byte_size   => 4,
  61
  62         digest      => undef,
  63         hash_size   => 16,  # In bytes
  64         hash_chars  => 256, # Number of chars the algorithm uses per byte
  65         max_buckets => 16,
  66         num_txns    => 1,   # The HEAD
  67         trans_id    => 0,   # Default to the HEAD
  68
  69         data_sector_size => 64, # Size in bytes of each data sector
  70
  71         entries => {}, # This is the list of entries for transactions
  72         storage => undef,
  73     }, $class;
  74
  75     # Never allow byte_size to be set directly.
  76     delete $args->{byte_size};
  77     if ( defined $args->{pack_size} ) {
  78         if ( lc $args->{pack_size} eq 'small' ) {
  79             $args->{byte_size} = 2;
  80         }
  81         elsif ( lc $args->{pack_size} eq 'medium' ) {
  82             $args->{byte_size} = 4;
  83         }
  84         elsif ( lc $args->{pack_size} eq 'large' ) {
  85             $args->{byte_size} = 8;
  86         }
  87         else {
  88             DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
  89         }
  90     }
  91
  92     # Grab the parameters we want to use
  93     foreach my $param ( keys %$self ) {
  94         next unless exists $args->{$param};
  95         $self->{$param} = $args->{$param};
  96     }
  97
  98     my %validations = (
  99         max_buckets      => { floor => 16, ceil => 256 },
 100         num_txns         => { floor => 1,  ceil => 255 },
 101         data_sector_size => { floor => 32, ceil => 256 },
 102     );
 103
 104     while ( my ($attr, $c) = each %validations ) {
 105         if (   !defined $self->{$attr}
 106             || !length $self->{$attr}
 107             || $self->{$attr} =~ /\D/
 108             || $self->{$attr} < $c->{floor}
 109         ) {
 110             $self->{$attr} = '(undef)' if !defined $self->{$attr};
 111             warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
 112             $self->{$attr} = $c->{floor};
 113         }
 114         elsif ( $self->{$attr} > $c->{ceil} ) {
 115             warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
 116             $self->{$attr} = $c->{ceil};
 117         }
 118     }
 119
 120     if ( !$self->{digest} ) {
 121         require Digest::MD5;
 122         $self->{digest} = \&Digest::MD5::md5;
 123     }
 124
 125     return $self;
 126 }
 127
 128 ################################################################################
 129
 130 sub read_value {
 131     my $self = shift;
 132     my ($obj, $key) = @_;
 133
 134     # This will be a Reference sector
 135     my $sector = $self->_load_sector( $obj->_base_offset )
 136         or return;
 137
 138     if ( $sector->staleness != $obj->_staleness ) {
 139         return;
 140     }
 141
 142     my $key_md5 = $self->_apply_digest( $key );
 143
 144     my $value_sector = $sector->get_data_for({
 145         key_md5    => $key_md5,
 146         allow_head => 1,
 147     });
 148
 149     unless ( $value_sector ) {
 150         $value_sector = DBM::Deep::Engine::Sector::Null->new({
 151             engine => $self,
 152             data   => undef,
 153         });
 154
 155         $sector->write_data({
 156             key_md5 => $key_md5,
 157             key     => $key,
 158             value   => $value_sector,
 159         });
 160     }
 161
 162     return $value_sector->data;
 163 }
 164
 165 sub get_classname {
 166     my $self = shift;
 167     my ($obj) = @_;
 168
 169     # This will be a Reference sector
 170     my $sector = $self->_load_sector( $obj->_base_offset )
 171         or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
 172
 173     if ( $sector->staleness != $obj->_staleness ) {
 174         return;
 175     }
 176
 177     return $sector->get_classname;
 178 }
 179
 180 sub make_reference {
 181     my $self = shift;
 182     my ($obj, $old_key, $new_key) = @_;
 183
 184     # This will be a Reference sector
 185     my $sector = $self->_load_sector( $obj->_base_offset )
 186         or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
 187
 188     if ( $sector->staleness != $obj->_staleness ) {
 189         return;
 190     }
 191
 192     my $old_md5 = $self->_apply_digest( $old_key );
 193
 194     my $value_sector = $sector->get_data_for({
 195         key_md5    => $old_md5,
 196         allow_head => 1,
 197     });
 198
 199     unless ( $value_sector ) {
 200         $value_sector = DBM::Deep::Engine::Sector::Null->new({
 201             engine => $self,
 202             data   => undef,
 203         });
 204
 205         $sector->write_data({
 206             key_md5 => $old_md5,
 207             key     => $old_key,
 208             value   => $value_sector,
 209         });
 210     }
 211
 212     if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
 213         $sector->write_data({
 214             key     => $new_key,
 215             key_md5 => $self->_apply_digest( $new_key ),
 216             value   => $value_sector,
 217         });
 218         $value_sector->increment_refcount;
 219     }
 220     else {
 221         $sector->write_data({
 222             key     => $new_key,
 223             key_md5 => $self->_apply_digest( $new_key ),
 224             value   => $value_sector->clone,
 225         });
 226     }
 227 }
 228
 229 sub key_exists {
 230     my $self = shift;
 231     my ($obj, $key) = @_;
 232
 233     # This will be a Reference sector
 234     my $sector = $self->_load_sector( $obj->_base_offset )
 235         or return '';
 236
 237     if ( $sector->staleness != $obj->_staleness ) {
 238         return '';
 239     }
 240
 241     my $data = $sector->get_data_for({
 242         key_md5    => $self->_apply_digest( $key ),
 243         allow_head => 1,
 244     });
 245
 246     # exists() returns 1 or '' for true/false.
 247     return $data ? 1 : '';
 248 }
 249
 250 sub delete_key {
 251     my $self = shift;
 252     my ($obj, $key) = @_;
 253
 254     my $sector = $self->_load_sector( $obj->_base_offset )
 255         or return;
 256
 257     if ( $sector->staleness != $obj->_staleness ) {
 258         return;
 259     }
 260
 261     return $sector->delete_key({
 262         key_md5    => $self->_apply_digest( $key ),
 263         allow_head => 0,
 264     });
 265 }
 266
 267 sub write_value {
 268     my $self = shift;
 269     my ($obj, $key, $value) = @_;
 270
 271     my $r = Scalar::Util::reftype( $value ) || '';
 272     {
 273         last if $r eq '';
 274         last if $r eq 'HASH';
 275         last if $r eq 'ARRAY';
 276
 277         DBM::Deep->_throw_error(
 278             "Storage of references of type '$r' is not supported."
 279         );
 280     }
 281
 282     # This will be a Reference sector
 283     my $sector = $self->_load_sector( $obj->_base_offset )
 284         or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
 285
 286     if ( $sector->staleness != $obj->_staleness ) {
 287         DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
 288     }
 289
 290     my ($class, $type);
 291     if ( !defined $value ) {
 292         $class = 'DBM::Deep::Engine::Sector::Null';
 293     }
 294     elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
 295         my $tmpvar;
 296         if ( $r eq 'ARRAY' ) {
 297             $tmpvar = tied @$value;
 298         } elsif ( $r eq 'HASH' ) {
 299             $tmpvar = tied %$value;
 300         }
 301
 302         if ( $tmpvar ) {
 303             my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
 304
 305             unless ( $is_dbm_deep ) {
 306                 DBM::Deep->_throw_error( "Cannot store something that is tied." );
 307             }
 308
 309             unless ( $tmpvar->_engine->storage == $self->storage ) {
 310                 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
 311             }
 312
 313             # First, verify if we're storing the same thing to this spot. If we are, then
 314             # this should be a no-op. -EJS, 2008-05-19
 315             my $loc = $sector->get_data_location_for({
 316                 key_md5 => $self->_apply_digest( $key ),
 317                 allow_head => 1,
 318             });
 319
 320             if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
 321                 return 1;
 322             }
 323
 324             #XXX Can this use $loc?
 325             my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
 326             $sector->write_data({
 327                 key     => $key,
 328                 key_md5 => $self->_apply_digest( $key ),
 329                 value   => $value_sector,
 330             });
 331             $value_sector->increment_refcount;
 332
 333             return 1;
 334         }
 335
 336         $class = 'DBM::Deep::Engine::Sector::Reference';
 337         $type = substr( $r, 0, 1 );
 338     }
 339     else {
 340         if ( tied($value) ) {
 341             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 342         }
 343         $class = 'DBM::Deep::Engine::Sector::Scalar';
 344     }
 345
 346     # Create this after loading the reference sector in case something bad happens.
 347     # This way, we won't allocate value sector(s) needlessly.
 348     my $value_sector = $class->new({
 349         engine => $self,
 350         data   => $value,
 351         type   => $type,
 352     });
 353
 354     $sector->write_data({
 355         key     => $key,
 356         key_md5 => $self->_apply_digest( $key ),
 357         value   => $value_sector,
 358     });
 359
 360     # This code is to make sure we write all the values in the $value to the disk
 361     # and to make sure all changes to $value after the assignment are reflected
 362     # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
 363     #   NOTE - simply tying $value won't perform a STORE on each value. Hence, the
 364     # copy to a temp value.
 365     if ( $r eq 'ARRAY' ) {
 366         my @temp = @$value;
 367         tie @$value, 'DBM::Deep', {
 368             base_offset => $value_sector->offset,
 369             staleness   => $value_sector->staleness,
 370             storage     => $self->storage,
 371             engine      => $self,
 372         };
 373         @$value = @temp;
 374         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
 375     }
 376     elsif ( $r eq 'HASH' ) {
 377         my %temp = %$value;
 378         tie %$value, 'DBM::Deep', {
 379             base_offset => $value_sector->offset,
 380             staleness   => $value_sector->staleness,
 381             storage     => $self->storage,
 382             engine      => $self,
 383         };
 384
 385         %$value = %temp;
 386         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
 387     }
 388
 389     return 1;
 390 }
 391
 392 # XXX Add staleness here
 393 sub get_next_key {
 394     my $self = shift;
 395     my ($obj, $prev_key) = @_;
 396
 397     # XXX Need to add logic about resetting the iterator if any key in the reference has changed
 398     unless ( $prev_key ) {
 399         $obj->{iterator} = DBM::Deep::Iterator->new({
 400             base_offset => $obj->_base_offset,
 401             engine      => $self,
 402         });
 403     }
 404
 405     return $obj->{iterator}->get_next_key( $obj );
 406 }
 407
 408 ################################################################################
 409
 410 sub setup_fh {
 411     my $self = shift;
 412     my ($obj) = @_;
 413
 414     # We're opening the file.
 415     unless ( $obj->_base_offset ) {
 416         my $bytes_read = $self->_read_file_header;
 417
 418         # Creating a new file
 419         unless ( $bytes_read ) {
 420             $self->_write_file_header;
 421
 422             # 1) Create Array/Hash entry
 423             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 424                 engine => $self,
 425                 type   => $obj->_type,
 426             });
 427             $obj->{base_offset} = $initial_reference->offset;
 428             $obj->{staleness} = $initial_reference->staleness;
 429
 430             $self->storage->flush;
 431         }
 432         # Reading from an existing file
 433         else {
 434             $obj->{base_offset} = $bytes_read;
 435             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 436                 engine => $self,
 437                 offset => $obj->_base_offset,
 438             });
 439             unless ( $initial_reference ) {
 440                 DBM::Deep->_throw_error("Corrupted file, no master index record");
 441             }
 442
 443             unless ($obj->_type eq $initial_reference->type) {
 444                 DBM::Deep->_throw_error("File type mismatch");
 445             }
 446
 447             $obj->{staleness} = $initial_reference->staleness;
 448         }
 449
 450         $self->storage->set_inode;
 451     }
 452
 453     return 1;
 454 }
 455
 456 sub begin_work {
 457     my $self = shift;
 458     my ($obj) = @_;
 459
 460     if ( $self->trans_id ) {
 461         DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
 462     }
 463
 464     my @slots = $self->read_txn_slots;
 465     my $found;
 466     for my $i ( 0 .. $#slots ) {
 467         next if $slots[$i];
 468
 469         $slots[$i] = 1;
 470         $self->set_trans_id( $i + 1 );
 471         $found = 1;
 472         last;
 473     }
 474     unless ( $found ) {
 475         DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
 476     }
 477     $self->write_txn_slots( @slots );
 478
 479     if ( !$self->trans_id ) {
 480         DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
 481     }
 482
 483     return;
 484 }
 485
 486 sub rollback {
 487     my $self = shift;
 488     my ($obj) = @_;
 489
 490     if ( !$self->trans_id ) {
 491         DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
 492     }
 493
 494     # Each entry is the file location for a bucket that has a modification for
 495     # this transaction. The entries need to be expunged.
 496     foreach my $entry (@{ $self->get_entries } ) {
 497         # Remove the entry here
 498         my $read_loc = $entry
 499           + $self->hash_size
 500           + $self->byte_size
 501           + $self->byte_size
 502           + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
 503
 504         my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
 505         $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
 506         $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
 507
 508         if ( $data_loc > 1 ) {
 509             $self->_load_sector( $data_loc )->free;
 510         }
 511     }
 512
 513     $self->clear_entries;
 514
 515     my @slots = $self->read_txn_slots;
 516     $slots[$self->trans_id-1] = 0;
 517     $self->write_txn_slots( @slots );
 518     $self->inc_txn_staleness_counter( $self->trans_id );
 519     $self->set_trans_id( 0 );
 520
 521     return 1;
 522 }
 523
 524 sub commit {
 525     my $self = shift;
 526     my ($obj) = @_;
 527
 528     if ( !$self->trans_id ) {
 529         DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
 530     }
 531
 532     foreach my $entry (@{ $self->get_entries } ) {
 533         # Overwrite the entry in head with the entry in trans_id
 534         my $base = $entry
 535           + $self->hash_size
 536           + $self->byte_size;
 537
 538         my $head_loc = $self->storage->read_at( $base, $self->byte_size );
 539         $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
 540
 541         my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
 542         my $trans_loc = $self->storage->read_at(
 543             $spot, $self->byte_size,
 544         );
 545
 546         $self->storage->print_at( $base, $trans_loc );
 547         $self->storage->print_at(
 548             $spot,
 549             pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
 550         );
 551
 552         if ( $head_loc > 1 ) {
 553             $self->_load_sector( $head_loc )->free;
 554         }
 555     }
 556
 557     $self->clear_entries;
 558
 559     my @slots = $self->read_txn_slots;
 560     $slots[$self->trans_id-1] = 0;
 561     $self->write_txn_slots( @slots );
 562     $self->inc_txn_staleness_counter( $self->trans_id );
 563     $self->set_trans_id( 0 );
 564
 565     return 1;
 566 }
 567
 568 sub read_txn_slots {
 569     my $self = shift;
 570     my $bl = $self->txn_bitfield_len;
 571     my $num_bits = $bl * 8;
 572     return split '', unpack( 'b'.$num_bits,
 573         $self->storage->read_at(
 574             $self->trans_loc, $bl,
 575         )
 576     );
 577 }
 578
 579 sub write_txn_slots {
 580     my $self = shift;
 581     my $num_bits = $self->txn_bitfield_len * 8;
 582     $self->storage->print_at( $self->trans_loc,
 583         pack( 'b'.$num_bits, join('', @_) ),
 584     );
 585 }
 586
 587 sub get_running_txn_ids {
 588     my $self = shift;
 589     my @transactions = $self->read_txn_slots;
 590     my @trans_ids = map { $_+1} grep { $transactions[$_] } 0 .. $#transactions;
 591 }
 592
 593 sub get_txn_staleness_counter {
 594     my $self = shift;
 595     my ($trans_id) = @_;
 596
 597     # Hardcode staleness of 0 for the HEAD
 598     return 0 unless $trans_id;
 599
 600     return unpack( $StP{$STALE_SIZE},
 601         $self->storage->read_at(
 602             $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
 603             $STALE_SIZE,
 604         )
 605     );
 606 }
 607
 608 sub inc_txn_staleness_counter {
 609     my $self = shift;
 610     my ($trans_id) = @_;
 611
 612     # Hardcode staleness of 0 for the HEAD
 613     return 0 unless $trans_id;
 614
 615     $self->storage->print_at(
 616         $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
 617         pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
 618     );
 619 }
 620
 621 sub get_entries {
 622     my $self = shift;
 623     return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
 624 }
 625
 626 sub add_entry {
 627     my $self = shift;
 628     my ($trans_id, $loc) = @_;
 629
 630     $self->{entries}{$trans_id} ||= {};
 631     $self->{entries}{$trans_id}{$loc} = undef;
 632 }
 633
 634 # If the buckets are being relocated because of a reindexing, the entries
 635 # mechanism needs to be made aware of it.
 636 sub reindex_entry {
 637     my $self = shift;
 638     my ($old_loc, $new_loc) = @_;
 639
 640     TRANS:
 641     while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
 642         if ( exists $locs->{$old_loc} ) {
 643             delete $locs->{$old_loc};
 644             $locs->{$new_loc} = undef;
 645             next TRANS;
 646         }
 647     }
 648 }
 649
 650 sub clear_entries {
 651     my $self = shift;
 652     delete $self->{entries}{$self->trans_id};
 653 }
 654
 655 ################################################################################
 656
 657 {
 658     my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
 659     my $this_file_version = 3;
 660
 661     sub _write_file_header {
 662         my $self = shift;
 663
 664         my $nt = $self->num_txns;
 665         my $bl = $self->txn_bitfield_len;
 666
 667         my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
 668
 669         my $loc = $self->storage->request_space( $header_fixed + $header_var );
 670
 671         $self->storage->print_at( $loc,
 672             SIG_FILE,
 673             SIG_HEADER,
 674             pack('N', $this_file_version), # At this point, we're at 9 bytes
 675             pack('N', $header_var),        # header size
 676             # --- Above is $header_fixed. Below is $header_var
 677             pack('C', $self->byte_size),
 678
 679             # These shenanigans are to allow a 256 within a C
 680             pack('C', $self->max_buckets - 1),
 681             pack('C', $self->data_sector_size - 1),
 682
 683             pack('C', $nt),
 684             pack('C' . $bl, 0 ),                           # Transaction activeness bitfield
 685             pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
 686             pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
 687             pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
 688             pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
 689         );
 690
 691         #XXX Set these less fragilely
 692         $self->set_trans_loc( $header_fixed + 4 );
 693         $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
 694
 695         return;
 696     }
 697
 698     sub _read_file_header {
 699         my $self = shift;
 700
 701         my $buffer = $self->storage->read_at( 0, $header_fixed );
 702         return unless length($buffer);
 703
 704         my ($file_signature, $sig_header, $file_version, $size) = unpack(
 705             'A4 A N N', $buffer
 706         );
 707
 708         unless ( $file_signature eq SIG_FILE ) {
 709             $self->storage->close;
 710             DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
 711         }
 712
 713         unless ( $sig_header eq SIG_HEADER ) {
 714             $self->storage->close;
 715             DBM::Deep->_throw_error( "Pre-1.00 file version found" );
 716         }
 717
 718         unless ( $file_version == $this_file_version ) {
 719             $self->storage->close;
 720             DBM::Deep->_throw_error(
 721                 "Wrong file version found - " .  $file_version .
 722                 " - expected " . $this_file_version
 723             );
 724         }
 725
 726         my $buffer2 = $self->storage->read_at( undef, $size );
 727         my @values = unpack( 'C C C C', $buffer2 );
 728
 729         if ( @values != 4 || grep { !defined } @values ) {
 730             $self->storage->close;
 731             DBM::Deep->_throw_error("Corrupted file - bad header");
 732         }
 733
 734         #XXX Add warnings if values weren't set right
 735         @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
 736
 737         # These shenangians are to allow a 256 within a C
 738         $self->{max_buckets} += 1;
 739         $self->{data_sector_size} += 1;
 740
 741         my $bl = $self->txn_bitfield_len;
 742
 743         my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
 744         unless ( $size == $header_var ) {
 745             $self->storage->close;
 746             DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
 747         }
 748
 749         $self->set_trans_loc( $header_fixed + scalar(@values) );
 750         $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
 751
 752         return length($buffer) + length($buffer2);
 753     }
 754 }
 755
 756 sub _load_sector {
 757     my $self = shift;
 758     my ($offset) = @_;
 759
 760     # Add a catch for offset of 0 or 1
 761     return if !$offset || $offset <= 1;
 762
 763     my $type = $self->storage->read_at( $offset, 1 );
 764     return if $type eq chr(0);
 765
 766     if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
 767         return DBM::Deep::Engine::Sector::Reference->new({
 768             engine => $self,
 769             type   => $type,
 770             offset => $offset,
 771         });
 772     }
 773     # XXX Don't we need key_md5 here?
 774     elsif ( $type eq $self->SIG_BLIST ) {
 775         return DBM::Deep::Engine::Sector::BucketList->new({
 776             engine => $self,
 777             type   => $type,
 778             offset => $offset,
 779         });
 780     }
 781     elsif ( $type eq $self->SIG_INDEX ) {
 782         return DBM::Deep::Engine::Sector::Index->new({
 783             engine => $self,
 784             type   => $type,
 785             offset => $offset,
 786         });
 787     }
 788     elsif ( $type eq $self->SIG_NULL ) {
 789         return DBM::Deep::Engine::Sector::Null->new({
 790             engine => $self,
 791             type   => $type,
 792             offset => $offset,
 793         });
 794     }
 795     elsif ( $type eq $self->SIG_DATA ) {
 796         return DBM::Deep::Engine::Sector::Scalar->new({
 797             engine => $self,
 798             type   => $type,
 799             offset => $offset,
 800         });
 801     }
 802     # This was deleted from under us, so just return and let the caller figure it out.
 803     elsif ( $type eq $self->SIG_FREE ) {
 804         return;
 805     }
 806
 807     DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
 808 }
 809
 810 sub _apply_digest {
 811     my $self = shift;
 812     return $self->{digest}->(@_);
 813 }
 814
 815 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
 816 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
 817 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
 818
 819 sub _add_free_sector {
 820     my $self = shift;
 821     my ($multiple, $offset, $size) = @_;
 822
 823     my $chains_offset = $multiple * $self->byte_size;
 824
 825     my $storage = $self->storage;
 826
 827     # Increment staleness.
 828     # XXX Can this increment+modulo be done by "&= 0x1" ?
 829     my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + SIG_SIZE, $STALE_SIZE ) );
 830     $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
 831     $storage->print_at( $offset + SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
 832
 833     my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 834
 835     $storage->print_at( $self->chains_loc + $chains_offset,
 836         pack( $StP{$self->byte_size}, $offset ),
 837     );
 838
 839     # Record the old head in the new sector after the signature and staleness counter
 840     $storage->print_at( $offset + SIG_SIZE + $STALE_SIZE, $old_head );
 841 }
 842
 843 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
 844 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
 845 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
 846
 847 sub _request_sector {
 848     my $self = shift;
 849     my ($multiple, $size) = @_;
 850
 851     my $chains_offset = $multiple * $self->byte_size;
 852
 853     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 854     my $loc = unpack( $StP{$self->byte_size}, $old_head );
 855
 856     # We don't have any free sectors of the right size, so allocate a new one.
 857     unless ( $loc ) {
 858         my $offset = $self->storage->request_space( $size );
 859
 860         # Zero out the new sector. This also guarantees correct increases
 861         # in the filesize.
 862         $self->storage->print_at( $offset, chr(0) x $size );
 863
 864         return $offset;
 865     }
 866
 867     # Read the new head after the signature and the staleness counter
 868     my $new_head = $self->storage->read_at( $loc + SIG_SIZE + $STALE_SIZE, $self->byte_size );
 869     $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
 870     $self->storage->print_at(
 871         $loc + SIG_SIZE + $STALE_SIZE,
 872         pack( $StP{$self->byte_size}, 0 ),
 873     );
 874
 875     return $loc;
 876 }
 877
 878 ################################################################################
 879
 880 sub dirty_sectors {
 881     my $self = shift;
 882     return $self->{dirty_sectors} ||= {};
 883 }
 884
 885 sub add_dirty_sector {
 886     my $self = shift;
 887     my ($sector) = @_;
 888
 889 #    if ( exists $self->dirty_sectors->{ $sector->offset } ) {
 890 #        DBM::Deep->_throw_error( "We have a duplicate sector!! " . $sector->offset );
 891 #    }
 892
 893     $self->dirty_sectors->{ $sector->offset } = $sector;
 894 }
 895
 896 sub clear_dirty_sectors {
 897     my $self = shift;
 898     $self->{dirty_sectors} = {};
 899 }
 900
 901 sub flush {
 902     my $self = shift;
 903
 904     for (values %{ $self->dirty_sectors }) {
 905         $_->flush;
 906     }
 907
 908     $self->clear_dirty_sectors;
 909 }
 910
 911 ################################################################################
 912
 913 sub lock_exclusive {
 914     my $self = shift;
 915     my ($obj) = @_;
 916     return $self->storage->lock_exclusive( $obj );
 917 }
 918
 919 sub lock_shared {
 920     my $self = shift;
 921     my ($obj) = @_;
 922     return $self->storage->lock_shared( $obj );
 923 }
 924
 925 sub unlock {
 926     my $self = shift;
 927     my ($obj) = @_;
 928
 929     my $rv = $self->storage->unlock( $obj );
 930
 931     $self->flush if $rv;
 932
 933     return $rv;
 934 }
 935
 936 ################################################################################
 937
 938 sub storage     { $_[0]{storage} }
 939 sub byte_size   { $_[0]{byte_size} }
 940 sub hash_size   { $_[0]{hash_size} }
 941 sub hash_chars  { $_[0]{hash_chars} }
 942 sub num_txns    { $_[0]{num_txns} }
 943 sub max_buckets { $_[0]{max_buckets} }
 944 sub blank_md5   { chr(0) x $_[0]->hash_size }
 945 sub data_sector_size { $_[0]{data_sector_size} }
 946
 947 # This is a calculated value
 948 sub txn_bitfield_len {
 949     my $self = shift;
 950     unless ( exists $self->{txn_bitfield_len} ) {
 951         my $temp = ($self->num_txns) / 8;
 952         if ( $temp > int( $temp ) ) {
 953             $temp = int( $temp ) + 1;
 954         }
 955         $self->{txn_bitfield_len} = $temp;
 956     }
 957     return $self->{txn_bitfield_len};
 958 }
 959
 960 sub trans_id     { $_[0]{trans_id} }
 961 sub set_trans_id { $_[0]{trans_id} = $_[1] }
 962
 963 sub trans_loc     { $_[0]{trans_loc} }
 964 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
 965
 966 sub chains_loc     { $_[0]{chains_loc} }
 967 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
 968
 969 sub cache       { $_[0]{cache} ||= {} }
 970 sub clear_cache { %{$_[0]->cache} = () }
 971
 972 sub _dump_file {
 973     my $self = shift;
 974
 975     # Read the header
 976     my $spot = $self->_read_file_header();
 977
 978     my %types = (
 979         0 => 'B',
 980         1 => 'D',
 981         2 => 'I',
 982     );
 983
 984     my %sizes = (
 985         'D' => $self->data_sector_size,
 986         'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
 987         'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
 988     );
 989
 990     my $return = "";
 991
 992     # Filesize
 993     $return .= "Size: " . (-s $self->storage->{fh}) . $/;
 994
 995     # Header values
 996     $return .= "NumTxns: " . $self->num_txns . $/;
 997
 998     # Read the free sector chains
 999     my %sectors;
1000     foreach my $multiple ( 0 .. 2 ) {
1001         $return .= "Chains($types{$multiple}):";
1002         my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1003         while ( 1 ) {
1004             my $loc = unpack(
1005                 $StP{$self->byte_size},
1006                 $self->storage->read_at( $old_loc, $self->byte_size ),
1007             );
1008
1009             # We're now out of free sectors of this kind.
1010             unless ( $loc ) {
1011                 last;
1012             }
1013
1014             $sectors{ $types{$multiple} }{ $loc } = undef;
1015             $old_loc = $loc + SIG_SIZE + $STALE_SIZE;
1016             $return .= " $loc";
1017         }
1018         $return .= $/;
1019     }
1020
1021     SECTOR:
1022     while ( $spot < $self->storage->{end} ) {
1023         # Read each sector in order.
1024         my $sector = $self->_load_sector( $spot );
1025         if ( !$sector ) {
1026             # Find it in the free-sectors that were found already
1027             foreach my $type ( keys %sectors ) {
1028                 if ( exists $sectors{$type}{$spot} ) {
1029                     my $size = $sizes{$type};
1030                     $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1031                     $spot += $size;
1032                     next SECTOR;
1033                 }
1034             }
1035
1036             die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1037         }
1038         else {
1039             $return .= sprintf "%08d: %s  %04d", $spot, $sector->type, $sector->size;
1040             if ( $sector->type eq 'D' ) {
1041                 $return .= ' ' . $sector->data;
1042             }
1043             elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1044                 $return .= ' REF: ' . $sector->get_refcount;
1045             }
1046             elsif ( $sector->type eq 'B' ) {
1047                 foreach my $bucket ( $sector->chopped_up ) {
1048                     $return .= "\n    ";
1049                     $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1050                         substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1051                     );
1052                     my $l = unpack( $StP{$self->byte_size},
1053                         substr( $bucket->[-1],
1054                             $self->hash_size + $self->byte_size,
1055                             $self->byte_size,
1056                         ),
1057                     );
1058                     $return .= sprintf " %08d", $l;
1059                     foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1060                         my $l = unpack( $StP{$self->byte_size},
1061                             substr( $bucket->[-1],
1062                                 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1063                                 $self->byte_size,
1064                             ),
1065                         );
1066                         $return .= sprintf " %08d", $l;
1067                     }
1068                 }
1069             }
1070             $return .= $/;
1071
1072             $spot += $sector->size;
1073         }
1074     }
1075
1076     return $return;
1077 }
1078
1079 1;
1080 __END__