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->{offset} = $e->_request_data_sector( $self->size );
25 my $classname = Scalar::Util::blessed( delete $self->{data} );
26 if ( defined $classname ) {
27 my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
31 $class_offset = $class_sector->offset;
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
41 $e->storage->print_at( $self->offset, $string );
44 $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 ),
55 sub staleness { $_[0]{staleness} }
57 sub get_data_location_for {
61 # Assume that the head is not allowed unless otherwise specified.
62 $args->{allow_head} = 0 unless exists $args->{allow_head};
64 # Assume we don't create a new blist location unless otherwise specified.
65 $args->{create} = 0 unless exists $args->{create};
67 my $blist = $self->get_bucket_list({
68 key_md5 => $args->{key_md5},
70 create => $args->{create},
72 return unless $blist && $blist->{found};
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
77 my $location = $blist->get_data_location_for({
78 allow_head => $args->{allow_head},
88 my $location = $self->get_data_location_for( $args )
91 return $self->engine->_load_sector( $location );
98 my $blist = $self->get_bucket_list({
99 key_md5 => $args->{key_md5},
102 }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
104 # Handle any transactional bookkeeping.
105 if ( $self->engine->trans_id ) {
106 if ( ! $blist->has_md5 ) {
107 $blist->mark_deleted({
113 my @trans_ids = $self->engine->get_running_txn_ids;
114 if ( $blist->has_md5 ) {
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,
123 trans_id => $other_trans_id,
125 key_md5 => $args->{key_md5},
126 value => $old_value->clone,
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,
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;
152 key_md5 => $args->{key_md5},
153 value => $args->{value},
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)?!" );
166 # Save the location so that we can free the data
167 my $location = $blist->get_data_location_for({
170 my $old_value = $location && $self->engine->_load_sector( $location );
172 my @trans_ids = $self->engine->get_running_txn_ids;
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 ) {
178 foreach my $other_trans_id ( @trans_ids ) {
179 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
181 trans_id => $other_trans_id,
183 key_md5 => $args->{key_md5},
184 value => $old_value->clone,
192 $blist->mark_deleted( $args );
195 $data = $old_value->data({ export => 1 });
200 $data = $blist->delete_md5( $args );
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 );
214 sub get_bucket_list {
219 # XXX Add in check here for recycling?
221 my $engine = $self->engine;
223 my $blist_loc = $self->get_blist_loc;
225 # There's no index or blist yet
226 unless ( $blist_loc ) {
227 return unless $args->{create};
229 my $blist = DBM::Deep::Engine::Sector::BucketList->new({
231 key_md5 => $args->{key_md5},
234 $engine->storage->print_at( $self->offset + $self->base_size,
235 pack( $engine->StP($engine->byte_size), $blist->offset ),
241 my $sector = $engine->_load_sector( $blist_loc )
242 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
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;
249 $sector = $engine->_load_sector( $blist_loc )
250 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
258 # This means we went through the Index sector(s) and found an empty slot
260 return unless $args->{create};
262 DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
265 my $blist = DBM::Deep::Engine::Sector::BucketList->new({
267 key_md5 => $args->{key_md5},
270 $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
275 $sector->find_md5( $args->{key_md5} );
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 ) {{
284 my $new_index = DBM::Deep::Engine::Sector::Index->new({
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 ) );
294 # XXX This is inefficient
295 my $blist = $blist_cache{$idx}
296 ||= DBM::Deep::Engine::Sector::BucketList->new({
300 $new_index->set_entry( $idx => $blist->offset );
302 my $new_spot = $blist->write_at_next_open( $md5 );
303 $engine->reindex_entry( $spot => $new_spot );
306 # Handle the new item separately.
308 my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
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
313 if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
316 my $blist = $blist_cache{$idx}
317 ||= DBM::Deep::Engine::Sector::BucketList->new({
321 $new_index->set_entry( $idx => $blist->offset );
324 $blist->find_md5( $args->{key_md5} );
327 key_md5 => $args->{key_md5},
328 value => DBM::Deep::Engine::Sector::Null->new({
334 # my $blist = $blist_cache{$idx}
335 # ||= DBM::Deep::Engine::Sector::BucketList->new({
339 # $new_index->set_entry( $idx => $blist->offset );
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({
353 if ( $last_sector ) {
354 $last_sector->set_entry(
355 ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
359 $engine->storage->print_at( $self->offset + $self->base_size,
360 pack( $engine->StP($engine->byte_size), $new_index->offset ),
368 (undef, $sector) = %blist_cache;
369 $last_sector = $new_index;
373 $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
374 $sector->find_md5( $args->{key_md5} );
380 sub get_class_offset {
383 my $e = $self->engine;
385 $e->StP($e->byte_size),
386 $e->storage->read_at(
387 $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size,
395 my $class_offset = $self->get_class_offset;
397 return unless $class_offset;
399 return $self->engine->_load_sector( $class_offset )->data;
408 unless ( $obj = $self->engine->cache->{ $self->offset } ) {
409 $obj = DBM::Deep->new({
411 base_offset => $self->offset,
412 staleness => $self->staleness,
413 storage => $self->engine->storage,
414 engine => $self->engine,
417 if ( $self->engine->storage->{autobless} ) {
418 my $classname = $self->get_classname;
419 if ( defined $classname ) {
420 bless $obj, $classname;
424 $self->engine->cache->{$self->offset} = $obj;
427 # We're not exporting, so just return.
428 unless ( $args->{export} ) {
432 # We shouldn't export if this is still referred to.
433 if ( $self->get_refcount > 1 ) {
443 # We're not ready to be removed yet.
444 if ( $self->decrement_refcount > 0 ) {
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 };
454 my $blist_loc = $self->get_blist_loc;
455 $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
457 my $class_loc = $self->get_class_offset;
458 $self->engine->_load_sector( $class_loc )->free if $class_loc;
460 $self->SUPER::free();
463 sub increment_refcount {
466 my $refcount = $self->get_refcount;
470 $self->write_refcount( $refcount );
475 sub decrement_refcount {
478 my $refcount = $self->get_refcount;
482 $self->write_refcount( $refcount );
490 my $e = $self->engine;
492 $e->StP($e->byte_size),
493 $e->storage->read_at(
494 $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
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 ),