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