lib/DBM/Deep/Engine/File.pm

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