utils/lib/DBM/Deep/09830.pm

   1 package DBM::Deep::09830;
   2
   3 ##
   4 # DBM::Deep
   5 #
   6 # Description:
   7 #       Multi-level database module for storing hash trees, arrays and simple
   8 #       key/value pairs into FTP-able, cross-platform binary database files.
   9 #
  10 #       Type `perldoc DBM::Deep` for complete documentation.
  11 #
  12 # Usage Examples:
  13 #       my %db;
  14 #       tie %db, 'DBM::Deep', 'my_database.db'; # standard tie() method
  15 #
  16 #       my $db = new DBM::Deep( 'my_database.db' ); # preferred OO method
  17 #
  18 #       $db->{my_scalar} = 'hello world';
  19 #       $db->{my_hash} = { larry => 'genius', hashes => 'fast' };
  20 #       $db->{my_array} = [ 1, 2, 3, time() ];
  21 #       $db->{my_complex} = [ 'hello', { perl => 'rules' }, 42, 99 ];
  22 #       push @{$db->{my_array}}, 'another value';
  23 #       my @key_list = keys %{$db->{my_hash}};
  24 #       print "This module " . $db->{my_complex}->[1]->{perl} . "!\n";
  25 #
  26 # Copyright:
  27 #       (c) 2002-2006 Joseph Huckaby.  All Rights Reserved.
  28 #       This program is free software; you can redistribute it and/or
  29 #       modify it under the same terms as Perl itself.
  30 ##
  31
  32 use strict;
  33
  34 use Fcntl qw( :DEFAULT :flock :seek );
  35 use Digest::MD5 ();
  36 use Scalar::Util ();
  37
  38 use vars qw( $VERSION );
  39 $VERSION = q(0.983);
  40
  41 ##
  42 # Set to 4 and 'N' for 32-bit offset tags (default).  Theoretical limit of 4 GB per file.
  43 #       (Perl must be compiled with largefile support for files > 2 GB)
  44 #
  45 # Set to 8 and 'Q' for 64-bit offsets.  Theoretical limit of 16 XB per file.
  46 #       (Perl must be compiled with largefile and 64-bit long support)
  47 ##
  48 #my $LONG_SIZE = 4;
  49 #my $LONG_PACK = 'N';
  50
  51 ##
  52 # Set to 4 and 'N' for 32-bit data length prefixes.  Limit of 4 GB for each key/value.
  53 # Upgrading this is possible (see above) but probably not necessary.  If you need
  54 # more than 4 GB for a single key or value, this module is really not for you :-)
  55 ##
  56 #my $DATA_LENGTH_SIZE = 4;
  57 #my $DATA_LENGTH_PACK = 'N';
  58 our ($LONG_SIZE, $LONG_PACK, $DATA_LENGTH_SIZE, $DATA_LENGTH_PACK);
  59
  60 ##
  61 # Maximum number of buckets per list before another level of indexing is done.
  62 # Increase this value for slightly greater speed, but larger database files.
  63 # DO NOT decrease this value below 16, due to risk of recursive reindex overrun.
  64 ##
  65 my $MAX_BUCKETS = 16;
  66
  67 ##
  68 # Better not adjust anything below here, unless you're me :-)
  69 ##
  70
  71 ##
  72 # Setup digest function for keys
  73 ##
  74 our ($DIGEST_FUNC, $HASH_SIZE);
  75 #my $DIGEST_FUNC = \&Digest::MD5::md5;
  76
  77 ##
  78 # Precalculate index and bucket sizes based on values above.
  79 ##
  80 #my $HASH_SIZE = 16;
  81 my ($INDEX_SIZE, $BUCKET_SIZE, $BUCKET_LIST_SIZE);
  82
  83 set_digest();
  84 #set_pack();
  85 #_precalc_sizes();
  86
  87 ##
  88 # Setup file and tag signatures.  These should never change.
  89 ##
  90 sub SIG_FILE   () { 'DPDB' }
  91 sub SIG_HASH   () { 'H' }
  92 sub SIG_ARRAY  () { 'A' }
  93 sub SIG_NULL   () { 'N' }
  94 sub SIG_DATA   () { 'D' }
  95 sub SIG_INDEX  () { 'I' }
  96 sub SIG_BLIST  () { 'B' }
  97 sub SIG_SIZE   () {  1  }
  98
  99 ##
 100 # Setup constants for users to pass to new()
 101 ##
 102 sub TYPE_HASH   () { SIG_HASH   }
 103 sub TYPE_ARRAY  () { SIG_ARRAY  }
 104
 105 sub _get_args {
 106     my $proto = shift;
 107
 108     my $args;
 109     if (scalar(@_) > 1) {
 110         if ( @_ % 2 ) {
 111             $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] );
 112         }
 113         $args = {@_};
 114     }
 115         elsif ( ref $_[0] ) {
 116         unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) {
 117             $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] );
 118         }
 119         $args = $_[0];
 120     }
 121         else {
 122         $args = { file => shift };
 123     }
 124
 125     return $args;
 126 }
 127
 128 sub new {
 129         ##
 130         # Class constructor method for Perl OO interface.
 131         # Calls tie() and returns blessed reference to tied hash or array,
 132         # providing a hybrid OO/tie interface.
 133         ##
 134         my $class = shift;
 135         my $args = $class->_get_args( @_ );
 136
 137         ##
 138         # Check if we want a tied hash or array.
 139         ##
 140         my $self;
 141         if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
 142         $class = 'DBM::Deep::09830::Array';
 143         #require DBM::Deep::09830::Array;
 144                 tie @$self, $class, %$args;
 145         }
 146         else {
 147         $class = 'DBM::Deep::09830::Hash';
 148         #require DBM::Deep::09830::Hash;
 149                 tie %$self, $class, %$args;
 150         }
 151
 152         return bless $self, $class;
 153 }
 154
 155 sub _init {
 156     ##
 157     # Setup $self and bless into this class.
 158     ##
 159     my $class = shift;
 160     my $args = shift;
 161
 162     # These are the defaults to be optionally overridden below
 163     my $self = bless {
 164         type => TYPE_HASH,
 165         base_offset => length(SIG_FILE),
 166     }, $class;
 167
 168     foreach my $param ( keys %$self ) {
 169         next unless exists $args->{$param};
 170         $self->{$param} = delete $args->{$param}
 171     }
 172
 173     # locking implicitly enables autoflush
 174     if ($args->{locking}) { $args->{autoflush} = 1; }
 175
 176     $self->{root} = exists $args->{root}
 177         ? $args->{root}
 178         : DBM::Deep::09830::_::Root->new( $args );
 179
 180     if (!defined($self->_fh)) { $self->_open(); }
 181
 182     return $self;
 183 }
 184
 185 sub TIEHASH {
 186     shift;
 187     #require DBM::Deep::09830::Hash;
 188     return DBM::Deep::09830::Hash->TIEHASH( @_ );
 189 }
 190
 191 sub TIEARRAY {
 192     shift;
 193     #require DBM::Deep::09830::Array;
 194     return DBM::Deep::09830::Array->TIEARRAY( @_ );
 195 }
 196
 197 #XXX Unneeded now ...
 198 #sub DESTROY {
 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 = $_[0]->_get_self;
 207
 208     local($/,$\);
 209
 210         if (defined($self->_fh)) { $self->_close(); }
 211
 212     my $flags = O_RDWR | O_CREAT | O_BINARY;
 213
 214     my $fh;
 215     sysopen( $fh, $self->_root->{file}, $flags )
 216                 or $self->_throw_error( "Cannot sysopen file: " . $self->_root->{file} . ": $!" );
 217
 218     $self->_root->{fh} = $fh;
 219
 220     if ($self->_root->{autoflush}) {
 221         my $old = select $fh;
 222         $|=1;
 223         select $old;
 224     }
 225
 226     seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET);
 227
 228     my $signature;
 229     my $bytes_read = read( $fh, $signature, length(SIG_FILE));
 230
 231     ##
 232     # File is empty -- write signature and master index
 233     ##
 234     if (!$bytes_read) {
 235         seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET);
 236         print( $fh SIG_FILE);
 237         $self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE);
 238
 239         my $plain_key = "[base]";
 240         print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
 241
 242         # Flush the filehandle
 243         my $old_fh = select $fh;
 244         my $old_af = $|; $| = 1; $| = $old_af;
 245         select $old_fh;
 246
 247         my @stats = stat($fh);
 248         $self->_root->{inode} = $stats[1];
 249         $self->_root->{end} = $stats[7];
 250
 251         return 1;
 252     }
 253
 254     ##
 255     # Check signature was valid
 256     ##
 257     unless ($signature eq SIG_FILE) {
 258         $self->_close();
 259         return $self->_throw_error("Signature not found -- file is not a Deep DB");
 260     }
 261
 262         my @stats = stat($fh);
 263         $self->_root->{inode} = $stats[1];
 264     $self->_root->{end} = $stats[7];
 265
 266     ##
 267     # Get our type from master index signature
 268     ##
 269     my $tag = $self->_load_tag($self->_base_offset);
 270
 271 #XXX We probably also want to store the hash algorithm name and not assume anything
 272 #XXX The cool thing would be to allow a different hashing algorithm at every level
 273
 274     if (!$tag) {
 275         return $self->_throw_error("Corrupted file, no master index record");
 276     }
 277     if ($self->{type} ne $tag->{signature}) {
 278         return $self->_throw_error("File type mismatch");
 279     }
 280
 281     return 1;
 282 }
 283
 284 sub _close {
 285         ##
 286         # Close database fh
 287         ##
 288     my $self = $_[0]->_get_self;
 289     close $self->_root->{fh} if $self->_root->{fh};
 290     $self->_root->{fh} = undef;
 291 }
 292
 293 sub _create_tag {
 294         ##
 295         # Given offset, signature and content, create tag and write to disk
 296         ##
 297         my ($self, $offset, $sig, $content) = @_;
 298         my $size = length($content);
 299
 300     local($/,$\);
 301
 302     my $fh = $self->_fh;
 303
 304         seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET);
 305         print( $fh $sig . pack($DATA_LENGTH_PACK, $size) . $content );
 306
 307         if ($offset == $self->_root->{end}) {
 308                 $self->_root->{end} += SIG_SIZE + $DATA_LENGTH_SIZE + $size;
 309         }
 310
 311         return {
 312                 signature => $sig,
 313                 size => $size,
 314                 offset => $offset + SIG_SIZE + $DATA_LENGTH_SIZE,
 315                 content => $content
 316         };
 317 }
 318
 319 sub _load_tag {
 320         ##
 321         # Given offset, load single tag and return signature, size and data
 322         ##
 323         my $self = shift;
 324         my $offset = shift;
 325
 326     local($/,$\);
 327
 328     my $fh = $self->_fh;
 329
 330         seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET);
 331         if (eof $fh) { return undef; }
 332
 333     my $b;
 334     read( $fh, $b, SIG_SIZE + $DATA_LENGTH_SIZE );
 335     my ($sig, $size) = unpack( "A $DATA_LENGTH_PACK", $b );
 336
 337         my $buffer;
 338         read( $fh, $buffer, $size);
 339
 340         return {
 341                 signature => $sig,
 342                 size => $size,
 343                 offset => $offset + SIG_SIZE + $DATA_LENGTH_SIZE,
 344                 content => $buffer
 345         };
 346 }
 347
 348 sub _index_lookup {
 349         ##
 350         # Given index tag, lookup single entry in index and return .
 351         ##
 352         my $self = shift;
 353         my ($tag, $index) = @_;
 354
 355         my $location = unpack($LONG_PACK, substr($tag->{content}, $index * $LONG_SIZE, $LONG_SIZE) );
 356         if (!$location) { return; }
 357
 358         return $self->_load_tag( $location );
 359 }
 360
 361 sub _add_bucket {
 362         ##
 363         # Adds one key/value pair to bucket list, given offset, MD5 digest of key,
 364         # plain (undigested) key and value.
 365         ##
 366         my $self = shift;
 367         my ($tag, $md5, $plain_key, $value) = @_;
 368         my $keys = $tag->{content};
 369         my $location = 0;
 370         my $result = 2;
 371
 372     local($/,$\);
 373
 374     # This verifies that only supported values will be stored.
 375     {
 376         my $r = Scalar::Util::reftype( $value );
 377         last if !defined $r;
 378
 379         last if $r eq 'HASH';
 380         last if $r eq 'ARRAY';
 381
 382         $self->_throw_error(
 383             "Storage of variables of type '$r' is not supported."
 384         );
 385     }
 386
 387     my $root = $self->_root;
 388
 389     my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep::09830' ) };
 390         my $internal_ref = $is_dbm_deep && ($value->_root eq $root);
 391
 392     my $fh = $self->_fh;
 393
 394         ##
 395         # Iterate through buckets, seeing if this is a new entry or a replace.
 396         ##
 397         for (my $i=0; $i<$MAX_BUCKETS; $i++) {
 398                 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
 399                 if (!$subloc) {
 400                         ##
 401                         # Found empty bucket (end of list).  Populate and exit loop.
 402                         ##
 403                         $result = 2;
 404
 405             $location = $internal_ref
 406                 ? $value->_base_offset
 407                 : $root->{end};
 408
 409                         seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
 410                         print( $fh $md5 . pack($LONG_PACK, $location) );
 411                         last;
 412                 }
 413
 414                 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
 415                 if ($md5 eq $key) {
 416                         ##
 417                         # Found existing bucket with same key.  Replace with new value.
 418                         ##
 419                         $result = 1;
 420
 421                         if ($internal_ref) {
 422                                 $location = $value->_base_offset;
 423                                 seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
 424                                 print( $fh $md5 . pack($LONG_PACK, $location) );
 425                 return $result;
 426                         }
 427
 428             seek($fh, $subloc + SIG_SIZE + $root->{file_offset}, SEEK_SET);
 429             my $size;
 430             read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
 431
 432             ##
 433             # If value is a hash, array, or raw value with equal or less size, we can
 434             # reuse the same content area of the database.  Otherwise, we have to create
 435             # a new content area at the EOF.
 436             ##
 437             my $actual_length;
 438             my $r = Scalar::Util::reftype( $value ) || '';
 439             if ( $r eq 'HASH' || $r eq 'ARRAY' ) {
 440                 $actual_length = $INDEX_SIZE;
 441
 442                 # if autobless is enabled, must also take into consideration
 443                 # the class name, as it is stored along with key/value.
 444                 if ( $root->{autobless} ) {
 445                     my $value_class = Scalar::Util::blessed($value);
 446                     if ( defined $value_class && !$value->isa('DBM::Deep::09830') ) {
 447                         $actual_length += length($value_class);
 448                     }
 449                 }
 450             }
 451             else { $actual_length = length($value); }
 452
 453             if ($actual_length <= ($size || 0)) {
 454                 $location = $subloc;
 455             }
 456             else {
 457                 $location = $root->{end};
 458                 seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE + $root->{file_offset}, SEEK_SET);
 459                 print( $fh pack($LONG_PACK, $location) );
 460             }
 461
 462                         last;
 463                 }
 464         }
 465
 466         ##
 467         # If this is an internal reference, return now.
 468         # No need to write value or plain key
 469         ##
 470         if ($internal_ref) {
 471         return $result;
 472     }
 473
 474         ##
 475         # If bucket didn't fit into list, split into a new index level
 476         ##
 477         if (!$location) {
 478                 seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET);
 479                 print( $fh pack($LONG_PACK, $root->{end}) );
 480
 481                 my $index_tag = $self->_create_tag($root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE);
 482                 my @offsets = ();
 483
 484                 $keys .= $md5 . pack($LONG_PACK, 0);
 485
 486                 for (my $i=0; $i<=$MAX_BUCKETS; $i++) {
 487                         my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
 488                         if ($key) {
 489                                 my $old_subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
 490                                 my $num = ord(substr($key, $tag->{ch} + 1, 1));
 491
 492                                 if ($offsets[$num]) {
 493                                         my $offset = $offsets[$num] + SIG_SIZE + $DATA_LENGTH_SIZE;
 494                                         seek($fh, $offset + $root->{file_offset}, SEEK_SET);
 495                                         my $subkeys;
 496                                         read( $fh, $subkeys, $BUCKET_LIST_SIZE);
 497
 498                                         for (my $k=0; $k<$MAX_BUCKETS; $k++) {
 499                                                 my $subloc = unpack($LONG_PACK, substr($subkeys, ($k * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
 500                                                 if (!$subloc) {
 501                                                         seek($fh, $offset + ($k * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
 502                                                         print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) );
 503                                                         last;
 504                                                 }
 505                                         } # k loop
 506                                 }
 507                                 else {
 508                                         $offsets[$num] = $root->{end};
 509                                         seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE) + $root->{file_offset}, SEEK_SET);
 510                                         print( $fh pack($LONG_PACK, $root->{end}) );
 511
 512                                         my $blist_tag = $self->_create_tag($root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
 513
 514                                         seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET);
 515                                         print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) );
 516                                 }
 517                         } # key is real
 518                 } # i loop
 519
 520                 $location ||= $root->{end};
 521         } # re-index bucket list
 522
 523         ##
 524         # Seek to content area and store signature, value and plaintext key
 525         ##
 526         if ($location) {
 527                 my $content_length;
 528                 seek($fh, $location + $root->{file_offset}, SEEK_SET);
 529
 530                 ##
 531                 # Write signature based on content type, set content length and write actual value.
 532                 ##
 533         my $r = Scalar::Util::reftype($value) || '';
 534                 if ($r eq 'HASH') {
 535             if ( !$internal_ref && tied %{$value} ) {
 536                 return $self->_throw_error("Cannot store a tied value");
 537             }
 538                         print( $fh TYPE_HASH );
 539                         print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
 540                         $content_length = $INDEX_SIZE;
 541                 }
 542                 elsif ($r eq 'ARRAY') {
 543             if ( !$internal_ref && tied @{$value} ) {
 544                 return $self->_throw_error("Cannot store a tied value");
 545             }
 546                         print( $fh TYPE_ARRAY );
 547                         print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
 548                         $content_length = $INDEX_SIZE;
 549                 }
 550                 elsif (!defined($value)) {
 551                         print( $fh SIG_NULL );
 552                         print( $fh pack($DATA_LENGTH_PACK, 0) );
 553                         $content_length = 0;
 554                 }
 555                 else {
 556                         print( $fh SIG_DATA );
 557                         print( $fh pack($DATA_LENGTH_PACK, length($value)) . $value );
 558                         $content_length = length($value);
 559                 }
 560
 561                 ##
 562                 # Plain key is stored AFTER value, as keys are typically fetched less often.
 563                 ##
 564                 print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
 565
 566                 ##
 567                 # If value is blessed, preserve class name
 568                 ##
 569                 if ( $root->{autobless} ) {
 570             my $value_class = Scalar::Util::blessed($value);
 571             if ( defined $value_class && $value_class ne 'DBM::Deep::09830' ) {
 572                 ##
 573                 # Blessed ref -- will restore later
 574                 ##
 575                 print( $fh chr(1) );
 576                 print( $fh pack($DATA_LENGTH_PACK, length($value_class)) . $value_class );
 577                 $content_length += 1;
 578                 $content_length += $DATA_LENGTH_SIZE + length($value_class);
 579             }
 580             else {
 581                 print( $fh chr(0) );
 582                 $content_length += 1;
 583             }
 584         }
 585
 586                 ##
 587                 # If this is a new content area, advance EOF counter
 588                 ##
 589                 if ($location == $root->{end}) {
 590                         $root->{end} += SIG_SIZE;
 591                         $root->{end} += $DATA_LENGTH_SIZE + $content_length;
 592                         $root->{end} += $DATA_LENGTH_SIZE + length($plain_key);
 593                 }
 594
 595                 ##
 596                 # If content is a hash or array, create new child DBM::Deep object and
 597                 # pass each key or element to it.
 598                 ##
 599                 if ($r eq 'HASH') {
 600             my %x = %$value;
 601             tie %$value, 'DBM::Deep::09830', {
 602                                 type => TYPE_HASH,
 603                                 base_offset => $location,
 604                                 root => $root,
 605                         };
 606             %$value = %x;
 607                 }
 608                 elsif ($r eq 'ARRAY') {
 609             my @x = @$value;
 610             tie @$value, 'DBM::Deep::09830', {
 611                                 type => TYPE_ARRAY,
 612                                 base_offset => $location,
 613                                 root => $root,
 614                         };
 615             @$value = @x;
 616                 }
 617
 618                 return $result;
 619         }
 620
 621         return $self->_throw_error("Fatal error: indexing failed -- possibly due to corruption in file");
 622 }
 623
 624 sub _get_bucket_value {
 625         ##
 626         # Fetch single value given tag and MD5 digested key.
 627         ##
 628         my $self = shift;
 629         my ($tag, $md5) = @_;
 630         my $keys = $tag->{content};
 631
 632     local($/,$\);
 633
 634     my $fh = $self->_fh;
 635
 636         ##
 637         # Iterate through buckets, looking for a key match
 638         ##
 639     BUCKET:
 640         for (my $i=0; $i<$MAX_BUCKETS; $i++) {
 641                 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
 642                 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
 643
 644                 if (!$subloc) {
 645                         ##
 646                         # Hit end of list, no match
 647                         ##
 648                         return;
 649                 }
 650
 651         if ( $md5 ne $key ) {
 652             next BUCKET;
 653         }
 654
 655         ##
 656         # Found match -- seek to offset and read signature
 657         ##
 658         my $signature;
 659         seek($fh, $subloc + $self->_root->{file_offset}, SEEK_SET);
 660         read( $fh, $signature, SIG_SIZE);
 661
 662         ##
 663         # If value is a hash or array, return new DBM::Deep object with correct offset
 664         ##
 665         if (($signature eq TYPE_HASH) || ($signature eq TYPE_ARRAY)) {
 666             my $obj = DBM::Deep::09830->new(
 667                 type => $signature,
 668                 base_offset => $subloc,
 669                 root => $self->_root
 670             );
 671
 672             if ($self->_root->{autobless}) {
 673                 ##
 674                 # Skip over value and plain key to see if object needs
 675                 # to be re-blessed
 676                 ##
 677                 seek($fh, $DATA_LENGTH_SIZE + $INDEX_SIZE, SEEK_CUR);
 678
 679                 my $size;
 680                 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
 681                 if ($size) { seek($fh, $size, SEEK_CUR); }
 682
 683                 my $bless_bit;
 684                 read( $fh, $bless_bit, 1);
 685                 if (ord($bless_bit)) {
 686                     ##
 687                     # Yes, object needs to be re-blessed
 688                     ##
 689                     my $class_name;
 690                     read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
 691                     if ($size) { read( $fh, $class_name, $size); }
 692                     if ($class_name) { $obj = bless( $obj, $class_name ); }
 693                 }
 694             }
 695
 696             return $obj;
 697         }
 698
 699         ##
 700         # Otherwise return actual value
 701         ##
 702         elsif ($signature eq SIG_DATA) {
 703             my $size;
 704             my $value = '';
 705             read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
 706             if ($size) { read( $fh, $value, $size); }
 707             return $value;
 708         }
 709
 710         ##
 711         # Key exists, but content is null
 712         ##
 713         else { return; }
 714         } # i loop
 715
 716         return;
 717 }
 718
 719 sub _delete_bucket {
 720         ##
 721         # Delete single key/value pair given tag and MD5 digested key.
 722         ##
 723         my $self = shift;
 724         my ($tag, $md5) = @_;
 725         my $keys = $tag->{content};
 726
 727     local($/,$\);
 728
 729     my $fh = $self->_fh;
 730
 731         ##
 732         # Iterate through buckets, looking for a key match
 733         ##
 734     BUCKET:
 735         for (my $i=0; $i<$MAX_BUCKETS; $i++) {
 736                 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
 737                 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
 738
 739                 if (!$subloc) {
 740                         ##
 741                         # Hit end of list, no match
 742                         ##
 743                         return;
 744                 }
 745
 746         if ( $md5 ne $key ) {
 747             next BUCKET;
 748         }
 749
 750         ##
 751         # Matched key -- delete bucket and return
 752         ##
 753         seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $self->_root->{file_offset}, SEEK_SET);
 754         print( $fh substr($keys, ($i+1) * $BUCKET_SIZE ) );
 755         print( $fh chr(0) x $BUCKET_SIZE );
 756
 757         return 1;
 758         } # i loop
 759
 760         return;
 761 }
 762
 763 sub _bucket_exists {
 764         ##
 765         # Check existence of single key given tag and MD5 digested key.
 766         ##
 767         my $self = shift;
 768         my ($tag, $md5) = @_;
 769         my $keys = $tag->{content};
 770
 771         ##
 772         # Iterate through buckets, looking for a key match
 773         ##
 774     BUCKET:
 775         for (my $i=0; $i<$MAX_BUCKETS; $i++) {
 776                 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
 777                 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
 778
 779                 if (!$subloc) {
 780                         ##
 781                         # Hit end of list, no match
 782                         ##
 783                         return;
 784                 }
 785
 786         if ( $md5 ne $key ) {
 787             next BUCKET;
 788         }
 789
 790         ##
 791         # Matched key -- return true
 792         ##
 793         return 1;
 794         } # i loop
 795
 796         return;
 797 }
 798
 799 sub _find_bucket_list {
 800         ##
 801         # Locate offset for bucket list, given digested key
 802         ##
 803         my $self = shift;
 804         my $md5 = shift;
 805
 806         ##
 807         # Locate offset for bucket list using digest index system
 808         ##
 809         my $ch = 0;
 810         my $tag = $self->_load_tag($self->_base_offset);
 811         if (!$tag) { return; }
 812
 813         while ($tag->{signature} ne SIG_BLIST) {
 814                 $tag = $self->_index_lookup($tag, ord(substr($md5, $ch, 1)));
 815                 if (!$tag) { return; }
 816                 $ch++;
 817         }
 818
 819         return $tag;
 820 }
 821
 822 sub _traverse_index {
 823         ##
 824         # Scan index and recursively step into deeper levels, looking for next key.
 825         ##
 826     my ($self, $offset, $ch, $force_return_next) = @_;
 827     $force_return_next = undef unless $force_return_next;
 828
 829     local($/,$\);
 830
 831         my $tag = $self->_load_tag( $offset );
 832
 833     my $fh = $self->_fh;
 834
 835         if ($tag->{signature} ne SIG_BLIST) {
 836                 my $content = $tag->{content};
 837                 my $start;
 838                 if ($self->{return_next}) { $start = 0; }
 839                 else { $start = ord(substr($self->{prev_md5}, $ch, 1)); }
 840
 841                 for (my $index = $start; $index < 256; $index++) {
 842                         my $subloc = unpack($LONG_PACK, substr($content, $index * $LONG_SIZE, $LONG_SIZE) );
 843                         if ($subloc) {
 844                                 my $result = $self->_traverse_index( $subloc, $ch + 1, $force_return_next );
 845                                 if (defined($result)) { return $result; }
 846                         }
 847                 } # index loop
 848
 849                 $self->{return_next} = 1;
 850         } # tag is an index
 851
 852         elsif ($tag->{signature} eq SIG_BLIST) {
 853                 my $keys = $tag->{content};
 854                 if ($force_return_next) { $self->{return_next} = 1; }
 855
 856                 ##
 857                 # Iterate through buckets, looking for a key match
 858                 ##
 859                 for (my $i=0; $i<$MAX_BUCKETS; $i++) {
 860                         my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
 861                         my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
 862
 863                         if (!$subloc) {
 864                                 ##
 865                                 # End of bucket list -- return to outer loop
 866                                 ##
 867                                 $self->{return_next} = 1;
 868                                 last;
 869                         }
 870                         elsif ($key eq $self->{prev_md5}) {
 871                                 ##
 872                                 # Located previous key -- return next one found
 873                                 ##
 874                                 $self->{return_next} = 1;
 875                                 next;
 876                         }
 877                         elsif ($self->{return_next}) {
 878                                 ##
 879                                 # Seek to bucket location and skip over signature
 880                                 ##
 881                                 seek($fh, $subloc + SIG_SIZE + $self->_root->{file_offset}, SEEK_SET);
 882
 883                                 ##
 884                                 # Skip over value to get to plain key
 885                                 ##
 886                                 my $size;
 887                                 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
 888                                 if ($size) { seek($fh, $size, SEEK_CUR); }
 889
 890                                 ##
 891                                 # Read in plain key and return as scalar
 892                                 ##
 893                                 my $plain_key;
 894                                 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
 895                                 if ($size) { read( $fh, $plain_key, $size); }
 896
 897                                 return $plain_key;
 898                         }
 899                 } # bucket loop
 900
 901                 $self->{return_next} = 1;
 902         } # tag is a bucket list
 903
 904         return;
 905 }
 906
 907 sub _get_next_key {
 908         ##
 909         # Locate next key, given digested previous one
 910         ##
 911     my $self = $_[0]->_get_self;
 912
 913         $self->{prev_md5} = $_[1] ? $_[1] : undef;
 914         $self->{return_next} = 0;
 915
 916         ##
 917         # If the previous key was not specifed, start at the top and
 918         # return the first one found.
 919         ##
 920         if (!$self->{prev_md5}) {
 921                 $self->{prev_md5} = chr(0) x $HASH_SIZE;
 922                 $self->{return_next} = 1;
 923         }
 924
 925         return $self->_traverse_index( $self->_base_offset, 0 );
 926 }
 927
 928 sub lock {
 929         ##
 930         # If db locking is set, flock() the db file.  If called multiple
 931         # times before unlock(), then the same number of unlocks() must
 932         # be called before the lock is released.
 933         ##
 934     my $self = $_[0]->_get_self;
 935         my $type = $_[1];
 936     $type = LOCK_EX unless defined $type;
 937
 938         if (!defined($self->_fh)) { return; }
 939
 940         if ($self->_root->{locking}) {
 941                 if (!$self->_root->{locked}) {
 942                         flock($self->_fh, $type);
 943
 944                         # refresh end counter in case file has changed size
 945                         my @stats = stat($self->_root->{file});
 946                         $self->_root->{end} = $stats[7];
 947
 948                         # double-check file inode, in case another process
 949                         # has optimize()d our file while we were waiting.
 950                         if ($stats[1] != $self->_root->{inode}) {
 951                                 $self->_open(); # re-open
 952                                 flock($self->_fh, $type); # re-lock
 953                                 $self->_root->{end} = (stat($self->_fh))[7]; # re-end
 954                         }
 955                 }
 956                 $self->_root->{locked}++;
 957
 958         return 1;
 959         }
 960
 961     return;
 962 }
 963
 964 sub unlock {
 965         ##
 966         # If db locking is set, unlock the db file.  See note in lock()
 967         # regarding calling lock() multiple times.
 968         ##
 969     my $self = $_[0]->_get_self;
 970
 971         if (!defined($self->_fh)) { return; }
 972
 973         if ($self->_root->{locking} && $self->_root->{locked} > 0) {
 974                 $self->_root->{locked}--;
 975                 if (!$self->_root->{locked}) { flock($self->_fh, LOCK_UN); }
 976
 977         return 1;
 978         }
 979
 980     return;
 981 }
 982
 983 sub _copy_value {
 984     my $self = shift->_get_self;
 985     my ($spot, $value) = @_;
 986
 987     if ( !ref $value ) {
 988         ${$spot} = $value;
 989     }
 990     elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep::09830' ) } ) {
 991         my $type = $value->_type;
 992         ${$spot} = $type eq TYPE_HASH ? {} : [];
 993         $value->_copy_node( ${$spot} );
 994     }
 995     else {
 996         my $r = Scalar::Util::reftype( $value );
 997         my $c = Scalar::Util::blessed( $value );
 998         if ( $r eq 'ARRAY' ) {
 999             ${$spot} = [ @{$value} ];
1000         }
1001         else {
1002             ${$spot} = { %{$value} };
1003         }
1004         ${$spot} = bless ${$spot}, $c
1005             if defined $c;
1006     }
1007
1008     return 1;
1009 }
1010
1011 sub _copy_node {
1012         ##
1013         # Copy single level of keys or elements to new DB handle.
1014         # Recurse for nested structures
1015         ##
1016     my $self = shift->_get_self;
1017         my ($db_temp) = @_;
1018
1019         if ($self->_type eq TYPE_HASH) {
1020                 my $key = $self->first_key();
1021                 while ($key) {
1022                         my $value = $self->get($key);
1023             $self->_copy_value( \$db_temp->{$key}, $value );
1024                         $key = $self->next_key($key);
1025                 }
1026         }
1027         else {
1028                 my $length = $self->length();
1029                 for (my $index = 0; $index < $length; $index++) {
1030                         my $value = $self->get($index);
1031             $self->_copy_value( \$db_temp->[$index], $value );
1032                 }
1033         }
1034
1035     return 1;
1036 }
1037
1038 sub export {
1039         ##
1040         # Recursively export into standard Perl hashes and arrays.
1041         ##
1042     my $self = $_[0]->_get_self;
1043
1044         my $temp;
1045         if ($self->_type eq TYPE_HASH) { $temp = {}; }
1046         elsif ($self->_type eq TYPE_ARRAY) { $temp = []; }
1047
1048         $self->lock();
1049         $self->_copy_node( $temp );
1050         $self->unlock();
1051
1052         return $temp;
1053 }
1054
1055 sub import {
1056         ##
1057         # Recursively import Perl hash/array structure
1058         ##
1059     #XXX This use of ref() seems to be ok
1060         if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
1061
1062     my $self = $_[0]->_get_self;
1063         my $struct = $_[1];
1064
1065     #XXX This use of ref() seems to be ok
1066         if (!ref($struct)) {
1067                 ##
1068                 # struct is not a reference, so just import based on our type
1069                 ##
1070                 shift @_;
1071
1072                 if ($self->_type eq TYPE_HASH) { $struct = {@_}; }
1073                 elsif ($self->_type eq TYPE_ARRAY) { $struct = [@_]; }
1074         }
1075
1076     my $r = Scalar::Util::reftype($struct) || '';
1077         if ($r eq "HASH" && $self->_type eq TYPE_HASH) {
1078                 foreach my $key (keys %$struct) { $self->put($key, $struct->{$key}); }
1079         }
1080         elsif ($r eq "ARRAY" && $self->_type eq TYPE_ARRAY) {
1081                 $self->push( @$struct );
1082         }
1083         else {
1084                 return $self->_throw_error("Cannot import: type mismatch");
1085         }
1086
1087         return 1;
1088 }
1089
1090 sub optimize {
1091         ##
1092         # Rebuild entire database into new file, then move
1093         # it back on top of original.
1094         ##
1095     my $self = $_[0]->_get_self;
1096
1097 #XXX Need to create a new test for this
1098 #       if ($self->_root->{links} > 1) {
1099 #               return $self->_throw_error("Cannot optimize: reference count is greater than 1");
1100 #       }
1101
1102         my $db_temp = DBM::Deep::09830->new(
1103                 file => $self->_root->{file} . '.tmp',
1104                 type => $self->_type
1105         );
1106         if (!$db_temp) {
1107                 return $self->_throw_error("Cannot optimize: failed to open temp file: $!");
1108         }
1109
1110         $self->lock();
1111         $self->_copy_node( $db_temp );
1112         undef $db_temp;
1113
1114         ##
1115         # Attempt to copy user, group and permissions over to new file
1116         ##
1117         my @stats = stat($self->_fh);
1118         my $perms = $stats[2] & 07777;
1119         my $uid = $stats[4];
1120         my $gid = $stats[5];
1121         chown( $uid, $gid, $self->_root->{file} . '.tmp' );
1122         chmod( $perms, $self->_root->{file} . '.tmp' );
1123
1124     # q.v. perlport for more information on this variable
1125     if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
1126                 ##
1127                 # Potential race condition when optmizing on Win32 with locking.
1128                 # The Windows filesystem requires that the filehandle be closed
1129                 # before it is overwritten with rename().  This could be redone
1130                 # with a soft copy.
1131                 ##
1132                 $self->unlock();
1133                 $self->_close();
1134         }
1135
1136         if (!rename $self->_root->{file} . '.tmp', $self->_root->{file}) {
1137                 unlink $self->_root->{file} . '.tmp';
1138                 $self->unlock();
1139                 return $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
1140         }
1141
1142         $self->unlock();
1143         $self->_close();
1144         $self->_open();
1145
1146         return 1;
1147 }
1148
1149 sub clone {
1150         ##
1151         # Make copy of object and return
1152         ##
1153     my $self = $_[0]->_get_self;
1154
1155         return DBM::Deep::09830->new(
1156                 type => $self->_type,
1157                 base_offset => $self->_base_offset,
1158                 root => $self->_root
1159         );
1160 }
1161
1162 {
1163     my %is_legal_filter = map {
1164         $_ => ~~1,
1165     } qw(
1166         store_key store_value
1167         fetch_key fetch_value
1168     );
1169
1170     sub set_filter {
1171         ##
1172         # Setup filter function for storing or fetching the key or value
1173         ##
1174         my $self = $_[0]->_get_self;
1175         my $type = lc $_[1];
1176         my $func = $_[2] ? $_[2] : undef;
1177
1178         if ( $is_legal_filter{$type} ) {
1179             $self->_root->{"filter_$type"} = $func;
1180             return 1;
1181         }
1182
1183         return;
1184     }
1185 }
1186
1187 ##
1188 # Accessor methods
1189 ##
1190
1191 sub _root {
1192         ##
1193         # Get access to the root structure
1194         ##
1195     my $self = $_[0]->_get_self;
1196         return $self->{root};
1197 }
1198
1199 sub _fh {
1200         ##
1201         # Get access to the raw fh
1202         ##
1203     #XXX It will be useful, though, when we split out HASH and ARRAY
1204     my $self = $_[0]->_get_self;
1205         return $self->_root->{fh};
1206 }
1207
1208 sub _type {
1209         ##
1210         # Get type of current node (TYPE_HASH or TYPE_ARRAY)
1211         ##
1212     my $self = $_[0]->_get_self;
1213         return $self->{type};
1214 }
1215
1216 sub _base_offset {
1217         ##
1218         # Get base_offset of current node (TYPE_HASH or TYPE_ARRAY)
1219         ##
1220     my $self = $_[0]->_get_self;
1221         return $self->{base_offset};
1222 }
1223
1224 sub error {
1225         ##
1226         # Get last error string, or undef if no error
1227         ##
1228         return $_[0]
1229         ? ( $_[0]->_get_self->{root}->{error} or undef )
1230         : $@;
1231 }
1232
1233 ##
1234 # Utility methods
1235 ##
1236
1237 sub _throw_error {
1238         ##
1239         # Store error string in self
1240         ##
1241         my $error_text = $_[1];
1242
1243     if ( Scalar::Util::blessed $_[0] ) {
1244         my $self = $_[0]->_get_self;
1245         $self->_root->{error} = $error_text;
1246
1247         unless ($self->_root->{debug}) {
1248             die "DBM::Deep::09830: $error_text\n";
1249         }
1250
1251         warn "DBM::Deep::09830: $error_text\n";
1252         return;
1253     }
1254     else {
1255         die "DBM::Deep::09830: $error_text\n";
1256     }
1257 }
1258
1259 sub clear_error {
1260         ##
1261         # Clear error state
1262         ##
1263     my $self = $_[0]->_get_self;
1264
1265         undef $self->_root->{error};
1266 }
1267
1268 sub _precalc_sizes {
1269         ##
1270         # Precalculate index, bucket and bucket list sizes
1271         ##
1272
1273     #XXX I don't like this ...
1274     set_pack() unless defined $LONG_SIZE;
1275
1276         $INDEX_SIZE = 256 * $LONG_SIZE;
1277         $BUCKET_SIZE = $HASH_SIZE + $LONG_SIZE;
1278         $BUCKET_LIST_SIZE = $MAX_BUCKETS * $BUCKET_SIZE;
1279 }
1280
1281 sub set_pack {
1282         ##
1283         # Set pack/unpack modes (see file header for more)
1284         ##
1285     my ($long_s, $long_p, $data_s, $data_p) = @_;
1286
1287     $LONG_SIZE = $long_s ? $long_s : 4;
1288     $LONG_PACK = $long_p ? $long_p : 'N';
1289
1290     $DATA_LENGTH_SIZE = $data_s ? $data_s : 4;
1291     $DATA_LENGTH_PACK = $data_p ? $data_p : 'N';
1292
1293         _precalc_sizes();
1294 }
1295
1296 sub set_digest {
1297         ##
1298         # Set key digest function (default is MD5)
1299         ##
1300     my ($digest_func, $hash_size) = @_;
1301
1302     $DIGEST_FUNC = $digest_func ? $digest_func : \&Digest::MD5::md5;
1303     $HASH_SIZE = $hash_size ? $hash_size : 16;
1304
1305         _precalc_sizes();
1306 }
1307
1308 sub _is_writable {
1309     my $fh = shift;
1310     (O_WRONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
1311 }
1312
1313 #sub _is_readable {
1314 #    my $fh = shift;
1315 #    (O_RDONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
1316 #}
1317
1318 ##
1319 # tie() methods (hashes and arrays)
1320 ##
1321
1322 sub STORE {
1323         ##
1324         # Store single hash key/value or array element in database.
1325         ##
1326     my $self = $_[0]->_get_self;
1327         my $key = $_[1];
1328
1329     local($/,$\);
1330
1331     # User may be storing a hash, in which case we do not want it run
1332     # through the filtering system
1333         my $value = ($self->_root->{filter_store_value} && !ref($_[2]))
1334         ? $self->_root->{filter_store_value}->($_[2])
1335         : $_[2];
1336
1337         my $md5 = $DIGEST_FUNC->($key);
1338
1339         ##
1340         # Make sure file is open
1341         ##
1342         if (!defined($self->_fh) && !$self->_open()) {
1343                 return;
1344         }
1345
1346     if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
1347         $self->_throw_error( 'Cannot write to a readonly filehandle' );
1348     }
1349
1350         ##
1351         # Request exclusive lock for writing
1352         ##
1353         $self->lock( LOCK_EX );
1354
1355         my $fh = $self->_fh;
1356
1357         ##
1358         # Locate offset for bucket list using digest index system
1359         ##
1360         my $tag = $self->_load_tag($self->_base_offset);
1361         if (!$tag) {
1362                 $tag = $self->_create_tag($self->_base_offset, SIG_INDEX, chr(0) x $INDEX_SIZE);
1363         }
1364
1365         my $ch = 0;
1366         while ($tag->{signature} ne SIG_BLIST) {
1367                 my $num = ord(substr($md5, $ch, 1));
1368
1369         my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
1370                 my $new_tag = $self->_index_lookup($tag, $num);
1371
1372                 if (!$new_tag) {
1373                         seek($fh, $ref_loc + $self->_root->{file_offset}, SEEK_SET);
1374                         print( $fh pack($LONG_PACK, $self->_root->{end}) );
1375
1376                         $tag = $self->_create_tag($self->_root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
1377
1378                         $tag->{ref_loc} = $ref_loc;
1379                         $tag->{ch} = $ch;
1380
1381                         last;
1382                 }
1383                 else {
1384                         $tag = $new_tag;
1385
1386                         $tag->{ref_loc} = $ref_loc;
1387                         $tag->{ch} = $ch;
1388                 }
1389                 $ch++;
1390         }
1391
1392         ##
1393         # Add key/value to bucket list
1394         ##
1395         my $result = $self->_add_bucket( $tag, $md5, $key, $value );
1396
1397         $self->unlock();
1398
1399         return $result;
1400 }
1401
1402 sub FETCH {
1403         ##
1404         # Fetch single value or element given plain key or array index
1405         ##
1406     my $self = shift->_get_self;
1407     my $key = shift;
1408
1409         ##
1410         # Make sure file is open
1411         ##
1412         if (!defined($self->_fh)) { $self->_open(); }
1413
1414         my $md5 = $DIGEST_FUNC->($key);
1415
1416         ##
1417         # Request shared lock for reading
1418         ##
1419         $self->lock( LOCK_SH );
1420
1421         my $tag = $self->_find_bucket_list( $md5 );
1422         if (!$tag) {
1423                 $self->unlock();
1424                 return;
1425         }
1426
1427         ##
1428         # Get value from bucket list
1429         ##
1430         my $result = $self->_get_bucket_value( $tag, $md5 );
1431
1432         $self->unlock();
1433
1434     #XXX What is ref() checking here?
1435     #YYY Filters only apply on scalar values, so the ref check is making
1436     #YYY sure the fetched bucket is a scalar, not a child hash or array.
1437         return ($result && !ref($result) && $self->_root->{filter_fetch_value})
1438         ? $self->_root->{filter_fetch_value}->($result)
1439         : $result;
1440 }
1441
1442 sub DELETE {
1443         ##
1444         # Delete single key/value pair or element given plain key or array index
1445         ##
1446     my $self = $_[0]->_get_self;
1447         my $key = $_[1];
1448
1449         my $md5 = $DIGEST_FUNC->($key);
1450
1451         ##
1452         # Make sure file is open
1453         ##
1454         if (!defined($self->_fh)) { $self->_open(); }
1455
1456         ##
1457         # Request exclusive lock for writing
1458         ##
1459         $self->lock( LOCK_EX );
1460
1461         my $tag = $self->_find_bucket_list( $md5 );
1462         if (!$tag) {
1463                 $self->unlock();
1464                 return;
1465         }
1466
1467         ##
1468         # Delete bucket
1469         ##
1470     my $value = $self->_get_bucket_value( $tag, $md5 );
1471         if ($value && !ref($value) && $self->_root->{filter_fetch_value}) {
1472         $value = $self->_root->{filter_fetch_value}->($value);
1473     }
1474
1475         my $result = $self->_delete_bucket( $tag, $md5 );
1476
1477         ##
1478         # If this object is an array and the key deleted was on the end of the stack,
1479         # decrement the length variable.
1480         ##
1481
1482         $self->unlock();
1483
1484         return $value;
1485 }
1486
1487 sub EXISTS {
1488         ##
1489         # Check if a single key or element exists given plain key or array index
1490         ##
1491     my $self = $_[0]->_get_self;
1492         my $key = $_[1];
1493
1494         my $md5 = $DIGEST_FUNC->($key);
1495
1496         ##
1497         # Make sure file is open
1498         ##
1499         if (!defined($self->_fh)) { $self->_open(); }
1500
1501         ##
1502         # Request shared lock for reading
1503         ##
1504         $self->lock( LOCK_SH );
1505
1506         my $tag = $self->_find_bucket_list( $md5 );
1507
1508         ##
1509         # For some reason, the built-in exists() function returns '' for false
1510         ##
1511         if (!$tag) {
1512                 $self->unlock();
1513                 return '';
1514         }
1515
1516         ##
1517         # Check if bucket exists and return 1 or ''
1518         ##
1519         my $result = $self->_bucket_exists( $tag, $md5 ) || '';
1520
1521         $self->unlock();
1522
1523         return $result;
1524 }
1525
1526 sub CLEAR {
1527         ##
1528         # Clear all keys from hash, or all elements from array.
1529         ##
1530     my $self = $_[0]->_get_self;
1531
1532         ##
1533         # Make sure file is open
1534         ##
1535         if (!defined($self->_fh)) { $self->_open(); }
1536
1537         ##
1538         # Request exclusive lock for writing
1539         ##
1540         $self->lock( LOCK_EX );
1541
1542     my $fh = $self->_fh;
1543
1544         seek($fh, $self->_base_offset + $self->_root->{file_offset}, SEEK_SET);
1545         if (eof $fh) {
1546                 $self->unlock();
1547                 return;
1548         }
1549
1550         $self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE);
1551
1552         $self->unlock();
1553
1554         return 1;
1555 }
1556
1557 ##
1558 # Public method aliases
1559 ##
1560 sub put { (shift)->STORE( @_ ) }
1561 sub store { (shift)->STORE( @_ ) }
1562 sub get { (shift)->FETCH( @_ ) }
1563 sub fetch { (shift)->FETCH( @_ ) }
1564 sub delete { (shift)->DELETE( @_ ) }
1565 sub exists { (shift)->EXISTS( @_ ) }
1566 sub clear { (shift)->CLEAR( @_ ) }
1567
1568 package DBM::Deep::09830::_::Root;
1569
1570 sub new {
1571     my $class = shift;
1572     my ($args) = @_;
1573
1574     my $self = bless {
1575         file => undef,
1576         fh => undef,
1577         file_offset => 0,
1578         end => 0,
1579         autoflush => undef,
1580         locking => undef,
1581         debug => undef,
1582         filter_store_key => undef,
1583         filter_store_value => undef,
1584         filter_fetch_key => undef,
1585         filter_fetch_value => undef,
1586         autobless => undef,
1587         locked => 0,
1588         %$args,
1589     }, $class;
1590
1591     if ( $self->{fh} && !$self->{file_offset} ) {
1592         $self->{file_offset} = tell( $self->{fh} );
1593     }
1594
1595     return $self;
1596 }
1597
1598 sub DESTROY {
1599     my $self = shift;
1600     return unless $self;
1601
1602     close $self->{fh} if $self->{fh};
1603
1604     return;
1605 }
1606
1607 package DBM::Deep::09830::Array;
1608
1609 use strict;
1610
1611 # This is to allow DBM::Deep::Array to handle negative indices on
1612 # its own. Otherwise, Perl would intercept the call to negative
1613 # indices for us. This was causing bugs for negative index handling.
1614 use vars qw( $NEGATIVE_INDICES );
1615 $NEGATIVE_INDICES = 1;
1616
1617 use base 'DBM::Deep::09830';
1618
1619 use Scalar::Util ();
1620
1621 sub _get_self {
1622     eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0]
1623 }
1624
1625 sub TIEARRAY {
1626 ##
1627 # Tied array constructor method, called by Perl's tie() function.
1628 ##
1629     my $class = shift;
1630     my $args = $class->_get_args( @_ );
1631
1632         $args->{type} = $class->TYPE_ARRAY;
1633
1634         return $class->_init($args);
1635 }
1636
1637 sub FETCH {
1638     my $self = $_[0]->_get_self;
1639     my $key = $_[1];
1640
1641         $self->lock( $self->LOCK_SH );
1642
1643     if ( $key =~ /^-?\d+$/ ) {
1644         if ( $key < 0 ) {
1645             $key += $self->FETCHSIZE;
1646             unless ( $key >= 0 ) {
1647                 $self->unlock;
1648                 return;
1649             }
1650         }
1651
1652         $key = pack($DBM::Deep::09830::LONG_PACK, $key);
1653     }
1654
1655     my $rv = $self->SUPER::FETCH( $key );
1656
1657     $self->unlock;
1658
1659     return $rv;
1660 }
1661
1662 sub STORE {
1663     my $self = shift->_get_self;
1664     my ($key, $value) = @_;
1665
1666     $self->lock( $self->LOCK_EX );
1667
1668     my $orig = $key;
1669
1670     my $size;
1671     my $numeric_idx;
1672     if ( $key =~ /^\-?\d+$/ ) {
1673         $numeric_idx = 1;
1674         if ( $key < 0 ) {
1675             $size = $self->FETCHSIZE;
1676             $key += $size;
1677             if ( $key < 0 ) {
1678                 die( "Modification of non-creatable array value attempted, subscript $orig" );
1679             }
1680         }
1681
1682         $key = pack($DBM::Deep::09830::LONG_PACK, $key);
1683     }
1684
1685     my $rv = $self->SUPER::STORE( $key, $value );
1686
1687     if ( $numeric_idx && $rv == 2 ) {
1688         $size = $self->FETCHSIZE unless defined $size;
1689         if ( $orig >= $size ) {
1690             $self->STORESIZE( $orig + 1 );
1691         }
1692     }
1693
1694     $self->unlock;
1695
1696     return $rv;
1697 }
1698
1699 sub EXISTS {
1700     my $self = $_[0]->_get_self;
1701     my $key = $_[1];
1702
1703         $self->lock( $self->LOCK_SH );
1704
1705     if ( $key =~ /^\-?\d+$/ ) {
1706         if ( $key < 0 ) {
1707             $key += $self->FETCHSIZE;
1708             unless ( $key >= 0 ) {
1709                 $self->unlock;
1710                 return;
1711             }
1712         }
1713
1714         $key = pack($DBM::Deep::09830::LONG_PACK, $key);
1715     }
1716
1717     my $rv = $self->SUPER::EXISTS( $key );
1718
1719     $self->unlock;
1720
1721     return $rv;
1722 }
1723
1724 sub DELETE {
1725     my $self = $_[0]->_get_self;
1726     my $key = $_[1];
1727
1728     my $unpacked_key = $key;
1729
1730     $self->lock( $self->LOCK_EX );
1731
1732     my $size = $self->FETCHSIZE;
1733     if ( $key =~ /^-?\d+$/ ) {
1734         if ( $key < 0 ) {
1735             $key += $size;
1736             unless ( $key >= 0 ) {
1737                 $self->unlock;
1738                 return;
1739             }
1740         }
1741
1742         $key = pack($DBM::Deep::09830::LONG_PACK, $key);
1743     }
1744
1745     my $rv = $self->SUPER::DELETE( $key );
1746
1747         if ($rv && $unpacked_key == $size - 1) {
1748                 $self->STORESIZE( $unpacked_key );
1749         }
1750
1751     $self->unlock;
1752
1753     return $rv;
1754 }
1755
1756 sub FETCHSIZE {
1757         ##
1758         # Return the length of the array
1759         ##
1760     my $self = shift->_get_self;
1761
1762     $self->lock( $self->LOCK_SH );
1763
1764         my $SAVE_FILTER = $self->_root->{filter_fetch_value};
1765         $self->_root->{filter_fetch_value} = undef;
1766
1767         my $packed_size = $self->FETCH('length');
1768
1769         $self->_root->{filter_fetch_value} = $SAVE_FILTER;
1770
1771     $self->unlock;
1772
1773         if ($packed_size) {
1774         return int(unpack($DBM::Deep::09830::LONG_PACK, $packed_size));
1775     }
1776
1777         return 0;
1778 }
1779
1780 sub STORESIZE {
1781         ##
1782         # Set the length of the array
1783         ##
1784     my $self = $_[0]->_get_self;
1785         my $new_length = $_[1];
1786
1787     $self->lock( $self->LOCK_EX );
1788
1789         my $SAVE_FILTER = $self->_root->{filter_store_value};
1790         $self->_root->{filter_store_value} = undef;
1791
1792         my $result = $self->STORE('length', pack($DBM::Deep::09830::LONG_PACK, $new_length));
1793
1794         $self->_root->{filter_store_value} = $SAVE_FILTER;
1795
1796     $self->unlock;
1797
1798         return $result;
1799 }
1800
1801 sub POP {
1802         ##
1803         # Remove and return the last element on the array
1804         ##
1805     my $self = $_[0]->_get_self;
1806
1807     $self->lock( $self->LOCK_EX );
1808
1809         my $length = $self->FETCHSIZE();
1810
1811         if ($length) {
1812                 my $content = $self->FETCH( $length - 1 );
1813                 $self->DELETE( $length - 1 );
1814
1815         $self->unlock;
1816
1817                 return $content;
1818         }
1819         else {
1820         $self->unlock;
1821                 return;
1822         }
1823 }
1824
1825 sub PUSH {
1826         ##
1827         # Add new element(s) to the end of the array
1828         ##
1829     my $self = shift->_get_self;
1830
1831     $self->lock( $self->LOCK_EX );
1832
1833         my $length = $self->FETCHSIZE();
1834
1835         while (my $content = shift @_) {
1836                 $self->STORE( $length, $content );
1837                 $length++;
1838         }
1839
1840     $self->unlock;
1841
1842     return $length;
1843 }
1844
1845 sub SHIFT {
1846         ##
1847         # Remove and return first element on the array.
1848         # Shift over remaining elements to take up space.
1849         ##
1850     my $self = $_[0]->_get_self;
1851
1852     $self->lock( $self->LOCK_EX );
1853
1854         my $length = $self->FETCHSIZE();
1855
1856         if ($length) {
1857                 my $content = $self->FETCH( 0 );
1858
1859                 ##
1860                 # Shift elements over and remove last one.
1861                 ##
1862                 for (my $i = 0; $i < $length - 1; $i++) {
1863                         $self->STORE( $i, $self->FETCH($i + 1) );
1864                 }
1865                 $self->DELETE( $length - 1 );
1866
1867         $self->unlock;
1868
1869                 return $content;
1870         }
1871         else {
1872         $self->unlock;
1873                 return;
1874         }
1875 }
1876
1877 sub UNSHIFT {
1878         ##
1879         # Insert new element(s) at beginning of array.
1880         # Shift over other elements to make space.
1881         ##
1882     my $self = shift->_get_self;
1883         my @new_elements = @_;
1884
1885     $self->lock( $self->LOCK_EX );
1886
1887         my $length = $self->FETCHSIZE();
1888         my $new_size = scalar @new_elements;
1889
1890         if ($length) {
1891                 for (my $i = $length - 1; $i >= 0; $i--) {
1892                         $self->STORE( $i + $new_size, $self->FETCH($i) );
1893                 }
1894         }
1895
1896         for (my $i = 0; $i < $new_size; $i++) {
1897                 $self->STORE( $i, $new_elements[$i] );
1898         }
1899
1900     $self->unlock;
1901
1902     return $length + $new_size;
1903 }
1904
1905 sub SPLICE {
1906         ##
1907         # Splices section of array with optional new section.
1908         # Returns deleted section, or last element deleted in scalar context.
1909         ##
1910     my $self = shift->_get_self;
1911
1912     $self->lock( $self->LOCK_EX );
1913
1914         my $length = $self->FETCHSIZE();
1915
1916         ##
1917         # Calculate offset and length of splice
1918         ##
1919         my $offset = shift;
1920     $offset = 0 unless defined $offset;
1921         if ($offset < 0) { $offset += $length; }
1922
1923         my $splice_length;
1924         if (scalar @_) { $splice_length = shift; }
1925         else { $splice_length = $length - $offset; }
1926         if ($splice_length < 0) { $splice_length += ($length - $offset); }
1927
1928         ##
1929         # Setup array with new elements, and copy out old elements for return
1930         ##
1931         my @new_elements = @_;
1932         my $new_size = scalar @new_elements;
1933
1934     my @old_elements = map {
1935         $self->FETCH( $_ )
1936     } $offset .. ($offset + $splice_length - 1);
1937
1938         ##
1939         # Adjust array length, and shift elements to accomodate new section.
1940         ##
1941     if ( $new_size != $splice_length ) {
1942         if ($new_size > $splice_length) {
1943             for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
1944                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
1945             }
1946         }
1947         else {
1948             for (my $i = $offset + $splice_length; $i < $length; $i++) {
1949                 $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
1950             }
1951             for (my $i = 0; $i < $splice_length - $new_size; $i++) {
1952                 $self->DELETE( $length - 1 );
1953                 $length--;
1954             }
1955         }
1956         }
1957
1958         ##
1959         # Insert new elements into array
1960         ##
1961         for (my $i = $offset; $i < $offset + $new_size; $i++) {
1962                 $self->STORE( $i, shift @new_elements );
1963         }
1964
1965     $self->unlock;
1966
1967         ##
1968         # Return deleted section, or last element in scalar context.
1969         ##
1970         return wantarray ? @old_elements : $old_elements[-1];
1971 }
1972
1973 sub EXTEND {
1974         ##
1975         # Perl will call EXTEND() when the array is likely to grow.
1976         # We don't care, but include it for compatibility.
1977         ##
1978 }
1979
1980 ##
1981 # Public method aliases
1982 ##
1983 *length = *FETCHSIZE;
1984 *pop = *POP;
1985 *push = *PUSH;
1986 *shift = *SHIFT;
1987 *unshift = *UNSHIFT;
1988 *splice = *SPLICE;
1989
1990 package DBM::Deep::09830::Hash;
1991
1992 use strict;
1993
1994 use base 'DBM::Deep::09830';
1995
1996 sub _get_self {
1997     eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0]
1998 }
1999
2000 sub TIEHASH {
2001     ##
2002     # Tied hash constructor method, called by Perl's tie() function.
2003     ##
2004     my $class = shift;
2005     my $args = $class->_get_args( @_ );
2006
2007     $args->{type} = $class->TYPE_HASH;
2008
2009     return $class->_init($args);
2010 }
2011
2012 sub FETCH {
2013     my $self = shift->_get_self;
2014     my $key = ($self->_root->{filter_store_key})
2015         ? $self->_root->{filter_store_key}->($_[0])
2016         : $_[0];
2017
2018     return $self->SUPER::FETCH( $key );
2019 }
2020
2021 sub STORE {
2022     my $self = shift->_get_self;
2023         my $key = ($self->_root->{filter_store_key})
2024         ? $self->_root->{filter_store_key}->($_[0])
2025         : $_[0];
2026     my $value = $_[1];
2027
2028     return $self->SUPER::STORE( $key, $value );
2029 }
2030
2031 sub EXISTS {
2032     my $self = shift->_get_self;
2033         my $key = ($self->_root->{filter_store_key})
2034         ? $self->_root->{filter_store_key}->($_[0])
2035         : $_[0];
2036
2037     return $self->SUPER::EXISTS( $key );
2038 }
2039
2040 sub DELETE {
2041     my $self = shift->_get_self;
2042         my $key = ($self->_root->{filter_store_key})
2043         ? $self->_root->{filter_store_key}->($_[0])
2044         : $_[0];
2045
2046     return $self->SUPER::DELETE( $key );
2047 }
2048
2049 sub FIRSTKEY {
2050         ##
2051         # Locate and return first key (in no particular order)
2052         ##
2053     my $self = $_[0]->_get_self;
2054
2055         ##
2056         # Make sure file is open
2057         ##
2058         if (!defined($self->_fh)) { $self->_open(); }
2059
2060         ##
2061         # Request shared lock for reading
2062         ##
2063         $self->lock( $self->LOCK_SH );
2064
2065         my $result = $self->_get_next_key();
2066
2067         $self->unlock();
2068
2069         return ($result && $self->_root->{filter_fetch_key})
2070         ? $self->_root->{filter_fetch_key}->($result)
2071         : $result;
2072 }
2073
2074 sub NEXTKEY {
2075         ##
2076         # Return next key (in no particular order), given previous one
2077         ##
2078     my $self = $_[0]->_get_self;
2079
2080         my $prev_key = ($self->_root->{filter_store_key})
2081         ? $self->_root->{filter_store_key}->($_[1])
2082         : $_[1];
2083
2084         my $prev_md5 = $DBM::Deep::09830::DIGEST_FUNC->($prev_key);
2085
2086         ##
2087         # Make sure file is open
2088         ##
2089         if (!defined($self->_fh)) { $self->_open(); }
2090
2091         ##
2092         # Request shared lock for reading
2093         ##
2094         $self->lock( $self->LOCK_SH );
2095
2096         my $result = $self->_get_next_key( $prev_md5 );
2097
2098         $self->unlock();
2099
2100         return ($result && $self->_root->{filter_fetch_key})
2101         ? $self->_root->{filter_fetch_key}->($result)
2102         : $result;
2103 }
2104
2105 ##
2106 # Public method aliases
2107 ##
2108 *first_key = *FIRSTKEY;
2109 *next_key = *NEXTKEY;
2110
2111 1;
2112 __END__