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