1 package DBM::Deep::Engine::Sector::Reference;
6 use warnings FATAL => 'all';
8 use base qw( DBM::Deep::Engine::Sector::Data );
13 my $e = $self->engine;
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;
20 if ( defined $classname ) {
21 my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
25 $class_offset = $class_sector->offset;
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
39 $self->{type} = $e->storage->read_at( $self->offset, 1 );
42 $self->{staleness} = unpack(
44 $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ),
50 sub staleness { $_[0]{staleness} }
52 sub get_data_location_for {
56 # Assume that the head is not allowed unless otherwise specified.
57 $args->{allow_head} = 0 unless exists $args->{allow_head};
59 # Assume we don't create a new blist location unless otherwise specified.
60 $args->{create} = 0 unless exists $args->{create};
62 my $blist = $self->get_bucket_list({
63 key_md5 => $args->{key_md5},
65 create => $args->{create},
67 return unless $blist && $blist->{found};
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
72 my $location = $blist->get_data_location_for({
73 allow_head => $args->{allow_head},
83 my $location = $self->get_data_location_for( $args )
86 return $self->engine->_load_sector( $location );
93 my $blist = $self->get_bucket_list({
94 key_md5 => $args->{key_md5},
97 }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
99 # Handle any transactional bookkeeping.
100 if ( $self->engine->trans_id ) {
101 if ( ! $blist->has_md5 ) {
102 $blist->mark_deleted({
108 my @trans_ids = $self->engine->get_running_txn_ids;
109 if ( $blist->has_md5 ) {
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,
118 trans_id => $other_trans_id,
120 key_md5 => $args->{key_md5},
121 value => $old_value->clone,
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,
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;
147 key_md5 => $args->{key_md5},
148 value => $args->{value},
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)?!" );
161 # Save the location so that we can free the data
162 my $location = $blist->get_data_location_for({
165 my $old_value = $location && $self->engine->_load_sector( $location );
167 my @trans_ids = $self->engine->get_running_txn_ids;
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 ) {
173 foreach my $other_trans_id ( @trans_ids ) {
174 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
176 trans_id => $other_trans_id,
178 key_md5 => $args->{key_md5},
179 value => $old_value->clone,
187 $blist->mark_deleted( $args );
190 $data = $old_value->data({ export => 1 });
195 $data = $blist->delete_md5( $args );
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 );
209 sub get_bucket_list {
214 # XXX Add in check here for recycling?
216 my $engine = $self->engine;
218 my $blist_loc = $self->get_blist_loc;
220 # There's no index or blist yet
221 unless ( $blist_loc ) {
222 return unless $args->{create};
224 my $blist = DBM::Deep::Engine::Sector::BucketList->new({
226 key_md5 => $args->{key_md5},
229 $engine->storage->print_at( $self->offset + $self->base_size,
230 pack( $StP{$engine->byte_size}, $blist->offset ),
236 my $sector = $engine->_load_sector( $blist_loc )
237 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
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;
244 $sector = $engine->_load_sector( $blist_loc )
245 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
253 # This means we went through the Index sector(s) and found an empty slot
255 return unless $args->{create};
257 DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
260 my $blist = DBM::Deep::Engine::Sector::BucketList->new({
262 key_md5 => $args->{key_md5},
265 $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
270 $sector->find_md5( $args->{key_md5} );
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 ) {{
279 my $new_index = DBM::Deep::Engine::Sector::Index->new({
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 ) );
289 # XXX This is inefficient
290 my $blist = $blist_cache{$idx}
291 ||= DBM::Deep::Engine::Sector::BucketList->new({
295 $new_index->set_entry( $idx => $blist->offset );
297 my $new_spot = $blist->write_at_next_open( $md5 );
298 $engine->reindex_entry( $spot => $new_spot );
301 # Handle the new item separately.
303 my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
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
308 if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
311 my $blist = $blist_cache{$idx}
312 ||= DBM::Deep::Engine::Sector::BucketList->new({
316 $new_index->set_entry( $idx => $blist->offset );
319 $blist->find_md5( $args->{key_md5} );
322 key_md5 => $args->{key_md5},
323 value => DBM::Deep::Engine::Sector::Null->new({
329 # my $blist = $blist_cache{$idx}
330 # ||= DBM::Deep::Engine::Sector::BucketList->new({
334 # $new_index->set_entry( $idx => $blist->offset );
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({
348 if ( $last_sector ) {
349 $last_sector->set_entry(
350 ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
354 $engine->storage->print_at( $self->offset + $self->base_size,
355 pack( $StP{$engine->byte_size}, $new_index->offset ),
363 (undef, $sector) = %blist_cache;
364 $last_sector = $new_index;
368 $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
369 $sector->find_md5( $args->{key_md5} );
375 sub get_class_offset {
378 my $e = $self->engine;
381 $e->storage->read_at(
382 $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size,
390 my $class_offset = $self->get_class_offset;
392 return unless $class_offset;
394 return $self->engine->_load_sector( $class_offset )->data;
403 unless ( $obj = $self->engine->cache->{ $self->offset } ) {
404 $obj = DBM::Deep->new({
406 base_offset => $self->offset,
407 staleness => $self->staleness,
408 storage => $self->engine->storage,
409 engine => $self->engine,
412 if ( $self->engine->storage->{autobless} ) {
413 my $classname = $self->get_classname;
414 if ( defined $classname ) {
415 bless $obj, $classname;
419 $self->engine->cache->{$self->offset} = $obj;
422 # We're not exporting, so just return.
423 unless ( $args->{export} ) {
427 # We shouldn't export if this is still referred to.
428 if ( $self->get_refcount > 1 ) {
438 # We're not ready to be removed yet.
439 if ( $self->decrement_refcount > 0 ) {
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 };
449 my $blist_loc = $self->get_blist_loc;
450 $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
452 my $class_loc = $self->get_class_offset;
453 $self->engine->_load_sector( $class_loc )->free if $class_loc;
455 $self->SUPER::free();
458 sub increment_refcount {
461 my $refcount = $self->get_refcount;
465 $self->write_refcount( $refcount );
470 sub decrement_refcount {
473 my $refcount = $self->get_refcount;
477 $self->write_refcount( $refcount );
485 my $e = $self->engine;
488 $e->storage->read_at(
489 $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
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 ),