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 =head2 read_value( $obj, $key )
 127
 128 This takes an object that provides _base_offset() and a string. It returns the
 129 value stored in the corresponding Sector::Value's data section.
 130
 131 =cut
 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::Engine::Sector::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 =head2 get_classname( $obj )
 169
 170 This takes an object that provides _base_offset() and returns the classname (if
 171 any) associated with it.
 172
 173 It delegates to Sector::Reference::get_classname() for the heavy lifting.
 174
 175 It performs a staleness check.
 176
 177 =cut
 178
 179 sub get_classname {
 180     my $self = shift;
 181     my ($obj) = @_;
 182
 183     # This will be a Reference sector
 184     my $sector = $self->_load_sector( $obj->_base_offset )
 185         or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
 186
 187     if ( $sector->staleness != $obj->_staleness ) {
 188         return;
 189     }
 190
 191     return $sector->get_classname;
 192 }
 193
 194 =head2 make_reference( $obj, $old_key, $new_key )
 195
 196 This takes an object that provides _base_offset() and two strings. The
 197 strings correspond to the old key and new key, respectively. This operation
 198 is equivalent to (given C<< $db->{foo} = []; >>) C<< $db->{bar} = $db->{foo} >>.
 199
 200 This returns nothing.
 201
 202 =cut
 203
 204 sub make_reference {
 205     my $self = shift;
 206     my ($obj, $old_key, $new_key) = @_;
 207
 208     # This will be a Reference sector
 209     my $sector = $self->_load_sector( $obj->_base_offset )
 210         or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
 211
 212     if ( $sector->staleness != $obj->_staleness ) {
 213         return;
 214     }
 215
 216     my $old_md5 = $self->_apply_digest( $old_key );
 217
 218     my $value_sector = $sector->get_data_for({
 219         key_md5    => $old_md5,
 220         allow_head => 1,
 221     });
 222
 223     unless ( $value_sector ) {
 224         $value_sector = DBM::Deep::Engine::Sector::Null->new({
 225             engine => $self,
 226             data   => undef,
 227         });
 228
 229         $sector->write_data({
 230             key_md5 => $old_md5,
 231             key     => $old_key,
 232             value   => $value_sector,
 233         });
 234     }
 235
 236     if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
 237         $sector->write_data({
 238             key     => $new_key,
 239             key_md5 => $self->_apply_digest( $new_key ),
 240             value   => $value_sector,
 241         });
 242         $value_sector->increment_refcount;
 243     }
 244     else {
 245         $sector->write_data({
 246             key     => $new_key,
 247             key_md5 => $self->_apply_digest( $new_key ),
 248             value   => $value_sector->clone,
 249         });
 250     }
 251
 252     return;
 253 }
 254
 255 =head2 key_exists( $obj, $key )
 256
 257 This takes an object that provides _base_offset() and a string for
 258 the key to be checked. This returns 1 for true and "" for false.
 259
 260 =cut
 261
 262 sub key_exists {
 263     my $self = shift;
 264     my ($obj, $key) = @_;
 265
 266     # This will be a Reference sector
 267     my $sector = $self->_load_sector( $obj->_base_offset )
 268         or return '';
 269
 270     if ( $sector->staleness != $obj->_staleness ) {
 271         return '';
 272     }
 273
 274     my $data = $sector->get_data_for({
 275         key_md5    => $self->_apply_digest( $key ),
 276         allow_head => 1,
 277     });
 278
 279     # exists() returns 1 or '' for true/false.
 280     return $data ? 1 : '';
 281 }
 282
 283 =head2 delete_key( $obj, $key )
 284
 285 This takes an object that provides _base_offset() and a string for
 286 the key to be deleted. This returns the result of the Sector::Reference
 287 delete_key() method.
 288
 289 =cut
 290
 291 sub delete_key {
 292     my $self = shift;
 293     my ($obj, $key) = @_;
 294
 295     my $sector = $self->_load_sector( $obj->_base_offset )
 296         or return;
 297
 298     if ( $sector->staleness != $obj->_staleness ) {
 299         return;
 300     }
 301
 302     return $sector->delete_key({
 303         key_md5    => $self->_apply_digest( $key ),
 304         allow_head => 0,
 305     });
 306 }
 307
 308 =head2 write_value( $obj, $key, $value )
 309
 310 This takes an object that provides _base_offset(), a string for the
 311 key, and a value. This value can be anything storable within L<DBM::Deep/>.
 312
 313 This returns 1 upon success.
 314
 315 =cut
 316
 317 sub write_value {
 318     my $self = shift;
 319     my ($obj, $key, $value) = @_;
 320
 321     my $r = Scalar::Util::reftype( $value ) || '';
 322     {
 323         last if $r eq '';
 324         last if $r eq 'HASH';
 325         last if $r eq 'ARRAY';
 326
 327         DBM::Deep->_throw_error(
 328             "Storage of references of type '$r' is not supported."
 329         );
 330     }
 331
 332     # This will be a Reference sector
 333     my $sector = $self->_load_sector( $obj->_base_offset )
 334         or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
 335
 336     if ( $sector->staleness != $obj->_staleness ) {
 337         DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
 338     }
 339
 340     my ($class, $type);
 341     if ( !defined $value ) {
 342         $class = 'DBM::Deep::Engine::Sector::Null';
 343     }
 344     elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
 345         my $tmpvar;
 346         if ( $r eq 'ARRAY' ) {
 347             $tmpvar = tied @$value;
 348         } elsif ( $r eq 'HASH' ) {
 349             $tmpvar = tied %$value;
 350         }
 351
 352         if ( $tmpvar ) {
 353             my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
 354
 355             unless ( $is_dbm_deep ) {
 356                 DBM::Deep->_throw_error( "Cannot store something that is tied." );
 357             }
 358
 359             unless ( $tmpvar->_engine->storage == $self->storage ) {
 360                 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
 361             }
 362
 363             # First, verify if we're storing the same thing to this spot. If we are, then
 364             # this should be a no-op. -EJS, 2008-05-19
 365             my $loc = $sector->get_data_location_for({
 366                 key_md5 => $self->_apply_digest( $key ),
 367                 allow_head => 1,
 368             });
 369
 370             if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
 371                 return 1;
 372             }
 373
 374             #XXX Can this use $loc?
 375             my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
 376             $sector->write_data({
 377                 key     => $key,
 378                 key_md5 => $self->_apply_digest( $key ),
 379                 value   => $value_sector,
 380             });
 381             $value_sector->increment_refcount;
 382
 383             return 1;
 384         }
 385
 386         $class = 'DBM::Deep::Engine::Sector::Reference';
 387         $type = substr( $r, 0, 1 );
 388     }
 389     else {
 390         if ( tied($value) ) {
 391             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 392         }
 393         $class = 'DBM::Deep::Engine::Sector::Scalar';
 394     }
 395
 396     # Create this after loading the reference sector in case something bad happens.
 397     # This way, we won't allocate value sector(s) needlessly.
 398     my $value_sector = $class->new({
 399         engine => $self,
 400         data   => $value,
 401         type   => $type,
 402     });
 403
 404     $sector->write_data({
 405         key     => $key,
 406         key_md5 => $self->_apply_digest( $key ),
 407         value   => $value_sector,
 408     });
 409
 410     # This code is to make sure we write all the values in the $value to the disk
 411     # and to make sure all changes to $value after the assignment are reflected
 412     # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
 413     #   NOTE - simply tying $value won't perform a STORE on each value. Hence, the
 414     # copy to a temp value.
 415     if ( $r eq 'ARRAY' ) {
 416         my @temp = @$value;
 417         tie @$value, 'DBM::Deep', {
 418             base_offset => $value_sector->offset,
 419             staleness   => $value_sector->staleness,
 420             storage     => $self->storage,
 421             engine      => $self,
 422         };
 423         @$value = @temp;
 424         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
 425     }
 426     elsif ( $r eq 'HASH' ) {
 427         my %temp = %$value;
 428         tie %$value, 'DBM::Deep', {
 429             base_offset => $value_sector->offset,
 430             staleness   => $value_sector->staleness,
 431             storage     => $self->storage,
 432             engine      => $self,
 433         };
 434
 435         %$value = %temp;
 436         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
 437     }
 438
 439     return 1;
 440 }
 441
 442 =head2 setup_fh( $obj )
 443
 444 This takes an object that provides _base_offset(). It will do everything needed
 445 in order to properly initialize all values for necessary functioning. If this is
 446 called upon an already initialized object, this will also reset the inode.
 447
 448 This returns 1.
 449
 450 =cut
 451
 452 sub setup_fh {
 453     my $self = shift;
 454     my ($obj) = @_;
 455
 456     # We're opening the file.
 457     unless ( $obj->_base_offset ) {
 458         my $bytes_read = $self->_read_file_header;
 459
 460         # Creating a new file
 461         unless ( $bytes_read ) {
 462             $self->_write_file_header;
 463
 464             # 1) Create Array/Hash entry
 465             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 466                 engine => $self,
 467                 type   => $obj->_type,
 468             });
 469             $obj->{base_offset} = $initial_reference->offset;
 470             $obj->{staleness} = $initial_reference->staleness;
 471
 472             $self->storage->flush;
 473         }
 474         # Reading from an existing file
 475         else {
 476             $obj->{base_offset} = $bytes_read;
 477             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 478                 engine => $self,
 479                 offset => $obj->_base_offset,
 480             });
 481             unless ( $initial_reference ) {
 482                 DBM::Deep->_throw_error("Corrupted file, no master index record");
 483             }
 484
 485             unless ($obj->_type eq $initial_reference->type) {
 486                 DBM::Deep->_throw_error("File type mismatch");
 487             }
 488
 489             $obj->{staleness} = $initial_reference->staleness;
 490         }
 491     }
 492
 493     $self->storage->set_inode;
 494
 495     return 1;
 496 }
 497
 498 =head2 begin_work( $obj )
 499
 500 This takes an object that provides _base_offset(). It will set up all necessary
 501 bookkeeping in order to run all work within a transaction.
 502
 503 If $obj is already within a transaction, an error wiill be thrown. If there are
 504 no more available transactions, an error will be thrown.
 505
 506 This returns undef.
 507
 508 =cut
 509
 510 sub begin_work {
 511     my $self = shift;
 512     my ($obj) = @_;
 513
 514     if ( $self->trans_id ) {
 515         DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
 516     }
 517
 518     my @slots = $self->read_txn_slots;
 519     my $found;
 520     for my $i ( 0 .. $#slots ) {
 521         next if $slots[$i];
 522
 523         $slots[$i] = 1;
 524         $self->set_trans_id( $i + 1 );
 525         $found = 1;
 526         last;
 527     }
 528     unless ( $found ) {
 529         DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
 530     }
 531     $self->write_txn_slots( @slots );
 532
 533     if ( !$self->trans_id ) {
 534         DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
 535     }
 536
 537     return;
 538 }
 539
 540 =head2 rollback( $obj )
 541
 542 This takes an object that provides _base_offset(). It will revert all
 543 actions taken within the running transaction.
 544
 545 If $obj is not within a transaction, an error will be thrown.
 546
 547 This returns 1.
 548
 549 =cut
 550
 551 sub rollback {
 552     my $self = shift;
 553     my ($obj) = @_;
 554
 555     if ( !$self->trans_id ) {
 556         DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
 557     }
 558
 559     # Each entry is the file location for a bucket that has a modification for
 560     # this transaction. The entries need to be expunged.
 561     foreach my $entry (@{ $self->get_entries } ) {
 562         # Remove the entry here
 563         my $read_loc = $entry
 564           + $self->hash_size
 565           + $self->byte_size
 566           + $self->byte_size
 567           + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
 568
 569         my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
 570         $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
 571         $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
 572
 573         if ( $data_loc > 1 ) {
 574             $self->_load_sector( $data_loc )->free;
 575         }
 576     }
 577
 578     $self->clear_entries;
 579
 580     my @slots = $self->read_txn_slots;
 581     $slots[$self->trans_id-1] = 0;
 582     $self->write_txn_slots( @slots );
 583     $self->inc_txn_staleness_counter( $self->trans_id );
 584     $self->set_trans_id( 0 );
 585
 586     return 1;
 587 }
 588
 589 =head2 commit( $obj )
 590
 591 This takes an object that provides _base_offset(). It will apply all
 592 actions taken within the transaction to the HEAD.
 593
 594 If $obj is not within a transaction, an error will be thrown.
 595
 596 This returns 1.
 597
 598 =cut
 599
 600 sub commit {
 601     my $self = shift;
 602     my ($obj) = @_;
 603
 604     if ( !$self->trans_id ) {
 605         DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
 606     }
 607
 608     foreach my $entry (@{ $self->get_entries } ) {
 609         # Overwrite the entry in head with the entry in trans_id
 610         my $base = $entry
 611           + $self->hash_size
 612           + $self->byte_size;
 613
 614         my $head_loc = $self->storage->read_at( $base, $self->byte_size );
 615         $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
 616
 617         my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
 618         my $trans_loc = $self->storage->read_at(
 619             $spot, $self->byte_size,
 620         );
 621
 622         $self->storage->print_at( $base, $trans_loc );
 623         $self->storage->print_at(
 624             $spot,
 625             pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
 626         );
 627
 628         if ( $head_loc > 1 ) {
 629             $self->_load_sector( $head_loc )->free;
 630         }
 631     }
 632
 633     $self->clear_entries;
 634
 635     my @slots = $self->read_txn_slots;
 636     $slots[$self->trans_id-1] = 0;
 637     $self->write_txn_slots( @slots );
 638     $self->inc_txn_staleness_counter( $self->trans_id );
 639     $self->set_trans_id( 0 );
 640
 641     return 1;
 642 }
 643
 644 =head2 lock_exclusive()
 645
 646 This takes an object that provides _base_offset(). It will guarantee that
 647 the storage has taken precautions to be safe for a write.
 648
 649 This returns nothing.
 650
 651 =cut
 652
 653 sub lock_exclusive {
 654     my $self = shift;
 655     my ($obj) = @_;
 656     return $self->storage->lock_exclusive( $obj );
 657 }
 658
 659 =head2 lock_shared()
 660
 661 This takes an object that provides _base_offset(). It will guarantee that
 662 the storage has taken precautions to be safe for a read.
 663
 664 This returns nothing.
 665
 666 =cut
 667
 668 sub lock_shared {
 669     my $self = shift;
 670     my ($obj) = @_;
 671     return $self->storage->lock_shared( $obj );
 672 }
 673
 674 =head2 unlock()
 675
 676 This takes an object that provides _base_offset(). It will guarantee that
 677 the storage has released all locks taken.
 678
 679 This returns nothing.
 680
 681 =cut
 682
 683 sub unlock {
 684     my $self = shift;
 685     my ($obj) = @_;
 686
 687     my $rv = $self->storage->unlock( $obj );
 688
 689     $self->flush if $rv;
 690
 691     return $rv;
 692 }
 693
 694 =head1 INTERNAL METHODS
 695
 696 The following methods are internal-use-only to DBM::Deep::Engine::File.
 697
 698 =cut
 699
 700 =head2 read_txn_slots()
 701
 702 This takes no arguments.
 703
 704 This will return an array with a 1 or 0 in each slot. Each spot represents one
 705 available transaction. If the slot is 1, that transaction is taken. If it is 0,
 706 the transaction is available.
 707
 708 =cut
 709
 710 sub read_txn_slots {
 711     my $self = shift;
 712     my $bl = $self->txn_bitfield_len;
 713     my $num_bits = $bl * 8;
 714     return split '', unpack( 'b'.$num_bits,
 715         $self->storage->read_at(
 716             $self->trans_loc, $bl,
 717         )
 718     );
 719 }
 720
 721 =head2 write_txn_slots( @slots )
 722
 723 This takes an array of 1's and 0's. This array represents the transaction slots
 724 returned by L</read_txn_slots()>. In other words, the following is true:
 725
 726   @x = read_txn_slots( write_txn_slots( @x ) );
 727
 728 (With the obviously missing object referents added back in.)
 729
 730 =cut
 731
 732 sub write_txn_slots {
 733     my $self = shift;
 734     my $num_bits = $self->txn_bitfield_len * 8;
 735     $self->storage->print_at( $self->trans_loc,
 736         pack( 'b'.$num_bits, join('', @_) ),
 737     );
 738 }
 739
 740 =head2 get_running_txn_ids()
 741
 742 This takes no arguments.
 743
 744 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
 745
 746 =cut
 747
 748 sub get_running_txn_ids {
 749     my $self = shift;
 750     my @transactions = $self->read_txn_slots;
 751     my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
 752 }
 753
 754 =head2 get_txn_staleness_counter( $trans_id )
 755
 756 This will return the staleness counter for the given transaction ID. Please see
 757 L</TRANSACTION STALENESS> for more information.
 758
 759 =cut
 760
 761 sub get_txn_staleness_counter {
 762     my $self = shift;
 763     my ($trans_id) = @_;
 764
 765     # Hardcode staleness of 0 for the HEAD
 766     return 0 unless $trans_id;
 767
 768     return unpack( $StP{$STALE_SIZE},
 769         $self->storage->read_at(
 770             $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
 771             $STALE_SIZE,
 772         )
 773     );
 774 }
 775
 776 =head2 inc_txn_staleness_counter( $trans_id )
 777
 778 This will increment the staleness counter for the given transaction ID. Please see
 779 L</TRANSACTION STALENESS> for more information.
 780
 781 =cut
 782
 783 sub inc_txn_staleness_counter {
 784     my $self = shift;
 785     my ($trans_id) = @_;
 786
 787     # Hardcode staleness of 0 for the HEAD
 788     return 0 unless $trans_id;
 789
 790     $self->storage->print_at(
 791         $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
 792         pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
 793     );
 794 }
 795
 796 =head2 get_entries()
 797
 798 This takes no arguments.
 799
 800 This returns a list of all the sectors that have been modified by this transaction.
 801
 802 =cut
 803
 804 sub get_entries {
 805     my $self = shift;
 806     return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
 807 }
 808
 809 =head2 add_entry( $trans_id, $location )
 810
 811 This takes a transaction ID and a file location and marks the sector at that
 812 location as having been modified by the transaction identified by $trans_id.
 813
 814 This returns nothing.
 815
 816 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
 817 C<< $trans_id != $self->trans_id >> for this method.
 818
 819 =cut
 820
 821 sub add_entry {
 822     my $self = shift;
 823     my ($trans_id, $loc) = @_;
 824
 825     $self->{entries}{$trans_id} ||= {};
 826     $self->{entries}{$trans_id}{$loc} = undef;
 827 }
 828
 829 =head2 reindex_entry( $old_loc, $new_loc )
 830
 831 This takes two locations (old and new, respectively). If a location that has
 832 been modified by this transaction is subsequently reindexed due to a bucketlist
 833 overflowing, then the entries hash needs to be made aware of this change.
 834
 835 This returns nothing.
 836
 837 =cut
 838
 839 sub reindex_entry {
 840     my $self = shift;
 841     my ($old_loc, $new_loc) = @_;
 842
 843     TRANS:
 844     while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
 845         if ( exists $locs->{$old_loc} ) {
 846             delete $locs->{$old_loc};
 847             $locs->{$new_loc} = undef;
 848             next TRANS;
 849         }
 850     }
 851 }
 852
 853 =head2 clear_entries()
 854
 855 This takes no arguments. It will clear the entries list for the running
 856 transaction.
 857
 858 This returns nothing.
 859
 860 =cut
 861
 862 sub clear_entries {
 863     my $self = shift;
 864     delete $self->{entries}{$self->trans_id};
 865 }
 866
 867 =head2 _write_file_header()
 868
 869 This writes the file header for a new file. This will write the various settings
 870 that set how the file is interpreted.
 871
 872 =head2 _read_file_header()
 873
 874 This reads the file header from an existing file. This will read the various
 875 settings that set how the file is interpreted.
 876
 877 =cut
 878
 879 {
 880     my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
 881     my $this_file_version = 3;
 882
 883     sub _write_file_header {
 884         my $self = shift;
 885
 886         my $nt = $self->num_txns;
 887         my $bl = $self->txn_bitfield_len;
 888
 889         my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
 890
 891         my $loc = $self->storage->request_space( $header_fixed + $header_var );
 892
 893         $self->storage->print_at( $loc,
 894             $self->SIG_FILE,
 895             $self->SIG_HEADER,
 896             pack('N', $this_file_version), # At this point, we're at 9 bytes
 897             pack('N', $header_var),        # header size
 898             # --- Above is $header_fixed. Below is $header_var
 899             pack('C', $self->byte_size),
 900
 901             # These shenanigans are to allow a 256 within a C
 902             pack('C', $self->max_buckets - 1),
 903             pack('C', $self->data_sector_size - 1),
 904
 905             pack('C', $nt),
 906             pack('C' . $bl, 0 ),                           # Transaction activeness bitfield
 907             pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
 908             pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
 909             pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
 910             pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
 911         );
 912
 913         #XXX Set these less fragilely
 914         $self->set_trans_loc( $header_fixed + 4 );
 915         $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
 916
 917         return;
 918     }
 919
 920     sub _read_file_header {
 921         my $self = shift;
 922
 923         my $buffer = $self->storage->read_at( 0, $header_fixed );
 924         return unless length($buffer);
 925
 926         my ($file_signature, $sig_header, $file_version, $size) = unpack(
 927             'A4 A N N', $buffer
 928         );
 929
 930         unless ( $file_signature eq $self->SIG_FILE ) {
 931             $self->storage->close;
 932             DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
 933         }
 934
 935         unless ( $sig_header eq $self->SIG_HEADER ) {
 936             $self->storage->close;
 937             DBM::Deep->_throw_error( "Pre-1.00 file version found" );
 938         }
 939
 940         unless ( $file_version == $this_file_version ) {
 941             $self->storage->close;
 942             DBM::Deep->_throw_error(
 943                 "Wrong file version found - " .  $file_version .
 944                 " - expected " . $this_file_version
 945             );
 946         }
 947
 948         my $buffer2 = $self->storage->read_at( undef, $size );
 949         my @values = unpack( 'C C C C', $buffer2 );
 950
 951         if ( @values != 4 || grep { !defined } @values ) {
 952             $self->storage->close;
 953             DBM::Deep->_throw_error("Corrupted file - bad header");
 954         }
 955
 956         #XXX Add warnings if values weren't set right
 957         @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
 958
 959         # These shenangians are to allow a 256 within a C
 960         $self->{max_buckets} += 1;
 961         $self->{data_sector_size} += 1;
 962
 963         my $bl = $self->txn_bitfield_len;
 964
 965         my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
 966         unless ( $size == $header_var ) {
 967             $self->storage->close;
 968             DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
 969         }
 970
 971         $self->set_trans_loc( $header_fixed + scalar(@values) );
 972         $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
 973
 974         return length($buffer) + length($buffer2);
 975     }
 976 }
 977
 978 =head2 _load_sector( $offset )
 979
 980 This will instantiate and return the sector object that represents the data found
 981 at $offset.
 982
 983 =cut
 984
 985 sub _load_sector {
 986     my $self = shift;
 987     my ($offset) = @_;
 988
 989     # Add a catch for offset of 0 or 1
 990     return if !$offset || $offset <= 1;
 991
 992     my $type = $self->storage->read_at( $offset, 1 );
 993     return if $type eq chr(0);
 994
 995     if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
 996         return DBM::Deep::Engine::Sector::Reference->new({
 997             engine => $self,
 998             type   => $type,
 999             offset => $offset,
1000         });
1001     }
1002     # XXX Don't we need key_md5 here?
1003     elsif ( $type eq $self->SIG_BLIST ) {
1004         return DBM::Deep::Engine::Sector::BucketList->new({
1005             engine => $self,
1006             type   => $type,
1007             offset => $offset,
1008         });
1009     }
1010     elsif ( $type eq $self->SIG_INDEX ) {
1011         return DBM::Deep::Engine::Sector::Index->new({
1012             engine => $self,
1013             type   => $type,
1014             offset => $offset,
1015         });
1016     }
1017     elsif ( $type eq $self->SIG_NULL ) {
1018         return DBM::Deep::Engine::Sector::Null->new({
1019             engine => $self,
1020             type   => $type,
1021             offset => $offset,
1022         });
1023     }
1024     elsif ( $type eq $self->SIG_DATA ) {
1025         return DBM::Deep::Engine::Sector::Scalar->new({
1026             engine => $self,
1027             type   => $type,
1028             offset => $offset,
1029         });
1030     }
1031     # This was deleted from under us, so just return and let the caller figure it out.
1032     elsif ( $type eq $self->SIG_FREE ) {
1033         return;
1034     }
1035
1036     DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
1037 }
1038
1039 =head2 _apply_digest( @stuff )
1040
1041 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
1042 passed in and return the result.
1043
1044 =cut
1045
1046 sub _apply_digest {
1047     my $self = shift;
1048     return $self->{digest}->(@_);
1049 }
1050
1051 =head2 _add_free_blist_sector( $offset, $size )
1052
1053 =head2 _add_free_data_sector( $offset, $size )
1054
1055 =head2 _add_free_index_sector( $offset, $size )
1056
1057 These methods are all wrappers around _add_free_sector(), providing the proper
1058 chain offset ($multiple) for the sector type.
1059
1060 =cut
1061
1062 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
1063 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
1064 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
1065
1066 =head2 _add_free_sector( $multiple, $offset, $size )
1067
1068 _add_free_sector() takes the offset into the chains location, the offset of the
1069 sector, and the size of that sector. It will mark the sector as a free sector
1070 and put it into the list of sectors that are free of this type for use later.
1071
1072 This returns nothing.
1073
1074 B<NOTE>: $size is unused?
1075
1076 =cut
1077
1078 sub _add_free_sector {
1079     my $self = shift;
1080     my ($multiple, $offset, $size) = @_;
1081
1082     my $chains_offset = $multiple * $self->byte_size;
1083
1084     my $storage = $self->storage;
1085
1086     # Increment staleness.
1087     # XXX Can this increment+modulo be done by "&= 0x1" ?
1088     my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
1089     $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
1090     $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
1091
1092     my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
1093
1094     $storage->print_at( $self->chains_loc + $chains_offset,
1095         pack( $StP{$self->byte_size}, $offset ),
1096     );
1097
1098     # Record the old head in the new sector after the signature and staleness counter
1099     $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
1100 }
1101
1102 =head2 _request_blist_sector( $size )
1103
1104 =head2 _request_data_sector( $size )
1105
1106 =head2 _request_index_sector( $size )
1107
1108 These methods are all wrappers around _request_sector(), providing the proper
1109 chain offset ($multiple) for the sector type.
1110
1111 =cut
1112
1113 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
1114 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
1115 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
1116
1117 =head2 _request_sector( $multiple $size )
1118
1119 This takes the offset into the chains location and the size of that sector.
1120
1121 This returns the object with the sector. If there is an available free sector of
1122 that type, then it will be reused. If there isn't one, then a new one will be
1123 allocated.
1124
1125 =cut
1126
1127 sub _request_sector {
1128     my $self = shift;
1129     my ($multiple, $size) = @_;
1130
1131     my $chains_offset = $multiple * $self->byte_size;
1132
1133     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
1134     my $loc = unpack( $StP{$self->byte_size}, $old_head );
1135
1136     # We don't have any free sectors of the right size, so allocate a new one.
1137     unless ( $loc ) {
1138         my $offset = $self->storage->request_space( $size );
1139
1140         # Zero out the new sector. This also guarantees correct increases
1141         # in the filesize.
1142         $self->storage->print_at( $offset, chr(0) x $size );
1143
1144         return $offset;
1145     }
1146
1147     # Read the new head after the signature and the staleness counter
1148     my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
1149     $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
1150     $self->storage->print_at(
1151         $loc + $self->SIG_SIZE + $STALE_SIZE,
1152         pack( $StP{$self->byte_size}, 0 ),
1153     );
1154
1155     return $loc;
1156 }
1157
1158 =head2 flush()
1159
1160 This takes no arguments. It will do everything necessary to flush all things to
1161 disk. This is usually called during unlock() and setup_fh().
1162
1163 This returns nothing.
1164
1165 =cut
1166
1167 sub flush {
1168     my $self = shift;
1169
1170     # Why do we need to have the storage flush? Shouldn't autoflush take care of things?
1171     # -RobK, 2008-06-26
1172     $self->storage->flush;
1173 }
1174
1175 =head2 ACCESSORS
1176
1177 The following are readonly attributes.
1178
1179 =over 4
1180
1181 =item * storage
1182
1183 =item * byte_size
1184
1185 =item * hash_size
1186
1187 =item * hash_chars
1188
1189 =item * num_txns
1190
1191 =item * max_buckets
1192
1193 =item * blank_md5
1194
1195 =item * data_sector_size
1196
1197 =item * txn_bitfield_len
1198
1199 =back
1200
1201 =cut
1202
1203 sub storage     { $_[0]{storage} }
1204 sub byte_size   { $_[0]{byte_size} }
1205 sub hash_size   { $_[0]{hash_size} }
1206 sub hash_chars  { $_[0]{hash_chars} }
1207 sub num_txns    { $_[0]{num_txns} }
1208 sub max_buckets { $_[0]{max_buckets} }
1209 sub blank_md5   { chr(0) x $_[0]->hash_size }
1210 sub data_sector_size { $_[0]{data_sector_size} }
1211
1212 # This is a calculated value
1213 sub txn_bitfield_len {
1214     my $self = shift;
1215     unless ( exists $self->{txn_bitfield_len} ) {
1216         my $temp = ($self->num_txns) / 8;
1217         if ( $temp > int( $temp ) ) {
1218             $temp = int( $temp ) + 1;
1219         }
1220         $self->{txn_bitfield_len} = $temp;
1221     }
1222     return $self->{txn_bitfield_len};
1223 }
1224
1225 =pod
1226
1227 The following are read/write attributes.
1228
1229 =over 4
1230
1231 =item * trans_id / set_trans_id( $new_id )
1232
1233 =item * trans_loc / set_trans_loc( $new_loc )
1234
1235 =item * chains_loc / set_chains_loc( $new_loc )
1236
1237 =back
1238
1239 =cut
1240
1241 sub trans_id     { $_[0]{trans_id} }
1242 sub set_trans_id { $_[0]{trans_id} = $_[1] }
1243
1244 sub trans_loc     { $_[0]{trans_loc} }
1245 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1246
1247 sub chains_loc     { $_[0]{chains_loc} }
1248 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1249
1250 sub cache       { $_[0]{cache} ||= {} }
1251 sub clear_cache { %{$_[0]->cache} = () }
1252
1253 =head2 _dump_file()
1254
1255 This method takes no arguments. It's used to print out a textual representation
1256 of the DBM::Deep DB file. It assumes the file is not-corrupted.
1257
1258 =cut
1259
1260 sub _dump_file {
1261     my $self = shift;
1262
1263     # Read the header
1264     my $spot = $self->_read_file_header();
1265
1266     my %types = (
1267         0 => 'B',
1268         1 => 'D',
1269         2 => 'I',
1270     );
1271
1272     my %sizes = (
1273         'D' => $self->data_sector_size,
1274         'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
1275         'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
1276     );
1277
1278     my $return = "";
1279
1280     # Header values
1281     $return .= "NumTxns: " . $self->num_txns . $/;
1282
1283     # Read the free sector chains
1284     my %sectors;
1285     foreach my $multiple ( 0 .. 2 ) {
1286         $return .= "Chains($types{$multiple}):";
1287         my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1288         while ( 1 ) {
1289             my $loc = unpack(
1290                 $StP{$self->byte_size},
1291                 $self->storage->read_at( $old_loc, $self->byte_size ),
1292             );
1293
1294             # We're now out of free sectors of this kind.
1295             unless ( $loc ) {
1296                 last;
1297             }
1298
1299             $sectors{ $types{$multiple} }{ $loc } = undef;
1300             $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
1301             $return .= " $loc";
1302         }
1303         $return .= $/;
1304     }
1305
1306     SECTOR:
1307     while ( $spot < $self->storage->{end} ) {
1308         # Read each sector in order.
1309         my $sector = $self->_load_sector( $spot );
1310         if ( !$sector ) {
1311             # Find it in the free-sectors that were found already
1312             foreach my $type ( keys %sectors ) {
1313                 if ( exists $sectors{$type}{$spot} ) {
1314                     my $size = $sizes{$type};
1315                     $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1316                     $spot += $size;
1317                     next SECTOR;
1318                 }
1319             }
1320
1321             die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1322         }
1323         else {
1324             $return .= sprintf "%08d: %s  %04d", $spot, $sector->type, $sector->size;
1325             if ( $sector->type eq 'D' ) {
1326                 $return .= ' ' . $sector->data;
1327             }
1328             elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1329                 $return .= ' REF: ' . $sector->get_refcount;
1330             }
1331             elsif ( $sector->type eq 'B' ) {
1332                 foreach my $bucket ( $sector->chopped_up ) {
1333                     $return .= "\n    ";
1334                     $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1335                         substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1336                     );
1337                     my $l = unpack( $StP{$self->byte_size},
1338                         substr( $bucket->[-1],
1339                             $self->hash_size + $self->byte_size,
1340                             $self->byte_size,
1341                         ),
1342                     );
1343                     $return .= sprintf " %08d", $l;
1344                     foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1345                         my $l = unpack( $StP{$self->byte_size},
1346                             substr( $bucket->[-1],
1347                                 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1348                                 $self->byte_size,
1349                             ),
1350                         );
1351                         $return .= sprintf " %08d", $l;
1352                     }
1353                 }
1354             }
1355             $return .= $/;
1356
1357             $spot += $sector->size;
1358         }
1359     }
1360
1361     return $return;
1362 }
1363
1364 1;
1365 __END__