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