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 Scalar::Util ();
   9
  10 use DBM::Deep::Null;
  11
  12 use DBM::Deep::Engine::Sector::Data;
  13 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
  14
  15 sub _init {
  16     my $self = shift;
  17
  18     my $e = $self->engine;
  19
  20     unless ( $self->offset ) {
  21         $self->{offset} = $e->_request_data_sector( $self->size );
  22
  23         my $class_offset = 0;
  24         my $classname = Scalar::Util::blessed( delete $self->{data} );
  25         if ( defined $classname ) {
  26             my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
  27                 engine => $e,
  28                 data   => $classname,
  29             });
  30             $class_offset = $class_sector->offset;
  31         }
  32
  33         $self->write( 0, $self->type );
  34         $self->write( $self->base_size,
  35             pack( $e->StP($e->byte_size), 0 )             # Index/BList loc
  36           . pack( $e->StP($e->byte_size), $class_offset ) # Classname loc
  37           . pack( $e->StP($e->byte_size), 1 )             # Initial refcount
  38         );
  39     }
  40     else {
  41         $self->{type} = $self->read( 0, $e->SIG_SIZE );
  42     }
  43
  44     $self->{staleness} = unpack(
  45         $e->StP($DBM::Deep::Engine::STALE_SIZE),
  46         $self->read( $e->SIG_SIZE, $DBM::Deep::Engine::STALE_SIZE ),
  47     );
  48
  49     return;
  50 }
  51
  52 sub staleness { $_[0]{staleness} }
  53
  54 sub get_data_location_for {
  55     my $self = shift;
  56     my ($args) = @_;
  57
  58     # Assume that the head is not allowed unless otherwise specified.
  59     $args->{allow_head} = 0 unless exists $args->{allow_head};
  60
  61     # Assume we don't create a new blist location unless otherwise specified.
  62     $args->{create} = 0 unless exists $args->{create};
  63
  64     my $blist = $self->get_bucket_list({
  65         key_md5 => $args->{key_md5},
  66         key => $args->{key},
  67         create  => $args->{create},
  68     });
  69     return unless $blist && $blist->{found};
  70
  71     # At this point, $blist knows where the md5 is. What it -doesn't- know yet
  72     # is whether or not this transaction has this key. That's part of the next
  73     # function call.
  74     my $location = $blist->get_data_location_for({
  75         allow_head => $args->{allow_head},
  76     }) or return;
  77
  78     return $location;
  79 }
  80
  81 sub get_data_for {
  82     my $self = shift;
  83     my ($args) = @_;
  84
  85     my $location = $self->get_data_location_for( $args )
  86         or return;
  87
  88     return $self->engine->_load_sector( $location );
  89 }
  90
  91 sub write_data {
  92     my $self = shift;
  93     my ($args) = @_;
  94
  95     my $blist = $self->get_bucket_list({
  96         key_md5 => $args->{key_md5},
  97         key => $args->{key},
  98         create  => 1,
  99     }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
 100
 101     # Handle any transactional bookkeeping.
 102     if ( $self->engine->trans_id ) {
 103         if ( ! $blist->has_md5 ) {
 104             $blist->mark_deleted({
 105                 trans_id => 0,
 106             });
 107         }
 108     }
 109     else {
 110         my @trans_ids = $self->engine->get_running_txn_ids;
 111         if ( $blist->has_md5 ) {
 112             if ( @trans_ids ) {
 113                 my $old_value = $blist->get_data_for;
 114                 foreach my $other_trans_id ( @trans_ids ) {
 115                     next if $blist->get_data_location_for({
 116                         trans_id   => $other_trans_id,
 117                         allow_head => 0,
 118                     });
 119                     $blist->write_md5({
 120                         trans_id => $other_trans_id,
 121                         key      => $args->{key},
 122                         key_md5  => $args->{key_md5},
 123                         value    => $old_value->clone,
 124                     });
 125                 }
 126             }
 127         }
 128         else {
 129             if ( @trans_ids ) {
 130                 foreach my $other_trans_id ( @trans_ids ) {
 131                     #XXX This doesn't seem to possible to ever happen . . .
 132                     next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
 133                     $blist->mark_deleted({
 134                         trans_id => $other_trans_id,
 135                     });
 136                 }
 137             }
 138         }
 139     }
 140
 141     #XXX Is this safe to do transactionally?
 142     # Free the place we're about to write to.
 143     if ( $blist->get_data_location_for({ allow_head => 0 }) ) {
 144         $blist->get_data_for({ allow_head => 0 })->free;
 145     }
 146
 147     $blist->write_md5({
 148         key      => $args->{key},
 149         key_md5  => $args->{key_md5},
 150         value    => $args->{value},
 151     });
 152 }
 153
 154 sub delete_key {
 155     my $self = shift;
 156     my ($args) = @_;
 157
 158     # XXX What should happen if this fails?
 159     my $blist = $self->get_bucket_list({
 160         key_md5 => $args->{key_md5},
 161     }) or DBM::Deep->_throw_error( "How did delete_key fail (no blist)?!" );
 162
 163     # Save the location so that we can free the data
 164     my $location = $blist->get_data_location_for({
 165         allow_head => 0,
 166     });
 167     my $old_value = $location && $self->engine->_load_sector( $location );
 168
 169     my @trans_ids = $self->engine->get_running_txn_ids;
 170
 171     # If we're the HEAD and there are running txns, then we need to clone this value to the other
 172     # transactions to preserve Isolation.
 173     if ( $self->engine->trans_id == 0 ) {
 174         if ( @trans_ids ) {
 175             foreach my $other_trans_id ( @trans_ids ) {
 176                 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
 177                 $blist->write_md5({
 178                     trans_id => $other_trans_id,
 179                     key      => $args->{key},
 180                     key_md5  => $args->{key_md5},
 181                     value    => $old_value->clone,
 182                 });
 183             }
 184         }
 185     }
 186
 187     my $data;
 188     if ( @trans_ids ) {
 189         $blist->mark_deleted( $args );
 190
 191         if ( $old_value ) {
 192             $data = $old_value->data({ export => 1 });
 193             $old_value->free;
 194         }
 195     }
 196     else {
 197         $data = $blist->delete_md5( $args );
 198     }
 199
 200     return $data;
 201 }
 202
 203 sub get_blist_loc {
 204     my $self = shift;
 205
 206     my $e = $self->engine;
 207     return unpack(
 208         $e->StP($e->byte_size),
 209         $self->read( $self->base_size, $e->byte_size ),
 210     );
 211 }
 212
 213 sub get_bucket_list {
 214     my $self = shift;
 215     my ($args) = @_;
 216     $args ||= {};
 217
 218     # XXX Add in check here for recycling?
 219
 220     my $engine = $self->engine;
 221
 222     my $blist_loc = $self->get_blist_loc;
 223
 224     # There's no index or blist yet
 225     unless ( $blist_loc ) {
 226         return unless $args->{create};
 227
 228         my $blist = DBM::Deep::Engine::Sector::BucketList->new({
 229             engine  => $engine,
 230             key_md5 => $args->{key_md5},
 231         });
 232
 233         $self->write( $self->base_size, pack( $engine->StP($engine->byte_size), $blist->offset ) );
 234
 235         return $blist;
 236     }
 237
 238     my $sector = $engine->_load_sector( $blist_loc )
 239         or DBM::Deep->_throw_error( "1: Cannot read sector at $blist_loc in get_bucket_list()" );
 240     my $i = 0;
 241     my $last_sector = undef;
 242     while ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) {
 243         $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
 244         $last_sector = $sector;
 245         if ( $blist_loc ) {
 246             $sector = $engine->_load_sector( $blist_loc )
 247                 or DBM::Deep->_throw_error( "2: Cannot read sector at $blist_loc in get_bucket_list()" );
 248         }
 249         else {
 250             $sector = undef;
 251             last;
 252         }
 253     }
 254
 255     # This means we went through the Index sector(s) and found an empty slot
 256     unless ( $sector ) {
 257         return unless $args->{create};
 258
 259         DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
 260             unless $last_sector;
 261
 262         my $blist = DBM::Deep::Engine::Sector::BucketList->new({
 263             engine  => $engine,
 264             key_md5 => $args->{key_md5},
 265         });
 266
 267         $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
 268
 269         return $blist;
 270     }
 271
 272     $sector->find_md5( $args->{key_md5} );
 273
 274     # See whether or not we need to reindex the bucketlist
 275     # Yes, the double-braces are there for a reason. if() doesn't create a redo-able block,
 276     # so we have to create a bare block within the if() for redo-purposes. Patch and idea
 277     # submitted by sprout@cpan.org. -RobK, 2008-01-09
 278     if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
 279         my $redo;
 280
 281         my $new_index = DBM::Deep::Engine::Sector::Index->new({
 282             engine => $engine,
 283         });
 284
 285         my %blist_cache;
 286         #XXX q.v. the comments for this function.
 287         my $old_idx = 0;
 288         foreach my $entry ( $sector->chopped_up ) {
 289             my ($spot, $md5) = @{$entry};
 290             my $idx = ord( substr( $md5, $i, 1 ) );
 291
 292             # XXX This is inefficient
 293             my $blist = $blist_cache{$idx}
 294                 ||= DBM::Deep::Engine::Sector::BucketList->new({
 295                     engine => $engine,
 296                 });
 297
 298             $new_index->set_entry( $idx => $blist->offset );
 299
 300             #XXX q.v. the comments for this function.
 301             my $new_idx = $blist->write_at_next_open( $md5 );
 302
 303             $engine->reindex_entry( ( $sector->offset, $old_idx ) => ( $blist->offset, $new_idx ) );
 304
 305             $old_idx++;
 306         }
 307
 308         # Handle the new item separately.
 309         {
 310             my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
 311
 312             # If all the previous blist's items have been thrown into one
 313             # blist and the new item belongs in there too, we need
 314             # another index.
 315             if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
 316                 ++$i, ++$redo;
 317             } else {
 318                 my $blist = $blist_cache{$idx}
 319                     ||= DBM::Deep::Engine::Sector::BucketList->new({
 320                         engine => $engine,
 321                     });
 322
 323                 $new_index->set_entry( $idx => $blist->offset );
 324
 325                 #XXX THIS IS HACKY!
 326                 $blist->find_md5( $args->{key_md5} );
 327                 $blist->write_md5({
 328                     key     => $args->{key},
 329                     key_md5 => $args->{key_md5},
 330                     value   => DBM::Deep::Engine::Sector::Null->new({
 331                         engine => $engine,
 332                         data   => undef,
 333                     }),
 334                 });
 335             }
 336
 337 #XXX Why is this code here? -RobK, 2008-06-15
 338 #            my $blist = $blist_cache{$idx}
 339 #                ||= DBM::Deep::Engine::Sector::BucketList->new({
 340 #                    engine => $engine,
 341 #                });
 342 #
 343 #            $new_index->set_entry( $idx => $blist->offset );
 344 #
 345 #            #XXX THIS IS HACKY!
 346 #            $blist->find_md5( $args->{key_md5} );
 347 #            $blist->write_md5({
 348 #                key     => $args->{key},
 349 #                key_md5 => $args->{key_md5},
 350 #                value   => DBM::Deep::Engine::Sector::Null->new({
 351 #                    engine => $engine,
 352 #                    data   => undef,
 353 #                }),
 354 #            });
 355         }
 356
 357         if ( $last_sector ) {
 358             $last_sector->set_entry(
 359                 ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
 360                 $new_index->offset,
 361             );
 362         } else {
 363             $self->write( $self->base_size, pack( $engine->StP($engine->byte_size), $new_index->offset ) );
 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         $self->read(
 389             $self->base_size + 1 * $e->byte_size,
 390             $e->byte_size,
 391         ),
 392     );
 393 }
 394
 395 sub get_classname {
 396     my $self = shift;
 397
 398     my $class_offset = $self->get_class_offset;
 399
 400     return unless $class_offset;
 401
 402     return $self->engine->_load_sector( $class_offset )->data;
 403 }
 404
 405 sub data {
 406     my $self = shift;
 407     my ($args) = @_;
 408     $args ||= {};
 409
 410     my $obj;
 411     unless ( $obj = $self->engine->cache->{ $self->offset } ) {
 412         $obj = DBM::Deep->new({
 413             type        => $self->type,
 414             base_offset => $self->offset,
 415             staleness   => $self->staleness,
 416             storage     => $self->engine->storage,
 417             engine      => $self->engine,
 418         });
 419
 420         if ( $self->engine->storage->{autobless} ) {
 421             my $classname = $self->get_classname;
 422             if ( defined $classname ) {
 423                 bless $obj, $classname;
 424             }
 425         }
 426
 427         $self->engine->cache->{$self->offset} = $obj;
 428     }
 429
 430     # We're not exporting, so just return.
 431     unless ( $args->{export} ) {
 432         return $obj;
 433     }
 434
 435     # We shouldn't export if this is still referred to.
 436     if ( $self->get_refcount > 1 ) {
 437         return $obj;
 438     }
 439
 440     return $obj->export;
 441 }
 442
 443 sub free {
 444     my $self = shift;
 445
 446     # We're not ready to be removed yet.
 447     if ( $self->decrement_refcount > 0 ) {
 448         return;
 449     }
 450
 451     # Rebless the object into DBM::Deep::Null.
 452     eval { %{ $self->engine->cache->{ $self->offset } } = (); };
 453     eval { @{ $self->engine->cache->{ $self->offset } } = (); };
 454     bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
 455     delete $self->engine->cache->{ $self->offset };
 456
 457     foreach my $meth ( qw( get_blist_loc get_class_offset ) ) {
 458         my $l = $self->$meth;
 459         my $s = $self->engine->_load_sector( $l );
 460         $s->free if $s;
 461     }
 462
 463     $self->SUPER::free();
 464 }
 465
 466 sub increment_refcount {
 467     my $self = shift;
 468
 469     my $refcount = $self->get_refcount;
 470
 471     $refcount++;
 472
 473     $self->write_refcount( $refcount );
 474
 475     return $refcount;
 476 }
 477
 478 sub decrement_refcount {
 479     my $self = shift;
 480
 481     my $refcount = $self->get_refcount;
 482
 483     $refcount--;
 484
 485     $self->write_refcount( $refcount );
 486
 487     return $refcount;
 488 }
 489
 490 sub get_refcount {
 491     my $self = shift;
 492
 493     my $e = $self->engine;
 494     return unpack(
 495         $e->StP($e->byte_size),
 496         $self->read(
 497             $self->base_size + 2 * $e->byte_size,
 498             $e->byte_size,
 499         ),
 500     );
 501 }
 502
 503 sub write_refcount {
 504     my $self = shift;
 505     my ($num) = @_;
 506
 507     my $e = $self->engine;
 508     $self->write(
 509         $self->base_size + 2 * $e->byte_size,
 510         pack( $e->StP($e->byte_size), $num ),
 511     );
 512 }
 513
 514
 515 1;
 516 __END__
 517