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 # print "Trying to read $key from $base_offset ($trans_id)\n" if $key > 400;
43 my ($_val_offset, $_is_del) = $self->_find_value_offset({
44 offset => $base_offset,
45 trans_id => $trans_id,
48 die "Attempt to use a deleted value" if $_is_del;
49 die "Internal error!" if !$_val_offset;
51 my ($key_tag) = $self->_find_key_offset({
52 offset => $_val_offset,
53 key_md5 => $self->_apply_digest( $key ),
57 my ($val_offset, $is_del) = $self->_find_value_offset({
58 offset => $key_tag->{start},
59 trans_id => $trans_id,
63 die "Internal error!" if !$val_offset;
65 return $self->_read_value({
66 keyloc => $key_tag->{start},
67 offset => $val_offset,
73 my ($trans_id, $base_offset, $key) = @_;
75 my ($_val_offset, $_is_del) = $self->_find_value_offset({
76 offset => $base_offset,
77 trans_id => $trans_id,
80 die "Attempt to use a deleted value" if $_is_del;
81 die "Internal error!" if !$_val_offset;
83 my ($key_tag) = $self->_find_key_offset({
84 offset => $_val_offset,
85 key_md5 => $self->_apply_digest( $key ),
87 return '' if !$key_tag->{start};
89 my ($val_offset, $is_del) = $self->_find_value_offset({
90 offset => $key_tag->{start},
91 trans_id => $trans_id,
94 die "Internal error!" if !$_val_offset;
103 my ($trans_id, $base_offset) = @_;
105 my ($_val_offset, $_is_del) = $self->_find_value_offset({
106 offset => $base_offset,
107 trans_id => $trans_id,
110 die "Attempt to use a deleted value" if $_is_del;
111 die "Internal error!" if !$_val_offset;
113 # If the previous key was not specifed, start at the top and
114 # return the first one found.
118 prev_md5 => $self->_apply_digest($_[2]),
124 prev_md5 => chr(0) x $self->{hash_size},
129 return $self->traverse_index( $temp, $_val_offset, 0 );
134 my ($trans_id, $base_offset, $key) = @_;
136 my ($_val_offset, $_is_del) = $self->_find_value_offset({
137 offset => $base_offset,
138 trans_id => $trans_id,
141 die "Attempt to use a deleted value" if $_is_del;
142 die "Internal error!" if !$_val_offset;
144 my ($key_tag, $bucket_tag) = $self->_find_key_offset({
145 offset => $_val_offset,
146 key_md5 => $self->_apply_digest( $key ),
148 return if !$key_tag->{start};
150 my $value = $self->read_value( $trans_id, $base_offset, $key );
152 $self->_mark_as_deleted({
154 trans_id => $trans_id,
158 if ( my @transactions = $self->_storage->current_transactions ) {
159 foreach my $other_trans_id ( @transactions ) {
160 next if $self->_has_keyloc_entry({
162 trans_id => $other_trans_id,
164 $self->write_value( $other_trans_id, $base_offset, $key, $value );
168 $self->_mark_as_deleted({
170 trans_id => $trans_id,
172 # $self->_remove_key_offset({
173 # offset => $_val_offset,
174 # key_md5 => $self->_apply_digest( $key ),
183 my ($trans_id, $base_offset, $key, $value) = @_;
185 # This verifies that only supported values will be stored.
187 my $r = Scalar::Util::reftype( $value );
190 last if $r eq 'HASH';
191 last if $r eq 'ARRAY';
194 "Storage of references of type '$r' is not supported."
198 my ($_val_offset, $_is_del) = $self->_find_value_offset({
199 offset => $base_offset,
200 trans_id => $trans_id,
203 die "Attempt to use a deleted value" if $_is_del;
204 die "Internal error!" if !$_val_offset;
206 my ($key_tag, $bucket_tag) = $self->_find_key_offset({
207 offset => $_val_offset,
208 key_md5 => $self->_apply_digest( $key ),
211 die "Cannot find/create new key offset!" if !$key_tag->{start};
214 if ( $key_tag->{is_new} ) {
215 # Must mark the HEAD as deleted because it doesn't exist
216 $self->_mark_as_deleted({
223 # If the HEAD isn't new, then we must take other transactions
224 # into account. If it is, then there can be no other transactions.
225 if ( !$key_tag->{is_new} ) {
226 my $old_value = $self->read_value( $trans_id, $base_offset, $key );
227 if ( my @transactions = $self->_storage->current_transactions ) {
228 foreach my $other_trans_id ( @transactions ) {
229 next if $self->_has_keyloc_entry({
231 trans_id => $other_trans_id,
233 $self->write_value( $other_trans_id, $base_offset, $key, $old_value );
239 my $value_loc = $self->_storage->request_space(
240 $self->_length_needed( $value, $key ),
243 $self->_add_key_offset({
245 trans_id => $trans_id,
249 $self->_write_value( $key_tag->{start}, $value_loc, $key, $value, $key );
254 sub _find_value_offset {
258 my $key_tag = $self->load_tag( $args->{offset} );
261 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
262 my ($loc, $trans_id, $is_deleted) = unpack(
263 "$self->{long_pack} C C",
264 substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
267 if ( $trans_id == HEAD ) {
268 @head = ($loc, $is_deleted);
271 next if $loc && $args->{trans_id} != $trans_id;
272 return( $loc, $is_deleted );
275 return @head if $args->{allow_head};
279 sub _find_key_offset {
283 my $bucket_tag = $self->load_tag( $args->{offset} )
284 or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
286 #XXX What happens when $ch >= $self->{hash_size} ??
287 for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
288 my $num = ord substr($args->{key_md5}, $ch, 1);
290 my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
291 $bucket_tag = $self->index_lookup( $bucket_tag, $num );
294 return if !$args->{create};
296 my $loc = $self->_storage->request_space(
297 $self->tag_size( $self->{bucket_list_size} ),
300 $self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
302 $bucket_tag = $self->write_tag(
304 chr(0)x$self->{bucket_list_size},
307 $bucket_tag->{ref_loc} = $ref_loc;
308 $bucket_tag->{ch} = $ch;
309 $bucket_tag->{is_new} = 1;
314 $bucket_tag->{ch} = $ch;
315 $bucket_tag->{ref_loc} = $ref_loc;
318 # Need to create a new keytag, too
319 if ( $bucket_tag->{is_new} ) {
320 # print "Creating new keytag\n";
321 my $keytag_loc = $self->_storage->request_space(
322 $self->tag_size( $self->{keyloc_size} ),
325 substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
326 $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
328 $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
330 my $key_tag = $self->write_tag(
331 $keytag_loc, SIG_KEYS,
332 chr(0)x$self->{keyloc_size},
335 return( $key_tag, $bucket_tag );
338 my ($key, $subloc, $index);
340 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
341 ($key, $subloc) = $self->_get_key_subloc(
342 $bucket_tag->{content}, $i,
345 next BUCKET if $subloc && $key ne $args->{key_md5};
347 # Keep track of where we are, in case we need to create a new
353 # If we have a subloc to return or we don't want to create a new
354 # entry, we need to return now.
355 $args->{create} ||= 0;
356 # print "Found ($subloc) at $index ($args->{create})\n";
357 return ($self->load_tag( $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 # print "There's space left in the bucket for $keytag_loc\n";
366 substr( $bucket_tag->{content}, $index * $self->{key_size}, $self->{key_size} ) =
367 $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
369 $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
371 # We need to split the index
373 # print "Splitting the index for $keytag_loc\n";
374 $self->split_index( $bucket_tag, $args->{key_md5}, $keytag_loc );
377 my $key_tag = $self->write_tag(
378 $keytag_loc, SIG_KEYS,
379 chr(0)x$self->{keyloc_size},
382 return( $key_tag, $bucket_tag );
392 return $self->read_from_loc( $args->{keyloc}, $args->{offset} );
395 sub _mark_as_deleted {
400 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
401 my ($loc, $trans_id, $is_deleted) = unpack(
402 "$self->{long_pack} C C",
403 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
406 last unless $loc || $is_deleted;
408 if ( $trans_id == $args->{trans_id} ) {
409 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
410 "$self->{long_pack} C C",
419 $self->_storage->print_at(
420 $args->{tag}{offset}, $args->{tag}{content},
427 sub _has_keyloc_entry {
431 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
432 my ($loc, $trans_id, $is_deleted) = unpack(
433 "$self->{long_pack} C C",
434 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
437 return 1 if $trans_id == $args->{trans_id};
443 sub _remove_key_offset {
448 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
449 my ($loc, $trans_id, $is_deleted) = unpack(
450 "$self->{long_pack} C C",
451 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
454 if ( $trans_id == $args->{trans_id} ) {
455 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = '';
456 $args->{tag}{content} .= chr(0) x $self->{key_size};
463 $self->_storage->print_at(
464 $args->{tag}{offset}, $args->{tag}{content},
471 sub _add_key_offset {
476 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
477 my ($loc, $trans_id, $is_deleted) = unpack(
478 "$self->{long_pack} C C",
479 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
482 if ( $trans_id == $args->{trans_id} || (!$loc && !$is_deleted) ) {
483 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
484 "$self->{long_pack} C C",
485 $args->{loc}, $args->{trans_id}, 0,
493 $self->_storage->print_at(
494 $args->{tag}{offset}, $args->{tag}{content},
498 die "Why didn't _add_key_offset() change something?!\n";
508 # Need to remove use of $fh here
509 my $fh = $self->_storage->{fh};
512 #XXX The duplication of calculate_sizes needs to go away
513 unless ( $obj->{base_offset} ) {
514 my $bytes_read = $self->read_file_header;
516 $self->calculate_sizes;
519 # File is empty -- write header and master index
522 $self->_storage->audit( "# Database created on" );
524 $self->write_file_header;
526 $obj->{base_offset} = $self->_storage->request_space(
527 $self->tag_size( $self->{keyloc_size} ),
529 warn "INITIAL BASE OFFSET: $obj->{base_offset}\n";
531 my $value_spot = $self->_storage->request_space(
532 $self->tag_size( $self->{index_size} ),
536 $obj->{base_offset}, SIG_KEYS,
537 pack( "$self->{long_pack} C C", $value_spot, HEAD, 0 ),
538 chr(0) x ($self->{index_size} - $self->{key_size}),
542 $value_spot, $obj->_type,
543 chr(0)x$self->{index_size},
546 # Flush the filehandle
547 my $old_fh = select $fh;
548 my $old_af = $|; $| = 1; $| = $old_af;
552 $obj->{base_offset} = $bytes_read;
553 warn "REOPEN BASE OFFSET: $obj->{base_offset}\n";
555 my ($_val_offset, $_is_del) = $self->_find_value_offset({
556 offset => $obj->{base_offset},
560 die "Attempt to use a deleted value" if $_is_del;
561 die "Internal error!" if !$_val_offset;
564 # Get our type from master index header
566 my $tag = $self->load_tag($_val_offset);
569 $self->_throw_error("Corrupted file, no master index record");
572 unless ($obj->_type eq $tag->{signature}) {
574 $self->_throw_error("File type mismatch");
579 $self->calculate_sizes;
582 #XXX We have to make sure we don't mess up when autoflush isn't turned on
583 $self->_storage->set_inode;