lib/DBM/Deep/Engine/File.pm

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