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