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