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