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

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