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