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