${$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 {
}
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 {
##
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 );
# 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 {
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},
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.
##
#}
+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__
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;
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 );
$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);
# 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') {
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
# 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,
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;
}
);
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 {
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);
projects / dbsrgits/DBM-Deep.git / commitdiff