Commit | Line | Data |
fb451ba6 |
1 | package DBM::Deep::Engine2; |
2 | |
3 | use base 'DBM::Deep::Engine'; |
4 | |
5 | use 5.6.0; |
6 | |
7 | use strict; |
8 | use warnings; |
9 | |
10 | our $VERSION = q(0.99_03); |
11 | |
12 | use Fcntl qw( :DEFAULT :flock ); |
13 | use 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. |
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' } |
33 | sub SIG_SIZE () { 1 } |
34 | |
35 | # This is the transaction ID for the HEAD |
36 | sub HEAD () { 0 } |
37 | |
38 | sub read_value { |
39 | my $self = shift; |
40 | my ($trans_id, $base_offset, $key) = @_; |
41 | |
f5677eab |
42 | # print "Trying to read $key from $base_offset ($trans_id)\n" if $key > 400; |
fb451ba6 |
43 | my ($_val_offset, $_is_del) = $self->_find_value_offset({ |
44 | offset => $base_offset, |
45 | trans_id => $trans_id, |
46 | allow_head => 1, |
47 | }); |
48 | die "Attempt to use a deleted value" if $_is_del; |
49 | die "Internal error!" if !$_val_offset; |
50 | |
f5677eab |
51 | my ($key_tag) = $self->_find_key_offset({ |
fb451ba6 |
52 | offset => $_val_offset, |
53 | key_md5 => $self->_apply_digest( $key ), |
54 | }); |
f5677eab |
55 | return if !$key_tag; |
fb451ba6 |
56 | |
57 | my ($val_offset, $is_del) = $self->_find_value_offset({ |
f5677eab |
58 | offset => $key_tag->{start}, |
fb451ba6 |
59 | trans_id => $trans_id, |
60 | allow_head => 1, |
61 | }); |
62 | return if $is_del; |
63 | die "Internal error!" if !$val_offset; |
64 | |
65 | return $self->_read_value({ |
f5677eab |
66 | keyloc => $key_tag->{start}, |
fb451ba6 |
67 | offset => $val_offset, |
68 | }); |
69 | } |
70 | |
71 | sub 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 | |
101 | sub 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 | |
129ea236 |
129 | return $self->traverse_index( $temp, $_val_offset, 0 ); |
fb451ba6 |
130 | } |
131 | |
132 | sub delete_key { |
133 | my $self = shift; |
134 | my ($trans_id, $base_offset, $key) = @_; |
135 | |
136 | my ($_val_offset, $_is_del) = $self->_find_value_offset({ |
137 | offset => $base_offset, |
138 | trans_id => $trans_id, |
139 | allow_head => 1, |
140 | }); |
141 | die "Attempt to use a deleted value" if $_is_del; |
142 | die "Internal error!" if !$_val_offset; |
143 | |
f5677eab |
144 | my ($key_tag, $bucket_tag) = $self->_find_key_offset({ |
fb451ba6 |
145 | offset => $_val_offset, |
146 | key_md5 => $self->_apply_digest( $key ), |
147 | }); |
f5677eab |
148 | return if !$key_tag->{start}; |
fb451ba6 |
149 | |
129ea236 |
150 | my $value = $self->read_value( $trans_id, $base_offset, $key ); |
11eb1592 |
151 | my $value = $self->read_value( $trans_id, $base_offset, $key ); |
fb451ba6 |
152 | if ( $trans_id ) { |
153 | $self->_mark_as_deleted({ |
154 | tag => $key_tag, |
155 | trans_id => $trans_id, |
156 | }); |
157 | } |
158 | else { |
fb451ba6 |
159 | if ( my @transactions = $self->_storage->current_transactions ) { |
160 | foreach my $other_trans_id ( @transactions ) { |
161 | next if $self->_has_keyloc_entry({ |
162 | tag => $key_tag, |
163 | trans_id => $other_trans_id, |
164 | }); |
165 | $self->write_value( $other_trans_id, $base_offset, $key, $value ); |
166 | } |
167 | } |
129ea236 |
168 | |
169 | $self->_mark_as_deleted({ |
170 | tag => $key_tag, |
171 | trans_id => $trans_id, |
172 | }); |
173 | # $self->_remove_key_offset({ |
174 | # offset => $_val_offset, |
175 | # key_md5 => $self->_apply_digest( $key ), |
176 | # }); |
fb451ba6 |
177 | } |
178 | |
129ea236 |
179 | return $value; |
fb451ba6 |
180 | } |
181 | |
182 | sub write_value { |
183 | my $self = shift; |
184 | my ($trans_id, $base_offset, $key, $value) = @_; |
185 | |
186 | # This verifies that only supported values will be stored. |
187 | { |
188 | my $r = Scalar::Util::reftype( $value ); |
189 | |
190 | last if !defined $r; |
191 | last if $r eq 'HASH'; |
192 | last if $r eq 'ARRAY'; |
193 | |
194 | $self->_throw_error( |
195 | "Storage of references of type '$r' is not supported." |
196 | ); |
197 | } |
198 | |
199 | my ($_val_offset, $_is_del) = $self->_find_value_offset({ |
200 | offset => $base_offset, |
201 | trans_id => $trans_id, |
202 | allow_head => 1, |
203 | }); |
204 | die "Attempt to use a deleted value" if $_is_del; |
205 | die "Internal error!" if !$_val_offset; |
206 | |
f5677eab |
207 | my ($key_tag, $bucket_tag) = $self->_find_key_offset({ |
fb451ba6 |
208 | offset => $_val_offset, |
209 | key_md5 => $self->_apply_digest( $key ), |
210 | create => 1, |
211 | }); |
f5677eab |
212 | die "Cannot find/create new key offset!" if !$key_tag->{start}; |
fb451ba6 |
213 | |
214 | if ( $trans_id ) { |
f5677eab |
215 | if ( $key_tag->{is_new} ) { |
fb451ba6 |
216 | # Must mark the HEAD as deleted because it doesn't exist |
217 | $self->_mark_as_deleted({ |
218 | tag => $key_tag, |
219 | trans_id => HEAD, |
220 | }); |
221 | } |
222 | } |
223 | else { |
224 | # If the HEAD isn't new, then we must take other transactions |
225 | # into account. If it is, then there can be no other transactions. |
f5677eab |
226 | if ( !$key_tag->{is_new} ) { |
fb451ba6 |
227 | my $old_value = $self->read_value( $trans_id, $base_offset, $key ); |
228 | if ( my @transactions = $self->_storage->current_transactions ) { |
229 | foreach my $other_trans_id ( @transactions ) { |
230 | next if $self->_has_keyloc_entry({ |
231 | tag => $key_tag, |
232 | trans_id => $other_trans_id, |
233 | }); |
234 | $self->write_value( $other_trans_id, $base_offset, $key, $old_value ); |
235 | } |
236 | } |
237 | } |
238 | } |
239 | |
40956c06 |
240 | my $value_loc = $self->_storage->request_space( |
241 | $self->_length_needed( $value, $key ), |
242 | ); |
243 | |
244 | $self->_add_key_offset({ |
245 | tag => $key_tag, |
246 | trans_id => $trans_id, |
247 | loc => $value_loc, |
fb451ba6 |
248 | }); |
249 | |
f5677eab |
250 | $self->_write_value( $key_tag->{start}, $value_loc, $key, $value, $key ); |
40956c06 |
251 | |
fb451ba6 |
252 | return 1; |
253 | } |
254 | |
255 | sub _find_value_offset { |
256 | my $self = shift; |
257 | my ($args) = @_; |
258 | |
259 | my $key_tag = $self->load_tag( $args->{offset} ); |
260 | |
261 | my @head; |
262 | for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) { |
263 | my ($loc, $trans_id, $is_deleted) = unpack( |
264 | "$self->{long_pack} C C", |
265 | substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ), |
266 | ); |
267 | |
268 | if ( $trans_id == HEAD ) { |
269 | @head = ($loc, $is_deleted); |
270 | } |
271 | |
272 | next if $loc && $args->{trans_id} != $trans_id; |
273 | return( $loc, $is_deleted ); |
274 | } |
275 | |
276 | return @head if $args->{allow_head}; |
277 | return; |
278 | } |
279 | |
fb451ba6 |
280 | sub _find_key_offset { |
281 | my $self = shift; |
282 | my ($args) = @_; |
283 | |
284 | my $bucket_tag = $self->load_tag( $args->{offset} ) |
285 | or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" ); |
286 | |
fb451ba6 |
287 | #XXX What happens when $ch >= $self->{hash_size} ?? |
288 | for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) { |
289 | my $num = ord substr($args->{key_md5}, $ch, 1); |
290 | |
291 | my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size}); |
292 | $bucket_tag = $self->index_lookup( $bucket_tag, $num ); |
293 | |
294 | if (!$bucket_tag) { |
295 | return if !$args->{create}; |
296 | |
297 | my $loc = $self->_storage->request_space( |
298 | $self->tag_size( $self->{bucket_list_size} ), |
299 | ); |
300 | |
301 | $self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) ); |
302 | |
303 | $bucket_tag = $self->write_tag( |
304 | $loc, SIG_BLIST, |
305 | chr(0)x$self->{bucket_list_size}, |
306 | ); |
307 | |
308 | $bucket_tag->{ref_loc} = $ref_loc; |
309 | $bucket_tag->{ch} = $ch; |
310 | $bucket_tag->{is_new} = 1; |
311 | |
312 | last; |
313 | } |
314 | |
315 | $bucket_tag->{ch} = $ch; |
316 | $bucket_tag->{ref_loc} = $ref_loc; |
317 | } |
318 | |
319 | # Need to create a new keytag, too |
320 | if ( $bucket_tag->{is_new} ) { |
f5677eab |
321 | # print "Creating new keytag\n"; |
fb451ba6 |
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; |
357 | # print "Found ($subloc) at $index ($args->{create})\n"; |
358 | return ($self->load_tag( $subloc ), $bucket_tag) if $subloc || !$args->{create}; |
40956c06 |
359 | |
360 | my $keytag_loc = $self->_storage->request_space( |
361 | $self->tag_size( $self->{keyloc_size} ), |
362 | ); |
363 | |
364 | # There's space left in this bucket |
365 | if ( defined $index ) { |
f5677eab |
366 | # print "There's space left in the bucket for $keytag_loc\n"; |
40956c06 |
367 | substr( $bucket_tag->{content}, $index * $self->{key_size}, $self->{key_size} ) = |
368 | $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc ); |
369 | |
370 | $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} ); |
371 | } |
372 | # We need to split the index |
373 | else { |
f5677eab |
374 | # print "Splitting the index for $keytag_loc\n"; |
40956c06 |
375 | $self->split_index( $bucket_tag, $args->{key_md5}, $keytag_loc ); |
376 | } |
377 | |
f5677eab |
378 | my $key_tag = $self->write_tag( |
40956c06 |
379 | $keytag_loc, SIG_KEYS, |
380 | chr(0)x$self->{keyloc_size}, |
381 | ); |
382 | |
f5677eab |
383 | return( $key_tag, $bucket_tag ); |
fb451ba6 |
384 | } |
385 | |
386 | return; |
387 | } |
388 | |
389 | sub _read_value { |
390 | my $self = shift; |
391 | my ($args) = @_; |
392 | |
129ea236 |
393 | return $self->read_from_loc( $args->{keyloc}, $args->{offset} ); |
fb451ba6 |
394 | } |
395 | |
396 | sub _mark_as_deleted { |
397 | my $self = shift; |
398 | my ($args) = @_; |
399 | |
400 | my $is_changed; |
401 | for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) { |
402 | my ($loc, $trans_id, $is_deleted) = unpack( |
403 | "$self->{long_pack} C C", |
404 | substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ), |
405 | ); |
406 | |
129ea236 |
407 | last unless $loc || $is_deleted; |
fb451ba6 |
408 | |
409 | if ( $trans_id == $args->{trans_id} ) { |
410 | substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack( |
411 | "$self->{long_pack} C C", |
412 | $loc, $trans_id, 1, |
40956c06 |
413 | ); |
129ea236 |
414 | $is_changed = 1; |
415 | last; |
fb451ba6 |
416 | } |
417 | } |
418 | |
419 | if ( $is_changed ) { |
420 | $self->_storage->print_at( |
421 | $args->{tag}{offset}, $args->{tag}{content}, |
422 | ); |
423 | } |
424 | |
425 | return 1; |
426 | } |
427 | |
428 | sub _has_keyloc_entry { |
429 | my $self = shift; |
430 | my ($args) = @_; |
431 | |
432 | for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) { |
433 | my ($loc, $trans_id, $is_deleted) = unpack( |
434 | "$self->{long_pack} C C", |
435 | substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ), |
436 | ); |
437 | |
438 | return 1 if $trans_id == $args->{trans_id}; |
439 | } |
440 | |
441 | return; |
442 | } |
443 | |
444 | sub _remove_key_offset { |
445 | my $self = shift; |
446 | my ($args) = @_; |
447 | |
448 | my $is_changed; |
449 | for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) { |
450 | my ($loc, $trans_id, $is_deleted) = unpack( |
451 | "$self->{long_pack} C C", |
452 | substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ), |
453 | ); |
454 | |
455 | if ( $trans_id == $args->{trans_id} ) { |
456 | substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = ''; |
457 | $args->{tag}{content} .= chr(0) x $self->{key_size}; |
458 | $is_changed = 1; |
459 | redo; |
460 | } |
461 | } |
462 | |
463 | if ( $is_changed ) { |
464 | $self->_storage->print_at( |
465 | $args->{tag}{offset}, $args->{tag}{content}, |
466 | ); |
467 | } |
468 | |
469 | return 1; |
470 | } |
471 | |
40956c06 |
472 | sub _add_key_offset { |
fb451ba6 |
473 | my $self = shift; |
474 | my ($args) = @_; |
475 | |
40956c06 |
476 | my $is_changed; |
477 | for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) { |
478 | my ($loc, $trans_id, $is_deleted) = unpack( |
479 | "$self->{long_pack} C C", |
480 | substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ), |
481 | ); |
fb451ba6 |
482 | |
40956c06 |
483 | if ( $trans_id == $args->{trans_id} || (!$loc && !$is_deleted) ) { |
484 | substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack( |
485 | "$self->{long_pack} C C", |
486 | $args->{loc}, $args->{trans_id}, 0, |
487 | ); |
488 | $is_changed = 1; |
489 | last; |
490 | } |
491 | } |
492 | |
493 | if ( $is_changed ) { |
494 | $self->_storage->print_at( |
495 | $args->{tag}{offset}, $args->{tag}{content}, |
496 | ); |
497 | } |
498 | else { |
499 | die "Why didn't _add_key_offset() change something?!\n"; |
500 | } |
501 | |
502 | return 1; |
fb451ba6 |
503 | } |
504 | |
505 | sub setup_fh { |
506 | my $self = shift; |
507 | my ($obj) = @_; |
508 | |
509 | # Need to remove use of $fh here |
510 | my $fh = $self->_storage->{fh}; |
511 | flock $fh, LOCK_EX; |
512 | |
513 | #XXX The duplication of calculate_sizes needs to go away |
514 | unless ( $obj->{base_offset} ) { |
515 | my $bytes_read = $self->read_file_header; |
516 | |
517 | $self->calculate_sizes; |
518 | |
519 | ## |
520 | # File is empty -- write header and master index |
521 | ## |
522 | if (!$bytes_read) { |
523 | $self->_storage->audit( "# Database created on" ); |
524 | |
525 | $self->write_file_header; |
526 | |
527 | $obj->{base_offset} = $self->_storage->request_space( |
528 | $self->tag_size( $self->{keyloc_size} ), |
529 | ); |
f5677eab |
530 | warn "INITIAL BASE OFFSET: $obj->{base_offset}\n"; |
fb451ba6 |
531 | |
532 | my $value_spot = $self->_storage->request_space( |
533 | $self->tag_size( $self->{index_size} ), |
534 | ); |
535 | |
536 | $self->write_tag( |
537 | $obj->{base_offset}, SIG_KEYS, |
129ea236 |
538 | pack( "$self->{long_pack} C C", $value_spot, HEAD, 0 ), |
539 | chr(0) x ($self->{index_size} - $self->{key_size}), |
fb451ba6 |
540 | ); |
541 | |
542 | $self->write_tag( |
543 | $value_spot, $obj->_type, |
544 | chr(0)x$self->{index_size}, |
545 | ); |
546 | |
547 | # Flush the filehandle |
548 | my $old_fh = select $fh; |
549 | my $old_af = $|; $| = 1; $| = $old_af; |
550 | select $old_fh; |
551 | } |
552 | else { |
553 | $obj->{base_offset} = $bytes_read; |
f5677eab |
554 | warn "REOPEN BASE OFFSET: $obj->{base_offset}\n"; |
fb451ba6 |
555 | |
129ea236 |
556 | my ($_val_offset, $_is_del) = $self->_find_value_offset({ |
557 | offset => $obj->{base_offset}, |
558 | trans_id => HEAD, |
559 | allow_head => 1, |
560 | }); |
561 | die "Attempt to use a deleted value" if $_is_del; |
562 | die "Internal error!" if !$_val_offset; |
563 | |
fb451ba6 |
564 | ## |
565 | # Get our type from master index header |
566 | ## |
129ea236 |
567 | my $tag = $self->load_tag($_val_offset); |
fb451ba6 |
568 | unless ( $tag ) { |
569 | flock $fh, LOCK_UN; |
570 | $self->_throw_error("Corrupted file, no master index record"); |
571 | } |
572 | |
573 | unless ($obj->_type eq $tag->{signature}) { |
574 | flock $fh, LOCK_UN; |
575 | $self->_throw_error("File type mismatch"); |
576 | } |
577 | } |
578 | } |
579 | else { |
580 | $self->calculate_sizes; |
581 | } |
582 | |
583 | #XXX We have to make sure we don't mess up when autoflush isn't turned on |
584 | $self->_storage->set_inode; |
585 | |
586 | flock $fh, LOCK_UN; |
587 | |
588 | return 1; |
589 | } |
590 | |
591 | 1; |
592 | __END__ |