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