1 package DBM::Deep::Engine2;
3 use base 'DBM::Deep::Engine';
10 our $VERSION = q(0.99_03);
12 use Fcntl qw( :DEFAULT :flock );
16 # * Every method in here assumes that the _storage has been appropriately
17 # safeguarded. This can be anything from flock() to some sort of manual
18 # mutex. But, it's the caller's responsability to make sure that this has
21 # Setup file and tag signatures. These should never change.
22 sub SIG_FILE () { 'DPDB' }
23 sub SIG_HEADER () { 'h' }
24 sub SIG_INTERNAL () { 'i' }
25 sub SIG_HASH () { 'H' }
26 sub SIG_ARRAY () { 'A' }
27 sub SIG_NULL () { 'N' }
28 sub SIG_DATA () { 'D' }
29 sub SIG_INDEX () { 'I' }
30 sub SIG_BLIST () { 'B' }
31 sub SIG_FREE () { 'F' }
32 sub SIG_KEYS () { 'K' }
35 # This is the transaction ID for the HEAD
40 my ($trans_id, $base_offset, $key) = @_;
42 my ($_val_offset, $_is_del) = $self->_find_value_offset({
43 offset => $base_offset,
44 trans_id => $trans_id,
47 die "Attempt to use a deleted value" if $_is_del;
48 die "Internal error!" if !$_val_offset;
50 my ($key_offset) = $self->_find_key_offset({
51 offset => $_val_offset,
52 key_md5 => $self->_apply_digest( $key ),
54 return if !$key_offset;
56 my ($val_offset, $is_del) = $self->_find_value_offset({
57 offset => $key_offset,
58 trans_id => $trans_id,
62 die "Internal error!" if !$val_offset;
64 return $self->_read_value({
65 keyloc => $key_offset,
66 offset => $val_offset,
72 my ($trans_id, $base_offset, $key) = @_;
74 my ($_val_offset, $_is_del) = $self->_find_value_offset({
75 offset => $base_offset,
76 trans_id => $trans_id,
79 die "Attempt to use a deleted value" if $_is_del;
80 die "Internal error!" if !$_val_offset;
82 my ($key_offset) = $self->_find_key_offset({
83 offset => $_val_offset,
84 key_md5 => $self->_apply_digest( $key ),
86 return '' if !$key_offset;
88 my ($val_offset, $is_del) = $self->_find_value_offset({
89 offset => $key_offset,
90 trans_id => $trans_id,
96 die "Internal error!" if !$_val_offset;
102 my ($trans_id, $base_offset) = @_;
104 my ($_val_offset, $_is_del) = $self->_find_value_offset({
105 offset => $base_offset,
106 trans_id => $trans_id,
109 die "Attempt to use a deleted value" if $_is_del;
110 die "Internal error!" if !$_val_offset;
112 # If the previous key was not specifed, start at the top and
113 # return the first one found.
117 prev_md5 => $self->_apply_digest($_[2]),
123 prev_md5 => chr(0) x $self->{hash_size},
128 return $self->traverse_index( $temp, $_val_offset, 0 );
133 my ($trans_id, $base_offset, $key) = @_;
135 my ($_val_offset, $_is_del) = $self->_find_value_offset({
136 offset => $base_offset,
137 trans_id => $trans_id,
140 die "Attempt to use a deleted value" if $_is_del;
141 die "Internal error!" if !$_val_offset;
143 my ($key_offset, $bucket_tag) = $self->_find_key_offset({
144 offset => $_val_offset,
145 key_md5 => $self->_apply_digest( $key ),
147 return if !$key_offset;
149 my $key_tag = $self->load_tag( $key_offset );
151 my $value = $self->read_value( $trans_id, $base_offset, $key );
153 $self->_mark_as_deleted({
155 trans_id => $trans_id,
159 if ( my @transactions = $self->_storage->current_transactions ) {
160 foreach my $other_trans_id ( @transactions ) {
161 next if $self->_has_keyloc_entry({
163 trans_id => $other_trans_id,
165 $self->write_value( $other_trans_id, $base_offset, $key, $value );
169 $self->_mark_as_deleted({
171 trans_id => $trans_id,
173 # $self->_remove_key_offset({
174 # offset => $_val_offset,
175 # key_md5 => $self->_apply_digest( $key ),
184 my ($trans_id, $base_offset, $key, $value) = @_;
186 # This verifies that only supported values will be stored.
188 my $r = Scalar::Util::reftype( $value );
191 last if $r eq 'HASH';
192 last if $r eq 'ARRAY';
195 "Storage of references of type '$r' is not supported."
199 my ($_val_offset, $_is_del) = $self->_find_value_offset({
200 offset => $base_offset,
201 trans_id => $trans_id,
204 die "Attempt to use a deleted value" if $_is_del;
205 die "Internal error!" if !$_val_offset;
207 my ($key_offset, $bucket_tag) = $self->_find_key_offset({
208 offset => $_val_offset,
209 key_md5 => $self->_apply_digest( $key ),
212 die "Cannot find/create new key offset!" if !$key_offset;
214 my $key_tag = $self->load_tag( $key_offset );
217 if ( $bucket_tag->{is_new} ) {
218 # Must mark the HEAD as deleted because it doesn't exist
219 $self->_mark_as_deleted({
226 # If the HEAD isn't new, then we must take other transactions
227 # into account. If it is, then there can be no other transactions.
228 if ( !$bucket_tag->{is_new} ) {
229 my $old_value = $self->read_value( $trans_id, $base_offset, $key );
230 if ( my @transactions = $self->_storage->current_transactions ) {
231 foreach my $other_trans_id ( @transactions ) {
232 next if $self->_has_keyloc_entry({
234 trans_id => $other_trans_id,
236 $self->write_value( $other_trans_id, $base_offset, $key, $old_value );
242 my $value_loc = $self->_storage->request_space(
243 $self->_length_needed( $value, $key ),
246 $self->_add_key_offset({
248 trans_id => $trans_id,
252 $self->_write_value( $key_offset, $value_loc, $key, $value, $key );
257 sub _find_value_offset {
261 my $key_tag = $self->load_tag( $args->{offset} );
264 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
265 my ($loc, $trans_id, $is_deleted) = unpack(
266 "$self->{long_pack} C C",
267 substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
270 if ( $trans_id == HEAD ) {
271 @head = ($loc, $is_deleted);
274 next if $loc && $args->{trans_id} != $trans_id;
275 return( $loc, $is_deleted );
278 return @head if $args->{allow_head};
282 sub _find_key_offset {
286 my $bucket_tag = $self->load_tag( $args->{offset} )
287 or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
289 #XXX What happens when $ch >= $self->{hash_size} ??
290 for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
291 my $num = ord substr($args->{key_md5}, $ch, 1);
293 my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
294 $bucket_tag = $self->index_lookup( $bucket_tag, $num );
297 return if !$args->{create};
299 my $loc = $self->_storage->request_space(
300 $self->tag_size( $self->{bucket_list_size} ),
303 $self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
305 $bucket_tag = $self->write_tag(
307 chr(0)x$self->{bucket_list_size},
310 $bucket_tag->{ref_loc} = $ref_loc;
311 $bucket_tag->{ch} = $ch;
312 $bucket_tag->{is_new} = 1;
317 $bucket_tag->{ch} = $ch;
318 $bucket_tag->{ref_loc} = $ref_loc;
321 # Need to create a new keytag, too
322 if ( $bucket_tag->{is_new} ) {
323 my $keytag_loc = $self->_storage->request_space(
324 $self->tag_size( $self->{keyloc_size} ),
327 substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
328 $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
330 $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
333 $keytag_loc, SIG_KEYS,
334 chr(0)x$self->{keyloc_size},
337 return( $keytag_loc, $bucket_tag );
340 my ($key, $subloc, $index);
342 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
343 ($key, $subloc) = $self->_get_key_subloc(
344 $bucket_tag->{content}, $i,
347 next BUCKET if $subloc && $key ne $args->{key_md5};
349 # Keep track of where we are, in case we need to create a new
355 # Either we have a subloc to return or we don't want to create a new
356 # entry. Either way, we need to return now.
357 return ($subloc, $bucket_tag) if $subloc || !$args->{create};
359 my $keytag_loc = $self->_storage->request_space(
360 $self->tag_size( $self->{keyloc_size} ),
363 # There's space left in this bucket
364 if ( defined $index ) {
365 substr( $bucket_tag->{content}, $index * $self->{key_size}, $self->{key_size} ) =
366 $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
368 $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
370 # We need to split the index
372 $self->split_index( $bucket_tag, $args->{key_md5}, $keytag_loc );
376 $keytag_loc, SIG_KEYS,
377 chr(0)x$self->{keyloc_size},
380 return( $keytag_loc, $bucket_tag );
390 return $self->read_from_loc( $args->{keyloc}, $args->{offset} );
393 sub _mark_as_deleted {
398 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
399 my ($loc, $trans_id, $is_deleted) = unpack(
400 "$self->{long_pack} C C",
401 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
404 last unless $loc || $is_deleted;
406 if ( $trans_id == $args->{trans_id} ) {
407 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
408 "$self->{long_pack} C C",
417 $self->_storage->print_at(
418 $args->{tag}{offset}, $args->{tag}{content},
425 sub _has_keyloc_entry {
429 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
430 my ($loc, $trans_id, $is_deleted) = unpack(
431 "$self->{long_pack} C C",
432 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
435 return 1 if $trans_id == $args->{trans_id};
441 sub _remove_key_offset {
446 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
447 my ($loc, $trans_id, $is_deleted) = unpack(
448 "$self->{long_pack} C C",
449 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
452 if ( $trans_id == $args->{trans_id} ) {
453 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = '';
454 $args->{tag}{content} .= chr(0) x $self->{key_size};
461 $self->_storage->print_at(
462 $args->{tag}{offset}, $args->{tag}{content},
469 sub _add_key_offset {
474 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
475 my ($loc, $trans_id, $is_deleted) = unpack(
476 "$self->{long_pack} C C",
477 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
480 if ( $trans_id == $args->{trans_id} || (!$loc && !$is_deleted) ) {
481 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
482 "$self->{long_pack} C C",
483 $args->{loc}, $args->{trans_id}, 0,
491 $self->_storage->print_at(
492 $args->{tag}{offset}, $args->{tag}{content},
496 die "Why didn't _add_key_offset() change something?!\n";
506 # Need to remove use of $fh here
507 my $fh = $self->_storage->{fh};
510 #XXX The duplication of calculate_sizes needs to go away
511 unless ( $obj->{base_offset} ) {
512 my $bytes_read = $self->read_file_header;
514 $self->calculate_sizes;
517 # File is empty -- write header and master index
520 $self->_storage->audit( "# Database created on" );
522 $self->write_file_header;
524 $obj->{base_offset} = $self->_storage->request_space(
525 $self->tag_size( $self->{keyloc_size} ),
528 my $value_spot = $self->_storage->request_space(
529 $self->tag_size( $self->{index_size} ),
533 $obj->{base_offset}, SIG_KEYS,
534 pack( "$self->{long_pack} C C", $value_spot, HEAD, 0 ),
535 chr(0) x ($self->{index_size} - $self->{key_size}),
539 $value_spot, $obj->_type,
540 chr(0)x$self->{index_size},
543 # Flush the filehandle
544 my $old_fh = select $fh;
545 my $old_af = $|; $| = 1; $| = $old_af;
549 $obj->{base_offset} = $bytes_read;
551 my ($_val_offset, $_is_del) = $self->_find_value_offset({
552 offset => $obj->{base_offset},
556 die "Attempt to use a deleted value" if $_is_del;
557 die "Internal error!" if !$_val_offset;
560 # Get our type from master index header
562 my $tag = $self->load_tag($_val_offset);
565 $self->_throw_error("Corrupted file, no master index record");
568 unless ($obj->_type eq $tag->{signature}) {
570 $self->_throw_error("File type mismatch");
575 $self->calculate_sizes;
578 #XXX We have to make sure we don't mess up when autoflush isn't turned on
579 $self->_storage->set_inode;