From: rkinyon Date: Tue, 25 Apr 2006 14:55:16 +0000 (+0000) Subject: Minor fixes, including removing the ==2/1 from add_bucket() X-Git-Tag: 0-99_01~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=86867f3a6f23efdf7c7290f5a0b7a69f5f39834f;p=dbsrgits%2FDBM-Deep.git Minor fixes, including removing the ==2/1 from add_bucket() --- diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 7c83413..75aee67 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -34,6 +34,8 @@ use 5.6.0; use strict; use warnings; +our $VERSION = q(0.99_01); + use Fcntl qw( :DEFAULT :flock :seek ); use Digest::MD5 (); use Scalar::Util (); @@ -41,14 +43,11 @@ use Scalar::Util (); use DBM::Deep::Engine; use DBM::Deep::File; -use vars qw( $VERSION ); -$VERSION = q(0.99_01); - ## # Setup constants for users to pass to new() ## -sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH } -sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY } +sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH } +sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY } sub _get_args { my $proto = shift; @@ -478,11 +477,11 @@ sub STORE { ## # Add key/value to bucket list ## - my $result = $self->{engine}->add_bucket( $tag, $md5, $key, $value, undef, $orig_key ); + $self->{engine}->add_bucket( $tag, $md5, $key, $value, undef, $orig_key ); $self->unlock(); - return $result; + return 1; } sub FETCH { diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index fd161be..65af4a7 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -5,6 +5,8 @@ use 5.6.0; use strict; use warnings; +our $VERSION = '0.99_01'; + # 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. @@ -95,7 +97,7 @@ sub STORE { my $rv = $self->SUPER::STORE( $key, $value, $orig_key ); - if ( $numeric_idx && $rv == 2 ) { + if ( $numeric_idx ) { $size = $self->FETCHSIZE unless defined $size; if ( $orig_key >= $size ) { $self->STORESIZE( $orig_key + 1 ); diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index 9538027..0ceb233 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -5,6 +5,8 @@ use 5.6.0; use strict; use warnings; +our $VERSION = q(0.99_01); + use Fcntl qw( :DEFAULT :flock ); use Scalar::Util (); @@ -27,6 +29,7 @@ sub SIG_DATA () { 'D' } sub SIG_INDEX () { 'I' } sub SIG_BLIST () { 'B' } sub SIG_FREE () { 'F' } +sub SIG_KEYS () { 'K' } sub SIG_SIZE () { 1 } sub new { @@ -34,16 +37,16 @@ sub new { my ($args) = @_; my $self = bless { - long_size => 4, - long_pack => 'N', - data_size => 4, - data_pack => 'N', + long_size => 4, + long_pack => 'N', + data_size => 4, + data_pack => 'N', - digest => \&Digest::MD5::md5, - hash_size => 16, + digest => \&Digest::MD5::md5, + hash_size => 16, ## - # Maximum number of buckets per list before another level of indexing is + # Maximum number of buckets per blist 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. @@ -250,9 +253,9 @@ sub write_tag { return { signature => $sig, - size => $size, - offset => $offset + SIG_SIZE + $self->{data_size}, - content => $content + size => $size, + offset => $offset + SIG_SIZE + $self->{data_size}, + content => $content }; } @@ -265,105 +268,19 @@ sub load_tag { my $fileobj = $self->_fileobj; - my $s = SIG_SIZE + $self->{data_size}; - my $b = $fileobj->read_at( $offset, $s ); - my ($sig, $size) = unpack( "A $self->{data_pack}", $b ); - - my $buffer = $fileobj->read_at( undef, $size ); + my ($sig, $size) = unpack( + "A $self->{data_pack}", + $fileobj->read_at( $offset, SIG_SIZE + $self->{data_size} ), + ); return { signature => $sig, - size => $size, - offset => $offset + SIG_SIZE + $self->{data_size}, - content => $buffer + size => $size, + offset => $offset + SIG_SIZE + $self->{data_size}, + content => $fileobj->read_at( undef, $size ), }; } -sub _get_dbm_object { - my $item = shift; - - my $obj = eval { - local $SIG{__DIE__}; - if ($item->isa( 'DBM::Deep' )) { - return $item; - } - return; - }; - return $obj if $obj; - - my $r = Scalar::Util::reftype( $item ) || ''; - if ( $r eq 'HASH' ) { - my $obj = eval { - local $SIG{__DIE__}; - my $obj = tied(%$item); - if ($obj->isa( 'DBM::Deep' )) { - return $obj; - } - return; - }; - return $obj if $obj; - } - elsif ( $r eq 'ARRAY' ) { - my $obj = eval { - local $SIG{__DIE__}; - my $obj = tied(@$item); - if ($obj->isa( 'DBM::Deep' )) { - return $obj; - } - return; - }; - return $obj if $obj; - } - - return; -} - -sub _length_needed { - my $self = shift; - my ($value, $key) = @_; - - my $is_dbm_deep = eval { - local $SIG{'__DIE__'}; - $value->isa( 'DBM::Deep' ); - }; - - my $len = SIG_SIZE - + $self->{data_size} # size for value - + $self->{data_size} # size for key - + length( $key ); # length of key - - if ( $is_dbm_deep && $value->_fileobj eq $self->_fileobj ) { - # long_size is for the internal reference - return $len + $self->{long_size}; - } - - if ( $self->_fileobj->{autobless} ) { - # This is for the bit saying whether or not this thing is blessed. - $len += 1; - } - - my $r = Scalar::Util::reftype( $value ) || ''; - unless ( $r eq 'HASH' || $r eq 'ARRAY' ) { - if ( defined $value ) { - $len += length( $value ); - } - return $len; - } - - $len += $self->{index_size}; - - # if autobless is enabled, must also take into consideration - # the class name as it is stored after the key. - if ( $self->_fileobj->{autobless} ) { - my $c = Scalar::Util::blessed($value); - if ( defined $c && !$is_dbm_deep ) { - $len += $self->{data_size} + length($c); - } - } - - return $len; -} - sub add_bucket { ## # Adds one key/value pair to bucket list, given offset, MD5 digest of key, @@ -373,24 +290,19 @@ sub add_bucket { my ($tag, $md5, $plain_key, $value, $deleted, $orig_key) = @_; $deleted ||= 0; - local($/,$\); - # This verifies that only supported values will be stored. { my $r = Scalar::Util::reftype( $value ); - last if !defined $r; + 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." + "Storage of references of type '$r' is not supported." ); } - my $location = 0; - my $result = 2; - my $fileobj = $self->_fileobj; my $actual_length = $self->_length_needed( $value, $plain_key ); @@ -406,9 +318,8 @@ sub add_bucket { # $self->_release_space( $size, $subloc ); # Updating a known md5 #XXX This needs updating to use _release_space + my $location; if ( $subloc ) { - $result = 1; - if ($actual_length <= $size) { $location = $subloc; } @@ -451,14 +362,15 @@ sub add_bucket { $tag = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} ); } # If bucket didn't fit into list, split into a new index level - # split_index() will do the _fileobj->request_space() call + # split_index() will do the $self->_fileobj->request_space() call + #XXX It also needs to be transactionally aware else { $location = $self->split_index( $md5, $tag ); } $self->write_value( $location, $plain_key, $value, $orig_key ); - return $result; + return 1; } sub write_value { @@ -664,16 +576,15 @@ sub read_from_loc { if ($size) { $fileobj->increment_pointer( $size ); } my $bless_bit = $fileobj->read_at( undef, 1 ); - if (ord($bless_bit)) { - ## - # Yes, object needs to be re-blessed - ## - my $size = $fileobj->read_at( undef, $self->{data_size} ); - $size = unpack($self->{data_pack}, $size); + if ( ord($bless_bit) ) { + my $size = unpack( + $self->{data_pack}, + $fileobj->read_at( undef, $self->{data_size} ), + ); - my $class_name; - if ($size) { $class_name = $fileobj->read_at( undef, $size ); } - if (defined $class_name) { $new_obj = bless( $new_obj, $class_name ); } + if ( $size ) { + $new_obj = bless $new_obj, $fileobj->read_at( undef, $size ); + } } } @@ -699,8 +610,7 @@ sub read_from_loc { my $size = $fileobj->read_at( undef, $self->{data_size} ); $size = unpack($self->{data_pack}, $size); - my $value = ''; - if ($size) { $value = $fileobj->read_at( undef, $size ); } + my $value = $size ? $fileobj->read_at( undef, $size ) : ''; return $value; } @@ -797,8 +707,6 @@ sub find_bucket_list { my ($offset, $md5, $args) = @_; $args = {} unless $args; - local($/,$\); - ## # Locate offset for bucket list using digest index system ## @@ -935,9 +843,9 @@ sub traverse_index { # Read in plain key and return as scalar $size = $fileobj->read_at( undef, $self->{data_size} ); $size = unpack($self->{data_pack}, $size); + my $plain_key; if ($size) { $plain_key = $fileobj->read_at( undef, $size); } - return $plain_key; } } @@ -1046,5 +954,90 @@ sub _throw_error { die "DBM::Deep: $_[1]\n"; } +sub _get_dbm_object { + my $item = shift; + + my $obj = eval { + local $SIG{__DIE__}; + if ($item->isa( 'DBM::Deep' )) { + return $item; + } + return; + }; + return $obj if $obj; + + my $r = Scalar::Util::reftype( $item ) || ''; + if ( $r eq 'HASH' ) { + my $obj = eval { + local $SIG{__DIE__}; + my $obj = tied(%$item); + if ($obj->isa( 'DBM::Deep' )) { + return $obj; + } + return; + }; + return $obj if $obj; + } + elsif ( $r eq 'ARRAY' ) { + my $obj = eval { + local $SIG{__DIE__}; + my $obj = tied(@$item); + if ($obj->isa( 'DBM::Deep' )) { + return $obj; + } + return; + }; + return $obj if $obj; + } + + return; +} + +sub _length_needed { + my $self = shift; + my ($value, $key) = @_; + + my $is_dbm_deep = eval { + local $SIG{'__DIE__'}; + $value->isa( 'DBM::Deep' ); + }; + + my $len = SIG_SIZE + + $self->{data_size} # size for value + + $self->{data_size} # size for key + + length( $key ); # length of key + + if ( $is_dbm_deep && $value->_fileobj eq $self->_fileobj ) { + # long_size is for the internal reference + return $len + $self->{long_size}; + } + + if ( $self->_fileobj->{autobless} ) { + # This is for the bit saying whether or not this thing is blessed. + $len += 1; + } + + my $r = Scalar::Util::reftype( $value ) || ''; + unless ( $r eq 'HASH' || $r eq 'ARRAY' ) { + if ( defined $value ) { + $len += length( $value ); + } + return $len; + } + + $len += $self->{index_size}; + + # if autobless is enabled, must also take into consideration + # the class name as it is stored after the key. + if ( $self->_fileobj->{autobless} ) { + my $c = Scalar::Util::blessed($value); + if ( defined $c && !$is_dbm_deep ) { + $len += $self->{data_size} + length($c); + } + } + + return $len; +} + 1; __END__ diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm index 3fcf9d0..72c2540 100644 --- a/lib/DBM/Deep/File.pm +++ b/lib/DBM/Deep/File.pm @@ -5,9 +5,9 @@ use 5.6.0; use strict; use warnings; -use Fcntl qw( :DEFAULT :flock :seek ); +our $VERSION = q(0.99_01); -our $VERSION = '0.01'; +use Fcntl qw( :DEFAULT :flock :seek ); sub new { my $class = shift; diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index 6957be8..a86ac10 100644 --- a/lib/DBM/Deep/Hash.pm +++ b/lib/DBM/Deep/Hash.pm @@ -5,6 +5,8 @@ use 5.6.0; use strict; use warnings; +our $VERSION = q(0.99_01); + use base 'DBM::Deep'; sub _get_self { diff --git a/t/03_bighash.t b/t/03_bighash.t index b7d46f7..8aff353 100644 --- a/t/03_bighash.t +++ b/t/03_bighash.t @@ -2,7 +2,8 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 4; +use Test::More tests => 5; +use Test::Deep; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); @@ -10,7 +11,7 @@ use_ok( 'DBM::Deep' ); my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new( file => $filename, - type => DBM::Deep->TYPE_HASH + type => DBM::Deep->TYPE_HASH, ); ## @@ -31,6 +32,11 @@ for ( 0 .. $max_keys ) { } is( $count, $max_keys, "We read $count keys" ); -cmp_ok( scalar(keys %$db), '==', $max_keys + 1, "Number of keys is correct" ); + +my @keys = sort keys %$db; +cmp_ok( scalar(@keys), '==', $max_keys + 1, "Number of keys is correct" ); +my @control = sort map { "hello $_" } 0 .. $max_keys; +cmp_deeply( \@keys, \@control, "Correct keys are there" ); + $db->clear; cmp_ok( scalar(keys %$db), '==', 0, "Number of keys after clear() is correct" ); diff --git a/t/26_scalar_ref.t b/t/26_scalar_ref.t index 71109a0..d04b439 100644 --- a/t/26_scalar_ref.t +++ b/t/26_scalar_ref.t @@ -14,22 +14,22 @@ my $x = 25; throws_ok { $db->{scalarref} = \$x; - } qr/Storage of variables of type 'SCALAR' is not supported/, + } qr/Storage of references of type 'SCALAR' is not supported/, 'Storage of scalar refs not supported'; throws_ok { $db->{scalarref} = \\$x; - } qr/Storage of variables of type 'REF' is not supported/, + } qr/Storage of references of type 'REF' is not supported/, 'Storage of ref refs not supported'; throws_ok { $db->{scalarref} = sub { 1 }; - } qr/Storage of variables of type 'CODE' is not supported/, + } qr/Storage of references of type 'CODE' is not supported/, 'Storage of code refs not supported'; throws_ok { $db->{scalarref} = $db->_get_self->_fh; - } qr/Storage of variables of type 'GLOB' is not supported/, + } qr/Storage of references of type 'GLOB' is not supported/, 'Storage of glob refs not supported'; $db->{scalar} = $x; diff --git a/t/30_already_tied.t b/t/30_already_tied.t index cc5e551..7305f64 100644 --- a/t/30_already_tied.t +++ b/t/30_already_tied.t @@ -72,4 +72,4 @@ my $db = DBM::Deep->new( $filename ); throws_ok { $db->{foo} = \$scalar; -} qr/Storage of variables of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars"; +} qr/Storage of references of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars";