Removed final vestiges of misunderstandings
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Engine2.pm
CommitLineData
fb451ba6 1package DBM::Deep::Engine2;
2
3use base 'DBM::Deep::Engine';
4
5use 5.6.0;
6
7use strict;
8use warnings;
9
10our $VERSION = q(0.99_03);
11
12use Fcntl qw( :DEFAULT :flock );
13use Scalar::Util ();
14
15# File-wide notes:
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
19# been done.
20
21# Setup file and tag signatures. These should never change.
22sub SIG_FILE () { 'DPDB' }
23sub SIG_HEADER () { 'h' }
24sub SIG_INTERNAL () { 'i' }
25sub SIG_HASH () { 'H' }
26sub SIG_ARRAY () { 'A' }
27sub SIG_NULL () { 'N' }
28sub SIG_DATA () { 'D' }
29sub SIG_INDEX () { 'I' }
30sub SIG_BLIST () { 'B' }
31sub SIG_FREE () { 'F' }
32sub SIG_KEYS () { 'K' }
33sub SIG_SIZE () { 1 }
34
35# This is the transaction ID for the HEAD
36sub HEAD () { 0 }
37
38sub read_value {
39 my $self = shift;
40 my ($trans_id, $base_offset, $key) = @_;
41
42 my ($_val_offset, $_is_del) = $self->_find_value_offset({
43 offset => $base_offset,
44 trans_id => $trans_id,
45 allow_head => 1,
46 });
47 die "Attempt to use a deleted value" if $_is_del;
48 die "Internal error!" if !$_val_offset;
49
f5677eab 50 my ($key_tag) = $self->_find_key_offset({
fb451ba6 51 offset => $_val_offset,
52 key_md5 => $self->_apply_digest( $key ),
53 });
f5677eab 54 return if !$key_tag;
fb451ba6 55
56 my ($val_offset, $is_del) = $self->_find_value_offset({
f5677eab 57 offset => $key_tag->{start},
fb451ba6 58 trans_id => $trans_id,
59 allow_head => 1,
60 });
61 return if $is_del;
62 die "Internal error!" if !$val_offset;
63
64 return $self->_read_value({
f5677eab 65 keyloc => $key_tag->{start},
fb451ba6 66 offset => $val_offset,
1ad1fc2b 67 key => $key,
fb451ba6 68 });
69}
70
71sub key_exists {
72 my $self = shift;
73 my ($trans_id, $base_offset, $key) = @_;
74
75 my ($_val_offset, $_is_del) = $self->_find_value_offset({
76 offset => $base_offset,
77 trans_id => $trans_id,
78 allow_head => 1,
79 });
80 die "Attempt to use a deleted value" if $_is_del;
81 die "Internal error!" if !$_val_offset;
82
f5677eab 83 my ($key_tag) = $self->_find_key_offset({
fb451ba6 84 offset => $_val_offset,
85 key_md5 => $self->_apply_digest( $key ),
86 });
f5677eab 87 return '' if !$key_tag->{start};
fb451ba6 88
89 my ($val_offset, $is_del) = $self->_find_value_offset({
f5677eab 90 offset => $key_tag->{start},
fb451ba6 91 trans_id => $trans_id,
92 allow_head => 1,
93 });
f5677eab 94 die "Internal error!" if !$_val_offset;
fb451ba6 95
129ea236 96 return '' if $is_del;
fb451ba6 97
129ea236 98 return 1;
fb451ba6 99}
100
101sub get_next_key {
102 my $self = shift;
129ea236 103 my ($trans_id, $base_offset) = @_;
104
105 my ($_val_offset, $_is_del) = $self->_find_value_offset({
106 offset => $base_offset,
107 trans_id => $trans_id,
108 allow_head => 1,
109 });
110 die "Attempt to use a deleted value" if $_is_del;
111 die "Internal error!" if !$_val_offset;
fb451ba6 112
113 # If the previous key was not specifed, start at the top and
114 # return the first one found.
115 my $temp;
129ea236 116 if ( @_ > 2 ) {
fb451ba6 117 $temp = {
129ea236 118 prev_md5 => $self->_apply_digest($_[2]),
fb451ba6 119 return_next => 0,
120 };
121 }
122 else {
123 $temp = {
124 prev_md5 => chr(0) x $self->{hash_size},
125 return_next => 1,
126 };
127 }
128
1ad1fc2b 129 local $::DEBUG = 1;
130 print "get_next_key: $_val_offset\n" if $::DEBUG;
129ea236 131 return $self->traverse_index( $temp, $_val_offset, 0 );
fb451ba6 132}
133
134sub delete_key {
135 my $self = shift;
136 my ($trans_id, $base_offset, $key) = @_;
137
138 my ($_val_offset, $_is_del) = $self->_find_value_offset({
139 offset => $base_offset,
140 trans_id => $trans_id,
141 allow_head => 1,
142 });
143 die "Attempt to use a deleted value" if $_is_del;
144 die "Internal error!" if !$_val_offset;
145
f5677eab 146 my ($key_tag, $bucket_tag) = $self->_find_key_offset({
fb451ba6 147 offset => $_val_offset,
148 key_md5 => $self->_apply_digest( $key ),
149 });
f5677eab 150 return if !$key_tag->{start};
fb451ba6 151
129ea236 152 my $value = $self->read_value( $trans_id, $base_offset, $key );
fb451ba6 153 if ( $trans_id ) {
154 $self->_mark_as_deleted({
155 tag => $key_tag,
156 trans_id => $trans_id,
157 });
158 }
159 else {
fb451ba6 160 if ( my @transactions = $self->_storage->current_transactions ) {
161 foreach my $other_trans_id ( @transactions ) {
162 next if $self->_has_keyloc_entry({
163 tag => $key_tag,
164 trans_id => $other_trans_id,
165 });
166 $self->write_value( $other_trans_id, $base_offset, $key, $value );
167 }
168 }
129ea236 169
170 $self->_mark_as_deleted({
171 tag => $key_tag,
172 trans_id => $trans_id,
173 });
174# $self->_remove_key_offset({
175# offset => $_val_offset,
176# key_md5 => $self->_apply_digest( $key ),
177# });
fb451ba6 178 }
179
129ea236 180 return $value;
fb451ba6 181}
182
183sub write_value {
184 my $self = shift;
185 my ($trans_id, $base_offset, $key, $value) = @_;
186
187 # This verifies that only supported values will be stored.
188 {
189 my $r = Scalar::Util::reftype( $value );
190
191 last if !defined $r;
192 last if $r eq 'HASH';
193 last if $r eq 'ARRAY';
194
195 $self->_throw_error(
196 "Storage of references of type '$r' is not supported."
197 );
198 }
199
200 my ($_val_offset, $_is_del) = $self->_find_value_offset({
201 offset => $base_offset,
202 trans_id => $trans_id,
203 allow_head => 1,
204 });
205 die "Attempt to use a deleted value" if $_is_del;
206 die "Internal error!" if !$_val_offset;
207
f5677eab 208 my ($key_tag, $bucket_tag) = $self->_find_key_offset({
fb451ba6 209 offset => $_val_offset,
210 key_md5 => $self->_apply_digest( $key ),
211 create => 1,
212 });
f5677eab 213 die "Cannot find/create new key offset!" if !$key_tag->{start};
fb451ba6 214
215 if ( $trans_id ) {
f5677eab 216 if ( $key_tag->{is_new} ) {
fb451ba6 217 # Must mark the HEAD as deleted because it doesn't exist
218 $self->_mark_as_deleted({
219 tag => $key_tag,
220 trans_id => HEAD,
221 });
222 }
223 }
224 else {
225 # If the HEAD isn't new, then we must take other transactions
226 # into account. If it is, then there can be no other transactions.
f5677eab 227 if ( !$key_tag->{is_new} ) {
fb451ba6 228 my $old_value = $self->read_value( $trans_id, $base_offset, $key );
229 if ( my @transactions = $self->_storage->current_transactions ) {
230 foreach my $other_trans_id ( @transactions ) {
231 next if $self->_has_keyloc_entry({
232 tag => $key_tag,
233 trans_id => $other_trans_id,
234 });
235 $self->write_value( $other_trans_id, $base_offset, $key, $old_value );
236 }
237 }
238 }
239 }
240
40956c06 241 my $value_loc = $self->_storage->request_space(
242 $self->_length_needed( $value, $key ),
243 );
244
245 $self->_add_key_offset({
246 tag => $key_tag,
247 trans_id => $trans_id,
248 loc => $value_loc,
fb451ba6 249 });
250
f5677eab 251 $self->_write_value( $key_tag->{start}, $value_loc, $key, $value, $key );
40956c06 252
fb451ba6 253 return 1;
254}
255
256sub _find_value_offset {
257 my $self = shift;
258 my ($args) = @_;
259
260 my $key_tag = $self->load_tag( $args->{offset} );
261
262 my @head;
263 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
264 my ($loc, $trans_id, $is_deleted) = unpack(
265 "$self->{long_pack} C C",
266 substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
267 );
268
269 if ( $trans_id == HEAD ) {
270 @head = ($loc, $is_deleted);
271 }
272
273 next if $loc && $args->{trans_id} != $trans_id;
274 return( $loc, $is_deleted );
275 }
276
277 return @head if $args->{allow_head};
278 return;
279}
280
fb451ba6 281sub _find_key_offset {
282 my $self = shift;
283 my ($args) = @_;
284
285 my $bucket_tag = $self->load_tag( $args->{offset} )
286 or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
287
fb451ba6 288 #XXX What happens when $ch >= $self->{hash_size} ??
289 for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
290 my $num = ord substr($args->{key_md5}, $ch, 1);
291
292 my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
293 $bucket_tag = $self->index_lookup( $bucket_tag, $num );
294
295 if (!$bucket_tag) {
296 return if !$args->{create};
297
298 my $loc = $self->_storage->request_space(
299 $self->tag_size( $self->{bucket_list_size} ),
300 );
301
302 $self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
303
304 $bucket_tag = $self->write_tag(
305 $loc, SIG_BLIST,
306 chr(0)x$self->{bucket_list_size},
307 );
308
309 $bucket_tag->{ref_loc} = $ref_loc;
310 $bucket_tag->{ch} = $ch;
311 $bucket_tag->{is_new} = 1;
312
313 last;
314 }
315
316 $bucket_tag->{ch} = $ch;
317 $bucket_tag->{ref_loc} = $ref_loc;
318 }
319
320 # Need to create a new keytag, too
321 if ( $bucket_tag->{is_new} ) {
322 my $keytag_loc = $self->_storage->request_space(
323 $self->tag_size( $self->{keyloc_size} ),
324 );
325
326 substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
327 $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
328
329 $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
330
f5677eab 331 my $key_tag = $self->write_tag(
fb451ba6 332 $keytag_loc, SIG_KEYS,
333 chr(0)x$self->{keyloc_size},
334 );
335
f5677eab 336 return( $key_tag, $bucket_tag );
fb451ba6 337 }
338 else {
40956c06 339 my ($key, $subloc, $index);
fb451ba6 340 BUCKET:
341 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
40956c06 342 ($key, $subloc) = $self->_get_key_subloc(
fb451ba6 343 $bucket_tag->{content}, $i,
344 );
345
346 next BUCKET if $subloc && $key ne $args->{key_md5};
40956c06 347
348 # Keep track of where we are, in case we need to create a new
349 # entry.
350 $index = $i;
351 last;
fb451ba6 352 }
40956c06 353
f5677eab 354 # If we have a subloc to return or we don't want to create a new
355 # entry, we need to return now.
356 $args->{create} ||= 0;
f5677eab 357 return ($self->load_tag( $subloc ), $bucket_tag) if $subloc || !$args->{create};
40956c06 358
359 my $keytag_loc = $self->_storage->request_space(
360 $self->tag_size( $self->{keyloc_size} ),
361 );
362
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 );
367
368 $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
369 }
370 # We need to split the index
371 else {
372 $self->split_index( $bucket_tag, $args->{key_md5}, $keytag_loc );
373 }
374
f5677eab 375 my $key_tag = $self->write_tag(
40956c06 376 $keytag_loc, SIG_KEYS,
377 chr(0)x$self->{keyloc_size},
378 );
379
f5677eab 380 return( $key_tag, $bucket_tag );
fb451ba6 381 }
382
383 return;
384}
385
386sub _read_value {
387 my $self = shift;
388 my ($args) = @_;
389
1ad1fc2b 390 return $self->read_from_loc( $args->{keyloc}, $args->{offset}, $args->{key} );
fb451ba6 391}
392
393sub _mark_as_deleted {
394 my $self = shift;
395 my ($args) = @_;
396
397 my $is_changed;
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} ),
402 );
403
129ea236 404 last unless $loc || $is_deleted;
fb451ba6 405
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",
409 $loc, $trans_id, 1,
40956c06 410 );
129ea236 411 $is_changed = 1;
412 last;
fb451ba6 413 }
414 }
415
416 if ( $is_changed ) {
417 $self->_storage->print_at(
418 $args->{tag}{offset}, $args->{tag}{content},
419 );
420 }
421
422 return 1;
423}
424
425sub _has_keyloc_entry {
426 my $self = shift;
427 my ($args) = @_;
428
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} ),
433 );
434
435 return 1 if $trans_id == $args->{trans_id};
436 }
437
438 return;
439}
440
441sub _remove_key_offset {
442 my $self = shift;
443 my ($args) = @_;
444
445 my $is_changed;
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} ),
450 );
451
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};
455 $is_changed = 1;
456 redo;
457 }
458 }
459
460 if ( $is_changed ) {
461 $self->_storage->print_at(
462 $args->{tag}{offset}, $args->{tag}{content},
463 );
464 }
465
466 return 1;
467}
468
40956c06 469sub _add_key_offset {
fb451ba6 470 my $self = shift;
471 my ($args) = @_;
472
40956c06 473 my $is_changed;
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} ),
478 );
fb451ba6 479
40956c06 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,
484 );
485 $is_changed = 1;
486 last;
487 }
488 }
489
490 if ( $is_changed ) {
491 $self->_storage->print_at(
492 $args->{tag}{offset}, $args->{tag}{content},
493 );
494 }
495 else {
496 die "Why didn't _add_key_offset() change something?!\n";
497 }
498
499 return 1;
fb451ba6 500}
501
502sub setup_fh {
503 my $self = shift;
504 my ($obj) = @_;
505
506 # Need to remove use of $fh here
507 my $fh = $self->_storage->{fh};
508 flock $fh, LOCK_EX;
509
510 #XXX The duplication of calculate_sizes needs to go away
511 unless ( $obj->{base_offset} ) {
512 my $bytes_read = $self->read_file_header;
513
514 $self->calculate_sizes;
515
516 ##
517 # File is empty -- write header and master index
518 ##
519 if (!$bytes_read) {
520 $self->_storage->audit( "# Database created on" );
521
522 $self->write_file_header;
523
524 $obj->{base_offset} = $self->_storage->request_space(
525 $self->tag_size( $self->{keyloc_size} ),
526 );
527
528 my $value_spot = $self->_storage->request_space(
529 $self->tag_size( $self->{index_size} ),
530 );
531
532 $self->write_tag(
533 $obj->{base_offset}, SIG_KEYS,
129ea236 534 pack( "$self->{long_pack} C C", $value_spot, HEAD, 0 ),
535 chr(0) x ($self->{index_size} - $self->{key_size}),
fb451ba6 536 );
537
538 $self->write_tag(
539 $value_spot, $obj->_type,
540 chr(0)x$self->{index_size},
541 );
542
543 # Flush the filehandle
544 my $old_fh = select $fh;
545 my $old_af = $|; $| = 1; $| = $old_af;
546 select $old_fh;
547 }
548 else {
549 $obj->{base_offset} = $bytes_read;
550
129ea236 551 my ($_val_offset, $_is_del) = $self->_find_value_offset({
552 offset => $obj->{base_offset},
553 trans_id => HEAD,
554 allow_head => 1,
555 });
556 die "Attempt to use a deleted value" if $_is_del;
557 die "Internal error!" if !$_val_offset;
558
fb451ba6 559 ##
560 # Get our type from master index header
561 ##
129ea236 562 my $tag = $self->load_tag($_val_offset);
fb451ba6 563 unless ( $tag ) {
564 flock $fh, LOCK_UN;
565 $self->_throw_error("Corrupted file, no master index record");
566 }
567
568 unless ($obj->_type eq $tag->{signature}) {
569 flock $fh, LOCK_UN;
570 $self->_throw_error("File type mismatch");
571 }
572 }
573 }
574 else {
575 $self->calculate_sizes;
576 }
577
578 #XXX We have to make sure we don't mess up when autoflush isn't turned on
579 $self->_storage->set_inode;
580
581 flock $fh, LOCK_UN;
582
583 return 1;
584}
585
5861;
587__END__