lib/DBM/Deep/Engine.pm

   1 package DBM::Deep::Engine;
   2
   3 use strict;
   4
   5 use Fcntl qw( :DEFAULT :flock :seek );
   6
   7 sub precalc_sizes {
   8     ##
   9     # Precalculate index, bucket and bucket list sizes
  10     ##
  11     my $self = shift;
  12
  13     $self->{index_size}       = (2**8) * $self->{long_size};
  14     $self->{bucket_size}      = $self->{hash_size} + $self->{long_size};
  15     $self->{bucket_list_size} = $self->{max_buckets} * $self->{bucket_size};
  16
  17     return 1;
  18 }
  19
  20 sub set_pack {
  21     ##
  22     # Set pack/unpack modes (see file header for more)
  23     ##
  24     my $self = shift;
  25     my ($long_s, $long_p, $data_s, $data_p) = @_;
  26
  27     ##
  28     # Set to 4 and 'N' for 32-bit offset tags (default).  Theoretical limit of 4
  29     # GB per file.
  30     #    (Perl must be compiled with largefile support for files > 2 GB)
  31     #
  32     # Set to 8 and 'Q' for 64-bit offsets.  Theoretical limit of 16 XB per file.
  33     #    (Perl must be compiled with largefile and 64-bit long support)
  34     ##
  35     $self->{long_size} = $long_s ? $long_s : 4;
  36     $self->{long_pack} = $long_p ? $long_p : 'N';
  37
  38     ##
  39     # Set to 4 and 'N' for 32-bit data length prefixes.  Limit of 4 GB for each
  40     # key/value. Upgrading this is possible (see above) but probably not necessary.
  41     # If you need more than 4 GB for a single key or value, this module is really
  42     # not for you :-)
  43     ##
  44     $self->{data_size} = $data_s ? $data_s : 4;
  45     $self->{data_pack} = $data_p ? $data_p : 'N';
  46
  47     return $self->precalc_sizes();
  48 }
  49
  50 sub set_digest {
  51     ##
  52     # Set key digest function (default is MD5)
  53     ##
  54     my $self = shift;
  55     my ($digest_func, $hash_size) = @_;
  56
  57     $self->{digest} = $digest_func ? $digest_func : \&Digest::MD5::md5;
  58     $self->{hash_size} = $hash_size ? $hash_size : 16;
  59
  60     return $self->precalc_sizes();
  61 }
  62
  63 sub new {
  64     my $class = shift;
  65     my ($args) = @_;
  66
  67     my $self = bless {
  68         long_size   => 4,
  69         long_pack   => 'N',
  70         data_size   => 4,
  71         data_pack   => 'N',
  72
  73         digest      => \&Digest::MD5::md5,
  74         hash_size   => 16,
  75
  76         ##
  77         # Maximum number of buckets per list before another level of indexing is done.
  78         # Increase this value for slightly greater speed, but larger database files.
  79         # DO NOT decrease this value below 16, due to risk of recursive reindex overrun.
  80         ##
  81         max_buckets => 16,
  82     }, $class;
  83
  84     $self->precalc_sizes;
  85
  86     return $self;
  87 }
  88
  89 sub setup_fh {
  90     my $self = shift;
  91     my ($obj) = @_;
  92
  93     $self->open( $obj ) if !defined $obj->_fh;
  94
  95     #XXX We have to make sure we don't mess up when autoflush isn't turned on
  96     unless ( $obj->_root->{inode} ) {
  97         my @stats = stat($obj->_fh);
  98         $obj->_root->{inode} = $stats[1];
  99         $obj->_root->{end} = $stats[7];
 100     }
 101
 102     return 1;
 103 }
 104
 105 sub open {
 106     ##
 107     # Open a fh to the database, create if nonexistent.
 108     # Make sure file signature matches DBM::Deep spec.
 109     ##
 110     my $self = shift;
 111     my ($obj) = @_;
 112
 113     if (defined($obj->_fh)) { $self->close_fh( $obj ); }
 114
 115     # Theoretically, adding O_BINARY should remove the need for the binmode
 116     # Of course, testing it is going to be ... interesting.
 117     my $flags = O_RDWR | O_CREAT | O_BINARY;
 118
 119     my $fh;
 120     sysopen( $fh, $obj->_root->{file}, $flags )
 121         or $obj->_throw_error("Cannot sysopen file: " . $obj->_root->{file} . ": $!");
 122     $obj->_root->{fh} = $fh;
 123
 124     #XXX Can we remove this by using the right sysopen() flags?
 125     # Maybe ... q.v. above
 126     binmode $fh; # for win32
 127
 128     if ($obj->_root->{autoflush}) {
 129         my $old = select $fh;
 130         $|=1;
 131         select $old;
 132     }
 133
 134     seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
 135
 136     my $signature;
 137     my $bytes_read = read( $fh, $signature, length(DBM::Deep->SIG_FILE));
 138
 139     ##
 140     # File is empty -- write signature and master index
 141     ##
 142     if (!$bytes_read) {
 143         seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
 144         print( $fh DBM::Deep->SIG_FILE);
 145
 146         $self->create_tag($obj, $obj->_base_offset, $obj->_type, chr(0) x $self->{index_size});
 147
 148         # Why is this being printed here? I'm not seeing where anything actually points to
 149         # this spot.
 150         #XXX $obj->_root->{end} isn't updated from these 10 bytes that are being written
 151         my $plain_key = "[base]";
 152         print( $fh pack($self->{data_pack}, length($plain_key)) . $plain_key );
 153
 154         # Flush the filehandle
 155         my $old_fh = select $fh;
 156         my $old_af = $|; $| = 1; $| = $old_af;
 157         select $old_fh;
 158
 159         return 1;
 160     }
 161
 162     ##
 163     # Check signature was valid
 164     ##
 165     unless ($signature eq DBM::Deep->SIG_FILE) {
 166         $self->close_fh( $obj );
 167         $obj->_throw_error("Signature not found -- file is not a Deep DB");
 168     }
 169
 170     ##
 171     # Get our type from master index signature
 172     ##
 173     my $tag = $self->load_tag($obj, $obj->_base_offset)
 174         or $obj->_throw_error("Corrupted file, no master index record");
 175
 176     unless ($obj->{type} eq $tag->{signature}) {
 177         $obj->_throw_error("File type mismatch");
 178     }
 179
 180 #XXX We probably also want to store the hash algorithm name and not assume anything
 181 #XXX The cool thing would be to allow a different hashing algorithm at every level
 182
 183     return 1;
 184 }
 185
 186 sub close_fh {
 187     my $self = shift;
 188     my ($obj) = @_;
 189
 190     if ( my $fh = $obj->_root->{fh} ) {
 191         close $fh;
 192     }
 193     $obj->_root->{fh} = undef;
 194
 195     return 1;
 196 }
 197
 198 sub create_tag {
 199     ##
 200     # Given offset, signature and content, create tag and write to disk
 201     ##
 202     my $self = shift;
 203     my ($obj, $offset, $sig, $content) = @_;
 204     my $size = length($content);
 205
 206     my $fh = $obj->_fh;
 207
 208     seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET);
 209     print( $fh $sig . pack($self->{data_pack}, $size) . $content );
 210
 211     if ($offset == $obj->_root->{end}) {
 212         $obj->_root->{end} += DBM::Deep->SIG_SIZE + $self->{data_size} + $size;
 213     }
 214
 215     return {
 216         signature => $sig,
 217         size => $size,
 218         offset => $offset + DBM::Deep->SIG_SIZE + $self->{data_size},
 219         content => $content
 220     };
 221 }
 222
 223 sub load_tag {
 224     ##
 225     # Given offset, load single tag and return signature, size and data
 226     ##
 227     my $self = shift;
 228     my ($obj, $offset) = @_;
 229
 230     my $fh = $obj->_fh;
 231
 232     seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET);
 233
 234     #XXX I'm not sure this check will work if autoflush isn't enabled ...
 235     return if eof $fh;
 236
 237     my $b;
 238     read( $fh, $b, DBM::Deep->SIG_SIZE + $self->{data_size} );
 239     my ($sig, $size) = unpack( "A $self->{data_pack}", $b );
 240
 241     my $buffer;
 242     read( $fh, $buffer, $size);
 243
 244     return {
 245         signature => $sig,
 246         size => $size,
 247         offset => $offset + DBM::Deep->SIG_SIZE + $self->{data_size},
 248         content => $buffer
 249     };
 250 }
 251
 252 sub add_bucket {
 253     ##
 254     # Adds one key/value pair to bucket list, given offset, MD5 digest of key,
 255     # plain (undigested) key and value.
 256     ##
 257     my $self = shift;
 258     my ($obj, $tag, $md5, $plain_key, $value) = @_;
 259
 260     my $keys = $tag->{content};
 261     my $location = 0;
 262     my $result = 2;
 263
 264     my $root = $obj->_root;
 265
 266     my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep' ) };
 267     my $internal_ref = $is_dbm_deep && ($value->_root eq $root);
 268
 269     my $fh = $obj->_fh;
 270
 271     ##
 272     # Iterate through buckets, seeing if this is a new entry or a replace.
 273     ##
 274     BUCKET:
 275     for (my $i = 0; $i < $self->{max_buckets}; $i++) {
 276         my $subloc = $self->_get_subloc( $keys, $i );
 277
 278         if (!$subloc) {
 279             ##
 280             # Found empty bucket (end of list).  Populate and exit loop.
 281             ##
 282             $result = 2;
 283
 284             $location = $internal_ref
 285                 ? $value->_base_offset
 286                 : $root->{end};
 287 print "NEW: $location\n";
 288
 289             seek(
 290                 $fh,
 291                 $tag->{offset} + ($i * $self->{bucket_size}) + $root->{file_offset},
 292                 SEEK_SET,
 293             );
 294
 295             print( $fh $md5 . pack($self->{long_pack}, $location) );
 296             last;
 297         }
 298
 299         my $key = substr($keys, $i * $self->{bucket_size}, $self->{hash_size});
 300         if ( $md5 ne $key ) {
 301             next BUCKET;
 302         }
 303
 304         ##
 305         # Found existing bucket with same key.  Replace with new value.
 306         ##
 307         $result = 1;
 308
 309         if ($internal_ref) {
 310             $location = $value->_base_offset;
 311             seek($fh, $tag->{offset} + ($i * $self->{bucket_size}) + $root->{file_offset}, SEEK_SET);
 312             print( $fh $md5 . pack($self->{long_pack}, $location) );
 313             return $result;
 314         }
 315
 316         seek($fh, $subloc + DBM::Deep->SIG_SIZE + $root->{file_offset}, SEEK_SET);
 317         my $size;
 318         read( $fh, $size, $self->{data_size});
 319         $size = unpack($self->{data_pack}, $size);
 320
 321         ##
 322         # If value is a hash, array, or raw value with equal or less size, we can
 323         # reuse the same content area of the database.  Otherwise, we have to create
 324         # a new content area at the EOF.
 325         ##
 326         my $actual_length;
 327         my $r = Scalar::Util::reftype( $value ) || '';
 328         if ( $r eq 'HASH' || $r eq 'ARRAY' ) {
 329             $actual_length = $self->{index_size};
 330
 331             # if autobless is enabled, must also take into consideration
 332             # the class name, as it is stored along with key/value.
 333             if ( $root->{autobless} ) {
 334                 my $value_class = Scalar::Util::blessed($value);
 335                 if ( defined $value_class && !$value->isa('DBM::Deep') ) {
 336                     $actual_length += length($value_class);
 337                 }
 338             }
 339         }
 340         else { $actual_length = length($value); }
 341
 342         if ($actual_length <= $size) {
 343             $location = $subloc;
 344         }
 345         else {
 346             $location = $root->{end};
 347             seek($fh, $tag->{offset} + ($i * $self->{bucket_size}) + $self->{hash_size} + $root->{file_offset}, SEEK_SET);
 348             print( $fh pack($self->{long_pack}, $location) );
 349         }
 350
 351         last;
 352     }
 353
 354     ##
 355     # If this is an internal reference, return now.
 356     # No need to write value or plain key
 357     ##
 358     #XXX We need to store the key as a reference to the internal spot
 359     if ($internal_ref) {
 360         return $result;
 361     }
 362
 363     ##
 364     # If bucket didn't fit into list, split into a new index level
 365     ##
 366     if (!$location) {
 367         # re-index bucket list
 368
 369         $self->split_index( $obj, $md5, $tag );
 370
 371         $location = $root->{end};
 372     }
 373
 374     ##
 375     # Seek to content area and store signature, value and plaintext key
 376     ##
 377     if ($location) {
 378         my $content_length;
 379         seek($fh, $location + $root->{file_offset}, SEEK_SET);
 380
 381         ##
 382         # Write signature based on content type, set content length and write actual value.
 383         ##
 384         my $r = Scalar::Util::reftype($value) || '';
 385         if ($r eq 'HASH') {
 386             print( $fh DBM::Deep->TYPE_HASH );
 387             print( $fh pack($self->{data_pack}, $self->{index_size}) . chr(0) x $self->{index_size} );
 388             $content_length = $self->{index_size};
 389         }
 390         elsif ($r eq 'ARRAY') {
 391             print( $fh DBM::Deep->TYPE_ARRAY );
 392             print( $fh pack($self->{data_pack}, $self->{index_size}) . chr(0) x $self->{index_size} );
 393             $content_length = $self->{index_size};
 394         }
 395         elsif (!defined($value)) {
 396             print( $fh DBM::Deep->SIG_NULL );
 397             print( $fh pack($self->{data_pack}, 0) );
 398             $content_length = 0;
 399         }
 400         else {
 401             print( $fh DBM::Deep->SIG_DATA );
 402             print( $fh pack($self->{data_pack}, length($value)) . $value );
 403             $content_length = length($value);
 404         }
 405
 406         ##
 407         # Plain key is stored AFTER value, as keys are typically fetched less often.
 408         ##
 409         print( $fh pack($self->{data_pack}, length($plain_key)) . $plain_key );
 410
 411         ##
 412         # If value is blessed, preserve class name
 413         ##
 414         if ( $root->{autobless} ) {
 415             my $value_class = Scalar::Util::blessed($value);
 416             if ( defined $value_class && $value_class ne 'DBM::Deep' ) {
 417                 ##
 418                 # Blessed ref -- will restore later
 419                 ##
 420                 print( $fh chr(1) );
 421                 print( $fh pack($self->{data_pack}, length($value_class)) . $value_class );
 422                 $content_length += 1;
 423                 $content_length += $self->{data_size} + length($value_class);
 424             }
 425             else {
 426                 print( $fh chr(0) );
 427                 $content_length += 1;
 428             }
 429         }
 430
 431         ##
 432         # If this is a new content area, advance EOF counter
 433         ##
 434         if ($location == $root->{end}) {
 435             $root->{end} += DBM::Deep->SIG_SIZE;
 436             $root->{end} += $self->{data_size} + $content_length;
 437             $root->{end} += $self->{data_size} + length($plain_key);
 438         }
 439
 440         ##
 441         # If content is a hash or array, create new child DBM::Deep object and
 442         # pass each key or element to it.
 443         ##
 444         if ($r eq 'HASH') {
 445             my $branch = DBM::Deep->new(
 446                 type => DBM::Deep->TYPE_HASH,
 447                 base_offset => $location,
 448                 root => $root,
 449             );
 450             foreach my $key (keys %{$value}) {
 451                 $branch->STORE( $key, $value->{$key} );
 452             }
 453         }
 454         elsif ($r eq 'ARRAY') {
 455             my $branch = DBM::Deep->new(
 456                 type => DBM::Deep->TYPE_ARRAY,
 457                 base_offset => $location,
 458                 root => $root,
 459             );
 460             my $index = 0;
 461             foreach my $element (@{$value}) {
 462                 $branch->STORE( $index, $element );
 463                 $index++;
 464             }
 465         }
 466
 467         return $result;
 468     }
 469
 470     $obj->_throw_error("Fatal error: indexing failed -- possibly due to corruption in file");
 471 }
 472
 473 sub split_index {
 474     my $self = shift;
 475     my ($obj, $md5, $tag) = @_;
 476
 477     my $fh = $obj->_fh;
 478     my $root = $obj->_root;
 479     my $keys = $tag->{content};
 480
 481     seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET);
 482     print( $fh pack($self->{long_pack}, $root->{end}) );
 483
 484     my $index_tag = $self->create_tag(
 485         $obj,
 486         $root->{end},
 487         DBM::Deep->SIG_INDEX,
 488         chr(0) x $self->{index_size},
 489     );
 490
 491     my @offsets = ();
 492
 493     $keys .= $md5 . pack($self->{long_pack}, 0);
 494
 495     BUCKET:
 496     for (my $i = 0; $i <= $self->{max_buckets}; $i++) {
 497         my $key = substr(
 498             $keys,
 499             ($i * $self->{bucket_size}),
 500             $self->{hash_size},
 501         );
 502
 503         next BUCKET unless $key;
 504
 505         my $old_subloc = $self->_get_subloc( $keys, $i );
 506
 507         my $num = ord(substr($key, $tag->{ch} + 1, 1));
 508
 509         if ($offsets[$num]) {
 510             my $offset = $offsets[$num] + DBM::Deep->SIG_SIZE + $self->{data_size};
 511             seek($fh, $offset + $root->{file_offset}, SEEK_SET);
 512             my $subkeys;
 513             read( $fh, $subkeys, $self->{bucket_list_size});
 514
 515             for (my $k=0; $k<$self->{max_buckets}; $k++) {
 516                 my $subloc = $self->_get_subloc( $subkeys, $k );
 517
 518                 if (!$subloc) {
 519                     seek($fh, $offset + ($k * $self->{bucket_size}) + $root->{file_offset}, SEEK_SET);
 520                     print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) );
 521                     last;
 522                 }
 523             } # k loop
 524         }
 525         else {
 526             $offsets[$num] = $root->{end};
 527             seek($fh, $index_tag->{offset} + ($num * $self->{long_size}) + $root->{file_offset}, SEEK_SET);
 528             print( $fh pack($self->{long_pack}, $root->{end}) );
 529
 530             my $blist_tag = $self->create_tag($obj, $root->{end}, DBM::Deep->SIG_BLIST, chr(0) x $self->{bucket_list_size});
 531
 532             seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET);
 533             print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) );
 534         }
 535     } # i loop
 536
 537     return;
 538 }
 539
 540 sub get_bucket_value {
 541     ##
 542     # Fetch single value given tag and MD5 digested key.
 543     ##
 544     my $self = shift;
 545     my ($obj, $tag, $md5) = @_;
 546     my $keys = $tag->{content};
 547
 548     my $fh = $obj->_fh;
 549
 550     ##
 551     # Iterate through buckets, looking for a key match
 552     ##
 553     BUCKET:
 554     for (my $i = 0; $i < $self->{max_buckets}; $i++) {
 555         my $subloc = $self->_get_subloc( $keys, $i );
 556
 557         if (!$subloc) {
 558             ##
 559             # Hit end of list, no match
 560             ##
 561             return;
 562         }
 563
 564         my $key = substr($keys, $i * $self->{bucket_size}, $self->{hash_size});
 565         if ( $md5 ne $key ) {
 566             next BUCKET;
 567         }
 568
 569         ##
 570         # Found match -- seek to offset and read signature
 571         ##
 572         my $signature;
 573         seek($fh, $subloc + $obj->_root->{file_offset}, SEEK_SET);
 574         read( $fh, $signature, DBM::Deep->SIG_SIZE);
 575
 576         ##
 577         # If value is a hash or array, return new DBM::Deep object with correct offset
 578         ##
 579         if (($signature eq DBM::Deep->TYPE_HASH) || ($signature eq DBM::Deep->TYPE_ARRAY)) {
 580             my $obj = DBM::Deep->new(
 581                 type => $signature,
 582                 base_offset => $subloc,
 583                 root => $obj->_root,
 584             );
 585
 586             if ($obj->_root->{autobless}) {
 587                 ##
 588                 # Skip over value and plain key to see if object needs
 589                 # to be re-blessed
 590                 ##
 591                 seek($fh, $self->{data_size} + $self->{index_size}, SEEK_CUR);
 592
 593                 my $size;
 594                 read( $fh, $size, $self->{data_size}); $size = unpack($self->{data_pack}, $size);
 595                 if ($size) { seek($fh, $size, SEEK_CUR); }
 596
 597                 my $bless_bit;
 598                 read( $fh, $bless_bit, 1);
 599                 if (ord($bless_bit)) {
 600                     ##
 601                     # Yes, object needs to be re-blessed
 602                     ##
 603                     my $class_name;
 604                     read( $fh, $size, $self->{data_size}); $size = unpack($self->{data_pack}, $size);
 605                     if ($size) { read( $fh, $class_name, $size); }
 606                     if ($class_name) { $obj = bless( $obj, $class_name ); }
 607                 }
 608             }
 609
 610             return $obj;
 611         }
 612
 613         ##
 614         # Otherwise return actual value
 615         ##
 616         elsif ($signature eq DBM::Deep->SIG_DATA) {
 617             my $size;
 618             read( $fh, $size, $self->{data_size});
 619             $size = unpack($self->{data_pack}, $size);
 620
 621             my $value = '';
 622             if ($size) { read( $fh, $value, $size); }
 623             return $value;
 624         }
 625
 626         ##
 627         # Key exists, but content is null
 628         ##
 629         else { return; }
 630     } # i loop
 631
 632     return;
 633 }
 634
 635 sub delete_bucket {
 636     ##
 637     # Delete single key/value pair given tag and MD5 digested key.
 638     ##
 639     my $self = shift;
 640     my ($obj, $tag, $md5) = @_;
 641     my $keys = $tag->{content};
 642
 643     my $fh = $obj->_fh;
 644
 645     ##
 646     # Iterate through buckets, looking for a key match
 647     ##
 648     BUCKET:
 649     for (my $i=0; $i<$self->{max_buckets}; $i++) {
 650         my $key = substr($keys, $i * $self->{bucket_size}, $self->{hash_size});
 651 #        my $subloc = unpack($self->{long_pack}, substr($keys, ($i * $self->{bucket_size}) + $self->{hash_size}, $self->{long_size}));
 652         my $subloc = $self->_get_subloc( $keys, $i );
 653
 654         if (!$subloc) {
 655             ##
 656             # Hit end of list, no match
 657             ##
 658             return;
 659         }
 660
 661         if ( $md5 ne $key ) {
 662             next BUCKET;
 663         }
 664
 665         ##
 666         # Matched key -- delete bucket and return
 667         ##
 668         seek($fh, $tag->{offset} + ($i * $self->{bucket_size}) + $obj->_root->{file_offset}, SEEK_SET);
 669         print( $fh substr($keys, ($i+1) * $self->{bucket_size} ) );
 670         print( $fh chr(0) x $self->{bucket_size} );
 671
 672         return 1;
 673     } # i loop
 674
 675     return;
 676 }
 677
 678 sub bucket_exists {
 679     ##
 680     # Check existence of single key given tag and MD5 digested key.
 681     ##
 682     my $self = shift;
 683     my ($obj, $tag, $md5) = @_;
 684     my $keys = $tag->{content};
 685
 686     ##
 687     # Iterate through buckets, looking for a key match
 688     ##
 689     BUCKET:
 690     for (my $i=0; $i<$self->{max_buckets}; $i++) {
 691         my $key = substr($keys, $i * $self->{bucket_size}, $self->{hash_size});
 692         #my $subloc = unpack($self->{long_pack}, substr($keys, ($i * $self->{bucket_size}) + $self->{hash_size}, $self->{long_size}));
 693         my $subloc = $self->_get_subloc( $keys, $i );
 694
 695         if (!$subloc) {
 696             ##
 697             # Hit end of list, no match
 698             ##
 699             return;
 700         }
 701
 702         if ( $md5 ne $key ) {
 703             next BUCKET;
 704         }
 705
 706         ##
 707         # Matched key -- return true
 708         ##
 709         return 1;
 710     } # i loop
 711
 712     return;
 713 }
 714
 715 sub find_bucket_list {
 716     ##
 717     # Locate offset for bucket list, given digested key
 718     ##
 719     my $self = shift;
 720     my ($obj, $md5, $args) = @_;
 721     $args = {} unless $args;
 722
 723     ##
 724     # Locate offset for bucket list using digest index system
 725     ##
 726     my $tag = $self->load_tag($obj, $obj->_base_offset)
 727         or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
 728 #print $obj->_base_offset, " : $tag->{signature} : $tag->{offset} : $tag->{size}\n";
 729
 730     my $ch = 0;
 731     while ($tag->{signature} ne DBM::Deep->SIG_BLIST) {
 732         my $num = ord substr($md5, $ch, 1);
 733
 734         my $ref_loc = $tag->{offset} + ($num * $self->{long_size});
 735         $tag = $self->index_lookup( $obj, $tag, $num );
 736
 737         if (!$tag) {
 738             if ( $args->{create} ) {
 739                 my $fh = $obj->_fh;
 740                 seek($fh, $ref_loc + $obj->_root->{file_offset}, SEEK_SET);
 741                 print( $fh pack($self->{long_pack}, $obj->_root->{end}) );
 742
 743                 $tag = $self->create_tag(
 744                     $obj, $obj->_root->{end},
 745                     DBM::Deep->SIG_BLIST,
 746                     chr(0) x $self->{bucket_list_size},
 747                 );
 748
 749                 $tag->{ref_loc} = $ref_loc;
 750                 $tag->{ch} = $ch;
 751
 752                 last;
 753             }
 754             else {
 755                 return;
 756             }
 757         }
 758
 759         $tag->{ch} = $ch;
 760         $tag->{ref_loc} = $ref_loc;
 761
 762         $ch++;
 763     }
 764
 765     return $tag;
 766 }
 767
 768 sub index_lookup {
 769     ##
 770     # Given index tag, lookup single entry in index and return .
 771     ##
 772     my $self = shift;
 773     my ($obj, $tag, $index) = @_;
 774
 775     my $location = unpack(
 776         $self->{long_pack},
 777         substr(
 778             $tag->{content},
 779             $index * $self->{long_size},
 780             $self->{long_size},
 781         ),
 782     );
 783
 784     if (!$location) { return; }
 785
 786     return $self->load_tag( $obj, $location );
 787 }
 788
 789 sub traverse_index {
 790     ##
 791     # Scan index and recursively step into deeper levels, looking for next key.
 792     ##
 793     my $self = shift;
 794     my ($obj, $offset, $ch, $force_return_next) = @_;
 795
 796     my $tag = $self->load_tag($obj, $offset );
 797
 798     my $fh = $obj->_fh;
 799
 800     if ($tag->{signature} ne DBM::Deep->SIG_BLIST) {
 801         my $content = $tag->{content};
 802         my $start = $obj->{return_next} ? 0 : ord(substr($obj->{prev_md5}, $ch, 1));
 803
 804         for (my $index = $start; $index < 256; $index++) {
 805             my $subloc = unpack(
 806                 $self->{long_pack},
 807                 substr($content, $index * $self->{long_size}, $self->{long_size}),
 808             );
 809
 810             if ($subloc) {
 811                 my $result = $self->traverse_index(
 812                     $obj, $subloc, $ch + 1, $force_return_next,
 813                 );
 814
 815                 if (defined($result)) { return $result; }
 816             }
 817         } # index loop
 818
 819         $obj->{return_next} = 1;
 820     } # tag is an index
 821
 822     else {
 823         my $keys = $tag->{content};
 824         if ($force_return_next) { $obj->{return_next} = 1; }
 825
 826         ##
 827         # Iterate through buckets, looking for a key match
 828         ##
 829         for (my $i=0; $i<$self->{max_buckets}; $i++) {
 830             my $key = substr($keys, $i * $self->{bucket_size}, $self->{hash_size});
 831 #            my $subloc = unpack(
 832 #                $self->{long_pack},
 833 #                substr(
 834 #                    $keys,
 835 #                    ($i * $self->{bucket_size}) + $self->{hash_size},
 836 #                    $self->{long_size},
 837 #                ),
 838 #            );
 839             my $subloc = $self->_get_subloc( $keys, $i );
 840
 841             if (!$subloc) {
 842                 ##
 843                 # End of bucket list -- return to outer loop
 844                 ##
 845                 $obj->{return_next} = 1;
 846                 last;
 847             }
 848             elsif ($key eq $obj->{prev_md5}) {
 849                 ##
 850                 # Located previous key -- return next one found
 851                 ##
 852                 $obj->{return_next} = 1;
 853                 next;
 854             }
 855             elsif ($obj->{return_next}) {
 856                 ##
 857                 # Seek to bucket location and skip over signature
 858                 ##
 859                 seek($fh, $subloc + DBM::Deep->SIG_SIZE + $obj->_root->{file_offset}, SEEK_SET);
 860
 861                 ##
 862                 # Skip over value to get to plain key
 863                 ##
 864                 my $size;
 865                 read( $fh, $size, $self->{data_size});
 866                 $size = unpack($self->{data_pack}, $size);
 867                 if ($size) { seek($fh, $size, SEEK_CUR); }
 868
 869                 ##
 870                 # Read in plain key and return as scalar
 871                 ##
 872                 my $plain_key;
 873                 read( $fh, $size, $self->{data_size});
 874                 $size = unpack($self->{data_pack}, $size);
 875                 if ($size) { read( $fh, $plain_key, $size); }
 876
 877                 return $plain_key;
 878             }
 879         } # bucket loop
 880
 881         $obj->{return_next} = 1;
 882     } # tag is a bucket list
 883
 884     return;
 885 }
 886
 887 sub get_next_key {
 888     ##
 889     # Locate next key, given digested previous one
 890     ##
 891     my $self = shift;
 892     my ($obj) = @_;
 893
 894     $obj->{prev_md5} = $_[1] ? $_[1] : undef;
 895     $obj->{return_next} = 0;
 896
 897     ##
 898     # If the previous key was not specifed, start at the top and
 899     # return the first one found.
 900     ##
 901     if (!$obj->{prev_md5}) {
 902         $obj->{prev_md5} = chr(0) x $self->{hash_size};
 903         $obj->{return_next} = 1;
 904     }
 905
 906     return $self->traverse_index( $obj, $obj->_base_offset, 0 );
 907 }
 908
 909 # Utilities
 910
 911 sub _get_subloc {
 912     my $self = shift;
 913     my ($keys, $idx) = @_;
 914
 915     my $subloc = unpack(
 916         $self->{long_pack},
 917         substr(
 918             $keys,
 919             ($idx * $self->{bucket_size}) + $self->{hash_size},
 920             $self->{long_size},
 921         ),
 922     );
 923
 924     return $subloc;
 925 }
 926
 927 1;
 928 __END__