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     # This code is to make sure we write all the values in the $value to the
 367     # disk and to make sure all changes to $value after the assignment are
 368     # reflected on disk. This may be counter-intuitive at first, but it is
 369     # correct dwimmery.
 370     #   NOTE - simply tying $value won't perform a STORE on each value. Hence,
 371     # the copy to a temp value.
 372     if ( $r eq 'ARRAY' ) {
 373         my @temp = @$value;
 374         tie @$value, 'DBM::Deep', {
 375             base_offset => $value_sector->offset,
 376             staleness   => $value_sector->staleness,
 377             storage     => $self->storage,
 378             engine      => $self,
 379         };
 380         @$value = @temp;
 381         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
 382     }
 383     elsif ( $r eq 'HASH' ) {
 384         my %temp = %$value;
 385         tie %$value, 'DBM::Deep', {
 386             base_offset => $value_sector->offset,
 387             staleness   => $value_sector->staleness,
 388             storage     => $self->storage,
 389             engine      => $self,
 390         };
 391
 392         %$value = %temp;
 393         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
 394     }
 395
 396     return 1;
 397 }
 398
 399 sub setup {
 400     my $self = shift;
 401     my ($obj) = @_;
 402
 403     # We're opening the file.
 404     unless ( $obj->_base_offset ) {
 405         my $bytes_read = $self->_read_file_header;
 406
 407         # Creating a new file
 408         unless ( $bytes_read ) {
 409             $self->_write_file_header;
 410
 411             # 1) Create Array/Hash entry
 412             my $initial_reference = DBM::Deep::Sector::File::Reference->new({
 413                 engine => $self,
 414                 type   => $obj->_type,
 415             });
 416             $obj->{base_offset} = $initial_reference->offset;
 417             $obj->{staleness} = $initial_reference->staleness;
 418
 419             $self->storage->flush;
 420         }
 421         # Reading from an existing file
 422         else {
 423             $obj->{base_offset} = $bytes_read;
 424             my $initial_reference = DBM::Deep::Sector::File::Reference->new({
 425                 engine => $self,
 426                 offset => $obj->_base_offset,
 427             });
 428             unless ( $initial_reference ) {
 429                 DBM::Deep->_throw_error("Corrupted file, no master index record");
 430             }
 431
 432             unless ($obj->_type eq $initial_reference->type) {
 433                 DBM::Deep->_throw_error("File type mismatch");
 434             }
 435
 436             $obj->{staleness} = $initial_reference->staleness;
 437         }
 438     }
 439
 440     $self->storage->set_inode;
 441
 442     return 1;
 443 }
 444
 445 sub begin_work {
 446     my $self = shift;
 447     my ($obj) = @_;
 448
 449     if ( $self->trans_id ) {
 450         DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
 451     }
 452
 453     my @slots = $self->read_txn_slots;
 454     my $found;
 455     for my $i ( 0 .. $#slots ) {
 456         next if $slots[$i];
 457
 458         $slots[$i] = 1;
 459         $self->set_trans_id( $i + 1 );
 460         $found = 1;
 461         last;
 462     }
 463     unless ( $found ) {
 464         DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
 465     }
 466     $self->write_txn_slots( @slots );
 467
 468     if ( !$self->trans_id ) {
 469         DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
 470     }
 471
 472     return;
 473 }
 474
 475 sub rollback {
 476     my $self = shift;
 477     my ($obj) = @_;
 478
 479     if ( !$self->trans_id ) {
 480         DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
 481     }
 482
 483     # Each entry is the file location for a bucket that has a modification for
 484     # this transaction. The entries need to be expunged.
 485     foreach my $entry (@{ $self->get_entries } ) {
 486         # Remove the entry here
 487         my $read_loc = $entry
 488           + $self->hash_size
 489           + $self->byte_size
 490           + $self->byte_size
 491           + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
 492
 493         my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
 494         $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
 495         $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
 496
 497         if ( $data_loc > 1 ) {
 498             $self->load_sector( $data_loc )->free;
 499         }
 500     }
 501
 502     $self->clear_entries;
 503
 504     my @slots = $self->read_txn_slots;
 505     $slots[$self->trans_id-1] = 0;
 506     $self->write_txn_slots( @slots );
 507     $self->inc_txn_staleness_counter( $self->trans_id );
 508     $self->set_trans_id( 0 );
 509
 510     return 1;
 511 }
 512
 513 sub commit {
 514     my $self = shift;
 515     my ($obj) = @_;
 516
 517     if ( !$self->trans_id ) {
 518         DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
 519     }
 520
 521     foreach my $entry (@{ $self->get_entries } ) {
 522         # Overwrite the entry in head with the entry in trans_id
 523         my $base = $entry
 524           + $self->hash_size
 525           + $self->byte_size;
 526
 527         my $head_loc = $self->storage->read_at( $base, $self->byte_size );
 528         $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
 529
 530         my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
 531         my $trans_loc = $self->storage->read_at(
 532             $spot, $self->byte_size,
 533         );
 534
 535         $self->storage->print_at( $base, $trans_loc );
 536         $self->storage->print_at(
 537             $spot,
 538             pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
 539         );
 540
 541         if ( $head_loc > 1 ) {
 542             $self->load_sector( $head_loc )->free;
 543         }
 544     }
 545
 546     $self->clear_entries;
 547
 548     my @slots = $self->read_txn_slots;
 549     $slots[$self->trans_id-1] = 0;
 550     $self->write_txn_slots( @slots );
 551     $self->inc_txn_staleness_counter( $self->trans_id );
 552     $self->set_trans_id( 0 );
 553
 554     return 1;
 555 }
 556
 557 =head1 INTERNAL METHODS
 558
 559 The following methods are internal-use-only to DBM::Deep::Engine::File.
 560
 561 =cut
 562
 563 =head2 read_txn_slots()
 564
 565 This takes no arguments.
 566
 567 This will return an array with a 1 or 0 in each slot. Each spot represents one
 568 available transaction. If the slot is 1, that transaction is taken. If it is 0,
 569 the transaction is available.
 570
 571 =cut
 572
 573 sub read_txn_slots {
 574     my $self = shift;
 575     my $bl = $self->txn_bitfield_len;
 576     my $num_bits = $bl * 8;
 577     return split '', unpack( 'b'.$num_bits,
 578         $self->storage->read_at(
 579             $self->trans_loc, $bl,
 580         )
 581     );
 582 }
 583
 584 =head2 write_txn_slots( @slots )
 585
 586 This takes an array of 1's and 0's. This array represents the transaction slots
 587 returned by L</read_txn_slots()>. In other words, the following is true:
 588
 589   @x = read_txn_slots( write_txn_slots( @x ) );
 590
 591 (With the obviously missing object referents added back in.)
 592
 593 =cut
 594
 595 sub write_txn_slots {
 596     my $self = shift;
 597     my $num_bits = $self->txn_bitfield_len * 8;
 598     $self->storage->print_at( $self->trans_loc,
 599         pack( 'b'.$num_bits, join('', @_) ),
 600     );
 601 }
 602
 603 =head2 get_running_txn_ids()
 604
 605 This takes no arguments.
 606
 607 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
 608
 609 =cut
 610
 611 sub get_running_txn_ids {
 612     my $self = shift;
 613     my @transactions = $self->read_txn_slots;
 614     my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
 615 }
 616
 617 =head2 get_txn_staleness_counter( $trans_id )
 618
 619 This will return the staleness counter for the given transaction ID. Please see
 620 L</TRANSACTION STALENESS> for more information.
 621
 622 =cut
 623
 624 sub get_txn_staleness_counter {
 625     my $self = shift;
 626     my ($trans_id) = @_;
 627
 628     # Hardcode staleness of 0 for the HEAD
 629     return 0 unless $trans_id;
 630
 631     return unpack( $StP{$STALE_SIZE},
 632         $self->storage->read_at(
 633             $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
 634             $STALE_SIZE,
 635         )
 636     );
 637 }
 638
 639 =head2 inc_txn_staleness_counter( $trans_id )
 640
 641 This will increment the staleness counter for the given transaction ID. Please see
 642 L</TRANSACTION STALENESS> for more information.
 643
 644 =cut
 645
 646 sub inc_txn_staleness_counter {
 647     my $self = shift;
 648     my ($trans_id) = @_;
 649
 650     # Hardcode staleness of 0 for the HEAD
 651     return 0 unless $trans_id;
 652
 653     $self->storage->print_at(
 654         $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
 655         pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
 656     );
 657 }
 658
 659 =head2 get_entries()
 660
 661 This takes no arguments.
 662
 663 This returns a list of all the sectors that have been modified by this transaction.
 664
 665 =cut
 666
 667 sub get_entries {
 668     my $self = shift;
 669     return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
 670 }
 671
 672 =head2 add_entry( $trans_id, $location )
 673
 674 This takes a transaction ID and a file location and marks the sector at that
 675 location as having been modified by the transaction identified by $trans_id.
 676
 677 This returns nothing.
 678
 679 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
 680 C<< $trans_id != $self->trans_id >> for this method.
 681
 682 =cut
 683
 684 sub add_entry {
 685     my $self = shift;
 686     my ($trans_id, $loc) = @_;
 687
 688     $self->{entries}{$trans_id} ||= {};
 689     $self->{entries}{$trans_id}{$loc} = undef;
 690 }
 691
 692 =head2 reindex_entry( $old_loc, $new_loc )
 693
 694 This takes two locations (old and new, respectively). If a location that has
 695 been modified by this transaction is subsequently reindexed due to a bucketlist
 696 overflowing, then the entries hash needs to be made aware of this change.
 697
 698 This returns nothing.
 699
 700 =cut
 701
 702 sub reindex_entry {
 703     my $self = shift;
 704     my ($old_loc, $new_loc) = @_;
 705
 706     TRANS:
 707     while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
 708         if ( exists $locs->{$old_loc} ) {
 709             delete $locs->{$old_loc};
 710             $locs->{$new_loc} = undef;
 711             next TRANS;
 712         }
 713     }
 714 }
 715
 716 =head2 clear_entries()
 717
 718 This takes no arguments. It will clear the entries list for the running
 719 transaction.
 720
 721 This returns nothing.
 722
 723 =cut
 724
 725 sub clear_entries {
 726     my $self = shift;
 727     delete $self->{entries}{$self->trans_id};
 728 }
 729
 730 =head2 _write_file_header()
 731
 732 This writes the file header for a new file. This will write the various settings
 733 that set how the file is interpreted.
 734
 735 =head2 _read_file_header()
 736
 737 This reads the file header from an existing file. This will read the various
 738 settings that set how the file is interpreted.
 739
 740 =cut
 741
 742 {
 743     my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
 744     my $this_file_version = 3;
 745
 746     sub _write_file_header {
 747         my $self = shift;
 748
 749         my $nt = $self->num_txns;
 750         my $bl = $self->txn_bitfield_len;
 751
 752         my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
 753
 754         my $loc = $self->storage->request_space( $header_fixed + $header_var );
 755
 756         $self->storage->print_at( $loc,
 757             $self->SIG_FILE,
 758             $self->SIG_HEADER,
 759             pack('N', $this_file_version), # At this point, we're at 9 bytes
 760             pack('N', $header_var),        # header size
 761             # --- Above is $header_fixed. Below is $header_var
 762             pack('C', $self->byte_size),
 763
 764             # These shenanigans are to allow a 256 within a C
 765             pack('C', $self->max_buckets - 1),
 766             pack('C', $self->data_sector_size - 1),
 767
 768             pack('C', $nt),
 769             pack('C' . $bl, 0 ),                           # Transaction activeness bitfield
 770             pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
 771             pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
 772             pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
 773             pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
 774         );
 775
 776         #XXX Set these less fragilely
 777         $self->set_trans_loc( $header_fixed + 4 );
 778         $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
 779
 780         return;
 781     }
 782
 783     sub _read_file_header {
 784         my $self = shift;
 785
 786         my $buffer = $self->storage->read_at( 0, $header_fixed );
 787         return unless length($buffer);
 788
 789         my ($file_signature, $sig_header, $file_version, $size) = unpack(
 790             'A4 A N N', $buffer
 791         );
 792
 793         unless ( $file_signature eq $self->SIG_FILE ) {
 794             $self->storage->close;
 795             DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
 796         }
 797
 798         unless ( $sig_header eq $self->SIG_HEADER ) {
 799             $self->storage->close;
 800             DBM::Deep->_throw_error( "Pre-1.00 file version found" );
 801         }
 802
 803         unless ( $file_version == $this_file_version ) {
 804             $self->storage->close;
 805             DBM::Deep->_throw_error(
 806                 "Wrong file version found - " .  $file_version .
 807                 " - expected " . $this_file_version
 808             );
 809         }
 810
 811         my $buffer2 = $self->storage->read_at( undef, $size );
 812         my @values = unpack( 'C C C C', $buffer2 );
 813
 814         if ( @values != 4 || grep { !defined } @values ) {
 815             $self->storage->close;
 816             DBM::Deep->_throw_error("Corrupted file - bad header");
 817         }
 818
 819         #XXX Add warnings if values weren't set right
 820         @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
 821
 822         # These shenangians are to allow a 256 within a C
 823         $self->{max_buckets} += 1;
 824         $self->{data_sector_size} += 1;
 825
 826         my $bl = $self->txn_bitfield_len;
 827
 828         my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
 829         unless ( $size == $header_var ) {
 830             $self->storage->close;
 831             DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
 832         }
 833
 834         $self->set_trans_loc( $header_fixed + scalar(@values) );
 835         $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
 836
 837         return length($buffer) + length($buffer2);
 838     }
 839 }
 840
 841 =head2 _apply_digest( @stuff )
 842
 843 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
 844 passed in and return the result.
 845
 846 =cut
 847
 848 sub _apply_digest {
 849     my $self = shift;
 850     return $self->{digest}->(@_);
 851 }
 852
 853 =head2 _add_free_blist_sector( $offset, $size )
 854
 855 =head2 _add_free_data_sector( $offset, $size )
 856
 857 =head2 _add_free_index_sector( $offset, $size )
 858
 859 These methods are all wrappers around _add_free_sector(), providing the proper
 860 chain offset ($multiple) for the sector type.
 861
 862 =cut
 863
 864 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
 865 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
 866 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
 867
 868 =head2 _add_free_sector( $multiple, $offset, $size )
 869
 870 _add_free_sector() takes the offset into the chains location, the offset of the
 871 sector, and the size of that sector. It will mark the sector as a free sector
 872 and put it into the list of sectors that are free of this type for use later.
 873
 874 This returns nothing.
 875
 876 B<NOTE>: $size is unused?
 877
 878 =cut
 879
 880 sub _add_free_sector {
 881     my $self = shift;
 882     my ($multiple, $offset, $size) = @_;
 883
 884     my $chains_offset = $multiple * $self->byte_size;
 885
 886     my $storage = $self->storage;
 887
 888     # Increment staleness.
 889     # XXX Can this increment+modulo be done by "&= 0x1" ?
 890     my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
 891     $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
 892     $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
 893
 894     my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 895
 896     $storage->print_at( $self->chains_loc + $chains_offset,
 897         pack( $StP{$self->byte_size}, $offset ),
 898     );
 899
 900     # Record the old head in the new sector after the signature and staleness counter
 901     $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
 902 }
 903
 904 =head2 _request_blist_sector( $size )
 905
 906 =head2 _request_data_sector( $size )
 907
 908 =head2 _request_index_sector( $size )
 909
 910 These methods are all wrappers around _request_sector(), providing the proper
 911 chain offset ($multiple) for the sector type.
 912
 913 =cut
 914
 915 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
 916 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
 917 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
 918
 919 =head2 _request_sector( $multiple $size )
 920
 921 This takes the offset into the chains location and the size of that sector.
 922
 923 This returns the object with the sector. If there is an available free sector of
 924 that type, then it will be reused. If there isn't one, then a new one will be
 925 allocated.
 926
 927 =cut
 928
 929 sub _request_sector {
 930     my $self = shift;
 931     my ($multiple, $size) = @_;
 932
 933     my $chains_offset = $multiple * $self->byte_size;
 934
 935     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 936     my $loc = unpack( $StP{$self->byte_size}, $old_head );
 937
 938     # We don't have any free sectors of the right size, so allocate a new one.
 939     unless ( $loc ) {
 940         my $offset = $self->storage->request_space( $size );
 941
 942         # Zero out the new sector. This also guarantees correct increases
 943         # in the filesize.
 944         $self->storage->print_at( $offset, chr(0) x $size );
 945
 946         return $offset;
 947     }
 948
 949     # Read the new head after the signature and the staleness counter
 950     my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
 951     $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
 952     $self->storage->print_at(
 953         $loc + $self->SIG_SIZE + $STALE_SIZE,
 954         pack( $StP{$self->byte_size}, 0 ),
 955     );
 956
 957     return $loc;
 958 }
 959
 960 =head2 ACCESSORS
 961
 962 The following are readonly attributes.
 963
 964 =over 4
 965
 966 =item * byte_size
 967
 968 =item * hash_size
 969
 970 =item * hash_chars
 971
 972 =item * num_txns
 973
 974 =item * max_buckets
 975
 976 =item * blank_md5
 977
 978 =item * data_sector_size
 979
 980 =item * txn_bitfield_len
 981
 982 =back
 983
 984 =cut
 985
 986 sub byte_size   { $_[0]{byte_size} }
 987 sub hash_size   { $_[0]{hash_size} }
 988 sub hash_chars  { $_[0]{hash_chars} }
 989 sub num_txns    { $_[0]{num_txns} }
 990 sub max_buckets { $_[0]{max_buckets} }
 991 sub blank_md5   { chr(0) x $_[0]->hash_size }
 992 sub data_sector_size { $_[0]{data_sector_size} }
 993
 994 # This is a calculated value
 995 sub txn_bitfield_len {
 996     my $self = shift;
 997     unless ( exists $self->{txn_bitfield_len} ) {
 998         my $temp = ($self->num_txns) / 8;
 999         if ( $temp > int( $temp ) ) {
1000             $temp = int( $temp ) + 1;
1001         }
1002         $self->{txn_bitfield_len} = $temp;
1003     }
1004     return $self->{txn_bitfield_len};
1005 }
1006
1007 =pod
1008
1009 The following are read/write attributes.
1010
1011 =over 4
1012
1013 =item * trans_id / set_trans_id( $new_id )
1014
1015 =item * trans_loc / set_trans_loc( $new_loc )
1016
1017 =item * chains_loc / set_chains_loc( $new_loc )
1018
1019 =back
1020
1021 =cut
1022
1023 sub trans_id     { $_[0]{trans_id} }
1024 sub set_trans_id { $_[0]{trans_id} = $_[1] }
1025
1026 sub trans_loc     { $_[0]{trans_loc} }
1027 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1028
1029 sub chains_loc     { $_[0]{chains_loc} }
1030 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1031
1032 sub cache       { $_[0]{cache} ||= {} }
1033 sub clear_cache { %{$_[0]->cache} = () }
1034
1035 =head2 _dump_file()
1036
1037 This method takes no arguments. It's used to print out a textual representation
1038 of the DBM::Deep DB file. It assumes the file is not-corrupted.
1039
1040 =cut
1041
1042 sub _dump_file {
1043     my $self = shift;
1044
1045     # Read the header
1046     my $spot = $self->_read_file_header();
1047
1048     my %types = (
1049         0 => 'B',
1050         1 => 'D',
1051         2 => 'I',
1052     );
1053
1054     my %sizes = (
1055         'D' => $self->data_sector_size,
1056         'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
1057         'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
1058     );
1059
1060     my $return = "";
1061
1062     # Header values
1063     $return .= "NumTxns: " . $self->num_txns . $/;
1064
1065     # Read the free sector chains
1066     my %sectors;
1067     foreach my $multiple ( 0 .. 2 ) {
1068         $return .= "Chains($types{$multiple}):";
1069         my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1070         while ( 1 ) {
1071             my $loc = unpack(
1072                 $StP{$self->byte_size},
1073                 $self->storage->read_at( $old_loc, $self->byte_size ),
1074             );
1075
1076             # We're now out of free sectors of this kind.
1077             unless ( $loc ) {
1078                 last;
1079             }
1080
1081             $sectors{ $types{$multiple} }{ $loc } = undef;
1082             $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
1083             $return .= " $loc";
1084         }
1085         $return .= $/;
1086     }
1087
1088     SECTOR:
1089     while ( $spot < $self->storage->{end} ) {
1090         # Read each sector in order.
1091         my $sector = $self->load_sector( $spot );
1092         if ( !$sector ) {
1093             # Find it in the free-sectors that were found already
1094             foreach my $type ( keys %sectors ) {
1095                 if ( exists $sectors{$type}{$spot} ) {
1096                     my $size = $sizes{$type};
1097                     $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1098                     $spot += $size;
1099                     next SECTOR;
1100                 }
1101             }
1102
1103             die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1104         }
1105         else {
1106             $return .= sprintf "%08d: %s  %04d", $spot, $sector->type, $sector->size;
1107             if ( $sector->type eq 'D' ) {
1108                 $return .= ' ' . $sector->data;
1109             }
1110             elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1111                 $return .= ' REF: ' . $sector->get_refcount;
1112             }
1113             elsif ( $sector->type eq 'B' ) {
1114                 foreach my $bucket ( $sector->chopped_up ) {
1115                     $return .= "\n    ";
1116                     $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1117                         substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1118                     );
1119                     my $l = unpack( $StP{$self->byte_size},
1120                         substr( $bucket->[-1],
1121                             $self->hash_size + $self->byte_size,
1122                             $self->byte_size,
1123                         ),
1124                     );
1125                     $return .= sprintf " %08d", $l;
1126                     foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1127                         my $l = unpack( $StP{$self->byte_size},
1128                             substr( $bucket->[-1],
1129                                 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1130                                 $self->byte_size,
1131                             ),
1132                         );
1133                         $return .= sprintf " %08d", $l;
1134                     }
1135                 }
1136             }
1137             $return .= $/;
1138
1139             $spot += $sector->size;
1140         }
1141     }
1142
1143     return $return;
1144 }
1145
1146 1;
1147 __END__