lib/DBM/Deep/Engine.pm

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