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