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 offset => $val_offset,
71 my ($trans_id, $base_offset, $key) = @_;
73 my ($_val_offset, $_is_del) = $self->_find_value_offset({
74 offset => $base_offset,
75 trans_id => $trans_id,
78 die "Attempt to use a deleted value" if $_is_del;
79 die "Internal error!" if !$_val_offset;
81 my ($key_offset) = $self->_find_key_offset({
82 offset => $_val_offset,
83 key_md5 => $self->_apply_digest( $key ),
85 return if !$key_offset;
87 my ($val_offset, $is_del) = $self->_find_value_offset({
88 offset => $key_offset,
89 trans_id => $trans_id,
95 die "Internal error!" if !$_val_offset;
103 # If the previous key was not specifed, start at the top and
104 # return the first one found.
108 prev_md5 => $self->apply_digest($_[1]),
114 prev_md5 => chr(0) x $self->{hash_size},
119 return $self->traverse_index( $temp, $offset, 0 );
124 my ($trans_id, $base_offset, $key) = @_;
126 my ($_val_offset, $_is_del) = $self->_find_value_offset({
127 offset => $base_offset,
128 trans_id => $trans_id,
131 die "Attempt to use a deleted value" if $_is_del;
132 die "Internal error!" if !$_val_offset;
134 my ($key_offset, $bucket_tag) = $self->_find_key_offset({
135 offset => $_val_offset,
136 key_md5 => $self->_apply_digest( $key ),
138 return if !$key_offset;
140 my $key_tag = $self->load_tag( $key_offset );
143 $self->_mark_as_deleted({
145 trans_id => $trans_id,
149 my $value = $self->read_value( $trans_id, $base_offset, $key );
150 if ( my @transactions = $self->_storage->current_transactions ) {
151 foreach my $other_trans_id ( @transactions ) {
152 next if $self->_has_keyloc_entry({
154 trans_id => $other_trans_id,
156 $self->write_value( $other_trans_id, $base_offset, $key, $value );
160 $self->_remove_key_offset({
161 offset => $_val_offset,
162 key_md5 => $self->_apply_digest( $key ),
172 my ($trans_id, $base_offset, $key, $value) = @_;
174 # This verifies that only supported values will be stored.
176 my $r = Scalar::Util::reftype( $value );
179 last if $r eq 'HASH';
180 last if $r eq 'ARRAY';
183 "Storage of references of type '$r' is not supported."
187 my ($_val_offset, $_is_del) = $self->_find_value_offset({
188 offset => $base_offset,
189 trans_id => $trans_id,
192 die "Attempt to use a deleted value" if $_is_del;
193 die "Internal error!" if !$_val_offset;
195 my ($key_offset, $bucket_tag) = $self->_find_key_offset({
196 offset => $_val_offset,
197 key_md5 => $self->_apply_digest( $key ),
200 die "Cannot find/create new key offset!" if !$key_offset;
202 my $key_tag = $self->load_tag( $key_offset );
205 if ( $bucket_tag->{is_new} ) {
206 # Must mark the HEAD as deleted because it doesn't exist
207 $self->_mark_as_deleted({
214 # If the HEAD isn't new, then we must take other transactions
215 # into account. If it is, then there can be no other transactions.
216 if ( !$bucket_tag->{is_new} ) {
217 my $old_value = $self->read_value( $trans_id, $base_offset, $key );
218 if ( my @transactions = $self->_storage->current_transactions ) {
219 foreach my $other_trans_id ( @transactions ) {
220 next if $self->_has_keyloc_entry({
222 trans_id => $other_trans_id,
224 $self->write_value( $other_trans_id, $base_offset, $key, $old_value );
231 $self->_write_value({
239 sub _find_value_offset {
243 my $key_tag = $self->load_tag( $args->{offset} );
246 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
247 my ($loc, $trans_id, $is_deleted) = unpack(
248 "$self->{long_pack} C C",
249 substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
252 if ( $trans_id == HEAD ) {
253 @head = ($loc, $is_deleted);
256 next if $loc && $args->{trans_id} != $trans_id;
257 return( $loc, $is_deleted );
260 return @head if $args->{allow_head};
264 #XXX Need to keep track of $bucket_tag->(ref_loc} and $bucket_tag->{ch}
265 sub _find_key_offset {
269 my $bucket_tag = $self->load_tag( $args->{offset} )
270 or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
272 # $bucket_tag->{ref_loc} and $bucket_tag->{ch} are used in split_index()
274 #XXX What happens when $ch >= $self->{hash_size} ??
275 for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
276 my $num = ord substr($args->{key_md5}, $ch, 1);
278 my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
279 $bucket_tag = $self->index_lookup( $bucket_tag, $num );
282 return if !$args->{create};
284 my $loc = $self->_storage->request_space(
285 $self->tag_size( $self->{bucket_list_size} ),
288 $self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
290 $bucket_tag = $self->write_tag(
292 chr(0)x$self->{bucket_list_size},
295 $bucket_tag->{ref_loc} = $ref_loc;
296 $bucket_tag->{ch} = $ch;
297 $bucket_tag->{is_new} = 1;
302 $bucket_tag->{ch} = $ch;
303 $bucket_tag->{ref_loc} = $ref_loc;
306 # Need to create a new keytag, too
307 if ( $bucket_tag->{is_new} ) {
308 my $keytag_loc = $self->_storage->request_space(
309 $self->tag_size( $self->{keyloc_size} ),
312 substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
313 $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
315 $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
318 $keytag_loc, SIG_KEYS,
319 chr(0)x$self->{keyloc_size},
322 return( $keytag_loc, $bucket_tag );
326 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
327 my ($key, $subloc) = $self->_get_key_subloc(
328 $bucket_tag->{content}, $i,
331 next BUCKET if $subloc && $key ne $args->{key_md5};
332 #XXX Right here, I need to create a new value, if I can
333 return( $subloc, $bucket_tag );
335 # Right here, it looks like split_index needs to happen
346 return $self->read_from_loc( $args->{offset} );
349 sub _mark_as_deleted {
354 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
355 my ($loc, $trans_id, $is_deleted) = unpack(
356 "$self->{long_pack} C C",
357 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
361 if ( $trans_id == $args->{trans_id} ) {
362 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
363 "$self->{long_pack} C C",
370 $self->_storage->print_at(
371 $args->{tag}{offset}, $args->{tag}{content},
378 sub _has_keyloc_entry {
382 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
383 my ($loc, $trans_id, $is_deleted) = unpack(
384 "$self->{long_pack} C C",
385 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
388 return 1 if $trans_id == $args->{trans_id};
394 sub _remove_key_offset {
399 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
400 my ($loc, $trans_id, $is_deleted) = unpack(
401 "$self->{long_pack} C C",
402 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
405 if ( $trans_id == $args->{trans_id} ) {
406 substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = '';
407 $args->{tag}{content} .= chr(0) x $self->{key_size};
414 $self->_storage->print_at(
415 $args->{tag}{offset}, $args->{tag}{content},
433 # Need to remove use of $fh here
434 my $fh = $self->_storage->{fh};
437 #XXX The duplication of calculate_sizes needs to go away
438 unless ( $obj->{base_offset} ) {
439 my $bytes_read = $self->read_file_header;
441 $self->calculate_sizes;
444 # File is empty -- write header and master index
447 $self->_storage->audit( "# Database created on" );
449 $self->write_file_header;
451 $obj->{base_offset} = $self->_storage->request_space(
452 $self->tag_size( $self->{keyloc_size} ),
455 my $value_spot = $self->_storage->request_space(
456 $self->tag_size( $self->{index_size} ),
460 $obj->{base_offset}, SIG_KEYS,
461 pack( "$self->{long_pack} C C", $obj->{base_offset}, 0, 0 ),
462 chr(0) x ($self->{index_size} - $self->{long_size} + 2),
466 $value_spot, $obj->_type,
467 chr(0)x$self->{index_size},
470 # Flush the filehandle
471 my $old_fh = select $fh;
472 my $old_af = $|; $| = 1; $| = $old_af;
476 $obj->{base_offset} = $bytes_read;
479 # Get our type from master index header
481 my $tag = $self->load_tag($obj->_base_offset);
484 $self->_throw_error("Corrupted file, no master index record");
487 unless ($obj->_type eq $tag->{signature}) {
489 $self->_throw_error("File type mismatch");
494 $self->calculate_sizes;
497 #XXX We have to make sure we don't mess up when autoflush isn't turned on
498 $self->_storage->set_inode;