sub SIG_DATA () { 'D' }
sub SIG_INDEX () { 'I' }
sub SIG_BLIST () { 'B' }
+sub SIG_FREE () { 'F' }
sub SIG_SIZE () { 1 }
sub precalc_sizes {
my $self = shift;
$self->{index_size} = (2**8) * $self->{long_size};
- $self->{bucket_size} = $self->{hash_size} + $self->{long_size};
+ $self->{bucket_size} = $self->{hash_size} + $self->{long_size} * 2;
$self->{bucket_list_size} = $self->{max_buckets} * $self->{bucket_size};
return 1;
$self->open( $obj ) if !defined $obj->_fh;
- unless ( $obj->{base_offset} ) {
- my $fh = $obj->_fh;
-
- flock $fh, LOCK_EX;
+ my $fh = $obj->_fh;
+ 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));
# File is empty -- write signature and master index
##
if (!$bytes_read) {
- seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
+ my $loc = $self->_request_space( $obj, length( SIG_FILE ) );
+ seek($fh, $loc + $obj->_root->{file_offset}, SEEK_SET);
print( $fh SIG_FILE);
- $obj->_root->{end} = length( SIG_FILE );
-
- $obj->{base_offset} = $self->_request_space($obj, $self->{index_size});
+ $obj->{base_offset} = $self->_request_space(
+ $obj, $self->tag_size( $self->{index_size} ),
+ );
- $self->create_tag(
- $obj, $obj->_base_offset, $obj->_type, chr(0) x $self->{index_size},
+ $self->write_tag(
+ $obj, $obj->_base_offset, $obj->_type,
+ chr(0)x$self->{index_size},
);
# Flush the filehandle
$obj->_throw_error("File type mismatch");
}
}
-
- flock $fh, LOCK_UN;
}
#XXX We have to make sure we don't mess up when autoflush isn't turned on
$obj->_root->{end} = $stats[7];
}
+ flock $fh, LOCK_UN;
+
return 1;
}
my $self = shift;
my ($obj) = @_;
- if (defined($obj->_fh)) { $self->close_fh( $obj ); }
-
# Theoretically, adding O_BINARY should remove the need for the binmode
# Of course, testing it is going to be ... interesting.
my $flags = O_RDWR | O_CREAT | O_BINARY;
return 1;
}
-sub create_tag {
+sub tag_size {
+ my $self = shift;
+ my ($size) = @_;
+ return SIG_SIZE + $self->{data_size} + $size;
+}
+
+sub write_tag {
##
# Given offset, signature and content, create tag and write to disk
##
my $self = shift;
my ($obj, $offset, $sig, $content) = @_;
- my $size = length($content);
+ my $size = length( $content );
my $fh = $obj->_fh;
- seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET);
+ if ( defined $offset ) {
+ seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET);
+ }
+
print( $fh $sig . pack($self->{data_pack}, $size) . $content );
- if ($offset == $obj->_root->{end}) {
- $obj->_root->{end} += SIG_SIZE + $self->{data_size} + $size;
- }
+ return unless defined $offset;
return {
signature => $sig,
};
}
+sub _length_needed {
+ my $self = shift;
+ my ($obj, $value, $key) = @_;
+
+ my $is_dbm_deep = eval {
+ local $SIG{'__DIE__'};
+ $value->isa( 'DBM::Deep' );
+ };
+
+ my $len = SIG_SIZE + $self->{data_size}
+ + $self->{data_size} + length( $key );
+
+ if ( $is_dbm_deep && $value->_root eq $obj->_root ) {
+ return $len + $self->{long_size};
+ }
+
+ 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 );
+ }
+ 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 ( $obj->_root->{autobless} ) {
+ my $value_class = Scalar::Util::blessed($value);
+ if ( defined $value_class && !$is_dbm_deep ) {
+ $len += $self->{data_size} + length($value_class);
+ }
+ }
+
+ return $len;
+}
+
sub add_bucket {
##
# Adds one key/value pair to bucket list, given offset, MD5 digest of key,
my $result = 2;
my $root = $obj->_root;
+ my $fh = $obj->_fh;
- my $is_dbm_deep = eval {
- local $SIG{'__DIE__'};
- $value->isa( 'DBM::Deep' );
- };
-
- my $internal_ref = $is_dbm_deep && ($value->_root eq $root);
-
- my $fh = $obj->_fh;
+ 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;
- ##
- # 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;
- if ( $internal_ref ) {
- $actual_length = $self->{long_size};
- }
- else {
- my $r = Scalar::Util::reftype( $value ) || '';
- if ( $r eq 'HASH' || $r eq 'ARRAY' ) {
- $actual_length = $self->{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') ) {
- $actual_length += length($value_class);
- }
- }
- }
- else { $actual_length = length($value); }
- }
-
- 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;
}
else {
- $location = $root->{end};
+ $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
elsif ( defined $offset ) {
- $location = $root->{end};
+ $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 = $root->{end};
+ $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) || '';
- my $content_length;
- if ( $internal_ref ) {
- print( $fh SIG_INTERNAL );
- print( $fh pack($self->{data_pack}, $self->{long_size}) );
- print( $fh pack($self->{long_pack}, $value->_base_offset) );
- $content_length = $self->{long_size};
+ if ( $is_internal_ref ) {
+ $self->write_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $value->_base_offset) );
+ }
+ elsif ($r eq 'HASH') {
+ $self->write_tag( $obj, undef, SIG_HASH, chr(0)x$self->{index_size} );
+ }
+ elsif ($r eq 'ARRAY') {
+ $self->write_tag( $obj, undef, SIG_ARRAY, chr(0)x$self->{index_size} );
+ }
+ elsif (!defined($value)) {
+ $self->write_tag( $obj, undef, SIG_NULL, '' );
}
else {
- if ($r eq 'HASH') {
- print( $fh SIG_HASH );
- print( $fh pack($self->{data_pack}, $self->{index_size}) . chr(0) x $self->{index_size} );
- $content_length = $self->{index_size};
- }
- elsif ($r eq 'ARRAY') {
- print( $fh SIG_ARRAY );
- print( $fh pack($self->{data_pack}, $self->{index_size}) . chr(0) x $self->{index_size} );
- $content_length = $self->{index_size};
- }
- elsif (!defined($value)) {
- print( $fh SIG_NULL );
- print( $fh pack($self->{data_pack}, 0) );
- $content_length = 0;
- }
- else {
- print( $fh SIG_DATA );
- print( $fh pack($self->{data_pack}, length($value)) . $value );
- $content_length = length($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 $is_internal_ref;
+
##
# If value is blessed, preserve class name
##
if ( $root->{autobless} ) {
my $value_class = Scalar::Util::blessed($value);
- if ( defined $value_class && !$value->isa( 'DBM::Deep' ) ) {
- ##
- # Blessed ref -- will restore later
- ##
+ if ( defined $value_class && !$is_dbm_deep ) {
print( $fh chr(1) );
print( $fh pack($self->{data_pack}, length($value_class)) . $value_class );
- $content_length += 1;
- $content_length += $self->{data_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} += $self->{data_size} + $content_length;
- $root->{end} += $self->{data_size} + length($key);
- }
-
- ##
# 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,
my $fh = $obj->_fh;
my $root = $obj->_root;
- my $keys = $tag->{content};
+
+ 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}, $root->{end}) );
+ print( $fh pack($self->{long_pack}, $loc) );
- my $index_tag = $self->create_tag(
- $obj,
- $root->{end},
- SIG_INDEX,
- chr(0) x $self->{index_size},
+ 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 }, '',
+ );
+
+ seek($fh, $newloc[$num] + $offset + $root->{file_offset}, SEEK_SET);
+ print( $fh $key . pack($self->{long_pack}, $old_subloc) );
- 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
+ next;
}
- else {
- $offsets[$num] = $root->{end};
- seek($fh, $index_tag->{offset} + ($num * $self->{long_size}) + $root->{file_offset}, SEEK_SET);
- print( $fh pack($self->{long_pack}, $root->{end}) );
- my $blist_tag = $self->create_tag($obj, $root->{end}, SIG_BLIST, chr(0) x $self->{bucket_list_size});
+ seek($fh, $index_tag->{offset} + ($num * $self->{long_size}) + $root->{file_offset}, SEEK_SET);
- seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET);
- print( $fh $key . pack($self->{long_pack}, $old_subloc || $root->{end}) );
- }
- } # i loop
+ my $loc = $self->_request_space(
+ $obj, $self->tag_size( $self->{bucket_list_size} ),
+ );
- return;
+ print( $fh pack($self->{long_pack}, $loc) );
+
+ my $blist_tag = $self->write_tag(
+ $obj, $loc, SIG_BLIST,
+ chr(0)x$self->{bucket_list_size},
+ );
+
+ 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 {
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;
}
$tag = $self->index_lookup( $obj, $tag, $num );
if (!$tag) {
- return if ! $args->{create};
+ return if !$args->{create};
+
+ 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}, $obj->_root->{end}) );
+ print( $fh pack($self->{long_pack}, $loc) );
- $tag = $self->create_tag(
- $obj, $obj->_root->{end},
- SIG_BLIST,
- chr(0) x $self->{bucket_list_size},
+ $tag = $self->write_tag(
+ $obj, $loc, SIG_BLIST,
+ chr(0)x$self->{bucket_list_size},
);
$tag->{ref_loc} = $ref_loc;
last;
}
- $tag->{ch} = $ch;
+ $tag->{ch} = $ch++;
$tag->{ref_loc} = $ref_loc;
-
- $ch++;
}
return $tag;
my $self = shift;
my ($keys, $idx) = @_;
- my ($key, $subloc) = unpack(
- "a$self->{hash_size} $self->{long_pack}",
+ my ($key, $subloc, $size) = unpack(
+ "a$self->{hash_size} $self->{long_pack} $self->{long_pack}",
substr(
$keys,
($idx * $self->{bucket_size}),
),
);
- return ($key, $subloc);
+ return ($key, $subloc, $size);
}
sub _find_in_buckets {
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 $loc = $obj->_root->{end};
+ $obj->_root->{end} += $size;
return $loc;
}
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