Commit | Line | Data |
2c70efe1 |
1 | package DBM::Deep::Sector::File::Reference; |
f0276afb |
2 | |
3 | use 5.006_000; |
4 | |
5 | use strict; |
6 | use warnings FATAL => 'all'; |
7 | |
2c70efe1 |
8 | use base qw( DBM::Deep::Sector::File::Data ); |
f0276afb |
9 | |
5ae752e2 |
10 | my $STALE_SIZE = 2; |
11 | |
12 | # Please refer to the pack() documentation for further information |
13 | my %StP = ( |
14 | 1 => 'C', # Unsigned char value (no order needed as it's just one byte) |
15 | 2 => 'n', # Unsigned short in "network" (big-endian) order |
16 | 4 => 'N', # Unsigned long in "network" (big-endian) order |
17 | 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) |
18 | ); |
19 | |
f0276afb |
20 | sub _init { |
21 | my $self = shift; |
22 | |
23 | my $e = $self->engine; |
24 | |
25 | unless ( $self->offset ) { |
26 | my $classname = Scalar::Util::blessed( delete $self->{data} ); |
27 | my $leftover = $self->size - $self->base_size - 3 * $e->byte_size; |
28 | |
29 | my $class_offset = 0; |
30 | if ( defined $classname ) { |
2c70efe1 |
31 | my $class_sector = DBM::Deep::Sector::File::Scalar->new({ |
f0276afb |
32 | engine => $e, |
33 | data => $classname, |
34 | }); |
35 | $class_offset = $class_sector->offset; |
36 | } |
37 | |
38 | $self->{offset} = $e->_request_data_sector( $self->size ); |
39 | $e->storage->print_at( $self->offset, $self->type ); # Sector type |
40 | # Skip staleness counter |
41 | $e->storage->print_at( $self->offset + $self->base_size, |
42 | pack( $StP{$e->byte_size}, 0 ), # Index/BList loc |
43 | pack( $StP{$e->byte_size}, $class_offset ), # Classname loc |
44 | pack( $StP{$e->byte_size}, 1 ), # Initial refcount |
45 | chr(0) x $leftover, # Zero-fill the rest |
46 | ); |
47 | } |
48 | else { |
49 | $self->{type} = $e->storage->read_at( $self->offset, 1 ); |
50 | } |
51 | |
52 | $self->{staleness} = unpack( |
53 | $StP{$STALE_SIZE}, |
54 | $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ), |
55 | ); |
56 | |
57 | return; |
58 | } |
59 | |
f0276afb |
60 | sub get_data_location_for { |
61 | my $self = shift; |
62 | my ($args) = @_; |
63 | |
64 | # Assume that the head is not allowed unless otherwise specified. |
65 | $args->{allow_head} = 0 unless exists $args->{allow_head}; |
66 | |
67 | # Assume we don't create a new blist location unless otherwise specified. |
68 | $args->{create} = 0 unless exists $args->{create}; |
69 | |
70 | my $blist = $self->get_bucket_list({ |
71 | key_md5 => $args->{key_md5}, |
72 | key => $args->{key}, |
73 | create => $args->{create}, |
74 | }); |
75 | return unless $blist && $blist->{found}; |
76 | |
77 | # At this point, $blist knows where the md5 is. What it -doesn't- know yet |
78 | # is whether or not this transaction has this key. That's part of the next |
79 | # function call. |
80 | my $location = $blist->get_data_location_for({ |
81 | allow_head => $args->{allow_head}, |
82 | }) or return; |
83 | |
84 | return $location; |
85 | } |
86 | |
87 | sub get_data_for { |
88 | my $self = shift; |
89 | my ($args) = @_; |
90 | |
91 | my $location = $self->get_data_location_for( $args ) |
92 | or return; |
93 | |
d6ecf579 |
94 | return $self->engine->load_sector( $location ); |
f0276afb |
95 | } |
96 | |
97 | sub write_data { |
98 | my $self = shift; |
99 | my ($args) = @_; |
100 | |
101 | my $blist = $self->get_bucket_list({ |
102 | key_md5 => $args->{key_md5}, |
103 | key => $args->{key}, |
104 | create => 1, |
105 | }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" ); |
106 | |
107 | # Handle any transactional bookkeeping. |
108 | if ( $self->engine->trans_id ) { |
109 | if ( ! $blist->has_md5 ) { |
110 | $blist->mark_deleted({ |
111 | trans_id => 0, |
112 | }); |
113 | } |
114 | } |
115 | else { |
116 | my @trans_ids = $self->engine->get_running_txn_ids; |
117 | if ( $blist->has_md5 ) { |
118 | if ( @trans_ids ) { |
119 | my $old_value = $blist->get_data_for; |
120 | foreach my $other_trans_id ( @trans_ids ) { |
121 | next if $blist->get_data_location_for({ |
122 | trans_id => $other_trans_id, |
123 | allow_head => 0, |
124 | }); |
125 | $blist->write_md5({ |
126 | trans_id => $other_trans_id, |
127 | key => $args->{key}, |
128 | key_md5 => $args->{key_md5}, |
129 | value => $old_value->clone, |
130 | }); |
131 | } |
132 | } |
133 | } |
134 | else { |
135 | if ( @trans_ids ) { |
136 | foreach my $other_trans_id ( @trans_ids ) { |
137 | #XXX This doesn't seem to possible to ever happen . . . |
138 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
139 | $blist->mark_deleted({ |
140 | trans_id => $other_trans_id, |
141 | }); |
142 | } |
143 | } |
144 | } |
145 | } |
146 | |
147 | #XXX Is this safe to do transactionally? |
148 | # Free the place we're about to write to. |
149 | if ( $blist->get_data_location_for({ allow_head => 0 }) ) { |
150 | $blist->get_data_for({ allow_head => 0 })->free; |
151 | } |
152 | |
153 | $blist->write_md5({ |
154 | key => $args->{key}, |
155 | key_md5 => $args->{key_md5}, |
156 | value => $args->{value}, |
157 | }); |
158 | } |
159 | |
160 | sub delete_key { |
161 | my $self = shift; |
162 | my ($args) = @_; |
163 | |
c803879b |
164 | # This can return nothing if we are deleting an entry in a hashref that was |
165 | # auto-vivified as part of the delete process. For example: |
166 | # my $x = {}; |
167 | # delete $x->{foo}{bar}; |
f0276afb |
168 | my $blist = $self->get_bucket_list({ |
169 | key_md5 => $args->{key_md5}, |
c803879b |
170 | }) or return; |
f0276afb |
171 | |
172 | # Save the location so that we can free the data |
173 | my $location = $blist->get_data_location_for({ |
174 | allow_head => 0, |
175 | }); |
d6ecf579 |
176 | my $old_value = $location && $self->engine->load_sector( $location ); |
f0276afb |
177 | |
178 | my @trans_ids = $self->engine->get_running_txn_ids; |
179 | |
a4d36ff6 |
180 | # If we're the HEAD and there are running txns, then we need to clone this |
181 | # value to the other transactions to preserve Isolation. |
f0276afb |
182 | if ( $self->engine->trans_id == 0 ) { |
183 | if ( @trans_ids ) { |
184 | foreach my $other_trans_id ( @trans_ids ) { |
185 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
186 | $blist->write_md5({ |
187 | trans_id => $other_trans_id, |
188 | key => $args->{key}, |
189 | key_md5 => $args->{key_md5}, |
190 | value => $old_value->clone, |
191 | }); |
192 | } |
193 | } |
194 | } |
195 | |
196 | my $data; |
197 | if ( @trans_ids ) { |
198 | $blist->mark_deleted( $args ); |
199 | |
200 | if ( $old_value ) { |
a4d36ff6 |
201 | #XXX Is this export => 1 actually doing anything? |
f0276afb |
202 | $data = $old_value->data({ export => 1 }); |
203 | $old_value->free; |
204 | } |
205 | } |
206 | else { |
207 | $data = $blist->delete_md5( $args ); |
208 | } |
209 | |
210 | return $data; |
211 | } |
212 | |
d3aaaf5e |
213 | sub write_blist_loc { |
214 | my $self = shift; |
215 | my ($loc) = @_; |
216 | |
217 | my $engine = $self->engine; |
218 | $engine->storage->print_at( $self->offset + $self->base_size, |
219 | pack( $StP{$engine->byte_size}, $loc ), |
220 | ); |
d3aaaf5e |
221 | } |
222 | |
f0276afb |
223 | sub get_blist_loc { |
224 | my $self = shift; |
225 | |
226 | my $e = $self->engine; |
227 | my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size ); |
228 | return unpack( $StP{$e->byte_size}, $blist_loc ); |
229 | } |
230 | |
231 | sub get_bucket_list { |
232 | my $self = shift; |
233 | my ($args) = @_; |
234 | $args ||= {}; |
235 | |
236 | # XXX Add in check here for recycling? |
237 | |
238 | my $engine = $self->engine; |
239 | |
240 | my $blist_loc = $self->get_blist_loc; |
241 | |
242 | # There's no index or blist yet |
243 | unless ( $blist_loc ) { |
244 | return unless $args->{create}; |
245 | |
2c70efe1 |
246 | my $blist = DBM::Deep::Sector::File::BucketList->new({ |
f0276afb |
247 | engine => $engine, |
248 | key_md5 => $args->{key_md5}, |
249 | }); |
250 | |
d3aaaf5e |
251 | $self->write_blist_loc( $blist->offset ); |
252 | # $engine->storage->print_at( $self->offset + $self->base_size, |
253 | # pack( $StP{$engine->byte_size}, $blist->offset ), |
254 | # ); |
f0276afb |
255 | |
256 | return $blist; |
257 | } |
258 | |
d6ecf579 |
259 | my $sector = $engine->load_sector( $blist_loc ) |
f0276afb |
260 | or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); |
261 | my $i = 0; |
262 | my $last_sector = undef; |
2c70efe1 |
263 | while ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) { |
f0276afb |
264 | $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) ); |
265 | $last_sector = $sector; |
266 | if ( $blist_loc ) { |
d6ecf579 |
267 | $sector = $engine->load_sector( $blist_loc ) |
f0276afb |
268 | or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); |
269 | } |
270 | else { |
271 | $sector = undef; |
272 | last; |
273 | } |
274 | } |
275 | |
276 | # This means we went through the Index sector(s) and found an empty slot |
277 | unless ( $sector ) { |
278 | return unless $args->{create}; |
279 | |
280 | DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" ) |
281 | unless $last_sector; |
282 | |
2c70efe1 |
283 | my $blist = DBM::Deep::Sector::File::BucketList->new({ |
f0276afb |
284 | engine => $engine, |
285 | key_md5 => $args->{key_md5}, |
286 | }); |
287 | |
288 | $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset ); |
289 | |
290 | return $blist; |
291 | } |
292 | |
293 | $sector->find_md5( $args->{key_md5} ); |
294 | |
295 | # See whether or not we need to reindex the bucketlist |
cd5303b4 |
296 | # Yes, the double-braces are there for a reason. if() doesn't create a |
297 | # redo-able block, so we have to create a bare block within the if() for |
298 | # redo-purposes. |
299 | # Patch and idea submitted by sprout@cpan.org. -RobK, 2008-01-09 |
f0276afb |
300 | if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{ |
301 | my $redo; |
302 | |
2c70efe1 |
303 | my $new_index = DBM::Deep::Sector::File::Index->new({ |
f0276afb |
304 | engine => $engine, |
305 | }); |
306 | |
307 | my %blist_cache; |
308 | #XXX q.v. the comments for this function. |
309 | foreach my $entry ( $sector->chopped_up ) { |
310 | my ($spot, $md5) = @{$entry}; |
311 | my $idx = ord( substr( $md5, $i, 1 ) ); |
312 | |
313 | # XXX This is inefficient |
314 | my $blist = $blist_cache{$idx} |
2c70efe1 |
315 | ||= DBM::Deep::Sector::File::BucketList->new({ |
f0276afb |
316 | engine => $engine, |
317 | }); |
318 | |
319 | $new_index->set_entry( $idx => $blist->offset ); |
320 | |
321 | my $new_spot = $blist->write_at_next_open( $md5 ); |
322 | $engine->reindex_entry( $spot => $new_spot ); |
323 | } |
324 | |
325 | # Handle the new item separately. |
326 | { |
327 | my $idx = ord( substr( $args->{key_md5}, $i, 1 ) ); |
328 | |
329 | # If all the previous blist's items have been thrown into one |
330 | # blist and the new item belongs in there too, we need |
331 | # another index. |
332 | if ( keys %blist_cache == 1 and each %blist_cache == $idx ) { |
333 | ++$i, ++$redo; |
334 | } else { |
335 | my $blist = $blist_cache{$idx} |
2c70efe1 |
336 | ||= DBM::Deep::Sector::File::BucketList->new({ |
f0276afb |
337 | engine => $engine, |
338 | }); |
339 | |
340 | $new_index->set_entry( $idx => $blist->offset ); |
341 | |
342 | #XXX THIS IS HACKY! |
343 | $blist->find_md5( $args->{key_md5} ); |
344 | $blist->write_md5({ |
345 | key => $args->{key}, |
346 | key_md5 => $args->{key_md5}, |
2c70efe1 |
347 | value => DBM::Deep::Sector::File::Null->new({ |
f0276afb |
348 | engine => $engine, |
349 | data => undef, |
350 | }), |
351 | }); |
352 | } |
f0276afb |
353 | } |
354 | |
355 | if ( $last_sector ) { |
356 | $last_sector->set_entry( |
357 | ord( substr( $args->{key_md5}, $i - 1, 1 ) ), |
358 | $new_index->offset, |
359 | ); |
360 | } else { |
361 | $engine->storage->print_at( $self->offset + $self->base_size, |
362 | pack( $StP{$engine->byte_size}, $new_index->offset ), |
363 | ); |
364 | } |
365 | |
d3aaaf5e |
366 | $sector->wipe; |
f0276afb |
367 | $sector->free; |
368 | |
369 | if ( $redo ) { |
370 | (undef, $sector) = %blist_cache; |
371 | $last_sector = $new_index; |
372 | redo; |
373 | } |
374 | |
375 | $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) }; |
376 | $sector->find_md5( $args->{key_md5} ); |
377 | }} |
378 | |
379 | return $sector; |
380 | } |
381 | |
382 | sub get_class_offset { |
383 | my $self = shift; |
384 | |
385 | my $e = $self->engine; |
386 | return unpack( |
387 | $StP{$e->byte_size}, |
388 | $e->storage->read_at( |
389 | $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size, |
390 | ), |
391 | ); |
392 | } |
393 | |
394 | sub get_classname { |
395 | my $self = shift; |
396 | |
397 | my $class_offset = $self->get_class_offset; |
398 | |
399 | return unless $class_offset; |
400 | |
d6ecf579 |
401 | return $self->engine->load_sector( $class_offset )->data; |
f0276afb |
402 | } |
403 | |
4f034d8f |
404 | # Look to hoist this method into a ::Reference trait |
f0276afb |
405 | sub data { |
406 | my $self = shift; |
407 | my ($args) = @_; |
408 | $args ||= {}; |
409 | |
e73f12ce |
410 | my $engine = $self->engine; |
66285e35 |
411 | # if ( !exists $engine->cache->{ $self->offset }{ $engine->trans_id } ) { |
e73f12ce |
412 | my $obj = DBM::Deep->new({ |
f0276afb |
413 | type => $self->type, |
414 | base_offset => $self->offset, |
415 | staleness => $self->staleness, |
e73f12ce |
416 | storage => $engine->storage, |
417 | engine => $engine, |
f0276afb |
418 | }); |
419 | |
66285e35 |
420 | # $engine->cache->{$self->offset}{ $engine->trans_id } = $obj; |
e73f12ce |
421 | # } |
66285e35 |
422 | # my $obj = $engine->cache->{$self->offset}{ $engine->trans_id }; |
e73f12ce |
423 | |
424 | # We're not exporting, so just return. |
425 | unless ( $args->{export} ) { |
426 | if ( $engine->storage->{autobless} ) { |
f0276afb |
427 | my $classname = $self->get_classname; |
428 | if ( defined $classname ) { |
429 | bless $obj, $classname; |
430 | } |
431 | } |
432 | |
f0276afb |
433 | return $obj; |
434 | } |
435 | |
436 | # We shouldn't export if this is still referred to. |
437 | if ( $self->get_refcount > 1 ) { |
438 | return $obj; |
439 | } |
440 | |
441 | return $obj->export; |
442 | } |
443 | |
444 | sub free { |
445 | my $self = shift; |
446 | |
447 | # We're not ready to be removed yet. |
4f034d8f |
448 | return if $self->decrement_refcount > 0; |
f0276afb |
449 | |
66285e35 |
450 | my $e = $self->engine; |
451 | |
f0276afb |
452 | # Rebless the object into DBM::Deep::Null. |
66285e35 |
453 | # eval { %{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); }; |
454 | # eval { @{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); }; |
455 | # bless $e->cache->{ $self->offset }{ $e->trans_id }, 'DBM::Deep::Null'; |
456 | # delete $e->cache->{ $self->offset }{ $e->trans_id }; |
f0276afb |
457 | |
458 | my $blist_loc = $self->get_blist_loc; |
66285e35 |
459 | $e->load_sector( $blist_loc )->free if $blist_loc; |
f0276afb |
460 | |
461 | my $class_loc = $self->get_class_offset; |
66285e35 |
462 | $e->load_sector( $class_loc )->free if $class_loc; |
f0276afb |
463 | |
464 | $self->SUPER::free(); |
465 | } |
466 | |
467 | sub increment_refcount { |
468 | my $self = shift; |
469 | |
470 | my $refcount = $self->get_refcount; |
471 | |
472 | $refcount++; |
473 | |
474 | $self->write_refcount( $refcount ); |
475 | |
476 | return $refcount; |
477 | } |
478 | |
479 | sub decrement_refcount { |
480 | my $self = shift; |
481 | |
482 | my $refcount = $self->get_refcount; |
483 | |
484 | $refcount--; |
485 | |
486 | $self->write_refcount( $refcount ); |
487 | |
488 | return $refcount; |
489 | } |
490 | |
491 | sub get_refcount { |
492 | my $self = shift; |
493 | |
494 | my $e = $self->engine; |
495 | return unpack( |
496 | $StP{$e->byte_size}, |
497 | $e->storage->read_at( |
498 | $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size, |
499 | ), |
500 | ); |
501 | } |
502 | |
503 | sub write_refcount { |
504 | my $self = shift; |
505 | my ($num) = @_; |
506 | |
507 | my $e = $self->engine; |
508 | $e->storage->print_at( |
509 | $self->offset + $self->base_size + 2 * $e->byte_size, |
510 | pack( $StP{$e->byte_size}, $num ), |
511 | ); |
512 | } |
513 | |
e73f12ce |
514 | sub clear { |
515 | my $self = shift; |
516 | |
517 | my $blist_loc = $self->get_blist_loc or return; |
518 | |
519 | my $engine = $self->engine; |
520 | |
521 | # This won't work with autoblessed items. |
522 | if ($engine->get_running_txn_ids) { |
523 | # ~~~ Temporary; the code below this block needs to be modified to |
524 | # take transactions into account. |
525 | $self->data->_get_self->_clear; |
526 | return; |
527 | } |
528 | |
529 | my $sector = $engine->load_sector( $blist_loc ) |
530 | or DBM::Deep->_throw_error( |
531 | "Cannot read sector at $blist_loc in clear()" |
532 | ); |
533 | |
534 | # Set blist offset to 0 |
535 | $engine->storage->print_at( $self->offset + $self->base_size, |
536 | pack( $StP{$engine->byte_size}, 0 ), |
537 | ); |
538 | |
539 | # Free the blist |
540 | $sector->free; |
541 | |
542 | return; |
543 | } |
544 | |
f0276afb |
545 | 1; |
546 | __END__ |