lib/DBM/Deep/Engine.pm

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