lib/DBM/Deep/Engine/Sector/Reference.pm

   1 package DBM::Deep::Engine::Sector::Reference;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 use base qw( DBM::Deep::Engine::Sector::Data );
   9
  10 sub _init {
  11     my $self = shift;
  12
  13     my $e = $self->engine;
  14
  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;
  18
  19         my $class_offset = 0;
  20         if ( defined $classname ) {
  21             my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
  22                 engine => $e,
  23                 data   => $classname,
  24             });
  25             $class_offset = $class_sector->offset;
  26         }
  27
  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
  36         );
  37     }
  38     else {
  39         $self->{type} = $e->storage->read_at( $self->offset, 1 );
  40     }
  41
  42     $self->{staleness} = unpack(
  43         $StP{$STALE_SIZE},
  44         $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ),
  45     );
  46
  47     return;
  48 }
  49
  50 sub staleness { $_[0]{staleness} }
  51
  52 sub get_data_location_for {
  53     my $self = shift;
  54     my ($args) = @_;
  55
  56     # Assume that the head is not allowed unless otherwise specified.
  57     $args->{allow_head} = 0 unless exists $args->{allow_head};
  58
  59     # Assume we don't create a new blist location unless otherwise specified.
  60     $args->{create} = 0 unless exists $args->{create};
  61
  62     my $blist = $self->get_bucket_list({
  63         key_md5 => $args->{key_md5},
  64         key => $args->{key},
  65         create  => $args->{create},
  66     });
  67     return unless $blist && $blist->{found};
  68
  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
  71     # function call.
  72     my $location = $blist->get_data_location_for({
  73         allow_head => $args->{allow_head},
  74     }) or return;
  75
  76     return $location;
  77 }
  78
  79 sub get_data_for {
  80     my $self = shift;
  81     my ($args) = @_;
  82
  83     my $location = $self->get_data_location_for( $args )
  84         or return;
  85
  86     return $self->engine->_load_sector( $location );
  87 }
  88
  89 sub write_data {
  90     my $self = shift;
  91     my ($args) = @_;
  92
  93     my $blist = $self->get_bucket_list({
  94         key_md5 => $args->{key_md5},
  95         key => $args->{key},
  96         create  => 1,
  97     }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
  98
  99     # Handle any transactional bookkeeping.
 100     if ( $self->engine->trans_id ) {
 101         if ( ! $blist->has_md5 ) {
 102             $blist->mark_deleted({
 103                 trans_id => 0,
 104             });
 105         }
 106     }
 107     else {
 108         my @trans_ids = $self->engine->get_running_txn_ids;
 109         if ( $blist->has_md5 ) {
 110             if ( @trans_ids ) {
 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,
 115                         allow_head => 0,
 116                     });
 117                     $blist->write_md5({
 118                         trans_id => $other_trans_id,
 119                         key      => $args->{key},
 120                         key_md5  => $args->{key_md5},
 121                         value    => $old_value->clone,
 122                     });
 123                 }
 124             }
 125         }
 126         else {
 127             if ( @trans_ids ) {
 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,
 133                     });
 134                 }
 135             }
 136         }
 137     }
 138
 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;
 143     }
 144
 145     $blist->write_md5({
 146         key      => $args->{key},
 147         key_md5  => $args->{key_md5},
 148         value    => $args->{value},
 149     });
 150 }
 151
 152 sub delete_key {
 153     my $self = shift;
 154     my ($args) = @_;
 155
 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)?!" );
 160
 161     # Save the location so that we can free the data
 162     my $location = $blist->get_data_location_for({
 163         allow_head => 0,
 164     });
 165     my $old_value = $location && $self->engine->_load_sector( $location );
 166
 167     my @trans_ids = $self->engine->get_running_txn_ids;
 168
 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 ) {
 172         if ( @trans_ids ) {
 173             foreach my $other_trans_id ( @trans_ids ) {
 174                 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
 175                 $blist->write_md5({
 176                     trans_id => $other_trans_id,
 177                     key      => $args->{key},
 178                     key_md5  => $args->{key_md5},
 179                     value    => $old_value->clone,
 180                 });
 181             }
 182         }
 183     }
 184
 185     my $data;
 186     if ( @trans_ids ) {
 187         $blist->mark_deleted( $args );
 188
 189         if ( $old_value ) {
 190             $data = $old_value->data({ export => 1 });
 191             $old_value->free;
 192         }
 193     }
 194     else {
 195         $data = $blist->delete_md5( $args );
 196     }
 197
 198     return $data;
 199 }
 200
 201 sub get_blist_loc {
 202     my $self = shift;
 203
 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 );
 207 }
 208
 209 sub get_bucket_list {
 210     my $self = shift;
 211     my ($args) = @_;
 212     $args ||= {};
 213
 214     # XXX Add in check here for recycling?
 215
 216     my $engine = $self->engine;
 217
 218     my $blist_loc = $self->get_blist_loc;
 219
 220     # There's no index or blist yet
 221     unless ( $blist_loc ) {
 222         return unless $args->{create};
 223
 224         my $blist = DBM::Deep::Engine::Sector::BucketList->new({
 225             engine  => $engine,
 226             key_md5 => $args->{key_md5},
 227         });
 228
 229         $engine->storage->print_at( $self->offset + $self->base_size,
 230             pack( $StP{$engine->byte_size}, $blist->offset ),
 231         );
 232
 233         return $blist;
 234     }
 235
 236     my $sector = $engine->_load_sector( $blist_loc )
 237         or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
 238     my $i = 0;
 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;
 243         if ( $blist_loc ) {
 244             $sector = $engine->_load_sector( $blist_loc )
 245                 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
 246         }
 247         else {
 248             $sector = undef;
 249             last;
 250         }
 251     }
 252
 253     # This means we went through the Index sector(s) and found an empty slot
 254     unless ( $sector ) {
 255         return unless $args->{create};
 256
 257         DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
 258             unless $last_sector;
 259
 260         my $blist = DBM::Deep::Engine::Sector::BucketList->new({
 261             engine  => $engine,
 262             key_md5 => $args->{key_md5},
 263         });
 264
 265         $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
 266
 267         return $blist;
 268     }
 269
 270     $sector->find_md5( $args->{key_md5} );
 271
 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 ) {{
 277         my $redo;
 278
 279         my $new_index = DBM::Deep::Engine::Sector::Index->new({
 280             engine => $engine,
 281         });
 282
 283         my %blist_cache;
 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 ) );
 288
 289             # XXX This is inefficient
 290             my $blist = $blist_cache{$idx}
 291                 ||= DBM::Deep::Engine::Sector::BucketList->new({
 292                     engine => $engine,
 293                 });
 294
 295             $new_index->set_entry( $idx => $blist->offset );
 296
 297             my $new_spot = $blist->write_at_next_open( $md5 );
 298             $engine->reindex_entry( $spot => $new_spot );
 299         }
 300
 301         # Handle the new item separately.
 302         {
 303             my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
 304
 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
 307             # another index.
 308             if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
 309                 ++$i, ++$redo;
 310             } else {
 311                 my $blist = $blist_cache{$idx}
 312                     ||= DBM::Deep::Engine::Sector::BucketList->new({
 313                         engine => $engine,
 314                     });
 315
 316                 $new_index->set_entry( $idx => $blist->offset );
 317
 318                 #XXX THIS IS HACKY!
 319                 $blist->find_md5( $args->{key_md5} );
 320                 $blist->write_md5({
 321                     key     => $args->{key},
 322                     key_md5 => $args->{key_md5},
 323                     value   => DBM::Deep::Engine::Sector::Null->new({
 324                         engine => $engine,
 325                         data   => undef,
 326                     }),
 327                 });
 328             }
 329 #            my $blist = $blist_cache{$idx}
 330 #                ||= DBM::Deep::Engine::Sector::BucketList->new({
 331 #                    engine => $engine,
 332 #                });
 333 #
 334 #            $new_index->set_entry( $idx => $blist->offset );
 335 #
 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({
 342 #                    engine => $engine,
 343 #                    data   => undef,
 344 #                }),
 345 #            });
 346         }
 347
 348         if ( $last_sector ) {
 349             $last_sector->set_entry(
 350                 ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
 351                 $new_index->offset,
 352             );
 353         } else {
 354             $engine->storage->print_at( $self->offset + $self->base_size,
 355                 pack( $StP{$engine->byte_size}, $new_index->offset ),
 356             );
 357         }
 358
 359         $sector->clear;
 360         $sector->free;
 361
 362         if ( $redo ) {
 363             (undef, $sector) = %blist_cache;
 364             $last_sector = $new_index;
 365             redo;
 366         }
 367
 368         $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
 369         $sector->find_md5( $args->{key_md5} );
 370     }}
 371
 372     return $sector;
 373 }
 374
 375 sub get_class_offset {
 376     my $self = shift;
 377
 378     my $e = $self->engine;
 379     return unpack(
 380         $StP{$e->byte_size},
 381         $e->storage->read_at(
 382             $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size,
 383         ),
 384     );
 385 }
 386
 387 sub get_classname {
 388     my $self = shift;
 389
 390     my $class_offset = $self->get_class_offset;
 391
 392     return unless $class_offset;
 393
 394     return $self->engine->_load_sector( $class_offset )->data;
 395 }
 396
 397 sub data {
 398     my $self = shift;
 399     my ($args) = @_;
 400     $args ||= {};
 401
 402     my $obj;
 403     unless ( $obj = $self->engine->cache->{ $self->offset } ) {
 404         $obj = DBM::Deep->new({
 405             type        => $self->type,
 406             base_offset => $self->offset,
 407             staleness   => $self->staleness,
 408             storage     => $self->engine->storage,
 409             engine      => $self->engine,
 410         });
 411
 412         if ( $self->engine->storage->{autobless} ) {
 413             my $classname = $self->get_classname;
 414             if ( defined $classname ) {
 415                 bless $obj, $classname;
 416             }
 417         }
 418
 419         $self->engine->cache->{$self->offset} = $obj;
 420     }
 421
 422     # We're not exporting, so just return.
 423     unless ( $args->{export} ) {
 424         return $obj;
 425     }
 426
 427     # We shouldn't export if this is still referred to.
 428     if ( $self->get_refcount > 1 ) {
 429         return $obj;
 430     }
 431
 432     return $obj->export;
 433 }
 434
 435 sub free {
 436     my $self = shift;
 437
 438     # We're not ready to be removed yet.
 439     if ( $self->decrement_refcount > 0 ) {
 440         return;
 441     }
 442
 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 };
 448
 449     my $blist_loc = $self->get_blist_loc;
 450     $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
 451
 452     my $class_loc = $self->get_class_offset;
 453     $self->engine->_load_sector( $class_loc )->free if $class_loc;
 454
 455     $self->SUPER::free();
 456 }
 457
 458 sub increment_refcount {
 459     my $self = shift;
 460
 461     my $refcount = $self->get_refcount;
 462
 463     $refcount++;
 464
 465     $self->write_refcount( $refcount );
 466
 467     return $refcount;
 468 }
 469
 470 sub decrement_refcount {
 471     my $self = shift;
 472
 473     my $refcount = $self->get_refcount;
 474
 475     $refcount--;
 476
 477     $self->write_refcount( $refcount );
 478
 479     return $refcount;
 480 }
 481
 482 sub get_refcount {
 483     my $self = shift;
 484
 485     my $e = $self->engine;
 486     return unpack(
 487         $StP{$e->byte_size},
 488         $e->storage->read_at(
 489             $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
 490         ),
 491     );
 492 }
 493
 494 sub write_refcount {
 495     my $self = shift;
 496     my ($num) = @_;
 497
 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 ),
 502     );
 503 }
 504
 505 1;
 506 __END__