From: rkinyon Date: Tue, 14 Mar 2006 15:05:10 +0000 (+0000) Subject: Removed some dependencies on ->_type, instead moving them into the appropriate child... X-Git-Tag: 0-99_01~60 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f9c3318778fb8f7926ec199c81f6278b2052c2ac;p=dbsrgits%2FDBM-Deep.git Removed some dependencies on ->_type, instead moving them into the appropriate child classes --- diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 8171d60..5bb3beb 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -209,8 +209,7 @@ sub _copy_value { ${$spot} = $value; } elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep' ) } ) { - my $type = $value->_type; - ${$spot} = $type eq TYPE_HASH ? {} : []; + ${$spot} = $value->_repr; $value->_copy_node( ${$spot} ); } else { @@ -230,30 +229,11 @@ sub _copy_value { } 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 ); - } - } + die "Must be implemented in a child class\n"; +} - return 1; +sub _repr { + die "Must be implemented in a child class\n"; } sub export { @@ -262,9 +242,7 @@ sub export { ## my $self = shift->_get_self; - my $temp; - if ($self->_type eq TYPE_HASH) { $temp = {}; } - elsif ($self->_type eq TYPE_ARRAY) { $temp = []; } + my $temp = $self->_repr; $self->lock(); $self->_copy_node( $temp ); @@ -284,22 +262,10 @@ sub import { # struct is not a reference, so just import based on our type if (!ref($struct)) { - 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 { - $self->_throw_error("Cannot import: type mismatch"); + $struct = $self->_repr( @_ ); } - return 1; + return $self->_import( $struct ); } sub optimize { @@ -622,6 +588,7 @@ sub CLEAR { return; } +#XXX This needs updating to use _release_space $self->{engine}->write_tag( $self, $self->_base_offset, $self->_type, chr(0)x$self->{engine}{index_size}, diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index a623a69..586fab9 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -16,6 +16,21 @@ sub _get_self { eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0] } +sub _repr { shift;[ @_ ] } + +sub _import { + my $self = shift; + my ($struct) = @_; + + eval { + local $SIG{'__DIE__'}; + $self->push( @$struct ); + }; if ($@) { + $self->_throw_error("Cannot import: type mismatch"); + } + + return 1; +} sub TIEARRAY { ## # Tied array constructor method, called by Perl's tie() function. @@ -373,15 +388,31 @@ sub SPLICE { ## #} +sub _copy_node { + my $self = shift->_get_self; + my ($db_temp) = @_; + + 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; +} + ## # Public method aliases ## -sub length { (CORE::shift)->FETCHSIZE(@_) } -sub pop { (CORE::shift)->POP(@_) } -sub push { (CORE::shift)->PUSH(@_) } +sub length { (shift)->FETCHSIZE(@_) } +sub pop { (shift)->POP(@_) } +sub push { (shift)->PUSH(@_) } +sub unshift { (shift)->UNSHIFT(@_) } +sub splice { (shift)->SPLICE(@_) } + +# This must be last otherwise we have to qualify all other calls to shift +# as calls to CORE::shift sub shift { (CORE::shift)->SHIFT(@_) } -sub unshift { (CORE::shift)->UNSHIFT(@_) } -sub splice { (CORE::shift)->SPLICE(@_) } 1; __END__ diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index cff3923..ad75d91 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -353,7 +353,9 @@ sub add_bucket { my ($subloc, $offset, $size) = $self->_find_in_buckets( $tag, $md5 ); +# $self->_release_space( $obj, $size, $subloc ); # Updating a known md5 +#XXX This needs updating to use _release_space if ( $subloc ) { $result = 1; @@ -381,11 +383,9 @@ sub add_bucket { print( $fh pack($self->{long_pack}, $actual_length ) ); } # If bucket didn't fit into list, split into a new index level + # split_index() will do the _request_space() call else { -#XXX This is going to be a problem. - $self->split_index( $obj, $md5, $tag ); - - $location = $self->_request_space( $obj, $actual_length ); + $location = $self->split_index( $obj, $md5, $tag ); } $self->write_value( $obj, $location, $plain_key, $value ); @@ -405,7 +405,7 @@ sub write_value { $value->isa( 'DBM::Deep' ); }; - my $internal_ref = $is_dbm_deep && ($value->_root eq $root); + my $is_internal_ref = $is_dbm_deep && ($value->_root eq $root); seek($fh, $location + $root->{file_offset}, SEEK_SET); @@ -414,7 +414,7 @@ sub write_value { # actual value. ## my $r = Scalar::Util::reftype($value) || ''; - if ( $internal_ref ) { + if ( $is_internal_ref ) { $self->write_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $value->_base_offset) ); } elsif ($r eq 'HASH') { @@ -436,7 +436,7 @@ sub write_value { print( $fh pack($self->{data_pack}, length($key)) . $key ); # Internal references don't care about autobless - return 1 if $internal_ref; + return 1 if $is_internal_ref; ## # If value is blessed, preserve class name @@ -456,7 +456,7 @@ sub write_value { # If content is a hash or array, create new child DBM::Deep object and # pass each key or element to it. ## - if ( !$internal_ref ) { + if ( !$is_internal_ref ) { if ($r eq 'HASH') { my $branch = DBM::Deep->new( type => DBM::Deep->TYPE_HASH, @@ -503,30 +503,36 @@ sub split_index { chr(0)x$self->{index_size}, ); - my @offsets = (); + my $newtag_loc = $self->_request_space( + $obj, $self->tag_size( $self->{bucket_list_size} ), + ); my $keys = $tag->{content} - . $md5 . (pack($self->{long_pack}, 0) x 2); + . $md5 . pack($self->{long_pack}, $newtag_loc) + . pack($self->{long_pack}, 0); + my @newloc = (); BUCKET: for (my $i = 0; $i <= $self->{max_buckets}; $i++) { my ($key, $old_subloc, $size) = $self->_get_key_subloc( $keys, $i ); - next BUCKET unless $key; + die "[INTERNAL ERROR]: No key in split_index()\n" unless $key; + die "[INTERNAL ERROR]: No subloc in split_index()\n" unless $old_subloc; my $num = ord(substr($key, $tag->{ch} + 1, 1)); - if ($offsets[$num]) { - seek($fh, $offsets[$num] + $root->{file_offset}, SEEK_SET); + if ($newloc[$num]) { + seek($fh, $newloc[$num] + $root->{file_offset}, SEEK_SET); my $subkeys; read( $fh, $subkeys, $self->{bucket_list_size}); + # This is looking for the first empty spot my ($subloc, $offset, $size) = $self->_find_in_buckets( - { content => $subkeys }, '' + { content => $subkeys }, '', ); - seek($fh, $offsets[$num] + $offset + $root->{file_offset}, SEEK_SET); - print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) ); + seek($fh, $newloc[$num] + $offset + $root->{file_offset}, SEEK_SET); + print( $fh $key . pack($self->{long_pack}, $old_subloc) ); next; } @@ -545,17 +551,17 @@ sub split_index { ); seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET); - print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) ); + print( $fh $key . pack($self->{long_pack}, $old_subloc) ); - $offsets[$num] = $blist_tag->{offset}; + $newloc[$num] = $blist_tag->{offset}; } $self->_release_space( - $obj, $self->tag_size( $self->{index_size} ), + $obj, $self->tag_size( $self->{bucket_list_size} ), $tag->{offset} - SIG_SIZE - $self->{data_size}, ); - return; + return $newtag_loc; } sub read_from_loc { @@ -664,6 +670,7 @@ sub delete_bucket { my ($obj, $tag, $md5) = @_; my ($subloc, $offset, $size) = $self->_find_in_buckets( $tag, $md5 ); +#XXX This needs _release_space() if ( $subloc ) { my $fh = $obj->_fh; seek($fh, $tag->{offset} + $offset + $obj->_root->{file_offset}, SEEK_SET); diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index 062c8bd..bb50c59 100644 --- a/lib/DBM/Deep/Hash.pm +++ b/lib/DBM/Deep/Hash.pm @@ -8,6 +8,24 @@ sub _get_self { eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0] } +sub _repr { shift;return { @_ } } + +sub _import { + my $self = shift; + my ($struct) = @_; + + eval { + local $SIG{'__DIE__'}; + foreach my $key (keys %$struct) { + $self->put($key, $struct->{$key}); + } + }; if ($@) { + $self->_throw_error("Cannot import: type mismatch"); + } + + return 1; +} + sub TIEHASH { ## # Tied hash constructor method, called by Perl's tie() function. @@ -106,8 +124,22 @@ sub NEXTKEY { ## # Public method aliases ## -sub first_key { (CORE::shift)->FIRSTKEY(@_) } -sub next_key { (CORE::shift)->NEXTKEY(@_) } +sub first_key { (shift)->FIRSTKEY(@_) } +sub next_key { (shift)->NEXTKEY(@_) } + +sub _copy_node { + my $self = shift->_get_self; + my ($db_temp) = @_; + + my $key = $self->first_key(); + while ($key) { + my $value = $self->get($key); + $self->_copy_value( \$db_temp->{$key}, $value ); + $key = $self->next_key($key); + } + + return 1; +} 1; __END__