1 package DBM::Deep::Engine::Sector::Reference;
6 use warnings FATAL => 'all';
12 use DBM::Deep::Engine::Sector::Data;
13 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
18 my $e = $self->engine;
20 unless ( $self->offset ) {
21 $self->{offset} = $e->_request_data_sector( $self->size );
24 my $classname = Scalar::Util::blessed( delete $self->{data} );
25 if ( defined $classname ) {
26 my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
30 $class_offset = $class_sector->offset;
33 $self->write( 0, $self->type );
34 $self->write( $self->base_size,
35 pack( $e->StP($e->byte_size), 0 ) # Index/BList loc
36 . pack( $e->StP($e->byte_size), $class_offset ) # Classname loc
37 . pack( $e->StP($e->byte_size), 1 ) # Initial refcount
41 $self->{type} = $self->read( 0, $e->SIG_SIZE );
44 $self->{staleness} = unpack(
45 $e->StP($DBM::Deep::Engine::STALE_SIZE),
46 $self->read( $e->SIG_SIZE, $DBM::Deep::Engine::STALE_SIZE ),
52 sub staleness { $_[0]{staleness} }
54 sub get_data_location_for {
58 # Assume that the head is not allowed unless otherwise specified.
59 $args->{allow_head} = 0 unless exists $args->{allow_head};
61 # Assume we don't create a new blist location unless otherwise specified.
62 $args->{create} = 0 unless exists $args->{create};
64 my $blist = $self->get_bucket_list({
65 key_md5 => $args->{key_md5},
67 create => $args->{create},
69 return unless $blist && $blist->{found};
71 # At this point, $blist knows where the md5 is. What it -doesn't- know yet
72 # is whether or not this transaction has this key. That's part of the next
74 my $location = $blist->get_data_location_for({
75 allow_head => $args->{allow_head},
85 my $location = $self->get_data_location_for( $args )
88 return $self->engine->_load_sector( $location );
95 my $blist = $self->get_bucket_list({
96 key_md5 => $args->{key_md5},
99 }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
101 # Handle any transactional bookkeeping.
102 if ( $self->engine->trans_id ) {
103 if ( ! $blist->has_md5 ) {
104 $blist->mark_deleted({
110 my @trans_ids = $self->engine->get_running_txn_ids;
111 if ( $blist->has_md5 ) {
113 my $old_value = $blist->get_data_for;
114 foreach my $other_trans_id ( @trans_ids ) {
115 next if $blist->get_data_location_for({
116 trans_id => $other_trans_id,
120 trans_id => $other_trans_id,
122 key_md5 => $args->{key_md5},
123 value => $old_value->clone,
130 foreach my $other_trans_id ( @trans_ids ) {
131 #XXX This doesn't seem to possible to ever happen . . .
132 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
133 $blist->mark_deleted({
134 trans_id => $other_trans_id,
141 #XXX Is this safe to do transactionally?
142 # Free the place we're about to write to.
143 if ( $blist->get_data_location_for({ allow_head => 0 }) ) {
144 $blist->get_data_for({ allow_head => 0 })->free;
149 key_md5 => $args->{key_md5},
150 value => $args->{value},
158 # XXX What should happen if this fails?
159 my $blist = $self->get_bucket_list({
160 key_md5 => $args->{key_md5},
161 }) or DBM::Deep->_throw_error( "How did delete_key fail (no blist)?!" );
163 # Save the location so that we can free the data
164 my $location = $blist->get_data_location_for({
167 my $old_value = $location && $self->engine->_load_sector( $location );
169 my @trans_ids = $self->engine->get_running_txn_ids;
171 # If we're the HEAD and there are running txns, then we need to clone this value to the other
172 # transactions to preserve Isolation.
173 if ( $self->engine->trans_id == 0 ) {
175 foreach my $other_trans_id ( @trans_ids ) {
176 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
178 trans_id => $other_trans_id,
180 key_md5 => $args->{key_md5},
181 value => $old_value->clone,
189 $blist->mark_deleted( $args );
192 $data = $old_value->data({ export => 1 });
197 $data = $blist->delete_md5( $args );
206 my $e = $self->engine;
208 $e->StP($e->byte_size),
209 $self->read( $self->base_size, $e->byte_size ),
213 sub get_bucket_list {
218 # XXX Add in check here for recycling?
220 my $engine = $self->engine;
222 my $blist_loc = $self->get_blist_loc;
224 # There's no index or blist yet
225 unless ( $blist_loc ) {
226 return unless $args->{create};
228 my $blist = DBM::Deep::Engine::Sector::BucketList->new({
230 key_md5 => $args->{key_md5},
233 $self->write( $self->base_size, pack( $engine->StP($engine->byte_size), $blist->offset ) );
238 my $sector = $engine->_load_sector( $blist_loc )
239 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
241 my $last_sector = undef;
242 while ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) {
243 $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
244 $last_sector = $sector;
246 $sector = $engine->_load_sector( $blist_loc )
247 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
255 # This means we went through the Index sector(s) and found an empty slot
257 return unless $args->{create};
259 DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
262 my $blist = DBM::Deep::Engine::Sector::BucketList->new({
264 key_md5 => $args->{key_md5},
267 $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
272 $sector->find_md5( $args->{key_md5} );
274 # See whether or not we need to reindex the bucketlist
275 # Yes, the double-braces are there for a reason. if() doesn't create a redo-able block,
276 # so we have to create a bare block within the if() for redo-purposes. Patch and idea
277 # submitted by sprout@cpan.org. -RobK, 2008-01-09
278 if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
281 my $new_index = DBM::Deep::Engine::Sector::Index->new({
286 #XXX q.v. the comments for this function.
287 foreach my $entry ( $sector->chopped_up ) {
288 my ($spot, $md5) = @{$entry};
289 my $idx = ord( substr( $md5, $i, 1 ) );
291 # XXX This is inefficient
292 my $blist = $blist_cache{$idx}
293 ||= DBM::Deep::Engine::Sector::BucketList->new({
297 $new_index->set_entry( $idx => $blist->offset );
299 my $new_spot = $blist->write_at_next_open( $md5 );
300 $engine->reindex_entry( $spot => $new_spot );
303 # Handle the new item separately.
305 my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
307 # If all the previous blist's items have been thrown into one
308 # blist and the new item belongs in there too, we need
310 if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
313 my $blist = $blist_cache{$idx}
314 ||= DBM::Deep::Engine::Sector::BucketList->new({
318 $new_index->set_entry( $idx => $blist->offset );
321 $blist->find_md5( $args->{key_md5} );
324 key_md5 => $args->{key_md5},
325 value => DBM::Deep::Engine::Sector::Null->new({
332 #XXX Why is this code here? -RobK, 2008-06-15
333 # my $blist = $blist_cache{$idx}
334 # ||= DBM::Deep::Engine::Sector::BucketList->new({
338 # $new_index->set_entry( $idx => $blist->offset );
340 # #XXX THIS IS HACKY!
341 # $blist->find_md5( $args->{key_md5} );
342 # $blist->write_md5({
343 # key => $args->{key},
344 # key_md5 => $args->{key_md5},
345 # value => DBM::Deep::Engine::Sector::Null->new({
352 if ( $last_sector ) {
353 $last_sector->set_entry(
354 ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
358 $self->write( $self->base_size, pack( $engine->StP($engine->byte_size), $new_index->offset ) );
365 (undef, $sector) = %blist_cache;
366 $last_sector = $new_index;
370 $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
371 $sector->find_md5( $args->{key_md5} );
377 sub get_class_offset {
380 my $e = $self->engine;
382 $e->StP($e->byte_size),
384 $self->base_size + 1 * $e->byte_size,
393 my $class_offset = $self->get_class_offset;
395 return unless $class_offset;
397 return $self->engine->_load_sector( $class_offset )->data;
406 unless ( $obj = $self->engine->cache->{ $self->offset } ) {
407 $obj = DBM::Deep->new({
409 base_offset => $self->offset,
410 staleness => $self->staleness,
411 storage => $self->engine->storage,
412 engine => $self->engine,
415 if ( $self->engine->storage->{autobless} ) {
416 my $classname = $self->get_classname;
417 if ( defined $classname ) {
418 bless $obj, $classname;
422 $self->engine->cache->{$self->offset} = $obj;
425 # We're not exporting, so just return.
426 unless ( $args->{export} ) {
430 # We shouldn't export if this is still referred to.
431 if ( $self->get_refcount > 1 ) {
441 # We're not ready to be removed yet.
442 if ( $self->decrement_refcount > 0 ) {
446 # Rebless the object into DBM::Deep::Null.
447 eval { %{ $self->engine->cache->{ $self->offset } } = (); };
448 eval { @{ $self->engine->cache->{ $self->offset } } = (); };
449 bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
450 delete $self->engine->cache->{ $self->offset };
452 my $blist_loc = $self->get_blist_loc;
453 $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
455 my $class_loc = $self->get_class_offset;
456 $self->engine->_load_sector( $class_loc )->free if $class_loc;
458 $self->SUPER::free();
461 sub increment_refcount {
464 my $refcount = $self->get_refcount;
468 $self->write_refcount( $refcount );
473 sub decrement_refcount {
476 my $refcount = $self->get_refcount;
480 $self->write_refcount( $refcount );
488 my $e = $self->engine;
490 $e->StP($e->byte_size),
492 $self->base_size + 2 * $e->byte_size,
502 my $e = $self->engine;
504 $self->base_size + 2 * $e->byte_size,
505 pack( $e->StP($e->byte_size), $num ),