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