sub SIG_DATA () { 'D' }
sub SIG_INDEX () { 'I' }
sub SIG_BLIST () { 'B' }
+sub SIG_FREE () { 'F' }
sub SIG_SIZE () { 1 }
sub precalc_sizes {
return $self;
}
+sub write_file_signature {
+ my $self = shift;
+ my ($obj) = @_;
+
+ my $fh = $obj->_fh;
+
+ my $loc = $self->_request_space(
+ $obj, length( SIG_FILE ) + $self->{data_size},
+ );
+ seek($fh, $loc + $obj->_root->{file_offset}, SEEK_SET);
+ print( $fh SIG_FILE, pack($self->{data_pack}, 0) );
+
+ return;
+}
+
+sub read_file_signature {
+ my $self = shift;
+ my ($obj) = @_;
+
+ my $fh = $obj->_fh;
+
+ seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
+ my $buffer;
+ my $bytes_read = read(
+ $fh, $buffer, length(SIG_FILE) + $self->{data_size},
+ );
+
+ if ( $bytes_read ) {
+ my ($signature, $version) = unpack( "A4 $self->{data_pack}", $buffer );
+ unless ($signature eq SIG_FILE) {
+ $self->close_fh( $obj );
+ $obj->_throw_error("Signature not found -- file is not a Deep DB");
+ }
+ }
+
+ return $bytes_read;
+}
+
sub setup_fh {
my $self = shift;
my ($obj) = @_;
flock $fh, LOCK_EX;
unless ( $obj->{base_offset} ) {
- seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
- my $signature;
- my $bytes_read = read( $fh, $signature, length(SIG_FILE));
+ my $bytes_read = $self->read_file_signature( $obj );
##
# File is empty -- write signature and master index
##
if (!$bytes_read) {
- my $loc = $self->_request_space( $obj, length( SIG_FILE ) );
- seek($fh, $loc + $obj->_root->{file_offset}, SEEK_SET);
- print( $fh SIG_FILE);
+ $self->write_file_signature( $obj );
$obj->{base_offset} = $self->_request_space(
$obj, $self->tag_size( $self->{index_size} ),
);
- $self->create_tag(
+ $self->write_tag(
$obj, $obj->_base_offset, $obj->_type,
chr(0)x$self->{index_size},
);
$obj->{base_offset} = $bytes_read;
##
- # Check signature was valid
- ##
- unless ($signature eq SIG_FILE) {
- $self->close_fh( $obj );
- $obj->_throw_error("Signature not found -- file is not a Deep DB");
- }
-
- ##
# Get our type from master index signature
##
my $tag = $self->load_tag($obj, $obj->_base_offset)
or $obj->_throw_error("Cannot sysopen file '$filename': $!");
$obj->_root->{fh} = $fh;
- #XXX Can we remove this by using the right sysopen() flags?
- # Maybe ... q.v. above
- binmode $fh; # for win32
+ # Even though we use O_BINARY, better be safe than sorry.
+ binmode $fh;
if ($obj->_root->{autoflush}) {
my $old = select $fh;
return SIG_SIZE + $self->{data_size} + $size;
}
-sub create_tag {
+sub write_tag {
##
# Given offset, signature and content, create tag and write to disk
##
}
my $r = Scalar::Util::reftype( $value ) || '';
+ if ( $obj->_root->{autobless} ) {
+ # This is for the bit saying whether or not this thing is blessed.
+ $len += 1;
+ }
+
unless ( $r eq 'HASH' || $r eq 'ARRAY' ) {
if ( defined $value ) {
$len += length( $value );
# if autobless is enabled, must also take into consideration
# the class name as it is stored after the key.
if ( $obj->_root->{autobless} ) {
- # This is for the bit saying whether or not this thing is blessed.
- $len += 1;
-
my $value_class = Scalar::Util::blessed($value);
if ( defined $value_class && !$is_dbm_deep ) {
$len += $self->{data_size} + length($value_class);
my $actual_length = $self->_length_needed( $obj, $value, $plain_key );
- my ($subloc, $offset) = $self->_find_in_buckets( $tag, $md5 );
+ 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;
- seek($fh, $subloc + SIG_SIZE + $root->{file_offset}, SEEK_SET);
- my $size;
- read( $fh, $size, $self->{data_size});
- $size = unpack($self->{data_pack}, $size);
-
if ($actual_length <= $size) {
$location = $subloc;
}
$location = $self->_request_space( $obj, $actual_length );
seek(
$fh,
- $tag->{offset} + $offset + $self->{hash_size} + $root->{file_offset},
+ $tag->{offset} + $offset
+ + $self->{hash_size} + $root->{file_offset},
SEEK_SET,
);
- print( $fh pack($self->{long_pack}, $location) );
+ print( $fh pack($self->{long_pack}, $location ) );
+ print( $fh pack($self->{long_pack}, $actual_length ) );
}
}
# Adding a new md5
$location = $self->_request_space( $obj, $actual_length );
seek( $fh, $tag->{offset} + $offset + $root->{file_offset}, SEEK_SET );
- print( $fh $md5 . pack($self->{long_pack}, $location) );
+ print( $fh $md5 . pack($self->{long_pack}, $location ) );
+ 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 {
- $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 );
return $result;
}
+sub _get_tied {
+ my $item = shift;
+ my $r = Scalar::Util::reftype( $item ) || return;
+ if ( $r eq 'HASH' ) {
+ return tied(%$item);
+ }
+ elsif ( $r eq 'ARRAY' ) {
+ return tied(@$item);
+ }
+ else {
+ return;
+ };
+}
+
+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 write_value {
my $self = shift;
my ($obj, $location, $key, $value) = @_;
my $fh = $obj->_fh;
my $root = $obj->_root;
- my $is_dbm_deep = eval {
- local $SIG{'__DIE__'};
- $value->isa( 'DBM::Deep' );
- };
-
- my $internal_ref = $is_dbm_deep && ($value->_root eq $root);
+ my $dbm_deep_obj = _get_dbm_object( $value );
+ if ( $dbm_deep_obj && $dbm_deep_obj->_root ne $obj->_root ) {
+ $obj->_throw_error( "Cannot cross-reference. Use export() instead" );
+ }
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 ( $internal_ref ) {
- $self->create_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $value->_base_offset) );
+ my $r = Scalar::Util::reftype( $value ) || '';
+ if ( $dbm_deep_obj ) {
+ $self->write_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $dbm_deep_obj->_base_offset) );
}
elsif ($r eq 'HASH') {
- $self->create_tag( $obj, undef, SIG_HASH, chr(0)x$self->{index_size} );
+ if ( !$dbm_deep_obj && tied %{$value} ) {
+ $obj->_throw_error( "Cannot store something that is tied" );
+ }
+ $self->write_tag( $obj, undef, SIG_HASH, chr(0)x$self->{index_size} );
}
elsif ($r eq 'ARRAY') {
- $self->create_tag( $obj, undef, SIG_ARRAY, chr(0)x$self->{index_size} );
+ if ( !$dbm_deep_obj && tied @{$value} ) {
+ $obj->_throw_error( "Cannot store something that is tied" );
+ }
+ $self->write_tag( $obj, undef, SIG_ARRAY, chr(0)x$self->{index_size} );
}
elsif (!defined($value)) {
- $self->create_tag( $obj, undef, SIG_INTERNAL, '' );
+ $self->write_tag( $obj, undef, SIG_NULL, '' );
}
else {
- $self->create_tag( $obj, undef, SIG_DATA, $value );
+ $self->write_tag( $obj, undef, SIG_DATA, $value );
}
##
##
print( $fh pack($self->{data_pack}, length($key)) . $key );
+ # Internal references don't care about autobless
+ return 1 if $dbm_deep_obj;
+
##
# If value is blessed, preserve class name
##
if ( $root->{autobless} ) {
my $value_class = Scalar::Util::blessed($value);
- if ( defined $value_class && !$is_dbm_deep ) {
+ if ( defined $value_class && !$dbm_deep_obj ) {
print( $fh chr(1) );
print( $fh pack($self->{data_pack}, length($value_class)) . $value_class );
}
# 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 ($r eq 'HASH') {
- my $branch = DBM::Deep->new(
- type => DBM::Deep->TYPE_HASH,
- base_offset => $location,
- root => $root,
- );
- foreach my $key (keys %{$value}) {
- $branch->STORE( $key, $value->{$key} );
- }
- }
- elsif ($r eq 'ARRAY') {
- my $branch = DBM::Deep->new(
- type => DBM::Deep->TYPE_ARRAY,
- base_offset => $location,
- root => $root,
- );
- my $index = 0;
- foreach my $element (@{$value}) {
- $branch->STORE( $index, $element );
- $index++;
- }
- }
+ if ($r eq 'HASH') {
+ my %x = %$value;
+ tie %$value, 'DBM::Deep', {
+ base_offset => $location,
+ root => $root,
+ };
+ %$value = %x;
+ }
+ elsif ($r eq 'ARRAY') {
+ my @x = @$value;
+ tie @$value, 'DBM::Deep', {
+ base_offset => $location,
+ root => $root,
+ };
+ @$value = @x;
}
return 1;
my $fh = $obj->_fh;
my $root = $obj->_root;
- my $keys = $tag->{content};
-
- seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET);
my $loc = $self->_request_space(
$obj, $self->tag_size( $self->{index_size} ),
);
+ seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET);
print( $fh pack($self->{long_pack}, $loc) );
- my $index_tag = $self->create_tag(
+ my $index_tag = $self->write_tag(
$obj, $loc, SIG_INDEX,
chr(0)x$self->{index_size},
);
- my @offsets = ();
+ my $newtag_loc = $self->_request_space(
+ $obj, $self->tag_size( $self->{bucket_list_size} ),
+ );
- $keys .= $md5 . pack($self->{long_pack}, 0);
+ my $keys = $tag->{content}
+ . $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) = $self->_get_key_subloc( $keys, $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]) {
- my $offset = $offsets[$num] + SIG_SIZE + $self->{data_size};
- seek($fh, $offset + $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});
- for (my $k=0; $k<$self->{max_buckets}; $k++) {
- my ($temp, $subloc) = $self->_get_key_subloc( $subkeys, $k );
+ # This is looking for the first empty spot
+ my ($subloc, $offset, $size) = $self->_find_in_buckets(
+ { content => $subkeys }, '',
+ );
- if (!$subloc) {
- seek($fh, $offset + ($k * $self->{bucket_size}) + $root->{file_offset}, SEEK_SET);
- print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) );
- last;
- }
- } # k loop
+ seek($fh, $newloc[$num] + $offset + $root->{file_offset}, SEEK_SET);
+ print( $fh $key . pack($self->{long_pack}, $old_subloc) );
+
+ next;
}
- else {
- $offsets[$num] = $root->{end};
- seek($fh, $index_tag->{offset} + ($num * $self->{long_size}) + $root->{file_offset}, SEEK_SET);
- my $loc = $self->_request_space(
- $obj, $self->tag_size( $self->{bucket_list_size} ),
- );
+ seek($fh, $index_tag->{offset} + ($num * $self->{long_size}) + $root->{file_offset}, SEEK_SET);
- print( $fh pack($self->{long_pack}, $loc) );
+ my $loc = $self->_request_space(
+ $obj, $self->tag_size( $self->{bucket_list_size} ),
+ );
- my $blist_tag = $self->create_tag(
- $obj, $loc, SIG_BLIST,
- chr(0)x$self->{bucket_list_size},
- );
+ print( $fh pack($self->{long_pack}, $loc) );
- seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET);
- print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) );
- }
- } # i loop
+ my $blist_tag = $self->write_tag(
+ $obj, $loc, SIG_BLIST,
+ chr(0)x$self->{bucket_list_size},
+ );
- return;
+ seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET);
+ print( $fh $key . pack($self->{long_pack}, $old_subloc) );
+
+ $newloc[$num] = $blist_tag->{offset};
+ }
+
+ $self->_release_space(
+ $obj, $self->tag_size( $self->{bucket_list_size} ),
+ $tag->{offset} - SIG_SIZE - $self->{data_size},
+ );
+
+ return $newtag_loc;
}
sub read_from_loc {
# If value is a hash or array, return new DBM::Deep object with correct offset
##
if (($signature eq SIG_HASH) || ($signature eq SIG_ARRAY)) {
- my $obj = DBM::Deep->new(
+ my $new_obj = DBM::Deep->new({
type => $signature,
base_offset => $subloc,
root => $obj->_root,
- );
+ });
- if ($obj->_root->{autobless}) {
+ if ($new_obj->_root->{autobless}) {
##
# Skip over value and plain key to see if object needs
# to be re-blessed
seek($fh, $self->{data_size} + $self->{index_size}, SEEK_CUR);
my $size;
- read( $fh, $size, $self->{data_size}); $size = unpack($self->{data_pack}, $size);
+ read( $fh, $size, $self->{data_size});
+ $size = unpack($self->{data_pack}, $size);
if ($size) { seek($fh, $size, SEEK_CUR); }
my $bless_bit;
# Yes, object needs to be re-blessed
##
my $class_name;
- read( $fh, $size, $self->{data_size}); $size = unpack($self->{data_pack}, $size);
+ read( $fh, $size, $self->{data_size});
+ $size = unpack($self->{data_pack}, $size);
if ($size) { read( $fh, $class_name, $size); }
- if ($class_name) { $obj = bless( $obj, $class_name ); }
+ if ($class_name) { $new_obj = bless( $new_obj, $class_name ); }
}
}
- return $obj;
+ return $new_obj;
}
elsif ( $signature eq SIG_INTERNAL ) {
my $size;
my $self = shift;
my ($obj, $tag, $md5) = @_;
- my ($subloc, $offset) = $self->_find_in_buckets( $tag, $md5 );
+ my ($subloc, $offset, $size) = $self->_find_in_buckets( $tag, $md5 );
if ( $subloc ) {
return $self->read_from_loc( $obj, $subloc );
}
my $self = shift;
my ($obj, $tag, $md5) = @_;
- my ($subloc, $offset) = $self->_find_in_buckets( $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);
my $self = shift;
my ($obj, $tag, $md5) = @_;
- my ($subloc, $offset) = $self->_find_in_buckets( $tag, $md5 );
+ my ($subloc, $offset, $size) = $self->_find_in_buckets( $tag, $md5 );
return $subloc && 1;
}
if (!$tag) {
return if !$args->{create};
- my $fh = $obj->_fh;
- seek($fh, $ref_loc + $obj->_root->{file_offset}, SEEK_SET);
-
my $loc = $self->_request_space(
$obj, $self->tag_size( $self->{bucket_list_size} ),
);
+ my $fh = $obj->_fh;
+ seek($fh, $ref_loc + $obj->_root->{file_offset}, SEEK_SET);
print( $fh pack($self->{long_pack}, $loc) );
- $tag = $self->create_tag(
+ $tag = $self->write_tag(
$obj, $loc, SIG_BLIST,
chr(0)x$self->{bucket_list_size},
);
BUCKET:
for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
- my ($key, $subloc) = $self->_get_key_subloc( $tag->{content}, $i );
+ my ($key, $subloc, $size) = $self->_get_key_subloc(
+ $tag->{content}, $i,
+ );
- return ($subloc, $i * $self->{bucket_size}) unless $subloc;
+ return ($subloc, $i * $self->{bucket_size}, $size) unless $subloc;
next BUCKET if $key ne $md5;
- return ($subloc, $i * $self->{bucket_size});
+ return ($subloc, $i * $self->{bucket_size}, $size);
}
return;
}
+#sub _print_at {
+# my $self = shift;
+# my ($obj, $spot, $data) = @_;
+#
+# my $fh = $obj->_fh;
+# seek( $fh, $spot, SEEK_SET );
+# print( $fh $data );
+#
+# return;
+#}
+
sub _request_space {
my $self = shift;
my ($obj, $size) = @_;
my $self = shift;
my ($obj, $size, $loc) = @_;
+ my $next_loc = 0;
+
+ my $fh = $obj->_fh;
+ seek( $fh, $loc + $obj->_root->{file_offset}, SEEK_SET );
+ print( $fh SIG_FREE
+ . pack($self->{long_pack}, $size )
+ . pack($self->{long_pack}, $next_loc )
+ );
+
return;
}
projects / dbsrgits/DBM-Deep.git / blobdiff