lib/DBM/Deep/Engine.pm

   1 package DBM::Deep::Engine;
   2
   3 use 5.6.0;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Fcntl qw( :DEFAULT :flock :seek );
   9 use Scalar::Util ();
  10
  11 # File-wide notes:
  12 # * All the local($/,$\); are to protect read() and print() from -l.
  13 # * To add to bucket_size, make sure you modify the following:
  14 #   - calculate_sizes()
  15 #   - _get_key_subloc()
  16 #   - add_bucket() - where the buckets are printed
  17
  18 ##
  19 # Setup file and tag signatures.  These should never change.
  20 ##
  21 sub SIG_FILE     () { 'DPDB' }
  22 sub SIG_HEADER   () { 'h'    }
  23 sub SIG_INTERNAL () { 'i'    }
  24 sub SIG_HASH     () { 'H'    }
  25 sub SIG_ARRAY    () { 'A'    }
  26 sub SIG_NULL     () { 'N'    }
  27 sub SIG_DATA     () { 'D'    }
  28 sub SIG_INDEX    () { 'I'    }
  29 sub SIG_BLIST    () { 'B'    }
  30 sub SIG_FREE     () { 'F'    }
  31 sub SIG_SIZE     () {  1     }
  32
  33 sub new {
  34     my $class = shift;
  35     my ($args) = @_;
  36
  37     my $self = bless {
  38         long_size   => 4,
  39         long_pack   => 'N',
  40         data_size   => 4,
  41         data_pack   => 'N',
  42
  43         digest      => \&Digest::MD5::md5,
  44         hash_size   => 16,
  45
  46         ##
  47         # Maximum number of buckets per list before another level of indexing is
  48         # done. Increase this value for slightly greater speed, but larger database
  49         # files. DO NOT decrease this value below 16, due to risk of recursive
  50         # reindex overrun.
  51         ##
  52         max_buckets => 16,
  53
  54         fileobj => undef,
  55         obj     => undef,
  56     }, $class;
  57
  58     if ( defined $args->{pack_size} ) {
  59         if ( lc $args->{pack_size} eq 'small' ) {
  60             $args->{long_size} = 2;
  61             $args->{long_pack} = 'n';
  62         }
  63         elsif ( lc $args->{pack_size} eq 'medium' ) {
  64             $args->{long_size} = 4;
  65             $args->{long_pack} = 'N';
  66         }
  67         elsif ( lc $args->{pack_size} eq 'large' ) {
  68             $args->{long_size} = 8;
  69             $args->{long_pack} = 'Q';
  70         }
  71         else {
  72             die "Unknown pack_size value: '$args->{pack_size}'\n";
  73         }
  74     }
  75
  76     # Grab the parameters we want to use
  77     foreach my $param ( keys %$self ) {
  78         next unless exists $args->{$param};
  79         $self->{$param} = $args->{$param};
  80     }
  81     Scalar::Util::weaken( $self->{obj} ) if $self->{obj};
  82
  83     if ( $self->{max_buckets} < 16 ) {
  84         warn "Floor of max_buckets is 16. Setting it to 16 from '$self->{max_buckets}'\n";
  85         $self->{max_buckets} = 16;
  86     }
  87
  88     return $self;
  89 }
  90
  91 sub _fileobj { return $_[0]{fileobj} }
  92 sub _fh      { return $_[0]->_fileobj->{fh} }
  93
  94 sub calculate_sizes {
  95     my $self = shift;
  96
  97     #XXX Does this need to be updated with different hashing algorithms?
  98     $self->{index_size}       = (2**8) * $self->{long_size};
  99     $self->{bucket_size}      = $self->{hash_size} + $self->{long_size} * 3;
 100     $self->{bucket_list_size} = $self->{max_buckets} * $self->{bucket_size};
 101
 102     return;
 103 }
 104
 105 sub write_file_header {
 106     my $self = shift;
 107
 108     my $loc = $self->_fileobj->request_space( length( SIG_FILE ) + 21 );
 109
 110     $self->_fileobj->print_at( $loc,
 111         SIG_FILE,
 112         SIG_HEADER,
 113         pack('N', 1),  # header version
 114         pack('N', 12), # header size
 115         pack('N', 0),  # currently running transaction IDs
 116         pack('n', $self->{long_size}),
 117         pack('A', $self->{long_pack}),
 118         pack('n', $self->{data_size}),
 119         pack('A', $self->{data_pack}),
 120         pack('n', $self->{max_buckets}),
 121     );
 122
 123     $self->_fileobj->set_transaction_offset( 13 );
 124
 125     return;
 126 }
 127
 128 sub read_file_header {
 129     my $self = shift;
 130
 131     local($/,$\);
 132
 133     my $fh = $self->_fh;
 134
 135     seek($fh, 0 + $self->_fileobj->{file_offset}, SEEK_SET);
 136     my $buffer;
 137     my $bytes_read = read( $fh, $buffer, length(SIG_FILE) + 9 );
 138
 139     return unless $bytes_read;
 140
 141     my ($file_signature, $sig_header, $header_version, $size) = unpack(
 142         'A4 A N N', $buffer
 143     );
 144
 145     unless ( $file_signature eq SIG_FILE ) {
 146         $self->_fileobj->close;
 147         $self->_throw_error( "Signature not found -- file is not a Deep DB" );
 148     }
 149
 150     unless ( $sig_header eq SIG_HEADER ) {
 151         $self->_fileobj->close;
 152         $self->_throw_error( "Old file version found." );
 153     }
 154
 155     my $buffer2;
 156     $bytes_read += read( $fh, $buffer2, $size );
 157     my ($running_transactions, @values) = unpack( 'N n A n A n', $buffer2 );
 158
 159     $self->_fileobj->set_transaction_offset( 13 );
 160
 161     if ( @values < 5 || grep { !defined } @values ) {
 162         $self->_fileobj->close;
 163         $self->_throw_error("Corrupted file - bad header");
 164     }
 165
 166     #XXX Add warnings if values weren't set right
 167     @{$self}{qw(long_size long_pack data_size data_pack max_buckets)} = @values;
 168
 169     return $bytes_read;
 170 }
 171
 172 sub setup_fh {
 173     my $self = shift;
 174     my ($obj) = @_;
 175
 176     local($/,$\);
 177
 178     my $fh = $self->_fh;
 179     flock $fh, LOCK_EX;
 180
 181     #XXX The duplication of calculate_sizes needs to go away
 182     unless ( $obj->{base_offset} ) {
 183         my $bytes_read = $self->read_file_header;
 184
 185         $self->calculate_sizes;
 186
 187         ##
 188         # File is empty -- write header and master index
 189         ##
 190         if (!$bytes_read) {
 191             $self->_fileobj->audit( "# Database created on" );
 192
 193             $self->write_file_header;
 194
 195             $obj->{base_offset} = $self->_fileobj->request_space( $self->tag_size( $self->{index_size} ) );
 196
 197             $self->write_tag(
 198                 $obj->_base_offset, $obj->_type,
 199                 chr(0)x$self->{index_size},
 200             );
 201
 202             # Flush the filehandle
 203             my $old_fh = select $fh;
 204             my $old_af = $|; $| = 1; $| = $old_af;
 205             select $old_fh;
 206         }
 207         else {
 208             $obj->{base_offset} = $bytes_read;
 209
 210             ##
 211             # Get our type from master index header
 212             ##
 213             my $tag = $self->load_tag($obj->_base_offset);
 214             unless ( $tag ) {
 215                 flock $fh, LOCK_UN;
 216                 $self->_throw_error("Corrupted file, no master index record");
 217             }
 218
 219             unless ($obj->_type eq $tag->{signature}) {
 220                 flock $fh, LOCK_UN;
 221                 $self->_throw_error("File type mismatch");
 222             }
 223         }
 224     }
 225     else {
 226         $self->calculate_sizes;
 227     }
 228
 229     #XXX We have to make sure we don't mess up when autoflush isn't turned on
 230     unless ( $self->_fileobj->{inode} ) {
 231         my @stats = stat($fh);
 232         $self->_fileobj->{inode} = $stats[1];
 233         $self->_fileobj->{end} = $stats[7];
 234     }
 235
 236     flock $fh, LOCK_UN;
 237
 238     return 1;
 239 }
 240
 241 sub tag_size {
 242     my $self = shift;
 243     my ($size) = @_;
 244     return SIG_SIZE + $self->{data_size} + $size;
 245 }
 246
 247 sub write_tag {
 248     ##
 249     # Given offset, signature and content, create tag and write to disk
 250     ##
 251     my $self = shift;
 252     my ($offset, $sig, $content) = @_;
 253     my $size = length( $content );
 254
 255     local($/,$\);
 256
 257     my $fh = $self->_fh;
 258
 259     if ( defined $offset ) {
 260         seek($fh, $offset + $self->_fileobj->{file_offset}, SEEK_SET);
 261     }
 262
 263     print( $fh $sig . pack($self->{data_pack}, $size) . $content );
 264
 265     return unless defined $offset;
 266
 267     return {
 268         signature => $sig,
 269         size => $size,
 270         offset => $offset + SIG_SIZE + $self->{data_size},
 271         content => $content
 272     };
 273 }
 274
 275 sub load_tag {
 276     ##
 277     # Given offset, load single tag and return signature, size and data
 278     ##
 279     my $self = shift;
 280     my ($offset) = @_;
 281
 282     local($/,$\);
 283
 284     my $fh = $self->_fh;
 285
 286     seek($fh, $offset + $self->_fileobj->{file_offset}, SEEK_SET);
 287
 288     #XXX I'm not sure this check will work if autoflush isn't enabled ...
 289     return if eof $fh;
 290
 291     my $b;
 292     read( $fh, $b, SIG_SIZE + $self->{data_size} );
 293     my ($sig, $size) = unpack( "A $self->{data_pack}", $b );
 294
 295     my $buffer;
 296     read( $fh, $buffer, $size);
 297
 298     return {
 299         signature => $sig,
 300         size => $size,
 301         offset => $offset + SIG_SIZE + $self->{data_size},
 302         content => $buffer
 303     };
 304 }
 305
 306 sub _get_dbm_object {
 307     my $item = shift;
 308
 309     my $obj = eval {
 310         local $SIG{__DIE__};
 311         if ($item->isa( 'DBM::Deep' )) {
 312             return $item;
 313         }
 314         return;
 315     };
 316     return $obj if $obj;
 317
 318     my $r = Scalar::Util::reftype( $item ) || '';
 319     if ( $r eq 'HASH' ) {
 320         my $obj = eval {
 321             local $SIG{__DIE__};
 322             my $obj = tied(%$item);
 323             if ($obj->isa( 'DBM::Deep' )) {
 324                 return $obj;
 325             }
 326             return;
 327         };
 328         return $obj if $obj;
 329     }
 330     elsif ( $r eq 'ARRAY' ) {
 331         my $obj = eval {
 332             local $SIG{__DIE__};
 333             my $obj = tied(@$item);
 334             if ($obj->isa( 'DBM::Deep' )) {
 335                 return $obj;
 336             }
 337             return;
 338         };
 339         return $obj if $obj;
 340     }
 341
 342     return;
 343 }
 344
 345 sub _length_needed {
 346     my $self = shift;
 347     my ($value, $key) = @_;
 348
 349     my $is_dbm_deep = eval {
 350         local $SIG{'__DIE__'};
 351         $value->isa( 'DBM::Deep' );
 352     };
 353
 354     my $len = SIG_SIZE + $self->{data_size}
 355             + $self->{data_size} + length( $key );
 356
 357     if ( $is_dbm_deep && $value->_fileobj eq $self->_fileobj ) {
 358         return $len + $self->{long_size};
 359     }
 360
 361     my $r = Scalar::Util::reftype( $value ) || '';
 362     if ( $self->_fileobj->{autobless} ) {
 363         # This is for the bit saying whether or not this thing is blessed.
 364         $len += 1;
 365     }
 366
 367     unless ( $r eq 'HASH' || $r eq 'ARRAY' ) {
 368         if ( defined $value ) {
 369             $len += length( $value );
 370         }
 371         return $len;
 372     }
 373
 374     $len += $self->{index_size};
 375
 376     # if autobless is enabled, must also take into consideration
 377     # the class name as it is stored after the key.
 378     if ( $self->_fileobj->{autobless} ) {
 379         my $c = Scalar::Util::blessed($value);
 380         if ( defined $c && !$is_dbm_deep ) {
 381             $len += $self->{data_size} + length($c);
 382         }
 383     }
 384
 385     return $len;
 386 }
 387
 388 sub add_bucket {
 389     ##
 390     # Adds one key/value pair to bucket list, given offset, MD5 digest of key,
 391     # plain (undigested) key and value.
 392     ##
 393     my $self = shift;
 394     my ($tag, $md5, $plain_key, $value, $deleted, $orig_key) = @_;
 395     $deleted ||= 0;
 396
 397     local($/,$\);
 398
 399     # This verifies that only supported values will be stored.
 400     {
 401         my $r = Scalar::Util::reftype( $value );
 402         last if !defined $r;
 403
 404         last if $r eq 'HASH';
 405         last if $r eq 'ARRAY';
 406
 407         $self->_throw_error(
 408             "Storage of variables of type '$r' is not supported."
 409         );
 410     }
 411
 412     my $location = 0;
 413     my $result = 2;
 414
 415     my $fileobj = $self->_fileobj;
 416
 417     my $actual_length = $self->_length_needed( $value, $plain_key );
 418
 419     #ACID - This is a mutation. Must only find the exact transaction
 420     my ($subloc, $offset, $size,$is_deleted) = $self->_find_in_buckets( $tag, $md5, 1 );
 421
 422     my @transactions;
 423     if ( $fileobj->transaction_id == 0 ) {
 424         @transactions = $fileobj->current_transactions;
 425     }
 426
 427 #    $self->_release_space( $size, $subloc );
 428     # Updating a known md5
 429 #XXX This needs updating to use _release_space
 430     if ( $subloc ) {
 431         $result = 1;
 432
 433         if ($actual_length <= $size) {
 434             $location = $subloc;
 435         }
 436         else {
 437             $location = $fileobj->request_space( $actual_length );
 438
 439             $fileobj->print_at( $tag->{offset} + $offset + $self->{hash_size},
 440                 pack($self->{long_pack}, $location ),
 441                 pack($self->{long_pack}, $actual_length ),
 442                 pack('n n', $fileobj->transaction_id, $deleted ),
 443             );
 444         }
 445     }
 446     # Adding a new md5
 447     elsif ( defined $offset ) {
 448         $location = $fileobj->request_space( $actual_length );
 449
 450         $fileobj->print_at( $tag->{offset} + $offset,
 451             $md5,
 452             pack($self->{long_pack}, $location ),
 453             pack($self->{long_pack}, $actual_length ),
 454             pack('n n', $fileobj->transaction_id, $deleted ),
 455         );
 456
 457         for ( @transactions ) {
 458             my $tag2 = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
 459             $fileobj->{transaction_id} = $_;
 460             $self->add_bucket( $tag2, $md5, '', '', 1, $orig_key );
 461             $fileobj->{transaction_id} = 0;
 462         }
 463     }
 464     # If bucket didn't fit into list, split into a new index level
 465     # split_index() will do the _fileobj->request_space() call
 466     else {
 467         $location = $self->split_index( $md5, $tag );
 468     }
 469
 470     $self->write_value( $location, $plain_key, $value, $orig_key );
 471
 472     return $result;
 473 }
 474
 475 sub write_value {
 476     my $self = shift;
 477     my ($location, $key, $value, $orig_key) = @_;
 478
 479     local($/,$\);
 480
 481     my $fh = $self->_fh;
 482     my $root = $self->_fileobj;
 483
 484     my $dbm_deep_obj = _get_dbm_object( $value );
 485     if ( $dbm_deep_obj && $dbm_deep_obj->_fileobj ne $self->_fileobj ) {
 486         $self->_throw_error( "Cannot cross-reference. Use export() instead" );
 487     }
 488
 489     seek($fh, $location + $root->{file_offset}, SEEK_SET);
 490
 491     ##
 492     # Write signature based on content type, set content length and write
 493     # actual value.
 494     ##
 495     my $r = Scalar::Util::reftype( $value ) || '';
 496     if ( $dbm_deep_obj ) {
 497         $self->write_tag( undef, SIG_INTERNAL,pack($self->{long_pack}, $dbm_deep_obj->_base_offset) );
 498     }
 499     elsif ($r eq 'HASH') {
 500         if ( !$dbm_deep_obj && tied %{$value} ) {
 501             $self->_throw_error( "Cannot store something that is tied" );
 502         }
 503         $self->write_tag( undef, SIG_HASH, chr(0)x$self->{index_size} );
 504     }
 505     elsif ($r eq 'ARRAY') {
 506         if ( !$dbm_deep_obj && tied @{$value} ) {
 507             $self->_throw_error( "Cannot store something that is tied" );
 508         }
 509         $self->write_tag( undef, SIG_ARRAY, chr(0)x$self->{index_size} );
 510     }
 511     elsif (!defined($value)) {
 512         $self->write_tag( undef, SIG_NULL, '' );
 513     }
 514     else {
 515         $self->write_tag( undef, SIG_DATA, $value );
 516     }
 517
 518     ##
 519     # Plain key is stored AFTER value, as keys are typically fetched less often.
 520     ##
 521     print( $fh pack($self->{data_pack}, length($key)) . $key );
 522
 523     # Internal references don't care about autobless
 524     return 1 if $dbm_deep_obj;
 525
 526     ##
 527     # If value is blessed, preserve class name
 528     ##
 529     if ( $root->{autobless} ) {
 530         my $c = Scalar::Util::blessed($value);
 531         if ( defined $c && !$dbm_deep_obj ) {
 532             print( $fh chr(1) );
 533             print( $fh pack($self->{data_pack}, length($c)) . $c );
 534         }
 535         else {
 536             print( $fh chr(0) );
 537         }
 538     }
 539
 540     ##
 541     # Tie the passed in reference so that changes to it are reflected in the
 542     # datafile. The use of $location as the base_offset will act as the
 543     # the linkage between parent and child.
 544     #
 545     # The overall assignment is a hack around the fact that just tying doesn't
 546     # store the values. This may not be the wrong thing to do.
 547     ##
 548     if ($r eq 'HASH') {
 549         my %x = %$value;
 550         tie %$value, 'DBM::Deep', {
 551             base_offset => $location,
 552             fileobj     => $root,
 553             parent      => $self->{obj},
 554             parent_key  => $orig_key,
 555         };
 556         %$value = %x;
 557     }
 558     elsif ($r eq 'ARRAY') {
 559         my @x = @$value;
 560         tie @$value, 'DBM::Deep', {
 561             base_offset => $location,
 562             fileobj     => $root,
 563             parent      => $self->{obj},
 564             parent_key  => $orig_key,
 565         };
 566         @$value = @x;
 567     }
 568
 569     return 1;
 570 }
 571
 572 sub split_index {
 573     my $self = shift;
 574     my ($md5, $tag) = @_;
 575
 576     my $fileobj = $self->_fileobj;
 577
 578     my $loc = $fileobj->request_space(
 579         $self->tag_size( $self->{index_size} ),
 580     );
 581
 582     $fileobj->print_at( $tag->{ref_loc}, pack($self->{long_pack}, $loc) );
 583
 584     my $index_tag = $self->write_tag(
 585         $loc, SIG_INDEX,
 586         chr(0)x$self->{index_size},
 587     );
 588
 589     my $newtag_loc = $fileobj->request_space(
 590         $self->tag_size( $self->{bucket_list_size} ),
 591     );
 592
 593     my $keys = $tag->{content}
 594              . $md5 . pack($self->{long_pack}, $newtag_loc)
 595                     . pack($self->{long_pack}, 0)  # size
 596                     . pack($self->{long_pack}, 0); # transaction ID
 597
 598     my @newloc = ();
 599     BUCKET:
 600     for (my $i = 0; $i <= $self->{max_buckets}; $i++) {
 601         my ($key, $old_subloc, $size) = $self->_get_key_subloc( $keys, $i );
 602
 603         die "[INTERNAL ERROR]: No key in split_index()\n" unless $key;
 604         die "[INTERNAL ERROR]: No subloc in split_index()\n" unless $old_subloc;
 605
 606         my $num = ord(substr($key, $tag->{ch} + 1, 1));
 607
 608         if ($newloc[$num]) {
 609             local($/,$\);
 610
 611             my $fh = $self->_fh;
 612
 613             seek($fh, $newloc[$num] + $fileobj->{file_offset}, SEEK_SET);
 614             my $subkeys;
 615             read( $fh, $subkeys, $self->{bucket_list_size});
 616
 617             # This is looking for the first empty spot
 618             my ($subloc, $offset, $size) = $self->_find_in_buckets(
 619                 { content => $subkeys }, '',
 620             );
 621
 622             $fileobj->print_at( $newloc[$num] + $offset, $key . pack($self->{long_pack}, $old_subloc) );
 623
 624             next;
 625         }
 626
 627         my $loc = $fileobj->request_space(
 628             $self->tag_size( $self->{bucket_list_size} ),
 629         );
 630
 631         $fileobj->print_at(
 632             $index_tag->{offset} + ($num * $self->{long_size}),
 633             pack($self->{long_pack}, $loc),
 634         );
 635
 636         my $blist_tag = $self->write_tag(
 637             $loc, SIG_BLIST,
 638             chr(0)x$self->{bucket_list_size},
 639         );
 640
 641         $fileobj->print_at( $blist_tag->{offset}, $key . pack($self->{long_pack}, $old_subloc) );
 642
 643         $newloc[$num] = $blist_tag->{offset};
 644     }
 645
 646     $self->_release_space(
 647         $self->tag_size( $self->{bucket_list_size} ),
 648         $tag->{offset} - SIG_SIZE - $self->{data_size},
 649     );
 650
 651     return $newtag_loc;
 652 }
 653
 654 sub read_from_loc {
 655     my $self = shift;
 656     my ($subloc, $orig_key) = @_;
 657
 658     local($/,$\);
 659
 660     my $fh = $self->_fh;
 661
 662     ##
 663     # Found match -- seek to offset and read signature
 664     ##
 665     my $signature;
 666     seek($fh, $subloc + $self->_fileobj->{file_offset}, SEEK_SET);
 667     read( $fh, $signature, SIG_SIZE);
 668
 669     ##
 670     # If value is a hash or array, return new DBM::Deep object with correct offset
 671     ##
 672     if (($signature eq SIG_HASH) || ($signature eq SIG_ARRAY)) {
 673         my $new_obj = DBM::Deep->new({
 674             type        => $signature,
 675             base_offset => $subloc,
 676             fileobj     => $self->_fileobj,
 677             parent      => $self->{obj},
 678             parent_key  => $orig_key,
 679         });
 680
 681         if ($new_obj->_fileobj->{autobless}) {
 682             ##
 683             # Skip over value and plain key to see if object needs
 684             # to be re-blessed
 685             ##
 686             seek($fh, $self->{data_size} + $self->{index_size}, SEEK_CUR);
 687
 688             my $size;
 689             read( $fh, $size, $self->{data_size});
 690             $size = unpack($self->{data_pack}, $size);
 691             if ($size) { seek($fh, $size, SEEK_CUR); }
 692
 693             my $bless_bit;
 694             read( $fh, $bless_bit, 1);
 695             if (ord($bless_bit)) {
 696                 ##
 697                 # Yes, object needs to be re-blessed
 698                 ##
 699                 my $class_name;
 700                 read( $fh, $size, $self->{data_size});
 701                 $size = unpack($self->{data_pack}, $size);
 702                 if ($size) { read( $fh, $class_name, $size); }
 703                 if ($class_name) { $new_obj = bless( $new_obj, $class_name ); }
 704             }
 705         }
 706
 707         return $new_obj;
 708     }
 709     elsif ( $signature eq SIG_INTERNAL ) {
 710         my $size;
 711         read( $fh, $size, $self->{data_size});
 712         $size = unpack($self->{data_pack}, $size);
 713
 714         if ( $size ) {
 715             my $new_loc;
 716             read( $fh, $new_loc, $size );
 717             $new_loc = unpack( $self->{long_pack}, $new_loc );
 718
 719             return $self->read_from_loc( $new_loc, $orig_key );
 720         }
 721         else {
 722             return;
 723         }
 724     }
 725     ##
 726     # Otherwise return actual value
 727     ##
 728     elsif ( $signature eq SIG_DATA ) {
 729         my $size;
 730         read( $fh, $size, $self->{data_size});
 731         $size = unpack($self->{data_pack}, $size);
 732
 733         my $value = '';
 734         if ($size) { read( $fh, $value, $size); }
 735         return $value;
 736     }
 737
 738     ##
 739     # Key exists, but content is null
 740     ##
 741     return;
 742 }
 743
 744 sub get_bucket_value {
 745     ##
 746     # Fetch single value given tag and MD5 digested key.
 747     ##
 748     my $self = shift;
 749     my ($tag, $md5, $orig_key) = @_;
 750
 751     #ACID - This is a read. Can find exact or HEAD
 752     my ($subloc, $offset, $size,$is_deleted) = $self->_find_in_buckets( $tag, $md5 );
 753     if ( $subloc && !$is_deleted ) {
 754         return $self->read_from_loc( $subloc, $orig_key );
 755     }
 756     return;
 757 }
 758
 759 sub delete_bucket {
 760     ##
 761     # Delete single key/value pair given tag and MD5 digested key.
 762     ##
 763     my $self = shift;
 764     my ($tag, $md5, $orig_key) = @_;
 765
 766     #ACID - This is a mutation. Must only find the exact transaction
 767     my ($subloc, $offset, $size) = $self->_find_in_buckets( $tag, $md5, 1 );
 768 #XXX This needs _release_space() for the value and anything below
 769     if ( $subloc ) {
 770         $self->_fileobj->print_at(
 771             $tag->{offset} + $offset,
 772             substr($tag->{content}, $offset + $self->{bucket_size} ),
 773             chr(0) x $self->{bucket_size},
 774         );
 775
 776         return 1;
 777     }
 778     return;
 779 }
 780
 781 sub bucket_exists {
 782     ##
 783     # Check existence of single key given tag and MD5 digested key.
 784     ##
 785     my $self = shift;
 786     my ($tag, $md5) = @_;
 787
 788     #ACID - This is a read. Can find exact or HEAD
 789     my ($subloc, $offset, $size, $is_deleted) = $self->_find_in_buckets( $tag, $md5 );
 790     return ($subloc && !$is_deleted) && 1;
 791 }
 792
 793 sub find_bucket_list {
 794     ##
 795     # Locate offset for bucket list, given digested key
 796     ##
 797     my $self = shift;
 798     my ($offset, $md5, $args) = @_;
 799     $args = {} unless $args;
 800
 801     local($/,$\);
 802
 803     ##
 804     # Locate offset for bucket list using digest index system
 805     ##
 806     my $tag = $self->load_tag( $offset )
 807         or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
 808
 809     my $ch = 0;
 810     while ($tag->{signature} ne SIG_BLIST) {
 811         my $num = ord substr($md5, $ch, 1);
 812
 813         my $ref_loc = $tag->{offset} + ($num * $self->{long_size});
 814         $tag = $self->index_lookup( $tag, $num );
 815
 816         if (!$tag) {
 817             return if !$args->{create};
 818
 819             my $loc = $self->_fileobj->request_space(
 820                 $self->tag_size( $self->{bucket_list_size} ),
 821             );
 822
 823             $self->_fileobj->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
 824
 825             $tag = $self->write_tag(
 826                 $loc, SIG_BLIST,
 827                 chr(0)x$self->{bucket_list_size},
 828             );
 829
 830             $tag->{ref_loc} = $ref_loc;
 831             $tag->{ch} = $ch;
 832
 833             last;
 834         }
 835
 836         $tag->{ch} = $ch++;
 837         $tag->{ref_loc} = $ref_loc;
 838     }
 839
 840     return $tag;
 841 }
 842
 843 sub index_lookup {
 844     ##
 845     # Given index tag, lookup single entry in index and return .
 846     ##
 847     my $self = shift;
 848     my ($tag, $index) = @_;
 849
 850     my $location = unpack(
 851         $self->{long_pack},
 852         substr(
 853             $tag->{content},
 854             $index * $self->{long_size},
 855             $self->{long_size},
 856         ),
 857     );
 858
 859     if (!$location) { return; }
 860
 861     return $self->load_tag( $location );
 862 }
 863
 864 sub traverse_index {
 865     ##
 866     # Scan index and recursively step into deeper levels, looking for next key.
 867     ##
 868     my $self = shift;
 869     my ($obj, $offset, $ch, $force_return_next) = @_;
 870
 871     local($/,$\);
 872
 873     my $tag = $self->load_tag( $offset );
 874
 875     my $fh = $self->_fh;
 876
 877     if ($tag->{signature} ne SIG_BLIST) {
 878         my $content = $tag->{content};
 879         my $start = $obj->{return_next} ? 0 : ord(substr($obj->{prev_md5}, $ch, 1));
 880
 881         for (my $idx = $start; $idx < (2**8); $idx++) {
 882             my $subloc = unpack(
 883                 $self->{long_pack},
 884                 substr(
 885                     $content,
 886                     $idx * $self->{long_size},
 887                     $self->{long_size},
 888                 ),
 889             );
 890
 891             if ($subloc) {
 892                 my $result = $self->traverse_index(
 893                     $obj, $subloc, $ch + 1, $force_return_next,
 894                 );
 895
 896                 if (defined($result)) { return $result; }
 897             }
 898         } # index loop
 899
 900         $obj->{return_next} = 1;
 901     } # tag is an index
 902
 903     else {
 904         my $keys = $tag->{content};
 905         if ($force_return_next) { $obj->{return_next} = 1; }
 906
 907         ##
 908         # Iterate through buckets, looking for a key match
 909         ##
 910         for (my $i = 0; $i < $self->{max_buckets}; $i++) {
 911             my ($key, $subloc) = $self->_get_key_subloc( $keys, $i );
 912
 913             # End of bucket list -- return to outer loop
 914             if (!$subloc) {
 915                 $obj->{return_next} = 1;
 916                 last;
 917             }
 918             # Located previous key -- return next one found
 919             elsif ($key eq $obj->{prev_md5}) {
 920                 $obj->{return_next} = 1;
 921                 next;
 922             }
 923             # Seek to bucket location and skip over signature
 924             elsif ($obj->{return_next}) {
 925                 seek($fh, $subloc + $self->_fileobj->{file_offset}, SEEK_SET);
 926
 927                 # Skip over value to get to plain key
 928                 my $sig;
 929                 read( $fh, $sig, SIG_SIZE );
 930
 931                 my $size;
 932                 read( $fh, $size, $self->{data_size});
 933                 $size = unpack($self->{data_pack}, $size);
 934                 if ($size) { seek($fh, $size, SEEK_CUR); }
 935
 936                 # Read in plain key and return as scalar
 937                 my $plain_key;
 938                 read( $fh, $size, $self->{data_size});
 939                 $size = unpack($self->{data_pack}, $size);
 940                 if ($size) { read( $fh, $plain_key, $size); }
 941
 942                 return $plain_key;
 943             }
 944         }
 945
 946         $obj->{return_next} = 1;
 947     } # tag is a bucket list
 948
 949     return;
 950 }
 951
 952 sub get_next_key {
 953     ##
 954     # Locate next key, given digested previous one
 955     ##
 956     my $self = shift;
 957     my ($obj) = @_;
 958
 959     $obj->{prev_md5} = $_[1] ? $_[1] : undef;
 960     $obj->{return_next} = 0;
 961
 962     ##
 963     # If the previous key was not specifed, start at the top and
 964     # return the first one found.
 965     ##
 966     if (!$obj->{prev_md5}) {
 967         $obj->{prev_md5} = chr(0) x $self->{hash_size};
 968         $obj->{return_next} = 1;
 969     }
 970
 971     return $self->traverse_index( $obj, $obj->_base_offset, 0 );
 972 }
 973
 974 # Utilities
 975
 976 sub _get_key_subloc {
 977     my $self = shift;
 978     my ($keys, $idx) = @_;
 979
 980     my ($key, $subloc, $size, $transaction_id, $is_deleted) = unpack(
 981         # This is 'a', not 'A'. Please read the pack() documentation for the
 982         # difference between the two and why it's important.
 983         "a$self->{hash_size} $self->{long_pack}2 n2",
 984         substr(
 985             $keys,
 986             ($idx * $self->{bucket_size}),
 987             $self->{bucket_size},
 988         ),
 989     );
 990
 991     return ($key, $subloc, $size, $transaction_id, $is_deleted);
 992 }
 993
 994 sub _find_in_buckets {
 995     my $self = shift;
 996     my ($tag, $md5, $exact) = @_;
 997
 998     my $trans_id = $self->_fileobj->transaction_id;
 999
1000     my @zero;
1001
1002     BUCKET:
1003     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
1004         my ($key, $subloc, $size, $transaction_id, $is_deleted) = $self->_get_key_subloc(
1005             $tag->{content}, $i,
1006         );
1007
1008         my @rv = ($subloc, $i * $self->{bucket_size}, $size, $is_deleted);
1009
1010         unless ( $subloc ) {
1011             if ( !$exact && @zero and $trans_id ) {
1012                 @rv = ($zero[2], $zero[0] * $self->{bucket_size},$zero[3],$is_deleted);
1013             }
1014             return @rv;
1015         }
1016
1017         next BUCKET if $key ne $md5;
1018
1019         # Save off the HEAD in case we need it.
1020         @zero = ($i,$key,$subloc,$size,$transaction_id,$is_deleted) if $transaction_id == 0;
1021
1022         next BUCKET if $transaction_id != $trans_id;
1023
1024         return @rv;
1025     }
1026
1027     return;
1028 }
1029
1030 sub _release_space {
1031     my $self = shift;
1032     my ($size, $loc) = @_;
1033
1034     my $next_loc = 0;
1035
1036     $self->_fileobj->print_at( $loc,
1037         SIG_FREE,
1038         pack($self->{long_pack}, $size ),
1039         pack($self->{long_pack}, $next_loc ),
1040     );
1041
1042     return;
1043 }
1044
1045 sub _throw_error {
1046     die "DBM::Deep: $_[1]\n";
1047 }
1048
1049 1;
1050 __END__
1051
1052 # This will be added in later, after more refactoring is done. This is an early
1053 # attempt at refactoring on the physical level instead of the virtual level.
1054 sub _read_at {
1055     my $self = shift;
1056     my ($spot, $amount, $unpack) = @_;
1057
1058     local($/,$\);
1059
1060     my $fh = $self->_fh;
1061     seek( $fh, $spot + $self->_fileobj->{file_offset}, SEEK_SET );
1062
1063     my $buffer;
1064     my $bytes_read = read( $fh, $buffer, $amount );
1065
1066     if ( $unpack ) {
1067         $buffer = unpack( $unpack, $buffer );
1068     }
1069
1070     if ( wantarray ) {
1071         return ($buffer, $bytes_read);
1072     }
1073     else {
1074         return $buffer;
1075     }
1076 }
1077
1078 sub get_file_version {
1079     my $self = shift;
1080
1081     local($/,$\);
1082
1083     my $fh = $self->_fh;
1084
1085     seek( $fh, 13 + $self->_fileobj->{file_offset}, SEEK_SET );
1086     my $buffer;
1087     my $bytes_read = read( $fh, $buffer, 4 );
1088     unless ( $bytes_read == 4 ) {
1089         $self->_throw_error( "Cannot read file version" );
1090     }
1091
1092     return unpack( 'N', $buffer );
1093 }
1094
1095 sub write_file_version {
1096     my $self = shift;
1097     my ($new_version) = @_;
1098
1099     local($/,$\);
1100
1101     my $fh = $self->_fh;
1102
1103     seek( $fh, 13 + $self->_fileobj->{file_offset}, SEEK_SET );
1104     print( $fh pack( 'N', $new_version ) );
1105
1106     return;
1107 }
1108