1 package DBM::Deep::Sector::File::Reference;
6 use warnings FATAL => 'all';
8 use base qw( DBM::Deep::Sector::File::Data );
12 # Please refer to the pack() documentation for further information
14 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
15 2 => 'n', # Unsigned short in "network" (big-endian) order
16 4 => 'N', # Unsigned long in "network" (big-endian) order
17 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
23 my $e = $self->engine;
25 unless ( $self->offset ) {
26 my $classname = Scalar::Util::blessed( delete $self->{data} );
27 my $leftover = $self->size - $self->base_size - 3 * $e->byte_size;
30 if ( defined $classname ) {
31 my $class_sector = DBM::Deep::Sector::File::Scalar->new({
35 $class_offset = $class_sector->offset;
38 $self->{offset} = $e->_request_data_sector( $self->size );
39 $e->storage->print_at( $self->offset, $self->type ); # Sector type
40 # Skip staleness counter
41 $e->storage->print_at( $self->offset + $self->base_size,
42 pack( $StP{$e->byte_size}, 0 ), # Index/BList loc
43 pack( $StP{$e->byte_size}, $class_offset ), # Classname loc
44 pack( $StP{$e->byte_size}, 1 ), # Initial refcount
45 chr(0) x $leftover, # Zero-fill the rest
49 $self->{type} = $e->storage->read_at( $self->offset, 1 );
52 $self->{staleness} = unpack(
54 $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ),
60 sub get_data_location_for {
64 # Assume that the head is not allowed unless otherwise specified.
65 $args->{allow_head} = 0 unless exists $args->{allow_head};
67 # Assume we don't create a new blist location unless otherwise specified.
68 $args->{create} = 0 unless exists $args->{create};
70 my $blist = $self->get_bucket_list({
71 key_md5 => $args->{key_md5},
73 create => $args->{create},
75 return unless $blist && $blist->{found};
77 # At this point, $blist knows where the md5 is. What it -doesn't- know yet
78 # is whether or not this transaction has this key. That's part of the next
80 my $location = $blist->get_data_location_for({
81 allow_head => $args->{allow_head},
91 my $location = $self->get_data_location_for( $args )
94 return $self->engine->load_sector( $location );
101 my $blist = $self->get_bucket_list({
102 key_md5 => $args->{key_md5},
105 }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
107 # Handle any transactional bookkeeping.
108 if ( $self->engine->trans_id ) {
109 if ( ! $blist->has_md5 ) {
110 $blist->mark_deleted({
116 my @trans_ids = $self->engine->get_running_txn_ids;
117 if ( $blist->has_md5 ) {
119 my $old_value = $blist->get_data_for;
120 foreach my $other_trans_id ( @trans_ids ) {
121 next if $blist->get_data_location_for({
122 trans_id => $other_trans_id,
126 trans_id => $other_trans_id,
128 key_md5 => $args->{key_md5},
129 value => $old_value->clone,
136 foreach my $other_trans_id ( @trans_ids ) {
137 #XXX This doesn't seem to possible to ever happen . . .
138 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
139 $blist->mark_deleted({
140 trans_id => $other_trans_id,
147 #XXX Is this safe to do transactionally?
148 # Free the place we're about to write to.
149 if ( $blist->get_data_location_for({ allow_head => 0 }) ) {
150 $blist->get_data_for({ allow_head => 0 })->free;
155 key_md5 => $args->{key_md5},
156 value => $args->{value},
164 # This can return nothing if we are deleting an entry in a hashref that was
165 # auto-vivified as part of the delete process. For example:
167 # delete $x->{foo}{bar};
168 my $blist = $self->get_bucket_list({
169 key_md5 => $args->{key_md5},
172 # Save the location so that we can free the data
173 my $location = $blist->get_data_location_for({
176 my $old_value = $location && $self->engine->load_sector( $location );
178 my @trans_ids = $self->engine->get_running_txn_ids;
180 # If we're the HEAD and there are running txns, then we need to clone this
181 # value to the other transactions to preserve Isolation.
182 if ( $self->engine->trans_id == 0 ) {
184 foreach my $other_trans_id ( @trans_ids ) {
185 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
187 trans_id => $other_trans_id,
189 key_md5 => $args->{key_md5},
190 value => $old_value->clone,
198 $blist->mark_deleted( $args );
201 #XXX Is this export => 1 actually doing anything?
202 $data = $old_value->data({ export => 1 });
207 $data = $blist->delete_md5( $args );
213 sub write_blist_loc {
217 my $engine = $self->engine;
218 $engine->storage->print_at( $self->offset + $self->base_size,
219 pack( $StP{$engine->byte_size}, $loc ),
227 my $e = $self->engine;
228 my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size );
229 return unpack( $StP{$e->byte_size}, $blist_loc );
237 # my $engine = $self->engine;
239 # # If there's nothing pointed to from this reference, there's nothing to do.
240 # my $loc = $self->get_blist_loc
243 # my $sector = $engine->load_sector( $loc )
244 # or DBM::Deep->_throw_error( "Cannot read sector at $loc in clear()" );
248 # $self->write_blist_loc( 0 );
253 sub get_bucket_list {
258 # XXX Add in check here for recycling?
260 my $engine = $self->engine;
262 my $blist_loc = $self->get_blist_loc;
264 # There's no index or blist yet
265 unless ( $blist_loc ) {
266 return unless $args->{create};
268 my $blist = DBM::Deep::Sector::File::BucketList->new({
270 key_md5 => $args->{key_md5},
273 $self->write_blist_loc( $blist->offset );
274 # $engine->storage->print_at( $self->offset + $self->base_size,
275 # pack( $StP{$engine->byte_size}, $blist->offset ),
281 my $sector = $engine->load_sector( $blist_loc )
282 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
284 my $last_sector = undef;
285 while ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
286 $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
287 $last_sector = $sector;
289 $sector = $engine->load_sector( $blist_loc )
290 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
298 # This means we went through the Index sector(s) and found an empty slot
300 return unless $args->{create};
302 DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
305 my $blist = DBM::Deep::Sector::File::BucketList->new({
307 key_md5 => $args->{key_md5},
310 $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
315 $sector->find_md5( $args->{key_md5} );
317 # See whether or not we need to reindex the bucketlist
318 # Yes, the double-braces are there for a reason. if() doesn't create a
319 # redo-able block, so we have to create a bare block within the if() for
321 # Patch and idea submitted by sprout@cpan.org. -RobK, 2008-01-09
322 if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
325 my $new_index = DBM::Deep::Sector::File::Index->new({
330 #XXX q.v. the comments for this function.
331 foreach my $entry ( $sector->chopped_up ) {
332 my ($spot, $md5) = @{$entry};
333 my $idx = ord( substr( $md5, $i, 1 ) );
335 # XXX This is inefficient
336 my $blist = $blist_cache{$idx}
337 ||= DBM::Deep::Sector::File::BucketList->new({
341 $new_index->set_entry( $idx => $blist->offset );
343 my $new_spot = $blist->write_at_next_open( $md5 );
344 $engine->reindex_entry( $spot => $new_spot );
347 # Handle the new item separately.
349 my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
351 # If all the previous blist's items have been thrown into one
352 # blist and the new item belongs in there too, we need
354 if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
357 my $blist = $blist_cache{$idx}
358 ||= DBM::Deep::Sector::File::BucketList->new({
362 $new_index->set_entry( $idx => $blist->offset );
365 $blist->find_md5( $args->{key_md5} );
368 key_md5 => $args->{key_md5},
369 value => DBM::Deep::Sector::File::Null->new({
377 if ( $last_sector ) {
378 $last_sector->set_entry(
379 ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
383 $engine->storage->print_at( $self->offset + $self->base_size,
384 pack( $StP{$engine->byte_size}, $new_index->offset ),
392 (undef, $sector) = %blist_cache;
393 $last_sector = $new_index;
397 $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
398 $sector->find_md5( $args->{key_md5} );
404 sub get_class_offset {
407 my $e = $self->engine;
410 $e->storage->read_at(
411 $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size,
419 my $class_offset = $self->get_class_offset;
421 return unless $class_offset;
423 return $self->engine->load_sector( $class_offset )->data;
426 # Look to hoist this method into a ::Reference trait
433 unless ( $obj = $self->engine->cache->{ $self->offset } ) {
434 $obj = DBM::Deep->new({
436 base_offset => $self->offset,
437 staleness => $self->staleness,
438 storage => $self->engine->storage,
439 engine => $self->engine,
442 if ( $self->engine->storage->{autobless} ) {
443 my $classname = $self->get_classname;
444 if ( defined $classname ) {
445 bless $obj, $classname;
449 $self->engine->cache->{$self->offset} = $obj;
452 # We're not exporting, so just return.
453 unless ( $args->{export} ) {
457 # We shouldn't export if this is still referred to.
458 if ( $self->get_refcount > 1 ) {
468 # We're not ready to be removed yet.
469 return if $self->decrement_refcount > 0;
471 # Rebless the object into DBM::Deep::Null.
472 eval { %{ $self->engine->cache->{ $self->offset } } = (); };
473 eval { @{ $self->engine->cache->{ $self->offset } } = (); };
474 bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
475 delete $self->engine->cache->{ $self->offset };
477 my $blist_loc = $self->get_blist_loc;
478 $self->engine->load_sector( $blist_loc )->free if $blist_loc;
480 my $class_loc = $self->get_class_offset;
481 $self->engine->load_sector( $class_loc )->free if $class_loc;
483 $self->SUPER::free();
486 sub increment_refcount {
489 my $refcount = $self->get_refcount;
493 $self->write_refcount( $refcount );
498 sub decrement_refcount {
501 my $refcount = $self->get_refcount;
505 $self->write_refcount( $refcount );
513 my $e = $self->engine;
516 $e->storage->read_at(
517 $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
526 my $e = $self->engine;
527 $e->storage->print_at(
528 $self->offset + $self->base_size + 2 * $e->byte_size,
529 pack( $StP{$e->byte_size}, $num ),