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