0-983 is now moved over and parsing - still need to perform tests on the converted...
rkinyon [Sun, 18 Feb 2007 11:10:55 +0000 (11:10 +0000)]
t/44_upgrade_db.t
utils/lib/DBM/Deep/09830.pm [new file with mode: 0644]
utils/upgrade_db.pl

index f02529d..8362c29 100644 (file)
@@ -10,7 +10,7 @@ BEGIN {
   }
 }
 
-plan tests => 6;
+plan tests => 11;
 
 use t::common qw( new_fh );
 use File::Spec;
@@ -24,26 +24,67 @@ is( run_prog( $PROG ), "Missing required parameters.\n$long", "Failed no params"
 is( run_prog( $PROG, '-input foo' ), "Missing required parameters.\n$long", "Failed only -input" );
 is( run_prog( $PROG, '-output foo' ), "Missing required parameters.\n$long", "Failed only -output" );
 is(
-  run_prog( $PROG, '-input foo', '-output foo' ),
-  "Cannot use the same filename for both input and output.\n$short",
-  "Failed same name",
+    run_prog( $PROG, '-input foo', '-output foo' ),
+    "Cannot use the same filename for both input and output.\n$short",
+    "Failed same name",
 );
 
 is(
-  run_prog( $PROG, '-input foo', '-output bar' ),
-  "'foo' is not a file.\n$short",
-  "Failed input does not exist",
+    run_prog( $PROG, '-input foo', '-output bar' ),
+    "'foo' is not a file.\n$short",
+    "Failed input does not exist",
 );
 
 my (undef, $input_filename) = new_fh();
 my (undef, $output_filename) = new_fh();
 
 is(
-  run_prog( $PROG, "-input $input_filename", "-output $output_filename" ),
-  "'$input_filename' is not a DBM::Deep file.\n$short",
-  "Input is not a DBM::Deep file",
+    run_prog( $PROG, "-input $input_filename", "-output $output_filename" ),
+    "'$input_filename' is not a DBM::Deep file.\n$short",
+    "Input is not a DBM::Deep file",
 );
 
+# All files are of the form:
+#   $db->{foo} = [ 1 .. 3 ];
+
+my @versions = (
+    '0-983',
+    '0-99_04',
+    '1-0000',
+);
+
+foreach my $input_version ( @versions ) {
+    my $input_filename = File::Spec->catfile( qw( t etc ), "db-$input_version" );
+
+    foreach my $output_version ( @versions ) {
+        (my $v = $output_version) =~ s/-/./g;
+        my $output = run_prog(
+            $PROG,
+            "-input $input_filename",
+            "-output $output_filename",
+            "-version $v",
+        );
+
+        if ( $input_version =~ /_/ ) {
+            is(
+                $output, "'$input_filename' is a dev release and not supported.\n$short",
+                "Input file is a dev release - not supported",
+            );
+
+            next;
+        }
+
+        if ( $output_version =~ /_/ ) {
+            is(
+                $output, "-version '$v' is a dev release and not supported.\n$short",
+                "Output version is a dev release - not supported",
+            );
+
+            next;
+        }
+    }
+}
+
 ################################################################################
 
 sub run_prog {
diff --git a/utils/lib/DBM/Deep/09830.pm b/utils/lib/DBM/Deep/09830.pm
new file mode 100644 (file)
index 0000000..b5342df
--- /dev/null
@@ -0,0 +1,2112 @@
+package DBM::Deep::09830;
+
+##
+# DBM::Deep
+#
+# Description:
+#      Multi-level database module for storing hash trees, arrays and simple
+#      key/value pairs into FTP-able, cross-platform binary database files.
+#
+#      Type `perldoc DBM::Deep` for complete documentation.
+#
+# Usage Examples:
+#      my %db;
+#      tie %db, 'DBM::Deep', 'my_database.db'; # standard tie() method
+#      
+#      my $db = new DBM::Deep( 'my_database.db' ); # preferred OO method
+#
+#      $db->{my_scalar} = 'hello world';
+#      $db->{my_hash} = { larry => 'genius', hashes => 'fast' };
+#      $db->{my_array} = [ 1, 2, 3, time() ];
+#      $db->{my_complex} = [ 'hello', { perl => 'rules' }, 42, 99 ];
+#      push @{$db->{my_array}}, 'another value';
+#      my @key_list = keys %{$db->{my_hash}};
+#      print "This module " . $db->{my_complex}->[1]->{perl} . "!\n";
+#
+# Copyright:
+#      (c) 2002-2006 Joseph Huckaby.  All Rights Reserved.
+#      This program is free software; you can redistribute it and/or 
+#      modify it under the same terms as Perl itself.
+##
+
+use strict;
+
+use Fcntl qw( :DEFAULT :flock :seek );
+use Digest::MD5 ();
+use Scalar::Util ();
+
+use vars qw( $VERSION );
+$VERSION = q(0.983);
+
+##
+# Set to 4 and 'N' for 32-bit offset tags (default).  Theoretical limit of 4 GB per file.
+#      (Perl must be compiled with largefile support for files > 2 GB)
+#
+# Set to 8 and 'Q' for 64-bit offsets.  Theoretical limit of 16 XB per file.
+#      (Perl must be compiled with largefile and 64-bit long support)
+##
+#my $LONG_SIZE = 4;
+#my $LONG_PACK = 'N';
+
+##
+# Set to 4 and 'N' for 32-bit data length prefixes.  Limit of 4 GB for each key/value.
+# Upgrading this is possible (see above) but probably not necessary.  If you need
+# more than 4 GB for a single key or value, this module is really not for you :-)
+##
+#my $DATA_LENGTH_SIZE = 4;
+#my $DATA_LENGTH_PACK = 'N';
+our ($LONG_SIZE, $LONG_PACK, $DATA_LENGTH_SIZE, $DATA_LENGTH_PACK);
+
+##
+# Maximum number of buckets per list before another level of indexing is done.
+# Increase this value for slightly greater speed, but larger database files.
+# DO NOT decrease this value below 16, due to risk of recursive reindex overrun.
+##
+my $MAX_BUCKETS = 16;
+
+##
+# Better not adjust anything below here, unless you're me :-)
+##
+
+##
+# Setup digest function for keys
+##
+our ($DIGEST_FUNC, $HASH_SIZE);
+#my $DIGEST_FUNC = \&Digest::MD5::md5;
+
+##
+# Precalculate index and bucket sizes based on values above.
+##
+#my $HASH_SIZE = 16;
+my ($INDEX_SIZE, $BUCKET_SIZE, $BUCKET_LIST_SIZE);
+
+set_digest();
+#set_pack();
+#_precalc_sizes();
+
+##
+# Setup file and tag signatures.  These should never change.
+##
+sub SIG_FILE   () { 'DPDB' }
+sub SIG_HASH   () { 'H' }
+sub SIG_ARRAY  () { 'A' }
+sub SIG_NULL   () { 'N' }
+sub SIG_DATA   () { 'D' }
+sub SIG_INDEX  () { 'I' }
+sub SIG_BLIST  () { 'B' }
+sub SIG_SIZE   () {  1  }
+
+##
+# Setup constants for users to pass to new()
+##
+sub TYPE_HASH   () { SIG_HASH   }
+sub TYPE_ARRAY  () { SIG_ARRAY  }
+
+sub _get_args {
+    my $proto = shift;
+
+    my $args;
+    if (scalar(@_) > 1) {
+        if ( @_ % 2 ) {
+            $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] );
+        }
+        $args = {@_};
+    }
+       elsif ( ref $_[0] ) {
+        unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) {
+            $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] );
+        }
+        $args = $_[0];
+    }
+       else {
+        $args = { file => shift };
+    }
+
+    return $args;
+}
+
+sub new {
+       ##
+       # Class constructor method for Perl OO interface.
+       # Calls tie() and returns blessed reference to tied hash or array,
+       # providing a hybrid OO/tie interface.
+       ##
+       my $class = shift;
+       my $args = $class->_get_args( @_ );
+       
+       ##
+       # Check if we want a tied hash or array.
+       ##
+       my $self;
+       if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
+        $class = 'DBM::Deep::09830::Array';
+        #require DBM::Deep::09830::Array;
+               tie @$self, $class, %$args;
+       }
+       else {
+        $class = 'DBM::Deep::09830::Hash';
+        #require DBM::Deep::09830::Hash;
+               tie %$self, $class, %$args;
+       }
+
+       return bless $self, $class;
+}
+
+sub _init {
+    ##
+    # Setup $self and bless into this class.
+    ##
+    my $class = shift;
+    my $args = shift;
+
+    # These are the defaults to be optionally overridden below
+    my $self = bless {
+        type => TYPE_HASH,
+        base_offset => length(SIG_FILE),
+    }, $class;
+
+    foreach my $param ( keys %$self ) {
+        next unless exists $args->{$param};
+        $self->{$param} = delete $args->{$param}
+    }
+    
+    # locking implicitly enables autoflush
+    if ($args->{locking}) { $args->{autoflush} = 1; }
+    
+    $self->{root} = exists $args->{root}
+        ? $args->{root}
+        : DBM::Deep::09830::_::Root->new( $args );
+
+    if (!defined($self->_fh)) { $self->_open(); }
+
+    return $self;
+}
+
+sub TIEHASH {
+    shift;
+    require DBM::Deep::09830::Hash;
+    return DBM::Deep::09830::Hash->TIEHASH( @_ );
+}
+
+sub TIEARRAY {
+    shift;
+    require DBM::Deep::09830::Array;
+    return DBM::Deep::09830::Array->TIEARRAY( @_ );
+}
+
+#XXX Unneeded now ...
+#sub DESTROY {
+#}
+
+sub _open {
+       ##
+       # Open a fh to the database, create if nonexistent.
+       # Make sure file signature matches DBM::Deep spec.
+       ##
+    my $self = $_[0]->_get_self;
+
+    local($/,$\);
+
+       if (defined($self->_fh)) { $self->_close(); }
+       
+    my $flags = O_RDWR | O_CREAT | O_BINARY;
+
+    my $fh;
+    sysopen( $fh, $self->_root->{file}, $flags )
+               or $self->_throw_error( "Cannot sysopen file: " . $self->_root->{file} . ": $!" );
+
+    $self->_root->{fh} = $fh;
+
+    if ($self->_root->{autoflush}) {
+        my $old = select $fh;
+        $|=1;
+        select $old;
+    }
+    
+    seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET);
+
+    my $signature;
+    my $bytes_read = read( $fh, $signature, length(SIG_FILE));
+    
+    ##
+    # File is empty -- write signature and master index
+    ##
+    if (!$bytes_read) {
+        seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET);
+        print( $fh SIG_FILE);
+        $self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE);
+
+        my $plain_key = "[base]";
+        print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
+
+        # Flush the filehandle
+        my $old_fh = select $fh;
+        my $old_af = $|; $| = 1; $| = $old_af;
+        select $old_fh;
+
+        my @stats = stat($fh);
+        $self->_root->{inode} = $stats[1];
+        $self->_root->{end} = $stats[7];
+
+        return 1;
+    }
+    
+    ##
+    # Check signature was valid
+    ##
+    unless ($signature eq SIG_FILE) {
+        $self->_close();
+        return $self->_throw_error("Signature not found -- file is not a Deep DB");
+    }
+
+       my @stats = stat($fh);
+       $self->_root->{inode} = $stats[1];
+    $self->_root->{end} = $stats[7];
+        
+    ##
+    # Get our type from master index signature
+    ##
+    my $tag = $self->_load_tag($self->_base_offset);
+
+#XXX We probably also want to store the hash algorithm name and not assume anything
+#XXX The cool thing would be to allow a different hashing algorithm at every level
+
+    if (!$tag) {
+       return $self->_throw_error("Corrupted file, no master index record");
+    }
+    if ($self->{type} ne $tag->{signature}) {
+       return $self->_throw_error("File type mismatch");
+    }
+    
+    return 1;
+}
+
+sub _close {
+       ##
+       # Close database fh
+       ##
+    my $self = $_[0]->_get_self;
+    close $self->_root->{fh} if $self->_root->{fh};
+    $self->_root->{fh} = undef;
+}
+
+sub _create_tag {
+       ##
+       # Given offset, signature and content, create tag and write to disk
+       ##
+       my ($self, $offset, $sig, $content) = @_;
+       my $size = length($content);
+
+    local($/,$\);
+       
+    my $fh = $self->_fh;
+
+       seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET);
+       print( $fh $sig . pack($DATA_LENGTH_PACK, $size) . $content );
+       
+       if ($offset == $self->_root->{end}) {
+               $self->_root->{end} += SIG_SIZE + $DATA_LENGTH_SIZE + $size;
+       }
+       
+       return {
+               signature => $sig,
+               size => $size,
+               offset => $offset + SIG_SIZE + $DATA_LENGTH_SIZE,
+               content => $content
+       };
+}
+
+sub _load_tag {
+       ##
+       # Given offset, load single tag and return signature, size and data
+       ##
+       my $self = shift;
+       my $offset = shift;
+
+    local($/,$\);
+       
+    my $fh = $self->_fh;
+
+       seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET);
+       if (eof $fh) { return undef; }
+       
+    my $b;
+    read( $fh, $b, SIG_SIZE + $DATA_LENGTH_SIZE );
+    my ($sig, $size) = unpack( "A $DATA_LENGTH_PACK", $b );
+       
+       my $buffer;
+       read( $fh, $buffer, $size);
+       
+       return {
+               signature => $sig,
+               size => $size,
+               offset => $offset + SIG_SIZE + $DATA_LENGTH_SIZE,
+               content => $buffer
+       };
+}
+
+sub _index_lookup {
+       ##
+       # Given index tag, lookup single entry in index and return .
+       ##
+       my $self = shift;
+       my ($tag, $index) = @_;
+
+       my $location = unpack($LONG_PACK, substr($tag->{content}, $index * $LONG_SIZE, $LONG_SIZE) );
+       if (!$location) { return; }
+       
+       return $self->_load_tag( $location );
+}
+
+sub _add_bucket {
+       ##
+       # Adds one key/value pair to bucket list, given offset, MD5 digest of key,
+       # plain (undigested) key and value.
+       ##
+       my $self = shift;
+       my ($tag, $md5, $plain_key, $value) = @_;
+       my $keys = $tag->{content};
+       my $location = 0;
+       my $result = 2;
+
+    local($/,$\);
+
+    # This verifies that only supported values will be stored.
+    {
+        my $r = Scalar::Util::reftype( $value );
+        last if !defined $r;
+
+        last if $r eq 'HASH';
+        last if $r eq 'ARRAY';
+
+        $self->_throw_error(
+            "Storage of variables of type '$r' is not supported."
+        );
+    }
+
+    my $root = $self->_root;
+
+    my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep::09830' ) };
+       my $internal_ref = $is_dbm_deep && ($value->_root eq $root);
+
+    my $fh = $self->_fh;
+
+       ##
+       # Iterate through buckets, seeing if this is a new entry or a replace.
+       ##
+       for (my $i=0; $i<$MAX_BUCKETS; $i++) {
+               my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
+               if (!$subloc) {
+                       ##
+                       # Found empty bucket (end of list).  Populate and exit loop.
+                       ##
+                       $result = 2;
+                       
+            $location = $internal_ref
+                ? $value->_base_offset
+                : $root->{end};
+                       
+                       seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
+                       print( $fh $md5 . pack($LONG_PACK, $location) );
+                       last;
+               }
+
+               my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
+               if ($md5 eq $key) {
+                       ##
+                       # Found existing bucket with same key.  Replace with new value.
+                       ##
+                       $result = 1;
+                       
+                       if ($internal_ref) {
+                               $location = $value->_base_offset;
+                               seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
+                               print( $fh $md5 . pack($LONG_PACK, $location) );
+                return $result;
+                       }
+
+            seek($fh, $subloc + SIG_SIZE + $root->{file_offset}, SEEK_SET);
+            my $size;
+            read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+            
+            ##
+            # If value is a hash, array, or raw value with equal or less size, we can
+            # reuse the same content area of the database.  Otherwise, we have to create
+            # a new content area at the EOF.
+            ##
+            my $actual_length;
+            my $r = Scalar::Util::reftype( $value ) || '';
+            if ( $r eq 'HASH' || $r eq 'ARRAY' ) {
+                $actual_length = $INDEX_SIZE;
+                
+                # if autobless is enabled, must also take into consideration
+                # the class name, as it is stored along with key/value.
+                if ( $root->{autobless} ) {
+                    my $value_class = Scalar::Util::blessed($value);
+                    if ( defined $value_class && !$value->isa('DBM::Deep::09830') ) {
+                        $actual_length += length($value_class);
+                    }
+                }
+            }
+            else { $actual_length = length($value); }
+            
+            if ($actual_length <= ($size || 0)) {
+                $location = $subloc;
+            }
+            else {
+                $location = $root->{end};
+                seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE + $root->{file_offset}, SEEK_SET);
+                print( $fh pack($LONG_PACK, $location) );
+            }
+
+                       last;
+               }
+       }
+       
+       ##
+       # If this is an internal reference, return now.
+       # No need to write value or plain key
+       ##
+       if ($internal_ref) {
+        return $result;
+    }
+       
+       ##
+       # If bucket didn't fit into list, split into a new index level
+       ##
+       if (!$location) {
+               seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET);
+               print( $fh pack($LONG_PACK, $root->{end}) );
+               
+               my $index_tag = $self->_create_tag($root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE);
+               my @offsets = ();
+               
+               $keys .= $md5 . pack($LONG_PACK, 0);
+               
+               for (my $i=0; $i<=$MAX_BUCKETS; $i++) {
+                       my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
+                       if ($key) {
+                               my $old_subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
+                               my $num = ord(substr($key, $tag->{ch} + 1, 1));
+                               
+                               if ($offsets[$num]) {
+                                       my $offset = $offsets[$num] + SIG_SIZE + $DATA_LENGTH_SIZE;
+                                       seek($fh, $offset + $root->{file_offset}, SEEK_SET);
+                                       my $subkeys;
+                                       read( $fh, $subkeys, $BUCKET_LIST_SIZE);
+                                       
+                                       for (my $k=0; $k<$MAX_BUCKETS; $k++) {
+                                               my $subloc = unpack($LONG_PACK, substr($subkeys, ($k * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
+                                               if (!$subloc) {
+                                                       seek($fh, $offset + ($k * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
+                                                       print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) );
+                                                       last;
+                                               }
+                                       } # k loop
+                               }
+                               else {
+                                       $offsets[$num] = $root->{end};
+                                       seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE) + $root->{file_offset}, SEEK_SET);
+                                       print( $fh pack($LONG_PACK, $root->{end}) );
+                                       
+                                       my $blist_tag = $self->_create_tag($root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
+                                       
+                                       seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET);
+                                       print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) );
+                               }
+                       } # key is real
+               } # i loop
+               
+               $location ||= $root->{end};
+       } # re-index bucket list
+       
+       ##
+       # Seek to content area and store signature, value and plaintext key
+       ##
+       if ($location) {
+               my $content_length;
+               seek($fh, $location + $root->{file_offset}, SEEK_SET);
+               
+               ##
+               # Write signature based on content type, set content length and write actual value.
+               ##
+        my $r = Scalar::Util::reftype($value) || '';
+               if ($r eq 'HASH') {
+            if ( !$internal_ref && tied %{$value} ) {
+                return $self->_throw_error("Cannot store a tied value");
+            }
+                       print( $fh TYPE_HASH );
+                       print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
+                       $content_length = $INDEX_SIZE;
+               }
+               elsif ($r eq 'ARRAY') {
+            if ( !$internal_ref && tied @{$value} ) {
+                return $self->_throw_error("Cannot store a tied value");
+            }
+                       print( $fh TYPE_ARRAY );
+                       print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
+                       $content_length = $INDEX_SIZE;
+               }
+               elsif (!defined($value)) {
+                       print( $fh SIG_NULL );
+                       print( $fh pack($DATA_LENGTH_PACK, 0) );
+                       $content_length = 0;
+               }
+               else {
+                       print( $fh SIG_DATA );
+                       print( $fh pack($DATA_LENGTH_PACK, length($value)) . $value );
+                       $content_length = length($value);
+               }
+               
+               ##
+               # Plain key is stored AFTER value, as keys are typically fetched less often.
+               ##
+               print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
+               
+               ##
+               # If value is blessed, preserve class name
+               ##
+               if ( $root->{autobless} ) {
+            my $value_class = Scalar::Util::blessed($value);
+            if ( defined $value_class && $value_class ne 'DBM::Deep::09830' ) {
+                ##
+                # Blessed ref -- will restore later
+                ##
+                print( $fh chr(1) );
+                print( $fh pack($DATA_LENGTH_PACK, length($value_class)) . $value_class );
+                $content_length += 1;
+                $content_length += $DATA_LENGTH_SIZE + length($value_class);
+            }
+            else {
+                print( $fh chr(0) );
+                $content_length += 1;
+            }
+        }
+            
+               ##
+               # If this is a new content area, advance EOF counter
+               ##
+               if ($location == $root->{end}) {
+                       $root->{end} += SIG_SIZE;
+                       $root->{end} += $DATA_LENGTH_SIZE + $content_length;
+                       $root->{end} += $DATA_LENGTH_SIZE + length($plain_key);
+               }
+               
+               ##
+               # If content is a hash or array, create new child DBM::Deep object and
+               # pass each key or element to it.
+               ##
+               if ($r eq 'HASH') {
+            my %x = %$value;
+            tie %$value, 'DBM::Deep::09830', {
+                               type => TYPE_HASH,
+                               base_offset => $location,
+                               root => $root,
+                       };
+            %$value = %x;
+               }
+               elsif ($r eq 'ARRAY') {
+            my @x = @$value;
+            tie @$value, 'DBM::Deep::09830', {
+                               type => TYPE_ARRAY,
+                               base_offset => $location,
+                               root => $root,
+                       };
+            @$value = @x;
+               }
+               
+               return $result;
+       }
+       
+       return $self->_throw_error("Fatal error: indexing failed -- possibly due to corruption in file");
+}
+
+sub _get_bucket_value {
+       ##
+       # Fetch single value given tag and MD5 digested key.
+       ##
+       my $self = shift;
+       my ($tag, $md5) = @_;
+       my $keys = $tag->{content};
+
+    local($/,$\);
+
+    my $fh = $self->_fh;
+
+       ##
+       # Iterate through buckets, looking for a key match
+       ##
+    BUCKET:
+       for (my $i=0; $i<$MAX_BUCKETS; $i++) {
+               my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
+               my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
+
+               if (!$subloc) {
+                       ##
+                       # Hit end of list, no match
+                       ##
+                       return;
+               }
+
+        if ( $md5 ne $key ) {
+            next BUCKET;
+        }
+
+        ##
+        # Found match -- seek to offset and read signature
+        ##
+        my $signature;
+        seek($fh, $subloc + $self->_root->{file_offset}, SEEK_SET);
+        read( $fh, $signature, SIG_SIZE);
+        
+        ##
+        # If value is a hash or array, return new DBM::Deep object with correct offset
+        ##
+        if (($signature eq TYPE_HASH) || ($signature eq TYPE_ARRAY)) {
+            my $obj = DBM::Deep::09830->new(
+                type => $signature,
+                base_offset => $subloc,
+                root => $self->_root
+            );
+            
+            if ($self->_root->{autobless}) {
+                ##
+                # Skip over value and plain key to see if object needs
+                # to be re-blessed
+                ##
+                seek($fh, $DATA_LENGTH_SIZE + $INDEX_SIZE, SEEK_CUR);
+                
+                my $size;
+                read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+                if ($size) { seek($fh, $size, SEEK_CUR); }
+                
+                my $bless_bit;
+                read( $fh, $bless_bit, 1);
+                if (ord($bless_bit)) {
+                    ##
+                    # Yes, object needs to be re-blessed
+                    ##
+                    my $class_name;
+                    read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+                    if ($size) { read( $fh, $class_name, $size); }
+                    if ($class_name) { $obj = bless( $obj, $class_name ); }
+                }
+            }
+            
+            return $obj;
+        }
+        
+        ##
+        # Otherwise return actual value
+        ##
+        elsif ($signature eq SIG_DATA) {
+            my $size;
+            my $value = '';
+            read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+            if ($size) { read( $fh, $value, $size); }
+            return $value;
+        }
+        
+        ##
+        # Key exists, but content is null
+        ##
+        else { return; }
+       } # i loop
+
+       return;
+}
+
+sub _delete_bucket {
+       ##
+       # Delete single key/value pair given tag and MD5 digested key.
+       ##
+       my $self = shift;
+       my ($tag, $md5) = @_;
+       my $keys = $tag->{content};
+
+    local($/,$\);
+
+    my $fh = $self->_fh;
+       
+       ##
+       # Iterate through buckets, looking for a key match
+       ##
+    BUCKET:
+       for (my $i=0; $i<$MAX_BUCKETS; $i++) {
+               my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
+               my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
+
+               if (!$subloc) {
+                       ##
+                       # Hit end of list, no match
+                       ##
+                       return;
+               }
+
+        if ( $md5 ne $key ) {
+            next BUCKET;
+        }
+
+        ##
+        # Matched key -- delete bucket and return
+        ##
+        seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $self->_root->{file_offset}, SEEK_SET);
+        print( $fh substr($keys, ($i+1) * $BUCKET_SIZE ) );
+        print( $fh chr(0) x $BUCKET_SIZE );
+        
+        return 1;
+       } # i loop
+
+       return;
+}
+
+sub _bucket_exists {
+       ##
+       # Check existence of single key given tag and MD5 digested key.
+       ##
+       my $self = shift;
+       my ($tag, $md5) = @_;
+       my $keys = $tag->{content};
+       
+       ##
+       # Iterate through buckets, looking for a key match
+       ##
+    BUCKET:
+       for (my $i=0; $i<$MAX_BUCKETS; $i++) {
+               my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
+               my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
+
+               if (!$subloc) {
+                       ##
+                       # Hit end of list, no match
+                       ##
+                       return;
+               }
+
+        if ( $md5 ne $key ) {
+            next BUCKET;
+        }
+
+        ##
+        # Matched key -- return true
+        ##
+        return 1;
+       } # i loop
+
+       return;
+}
+
+sub _find_bucket_list {
+       ##
+       # Locate offset for bucket list, given digested key
+       ##
+       my $self = shift;
+       my $md5 = shift;
+       
+       ##
+       # Locate offset for bucket list using digest index system
+       ##
+       my $ch = 0;
+       my $tag = $self->_load_tag($self->_base_offset);
+       if (!$tag) { return; }
+       
+       while ($tag->{signature} ne SIG_BLIST) {
+               $tag = $self->_index_lookup($tag, ord(substr($md5, $ch, 1)));
+               if (!$tag) { return; }
+               $ch++;
+       }
+       
+       return $tag;
+}
+
+sub _traverse_index {
+       ##
+       # Scan index and recursively step into deeper levels, looking for next key.
+       ##
+    my ($self, $offset, $ch, $force_return_next) = @_;
+    $force_return_next = undef unless $force_return_next;
+
+    local($/,$\);
+       
+       my $tag = $self->_load_tag( $offset );
+
+    my $fh = $self->_fh;
+       
+       if ($tag->{signature} ne SIG_BLIST) {
+               my $content = $tag->{content};
+               my $start;
+               if ($self->{return_next}) { $start = 0; }
+               else { $start = ord(substr($self->{prev_md5}, $ch, 1)); }
+               
+               for (my $index = $start; $index < 256; $index++) {
+                       my $subloc = unpack($LONG_PACK, substr($content, $index * $LONG_SIZE, $LONG_SIZE) );
+                       if ($subloc) {
+                               my $result = $self->_traverse_index( $subloc, $ch + 1, $force_return_next );
+                               if (defined($result)) { return $result; }
+                       }
+               } # index loop
+               
+               $self->{return_next} = 1;
+       } # tag is an index
+       
+       elsif ($tag->{signature} eq SIG_BLIST) {
+               my $keys = $tag->{content};
+               if ($force_return_next) { $self->{return_next} = 1; }
+               
+               ##
+               # Iterate through buckets, looking for a key match
+               ##
+               for (my $i=0; $i<$MAX_BUCKETS; $i++) {
+                       my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
+                       my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
+       
+                       if (!$subloc) {
+                               ##
+                               # End of bucket list -- return to outer loop
+                               ##
+                               $self->{return_next} = 1;
+                               last;
+                       }
+                       elsif ($key eq $self->{prev_md5}) {
+                               ##
+                               # Located previous key -- return next one found
+                               ##
+                               $self->{return_next} = 1;
+                               next;
+                       }
+                       elsif ($self->{return_next}) {
+                               ##
+                               # Seek to bucket location and skip over signature
+                               ##
+                               seek($fh, $subloc + SIG_SIZE + $self->_root->{file_offset}, SEEK_SET);
+                               
+                               ##
+                               # Skip over value to get to plain key
+                               ##
+                               my $size;
+                               read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+                               if ($size) { seek($fh, $size, SEEK_CUR); }
+                               
+                               ##
+                               # Read in plain key and return as scalar
+                               ##
+                               my $plain_key;
+                               read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
+                               if ($size) { read( $fh, $plain_key, $size); }
+                               
+                               return $plain_key;
+                       }
+               } # bucket loop
+               
+               $self->{return_next} = 1;
+       } # tag is a bucket list
+       
+       return;
+}
+
+sub _get_next_key {
+       ##
+       # Locate next key, given digested previous one
+       ##
+    my $self = $_[0]->_get_self;
+       
+       $self->{prev_md5} = $_[1] ? $_[1] : undef;
+       $self->{return_next} = 0;
+       
+       ##
+       # If the previous key was not specifed, start at the top and
+       # return the first one found.
+       ##
+       if (!$self->{prev_md5}) {
+               $self->{prev_md5} = chr(0) x $HASH_SIZE;
+               $self->{return_next} = 1;
+       }
+       
+       return $self->_traverse_index( $self->_base_offset, 0 );
+}
+
+sub lock {
+       ##
+       # If db locking is set, flock() the db file.  If called multiple
+       # times before unlock(), then the same number of unlocks() must
+       # be called before the lock is released.
+       ##
+    my $self = $_[0]->_get_self;
+       my $type = $_[1];
+    $type = LOCK_EX unless defined $type;
+       
+       if (!defined($self->_fh)) { return; }
+
+       if ($self->_root->{locking}) {
+               if (!$self->_root->{locked}) {
+                       flock($self->_fh, $type);
+                       
+                       # refresh end counter in case file has changed size
+                       my @stats = stat($self->_root->{file});
+                       $self->_root->{end} = $stats[7];
+                       
+                       # double-check file inode, in case another process
+                       # has optimize()d our file while we were waiting.
+                       if ($stats[1] != $self->_root->{inode}) {
+                               $self->_open(); # re-open
+                               flock($self->_fh, $type); # re-lock
+                               $self->_root->{end} = (stat($self->_fh))[7]; # re-end
+                       }
+               }
+               $self->_root->{locked}++;
+
+        return 1;
+       }
+
+    return;
+}
+
+sub unlock {
+       ##
+       # If db locking is set, unlock the db file.  See note in lock()
+       # regarding calling lock() multiple times.
+       ##
+    my $self = $_[0]->_get_self;
+
+       if (!defined($self->_fh)) { return; }
+       
+       if ($self->_root->{locking} && $self->_root->{locked} > 0) {
+               $self->_root->{locked}--;
+               if (!$self->_root->{locked}) { flock($self->_fh, LOCK_UN); }
+
+        return 1;
+       }
+
+    return;
+}
+
+sub _copy_value {
+    my $self = shift->_get_self;
+    my ($spot, $value) = @_;
+
+    if ( !ref $value ) {
+        ${$spot} = $value;
+    }
+    elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep::09830' ) } ) {
+        my $type = $value->_type;
+        ${$spot} = $type eq TYPE_HASH ? {} : [];
+        $value->_copy_node( ${$spot} );
+    }
+    else {
+        my $r = Scalar::Util::reftype( $value );
+        my $c = Scalar::Util::blessed( $value );
+        if ( $r eq 'ARRAY' ) {
+            ${$spot} = [ @{$value} ];
+        }
+        else {
+            ${$spot} = { %{$value} };
+        }
+        ${$spot} = bless ${$spot}, $c
+            if defined $c;
+    }
+
+    return 1;
+}
+
+sub _copy_node {
+       ##
+       # Copy single level of keys or elements to new DB handle.
+       # Recurse for nested structures
+       ##
+    my $self = shift->_get_self;
+       my ($db_temp) = @_;
+
+       if ($self->_type eq TYPE_HASH) {
+               my $key = $self->first_key();
+               while ($key) {
+                       my $value = $self->get($key);
+            $self->_copy_value( \$db_temp->{$key}, $value );
+                       $key = $self->next_key($key);
+               }
+       }
+       else {
+               my $length = $self->length();
+               for (my $index = 0; $index < $length; $index++) {
+                       my $value = $self->get($index);
+            $self->_copy_value( \$db_temp->[$index], $value );
+               }
+       }
+
+    return 1;
+}
+
+sub export {
+       ##
+       # Recursively export into standard Perl hashes and arrays.
+       ##
+    my $self = $_[0]->_get_self;
+       
+       my $temp;
+       if ($self->_type eq TYPE_HASH) { $temp = {}; }
+       elsif ($self->_type eq TYPE_ARRAY) { $temp = []; }
+       
+       $self->lock();
+       $self->_copy_node( $temp );
+       $self->unlock();
+       
+       return $temp;
+}
+
+sub import {
+       ##
+       # Recursively import Perl hash/array structure
+       ##
+    #XXX This use of ref() seems to be ok
+       if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
+       
+    my $self = $_[0]->_get_self;
+       my $struct = $_[1];
+       
+    #XXX This use of ref() seems to be ok
+       if (!ref($struct)) {
+               ##
+               # struct is not a reference, so just import based on our type
+               ##
+               shift @_;
+               
+               if ($self->_type eq TYPE_HASH) { $struct = {@_}; }
+               elsif ($self->_type eq TYPE_ARRAY) { $struct = [@_]; }
+       }
+       
+    my $r = Scalar::Util::reftype($struct) || '';
+       if ($r eq "HASH" && $self->_type eq TYPE_HASH) {
+               foreach my $key (keys %$struct) { $self->put($key, $struct->{$key}); }
+       }
+       elsif ($r eq "ARRAY" && $self->_type eq TYPE_ARRAY) {
+               $self->push( @$struct );
+       }
+       else {
+               return $self->_throw_error("Cannot import: type mismatch");
+       }
+       
+       return 1;
+}
+
+sub optimize {
+       ##
+       # Rebuild entire database into new file, then move
+       # it back on top of original.
+       ##
+    my $self = $_[0]->_get_self;
+
+#XXX Need to create a new test for this
+#      if ($self->_root->{links} > 1) {
+#              return $self->_throw_error("Cannot optimize: reference count is greater than 1");
+#      }
+       
+       my $db_temp = DBM::Deep::09830->new(
+               file => $self->_root->{file} . '.tmp',
+               type => $self->_type
+       );
+       if (!$db_temp) {
+               return $self->_throw_error("Cannot optimize: failed to open temp file: $!");
+       }
+       
+       $self->lock();
+       $self->_copy_node( $db_temp );
+       undef $db_temp;
+       
+       ##
+       # Attempt to copy user, group and permissions over to new file
+       ##
+       my @stats = stat($self->_fh);
+       my $perms = $stats[2] & 07777;
+       my $uid = $stats[4];
+       my $gid = $stats[5];
+       chown( $uid, $gid, $self->_root->{file} . '.tmp' );
+       chmod( $perms, $self->_root->{file} . '.tmp' );
+       
+    # q.v. perlport for more information on this variable
+    if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
+               ##
+               # Potential race condition when optmizing on Win32 with locking.
+               # The Windows filesystem requires that the filehandle be closed 
+               # before it is overwritten with rename().  This could be redone
+               # with a soft copy.
+               ##
+               $self->unlock();
+               $self->_close();
+       }
+       
+       if (!rename $self->_root->{file} . '.tmp', $self->_root->{file}) {
+               unlink $self->_root->{file} . '.tmp';
+               $self->unlock();
+               return $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
+       }
+       
+       $self->unlock();
+       $self->_close();
+       $self->_open();
+       
+       return 1;
+}
+
+sub clone {
+       ##
+       # Make copy of object and return
+       ##
+    my $self = $_[0]->_get_self;
+       
+       return DBM::Deep::09830->new(
+               type => $self->_type,
+               base_offset => $self->_base_offset,
+               root => $self->_root
+       );
+}
+
+{
+    my %is_legal_filter = map {
+        $_ => ~~1,
+    } qw(
+        store_key store_value
+        fetch_key fetch_value
+    );
+
+    sub set_filter {
+        ##
+        # Setup filter function for storing or fetching the key or value
+        ##
+        my $self = $_[0]->_get_self;
+        my $type = lc $_[1];
+        my $func = $_[2] ? $_[2] : undef;
+       
+        if ( $is_legal_filter{$type} ) {
+            $self->_root->{"filter_$type"} = $func;
+            return 1;
+        }
+
+        return;
+    }
+}
+
+##
+# Accessor methods
+##
+
+sub _root {
+       ##
+       # Get access to the root structure
+       ##
+    my $self = $_[0]->_get_self;
+       return $self->{root};
+}
+
+sub _fh {
+       ##
+       # Get access to the raw fh
+       ##
+    #XXX It will be useful, though, when we split out HASH and ARRAY
+    my $self = $_[0]->_get_self;
+       return $self->_root->{fh};
+}
+
+sub _type {
+       ##
+       # Get type of current node (TYPE_HASH or TYPE_ARRAY)
+       ##
+    my $self = $_[0]->_get_self;
+       return $self->{type};
+}
+
+sub _base_offset {
+       ##
+       # Get base_offset of current node (TYPE_HASH or TYPE_ARRAY)
+       ##
+    my $self = $_[0]->_get_self;
+       return $self->{base_offset};
+}
+
+sub error {
+       ##
+       # Get last error string, or undef if no error
+       ##
+       return $_[0]
+        ? ( $_[0]->_get_self->{root}->{error} or undef )
+        : $@;
+}
+
+##
+# Utility methods
+##
+
+sub _throw_error {
+       ##
+       # Store error string in self
+       ##
+       my $error_text = $_[1];
+       
+    if ( Scalar::Util::blessed $_[0] ) {
+        my $self = $_[0]->_get_self;
+        $self->_root->{error} = $error_text;
+       
+        unless ($self->_root->{debug}) {
+            die "DBM::Deep::09830: $error_text\n";
+        }
+
+        warn "DBM::Deep::09830: $error_text\n";
+        return;
+    }
+    else {
+        die "DBM::Deep::09830: $error_text\n";
+    }
+}
+
+sub clear_error {
+       ##
+       # Clear error state
+       ##
+    my $self = $_[0]->_get_self;
+       
+       undef $self->_root->{error};
+}
+
+sub _precalc_sizes {
+       ##
+       # Precalculate index, bucket and bucket list sizes
+       ##
+
+    #XXX I don't like this ...
+    set_pack() unless defined $LONG_SIZE;
+
+       $INDEX_SIZE = 256 * $LONG_SIZE;
+       $BUCKET_SIZE = $HASH_SIZE + $LONG_SIZE;
+       $BUCKET_LIST_SIZE = $MAX_BUCKETS * $BUCKET_SIZE;
+}
+
+sub set_pack {
+       ##
+       # Set pack/unpack modes (see file header for more)
+       ##
+    my ($long_s, $long_p, $data_s, $data_p) = @_;
+
+    $LONG_SIZE = $long_s ? $long_s : 4;
+    $LONG_PACK = $long_p ? $long_p : 'N';
+
+    $DATA_LENGTH_SIZE = $data_s ? $data_s : 4;
+    $DATA_LENGTH_PACK = $data_p ? $data_p : 'N';
+
+       _precalc_sizes();
+}
+
+sub set_digest {
+       ##
+       # Set key digest function (default is MD5)
+       ##
+    my ($digest_func, $hash_size) = @_;
+
+    $DIGEST_FUNC = $digest_func ? $digest_func : \&Digest::MD5::md5;
+    $HASH_SIZE = $hash_size ? $hash_size : 16;
+
+       _precalc_sizes();
+}
+
+sub _is_writable {
+    my $fh = shift;
+    (O_WRONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
+}
+
+#sub _is_readable {
+#    my $fh = shift;
+#    (O_RDONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
+#}
+
+##
+# tie() methods (hashes and arrays)
+##
+
+sub STORE {
+       ##
+       # Store single hash key/value or array element in database.
+       ##
+    my $self = $_[0]->_get_self;
+       my $key = $_[1];
+
+    local($/,$\);
+
+    # User may be storing a hash, in which case we do not want it run 
+    # through the filtering system
+       my $value = ($self->_root->{filter_store_value} && !ref($_[2]))
+        ? $self->_root->{filter_store_value}->($_[2])
+        : $_[2];
+       
+       my $md5 = $DIGEST_FUNC->($key);
+       
+       ##
+       # Make sure file is open
+       ##
+       if (!defined($self->_fh) && !$self->_open()) {
+               return;
+       }
+
+    if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
+        $self->_throw_error( 'Cannot write to a readonly filehandle' );
+    }
+       
+       ##
+       # Request exclusive lock for writing
+       ##
+       $self->lock( LOCK_EX );
+       
+       my $fh = $self->_fh;
+       
+       ##
+       # Locate offset for bucket list using digest index system
+       ##
+       my $tag = $self->_load_tag($self->_base_offset);
+       if (!$tag) {
+               $tag = $self->_create_tag($self->_base_offset, SIG_INDEX, chr(0) x $INDEX_SIZE);
+       }
+       
+       my $ch = 0;
+       while ($tag->{signature} ne SIG_BLIST) {
+               my $num = ord(substr($md5, $ch, 1));
+
+        my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
+               my $new_tag = $self->_index_lookup($tag, $num);
+
+               if (!$new_tag) {
+                       seek($fh, $ref_loc + $self->_root->{file_offset}, SEEK_SET);
+                       print( $fh pack($LONG_PACK, $self->_root->{end}) );
+                       
+                       $tag = $self->_create_tag($self->_root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
+
+                       $tag->{ref_loc} = $ref_loc;
+                       $tag->{ch} = $ch;
+
+                       last;
+               }
+               else {
+                       $tag = $new_tag;
+
+                       $tag->{ref_loc} = $ref_loc;
+                       $tag->{ch} = $ch;
+               }
+               $ch++;
+       }
+       
+       ##
+       # Add key/value to bucket list
+       ##
+       my $result = $self->_add_bucket( $tag, $md5, $key, $value );
+       
+       $self->unlock();
+
+       return $result;
+}
+
+sub FETCH {
+       ##
+       # Fetch single value or element given plain key or array index
+       ##
+    my $self = shift->_get_self;
+    my $key = shift;
+
+       ##
+       # Make sure file is open
+       ##
+       if (!defined($self->_fh)) { $self->_open(); }
+       
+       my $md5 = $DIGEST_FUNC->($key);
+
+       ##
+       # Request shared lock for reading
+       ##
+       $self->lock( LOCK_SH );
+       
+       my $tag = $self->_find_bucket_list( $md5 );
+       if (!$tag) {
+               $self->unlock();
+               return;
+       }
+       
+       ##
+       # Get value from bucket list
+       ##
+       my $result = $self->_get_bucket_value( $tag, $md5 );
+       
+       $self->unlock();
+       
+    #XXX What is ref() checking here?
+    #YYY Filters only apply on scalar values, so the ref check is making
+    #YYY sure the fetched bucket is a scalar, not a child hash or array.
+       return ($result && !ref($result) && $self->_root->{filter_fetch_value})
+        ? $self->_root->{filter_fetch_value}->($result)
+        : $result;
+}
+
+sub DELETE {
+       ##
+       # Delete single key/value pair or element given plain key or array index
+       ##
+    my $self = $_[0]->_get_self;
+       my $key = $_[1];
+       
+       my $md5 = $DIGEST_FUNC->($key);
+
+       ##
+       # Make sure file is open
+       ##
+       if (!defined($self->_fh)) { $self->_open(); }
+       
+       ##
+       # Request exclusive lock for writing
+       ##
+       $self->lock( LOCK_EX );
+       
+       my $tag = $self->_find_bucket_list( $md5 );
+       if (!$tag) {
+               $self->unlock();
+               return;
+       }
+       
+       ##
+       # Delete bucket
+       ##
+    my $value = $self->_get_bucket_value( $tag, $md5 );
+       if ($value && !ref($value) && $self->_root->{filter_fetch_value}) {
+        $value = $self->_root->{filter_fetch_value}->($value);
+    }
+
+       my $result = $self->_delete_bucket( $tag, $md5 );
+       
+       ##
+       # If this object is an array and the key deleted was on the end of the stack,
+       # decrement the length variable.
+       ##
+       
+       $self->unlock();
+       
+       return $value;
+}
+
+sub EXISTS {
+       ##
+       # Check if a single key or element exists given plain key or array index
+       ##
+    my $self = $_[0]->_get_self;
+       my $key = $_[1];
+       
+       my $md5 = $DIGEST_FUNC->($key);
+
+       ##
+       # Make sure file is open
+       ##
+       if (!defined($self->_fh)) { $self->_open(); }
+       
+       ##
+       # Request shared lock for reading
+       ##
+       $self->lock( LOCK_SH );
+       
+       my $tag = $self->_find_bucket_list( $md5 );
+       
+       ##
+       # For some reason, the built-in exists() function returns '' for false
+       ##
+       if (!$tag) {
+               $self->unlock();
+               return '';
+       }
+       
+       ##
+       # Check if bucket exists and return 1 or ''
+       ##
+       my $result = $self->_bucket_exists( $tag, $md5 ) || '';
+       
+       $self->unlock();
+       
+       return $result;
+}
+
+sub CLEAR {
+       ##
+       # Clear all keys from hash, or all elements from array.
+       ##
+    my $self = $_[0]->_get_self;
+
+       ##
+       # Make sure file is open
+       ##
+       if (!defined($self->_fh)) { $self->_open(); }
+       
+       ##
+       # Request exclusive lock for writing
+       ##
+       $self->lock( LOCK_EX );
+       
+    my $fh = $self->_fh;
+
+       seek($fh, $self->_base_offset + $self->_root->{file_offset}, SEEK_SET);
+       if (eof $fh) {
+               $self->unlock();
+               return;
+       }
+       
+       $self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE);
+       
+       $self->unlock();
+       
+       return 1;
+}
+
+##
+# Public method aliases
+##
+sub put { (shift)->STORE( @_ ) }
+sub store { (shift)->STORE( @_ ) }
+sub get { (shift)->FETCH( @_ ) }
+sub fetch { (shift)->FETCH( @_ ) }
+sub delete { (shift)->DELETE( @_ ) }
+sub exists { (shift)->EXISTS( @_ ) }
+sub clear { (shift)->CLEAR( @_ ) }
+
+package DBM::Deep::09830::_::Root;
+
+sub new {
+    my $class = shift;
+    my ($args) = @_;
+
+    my $self = bless {
+        file => undef,
+        fh => undef,
+        file_offset => 0,
+        end => 0,
+        autoflush => undef,
+        locking => undef,
+        debug => undef,
+        filter_store_key => undef,
+        filter_store_value => undef,
+        filter_fetch_key => undef,
+        filter_fetch_value => undef,
+        autobless => undef,
+        locked => 0,
+        %$args,
+    }, $class;
+
+    if ( $self->{fh} && !$self->{file_offset} ) {
+        $self->{file_offset} = tell( $self->{fh} );
+    }
+
+    return $self;
+}
+
+sub DESTROY {
+    my $self = shift;
+    return unless $self;
+
+    close $self->{fh} if $self->{fh};
+
+    return;
+}
+
+package DBM::Deep::09830::Array;
+
+use strict;
+
+# This is to allow DBM::Deep::Array to handle negative indices on
+# its own. Otherwise, Perl would intercept the call to negative
+# indices for us. This was causing bugs for negative index handling.
+use vars qw( $NEGATIVE_INDICES );
+$NEGATIVE_INDICES = 1;
+
+use base 'DBM::Deep::09830';
+
+use Scalar::Util ();
+
+sub _get_self {
+    eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0]
+}
+
+sub TIEARRAY {
+##
+# Tied array constructor method, called by Perl's tie() function.
+##
+    my $class = shift;
+    my $args = $class->_get_args( @_ );
+       
+       $args->{type} = $class->TYPE_ARRAY;
+       
+       return $class->_init($args);
+}
+
+sub FETCH {
+    my $self = $_[0]->_get_self;
+    my $key = $_[1];
+
+       $self->lock( $self->LOCK_SH );
+       
+    if ( $key =~ /^-?\d+$/ ) {
+        if ( $key < 0 ) {
+            $key += $self->FETCHSIZE;
+            unless ( $key >= 0 ) {
+                $self->unlock;
+                return;
+            }
+        }
+
+        $key = pack($DBM::Deep::09830::LONG_PACK, $key);
+    }
+
+    my $rv = $self->SUPER::FETCH( $key );
+
+    $self->unlock;
+
+    return $rv;
+}
+
+sub STORE {
+    my $self = shift->_get_self;
+    my ($key, $value) = @_;
+
+    $self->lock( $self->LOCK_EX );
+
+    my $orig = $key;
+
+    my $size;
+    my $numeric_idx;
+    if ( $key =~ /^\-?\d+$/ ) {
+        $numeric_idx = 1;
+        if ( $key < 0 ) {
+            $size = $self->FETCHSIZE;
+            $key += $size;
+            if ( $key < 0 ) {
+                die( "Modification of non-creatable array value attempted, subscript $orig" );
+            }
+        }
+
+        $key = pack($DBM::Deep::09830::LONG_PACK, $key);
+    }
+
+    my $rv = $self->SUPER::STORE( $key, $value );
+
+    if ( $numeric_idx && $rv == 2 ) {
+        $size = $self->FETCHSIZE unless defined $size;
+        if ( $orig >= $size ) {
+            $self->STORESIZE( $orig + 1 );
+        }
+    }
+
+    $self->unlock;
+
+    return $rv;
+}
+
+sub EXISTS {
+    my $self = $_[0]->_get_self;
+    my $key = $_[1];
+
+       $self->lock( $self->LOCK_SH );
+
+    if ( $key =~ /^\-?\d+$/ ) {
+        if ( $key < 0 ) {
+            $key += $self->FETCHSIZE;
+            unless ( $key >= 0 ) {
+                $self->unlock;
+                return;
+            }
+        }
+
+        $key = pack($DBM::Deep::09830::LONG_PACK, $key);
+    }
+
+    my $rv = $self->SUPER::EXISTS( $key );
+
+    $self->unlock;
+
+    return $rv;
+}
+
+sub DELETE {
+    my $self = $_[0]->_get_self;
+    my $key = $_[1];
+
+    my $unpacked_key = $key;
+
+    $self->lock( $self->LOCK_EX );
+
+    my $size = $self->FETCHSIZE;
+    if ( $key =~ /^-?\d+$/ ) {
+        if ( $key < 0 ) {
+            $key += $size;
+            unless ( $key >= 0 ) {
+                $self->unlock;
+                return;
+            }
+        }
+
+        $key = pack($DBM::Deep::09830::LONG_PACK, $key);
+    }
+
+    my $rv = $self->SUPER::DELETE( $key );
+
+       if ($rv && $unpacked_key == $size - 1) {
+               $self->STORESIZE( $unpacked_key );
+       }
+
+    $self->unlock;
+
+    return $rv;
+}
+
+sub FETCHSIZE {
+       ##
+       # Return the length of the array
+       ##
+    my $self = shift->_get_self;
+
+    $self->lock( $self->LOCK_SH );
+
+       my $SAVE_FILTER = $self->_root->{filter_fetch_value};
+       $self->_root->{filter_fetch_value} = undef;
+       
+       my $packed_size = $self->FETCH('length');
+       
+       $self->_root->{filter_fetch_value} = $SAVE_FILTER;
+       
+    $self->unlock;
+
+       if ($packed_size) {
+        return int(unpack($DBM::Deep::09830::LONG_PACK, $packed_size));
+    }
+
+       return 0;
+}
+
+sub STORESIZE {
+       ##
+       # Set the length of the array
+       ##
+    my $self = $_[0]->_get_self;
+       my $new_length = $_[1];
+       
+    $self->lock( $self->LOCK_EX );
+
+       my $SAVE_FILTER = $self->_root->{filter_store_value};
+       $self->_root->{filter_store_value} = undef;
+       
+       my $result = $self->STORE('length', pack($DBM::Deep::09830::LONG_PACK, $new_length));
+       
+       $self->_root->{filter_store_value} = $SAVE_FILTER;
+       
+    $self->unlock;
+
+       return $result;
+}
+
+sub POP {
+       ##
+       # Remove and return the last element on the array
+       ##
+    my $self = $_[0]->_get_self;
+
+    $self->lock( $self->LOCK_EX );
+
+       my $length = $self->FETCHSIZE();
+       
+       if ($length) {
+               my $content = $self->FETCH( $length - 1 );
+               $self->DELETE( $length - 1 );
+
+        $self->unlock;
+
+               return $content;
+       }
+       else {
+        $self->unlock;
+               return;
+       }
+}
+
+sub PUSH {
+       ##
+       # Add new element(s) to the end of the array
+       ##
+    my $self = shift->_get_self;
+       
+    $self->lock( $self->LOCK_EX );
+
+       my $length = $self->FETCHSIZE();
+
+       while (my $content = shift @_) {
+               $self->STORE( $length, $content );
+               $length++;
+       }
+
+    $self->unlock;
+
+    return $length;
+}
+
+sub SHIFT {
+       ##
+       # Remove and return first element on the array.
+       # Shift over remaining elements to take up space.
+       ##
+    my $self = $_[0]->_get_self;
+
+    $self->lock( $self->LOCK_EX );
+
+       my $length = $self->FETCHSIZE();
+       
+       if ($length) {
+               my $content = $self->FETCH( 0 );
+               
+               ##
+               # Shift elements over and remove last one.
+               ##
+               for (my $i = 0; $i < $length - 1; $i++) {
+                       $self->STORE( $i, $self->FETCH($i + 1) );
+               }
+               $self->DELETE( $length - 1 );
+
+        $self->unlock;
+               
+               return $content;
+       }
+       else {
+        $self->unlock;
+               return;
+       }
+}
+
+sub UNSHIFT {
+       ##
+       # Insert new element(s) at beginning of array.
+       # Shift over other elements to make space.
+       ##
+    my $self = shift->_get_self;
+       my @new_elements = @_;
+
+    $self->lock( $self->LOCK_EX );
+
+       my $length = $self->FETCHSIZE();
+       my $new_size = scalar @new_elements;
+       
+       if ($length) {
+               for (my $i = $length - 1; $i >= 0; $i--) {
+                       $self->STORE( $i + $new_size, $self->FETCH($i) );
+               }
+       }
+       
+       for (my $i = 0; $i < $new_size; $i++) {
+               $self->STORE( $i, $new_elements[$i] );
+       }
+
+    $self->unlock;
+
+    return $length + $new_size;
+}
+
+sub SPLICE {
+       ##
+       # Splices section of array with optional new section.
+       # Returns deleted section, or last element deleted in scalar context.
+       ##
+    my $self = shift->_get_self;
+
+    $self->lock( $self->LOCK_EX );
+
+       my $length = $self->FETCHSIZE();
+       
+       ##
+       # Calculate offset and length of splice
+       ##
+       my $offset = shift;
+    $offset = 0 unless defined $offset;
+       if ($offset < 0) { $offset += $length; }
+       
+       my $splice_length;
+       if (scalar @_) { $splice_length = shift; }
+       else { $splice_length = $length - $offset; }
+       if ($splice_length < 0) { $splice_length += ($length - $offset); }
+       
+       ##
+       # Setup array with new elements, and copy out old elements for return
+       ##
+       my @new_elements = @_;
+       my $new_size = scalar @new_elements;
+       
+    my @old_elements = map {
+        $self->FETCH( $_ )
+    } $offset .. ($offset + $splice_length - 1);
+       
+       ##
+       # Adjust array length, and shift elements to accomodate new section.
+       ##
+    if ( $new_size != $splice_length ) {
+        if ($new_size > $splice_length) {
+            for (my $i = $length - 1; $i >= $offset + $splice_length; $i--) {
+                $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
+            }
+        }
+        else {
+            for (my $i = $offset + $splice_length; $i < $length; $i++) {
+                $self->STORE( $i + ($new_size - $splice_length), $self->FETCH($i) );
+            }
+            for (my $i = 0; $i < $splice_length - $new_size; $i++) {
+                $self->DELETE( $length - 1 );
+                $length--;
+            }
+        }
+       }
+       
+       ##
+       # Insert new elements into array
+       ##
+       for (my $i = $offset; $i < $offset + $new_size; $i++) {
+               $self->STORE( $i, shift @new_elements );
+       }
+       
+    $self->unlock;
+
+       ##
+       # Return deleted section, or last element in scalar context.
+       ##
+       return wantarray ? @old_elements : $old_elements[-1];
+}
+
+sub EXTEND {
+       ##
+       # Perl will call EXTEND() when the array is likely to grow.
+       # We don't care, but include it for compatibility.
+       ##
+}
+
+##
+# Public method aliases
+##
+*length = *FETCHSIZE;
+*pop = *POP;
+*push = *PUSH;
+*shift = *SHIFT;
+*unshift = *UNSHIFT;
+*splice = *SPLICE;
+
+package DBM::Deep::09830::Hash;
+
+use strict;
+
+use base 'DBM::Deep::09830';
+
+sub _get_self {
+    eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0]
+}
+
+sub TIEHASH {
+    ##
+    # Tied hash constructor method, called by Perl's tie() function.
+    ##
+    my $class = shift;
+    my $args = $class->_get_args( @_ );
+    
+    $args->{type} = $class->TYPE_HASH;
+
+    return $class->_init($args);
+}
+
+sub FETCH {
+    my $self = shift->_get_self;
+    my $key = ($self->_root->{filter_store_key})
+        ? $self->_root->{filter_store_key}->($_[0])
+        : $_[0];
+
+    return $self->SUPER::FETCH( $key );
+}
+
+sub STORE {
+    my $self = shift->_get_self;
+       my $key = ($self->_root->{filter_store_key})
+        ? $self->_root->{filter_store_key}->($_[0])
+        : $_[0];
+    my $value = $_[1];
+
+    return $self->SUPER::STORE( $key, $value );
+}
+
+sub EXISTS {
+    my $self = shift->_get_self;
+       my $key = ($self->_root->{filter_store_key})
+        ? $self->_root->{filter_store_key}->($_[0])
+        : $_[0];
+
+    return $self->SUPER::EXISTS( $key );
+}
+
+sub DELETE {
+    my $self = shift->_get_self;
+       my $key = ($self->_root->{filter_store_key})
+        ? $self->_root->{filter_store_key}->($_[0])
+        : $_[0];
+
+    return $self->SUPER::DELETE( $key );
+}
+
+sub FIRSTKEY {
+       ##
+       # Locate and return first key (in no particular order)
+       ##
+    my $self = $_[0]->_get_self;
+
+       ##
+       # Make sure file is open
+       ##
+       if (!defined($self->_fh)) { $self->_open(); }
+       
+       ##
+       # Request shared lock for reading
+       ##
+       $self->lock( $self->LOCK_SH );
+       
+       my $result = $self->_get_next_key();
+       
+       $self->unlock();
+       
+       return ($result && $self->_root->{filter_fetch_key})
+        ? $self->_root->{filter_fetch_key}->($result)
+        : $result;
+}
+
+sub NEXTKEY {
+       ##
+       # Return next key (in no particular order), given previous one
+       ##
+    my $self = $_[0]->_get_self;
+
+       my $prev_key = ($self->_root->{filter_store_key})
+        ? $self->_root->{filter_store_key}->($_[1])
+        : $_[1];
+
+       my $prev_md5 = $DBM::Deep::09830::DIGEST_FUNC->($prev_key);
+
+       ##
+       # Make sure file is open
+       ##
+       if (!defined($self->_fh)) { $self->_open(); }
+       
+       ##
+       # Request shared lock for reading
+       ##
+       $self->lock( $self->LOCK_SH );
+       
+       my $result = $self->_get_next_key( $prev_md5 );
+       
+       $self->unlock();
+       
+       return ($result && $self->_root->{filter_fetch_key})
+        ? $self->_root->{filter_fetch_key}->($result)
+        : $result;
+}
+
+##
+# Public method aliases
+##
+*first_key = *FIRSTKEY;
+*next_key = *NEXTKEY;
+
+1;
+__END__
index 1a37be0..bbd9586 100755 (executable)
@@ -56,7 +56,7 @@ my %db;
   }
 
   my $mod = $headerver_to_module{ $ver };
-  require $mod;
+  eval "use $mod;";
   $db{input} = $mod->new({
     file      => $opts{input},
     locking   => 1,
@@ -81,11 +81,11 @@ my %db;
   }
 
   if ( $is_dev{ $ver } ) {
-    _exit( "'$opts{version}' is a dev release and not supported." );
+    _exit( "-version '$opts{version}' is a dev release and not supported." );
   }
 
   my $mod = $headerver_to_module{ $ver };
-  require $mod;
+  eval "use $mod;";
   $db{output} = $mod->new({
     file      => $opts{output},
     locking   => 1,