1 #TODO: Convert this to a string
2 package DBM::Deep::Engine::Sector::Reference;
7 use warnings FATAL => 'all';
13 use DBM::Deep::Engine::Sector::Data;
14 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
19 my $e = $self->engine;
21 unless ( $self->offset ) {
22 $self->{staleness} = 0;
23 $self->{offset} = $e->_request_data_sector( $self->size );
26 my $classname = Scalar::Util::blessed( delete $self->{data} );
27 if ( defined $classname ) {
28 my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
32 $class_offset = $class_sector->offset;
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
42 $e->storage->print_at( $self->offset, $string );
45 $self->{type} = $e->storage->read_at( $self->offset, 1 );
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 ),
56 sub staleness { $_[0]{staleness} }
58 sub get_data_location_for {
62 # Assume that the head is not allowed unless otherwise specified.
63 $args->{allow_head} = 0 unless exists $args->{allow_head};
65 # Assume we don't create a new blist location unless otherwise specified.
66 $args->{create} = 0 unless exists $args->{create};
68 my $blist = $self->get_bucket_list({
69 key_md5 => $args->{key_md5},
71 create => $args->{create},
73 return unless $blist && $blist->{found};
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
78 my $location = $blist->get_data_location_for({
79 allow_head => $args->{allow_head},
89 my $location = $self->get_data_location_for( $args )
92 return $self->engine->_load_sector( $location );
99 my $blist = $self->get_bucket_list({
100 key_md5 => $args->{key_md5},
103 }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
105 # Handle any transactional bookkeeping.
106 if ( $self->engine->trans_id ) {
107 if ( ! $blist->has_md5 ) {
108 $blist->mark_deleted({
114 my @trans_ids = $self->engine->get_running_txn_ids;
115 if ( $blist->has_md5 ) {
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,
124 trans_id => $other_trans_id,
126 key_md5 => $args->{key_md5},
127 value => $old_value->clone,
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,
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;
153 key_md5 => $args->{key_md5},
154 value => $args->{value},
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)?!" );
167 # Save the location so that we can free the data
168 my $location = $blist->get_data_location_for({
171 my $old_value = $location && $self->engine->_load_sector( $location );
173 my @trans_ids = $self->engine->get_running_txn_ids;
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 ) {
179 foreach my $other_trans_id ( @trans_ids ) {
180 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
182 trans_id => $other_trans_id,
184 key_md5 => $args->{key_md5},
185 value => $old_value->clone,
193 $blist->mark_deleted( $args );
196 $data = $old_value->data({ export => 1 });
201 $data = $blist->delete_md5( $args );
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 );
215 sub get_bucket_list {
220 # XXX Add in check here for recycling?
222 my $engine = $self->engine;
224 my $blist_loc = $self->get_blist_loc;
226 # There's no index or blist yet
227 unless ( $blist_loc ) {
228 return unless $args->{create};
230 my $blist = DBM::Deep::Engine::Sector::BucketList->new({
232 key_md5 => $args->{key_md5},
235 $engine->storage->print_at( $self->offset + $self->base_size,
236 pack( $engine->StP($engine->byte_size), $blist->offset ),
242 my $sector = $engine->_load_sector( $blist_loc )
243 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
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;
250 $sector = $engine->_load_sector( $blist_loc )
251 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
259 # This means we went through the Index sector(s) and found an empty slot
261 return unless $args->{create};
263 DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
266 my $blist = DBM::Deep::Engine::Sector::BucketList->new({
268 key_md5 => $args->{key_md5},
271 $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
276 $sector->find_md5( $args->{key_md5} );
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 ) {{
285 my $new_index = DBM::Deep::Engine::Sector::Index->new({
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 ) );
295 # XXX This is inefficient
296 my $blist = $blist_cache{$idx}
297 ||= DBM::Deep::Engine::Sector::BucketList->new({
301 $new_index->set_entry( $idx => $blist->offset );
303 my $new_spot = $blist->write_at_next_open( $md5 );
304 $engine->reindex_entry( $spot => $new_spot );
307 # Handle the new item separately.
309 my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
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
314 if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
317 my $blist = $blist_cache{$idx}
318 ||= DBM::Deep::Engine::Sector::BucketList->new({
322 $new_index->set_entry( $idx => $blist->offset );
325 $blist->find_md5( $args->{key_md5} );
328 key_md5 => $args->{key_md5},
329 value => DBM::Deep::Engine::Sector::Null->new({
335 # my $blist = $blist_cache{$idx}
336 # ||= DBM::Deep::Engine::Sector::BucketList->new({
340 # $new_index->set_entry( $idx => $blist->offset );
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({
354 if ( $last_sector ) {
355 $last_sector->set_entry(
356 ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
360 $engine->storage->print_at( $self->offset + $self->base_size,
361 pack( $engine->StP($engine->byte_size), $new_index->offset ),
369 (undef, $sector) = %blist_cache;
370 $last_sector = $new_index;
374 $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
375 $sector->find_md5( $args->{key_md5} );
381 sub get_class_offset {
384 my $e = $self->engine;
386 $e->StP($e->byte_size),
387 $e->storage->read_at(
388 $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size,
396 my $class_offset = $self->get_class_offset;
398 return unless $class_offset;
400 return $self->engine->_load_sector( $class_offset )->data;
409 unless ( $obj = $self->engine->cache->{ $self->offset } ) {
410 $obj = DBM::Deep->new({
412 base_offset => $self->offset,
413 staleness => $self->staleness,
414 storage => $self->engine->storage,
415 engine => $self->engine,
418 if ( $self->engine->storage->{autobless} ) {
419 my $classname = $self->get_classname;
420 if ( defined $classname ) {
421 bless $obj, $classname;
425 $self->engine->cache->{$self->offset} = $obj;
428 # We're not exporting, so just return.
429 unless ( $args->{export} ) {
433 # We shouldn't export if this is still referred to.
434 if ( $self->get_refcount > 1 ) {
444 # We're not ready to be removed yet.
445 if ( $self->decrement_refcount > 0 ) {
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 };
455 my $blist_loc = $self->get_blist_loc;
456 $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
458 my $class_loc = $self->get_class_offset;
459 $self->engine->_load_sector( $class_loc )->free if $class_loc;
461 $self->SUPER::free();
464 sub increment_refcount {
467 my $refcount = $self->get_refcount;
471 $self->write_refcount( $refcount );
476 sub decrement_refcount {
479 my $refcount = $self->get_refcount;
483 $self->write_refcount( $refcount );
491 my $e = $self->engine;
493 $e->StP($e->byte_size),
494 $e->storage->read_at(
495 $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
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 ),