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