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

   1 package DBM::Deep::Sector::File::Reference;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 use base qw( DBM::Deep::Sector::File::Data );
   9
  10 my $STALE_SIZE = 2;
  11
  12 # Please refer to the pack() documentation for further information
  13 my %StP = (
  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)
  18 );
  19
  20 sub _init {
  21     my $self = shift;
  22
  23     my $e = $self->engine;
  24
  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;
  28
  29         my $class_offset = 0;
  30         if ( defined $classname ) {
  31             my $class_sector = DBM::Deep::Sector::File::Scalar->new({
  32                 engine => $e,
  33                 data   => $classname,
  34             });
  35             $class_offset = $class_sector->offset;
  36         }
  37
  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
  46         );
  47     }
  48     else {
  49         $self->{type} = $e->storage->read_at( $self->offset, 1 );
  50     }
  51
  52     $self->{staleness} = unpack(
  53         $StP{$STALE_SIZE},
  54         $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ),
  55     );
  56
  57     return;
  58 }
  59
  60 sub get_data_location_for {
  61     my $self = shift;
  62     my ($args) = @_;
  63
  64     # Assume that the head is not allowed unless otherwise specified.
  65     $args->{allow_head} = 0 unless exists $args->{allow_head};
  66
  67     # Assume we don't create a new blist location unless otherwise specified.
  68     $args->{create} = 0 unless exists $args->{create};
  69
  70     my $blist = $self->get_bucket_list({
  71         key_md5 => $args->{key_md5},
  72         key => $args->{key},
  73         create  => $args->{create},
  74     });
  75     return unless $blist && $blist->{found};
  76
  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
  79     # function call.
  80     my $location = $blist->get_data_location_for({
  81         allow_head => $args->{allow_head},
  82     }) or return;
  83
  84     return $location;
  85 }
  86
  87 sub get_data_for {
  88     my $self = shift;
  89     my ($args) = @_;
  90
  91     my $location = $self->get_data_location_for( $args )
  92         or return;
  93
  94     return $self->engine->load_sector( $location );
  95 }
  96
  97 sub write_data {
  98     my $self = shift;
  99     my ($args) = @_;
 100
 101     my $blist = $self->get_bucket_list({
 102         key_md5 => $args->{key_md5},
 103         key => $args->{key},
 104         create  => 1,
 105     }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
 106
 107     # Handle any transactional bookkeeping.
 108     if ( $self->engine->trans_id ) {
 109         if ( ! $blist->has_md5 ) {
 110             $blist->mark_deleted({
 111                 trans_id => 0,
 112             });
 113         }
 114     }
 115     else {
 116         my @trans_ids = $self->engine->get_running_txn_ids;
 117         if ( $blist->has_md5 ) {
 118             if ( @trans_ids ) {
 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,
 123                         allow_head => 0,
 124                     });
 125                     $blist->write_md5({
 126                         trans_id => $other_trans_id,
 127                         key      => $args->{key},
 128                         key_md5  => $args->{key_md5},
 129                         value    => $old_value->clone,
 130                     });
 131                 }
 132             }
 133         }
 134         else {
 135             if ( @trans_ids ) {
 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,
 141                     });
 142                 }
 143             }
 144         }
 145     }
 146
 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;
 151     }
 152
 153     $blist->write_md5({
 154         key      => $args->{key},
 155         key_md5  => $args->{key_md5},
 156         value    => $args->{value},
 157     });
 158 }
 159
 160 sub delete_key {
 161     my $self = shift;
 162     my ($args) = @_;
 163
 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:
 166     #     my $x = {};
 167     #     delete $x->{foo}{bar};
 168     my $blist = $self->get_bucket_list({
 169         key_md5 => $args->{key_md5},
 170     }) or return;
 171
 172     # Save the location so that we can free the data
 173     my $location = $blist->get_data_location_for({
 174         allow_head => 0,
 175     });
 176     my $old_value = $location && $self->engine->load_sector( $location );
 177
 178     my @trans_ids = $self->engine->get_running_txn_ids;
 179
 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 ) {
 183         if ( @trans_ids ) {
 184             foreach my $other_trans_id ( @trans_ids ) {
 185                 next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
 186                 $blist->write_md5({
 187                     trans_id => $other_trans_id,
 188                     key      => $args->{key},
 189                     key_md5  => $args->{key_md5},
 190                     value    => $old_value->clone,
 191                 });
 192             }
 193         }
 194     }
 195
 196     my $data;
 197     if ( @trans_ids ) {
 198         $blist->mark_deleted( $args );
 199
 200         if ( $old_value ) {
 201             #XXX Is this export => 1 actually doing anything?
 202             $data = $old_value->data({ export => 1 });
 203             $old_value->free;
 204         }
 205     }
 206     else {
 207         $data = $blist->delete_md5( $args );
 208     }
 209
 210     return $data;
 211 }
 212
 213 sub write_blist_loc {
 214     my $self = shift;
 215     my ($loc) = @_;
 216
 217     my $engine = $self->engine;
 218     $engine->storage->print_at( $self->offset + $self->base_size,
 219         pack( $StP{$engine->byte_size}, $loc ),
 220     );
 221 }
 222
 223 sub get_blist_loc {
 224     my $self = shift;
 225
 226     my $e = $self->engine;
 227     my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size );
 228     return unpack( $StP{$e->byte_size}, $blist_loc );
 229 }
 230
 231 sub get_bucket_list {
 232     my $self = shift;
 233     my ($args) = @_;
 234     $args ||= {};
 235
 236     # XXX Add in check here for recycling?
 237
 238     my $engine = $self->engine;
 239
 240     my $blist_loc = $self->get_blist_loc;
 241
 242     # There's no index or blist yet
 243     unless ( $blist_loc ) {
 244         return unless $args->{create};
 245
 246         my $blist = DBM::Deep::Sector::File::BucketList->new({
 247             engine  => $engine,
 248             key_md5 => $args->{key_md5},
 249         });
 250
 251         $self->write_blist_loc( $blist->offset );
 252 #        $engine->storage->print_at( $self->offset + $self->base_size,
 253 #            pack( $StP{$engine->byte_size}, $blist->offset ),
 254 #        );
 255
 256         return $blist;
 257     }
 258
 259     my $sector = $engine->load_sector( $blist_loc )
 260         or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
 261     my $i = 0;
 262     my $last_sector = undef;
 263     while ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
 264         $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
 265         $last_sector = $sector;
 266         if ( $blist_loc ) {
 267             $sector = $engine->load_sector( $blist_loc )
 268                 or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
 269         }
 270         else {
 271             $sector = undef;
 272             last;
 273         }
 274     }
 275
 276     # This means we went through the Index sector(s) and found an empty slot
 277     unless ( $sector ) {
 278         return unless $args->{create};
 279
 280         DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
 281             unless $last_sector;
 282
 283         my $blist = DBM::Deep::Sector::File::BucketList->new({
 284             engine  => $engine,
 285             key_md5 => $args->{key_md5},
 286         });
 287
 288         $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
 289
 290         return $blist;
 291     }
 292
 293     $sector->find_md5( $args->{key_md5} );
 294
 295     # See whether or not we need to reindex the bucketlist
 296     # Yes, the double-braces are there for a reason. if() doesn't create a
 297     # redo-able block, so we have to create a bare block within the if() for
 298     # redo-purposes.
 299     # Patch and idea submitted by sprout@cpan.org. -RobK, 2008-01-09
 300     if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
 301         my $redo;
 302
 303         my $new_index = DBM::Deep::Sector::File::Index->new({
 304             engine => $engine,
 305         });
 306
 307         my %blist_cache;
 308         #XXX q.v. the comments for this function.
 309         foreach my $entry ( $sector->chopped_up ) {
 310             my ($spot, $md5) = @{$entry};
 311             my $idx = ord( substr( $md5, $i, 1 ) );
 312
 313             # XXX This is inefficient
 314             my $blist = $blist_cache{$idx}
 315                 ||= DBM::Deep::Sector::File::BucketList->new({
 316                     engine => $engine,
 317                 });
 318
 319             $new_index->set_entry( $idx => $blist->offset );
 320
 321             my $new_spot = $blist->write_at_next_open( $md5 );
 322             $engine->reindex_entry( $spot => $new_spot );
 323         }
 324
 325         # Handle the new item separately.
 326         {
 327             my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
 328
 329             # If all the previous blist's items have been thrown into one
 330             # blist and the new item belongs in there too, we need
 331             # another index.
 332             if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
 333                 ++$i, ++$redo;
 334             } else {
 335                 my $blist = $blist_cache{$idx}
 336                     ||= DBM::Deep::Sector::File::BucketList->new({
 337                         engine => $engine,
 338                     });
 339
 340                 $new_index->set_entry( $idx => $blist->offset );
 341
 342                 #XXX THIS IS HACKY!
 343                 $blist->find_md5( $args->{key_md5} );
 344                 $blist->write_md5({
 345                     key     => $args->{key},
 346                     key_md5 => $args->{key_md5},
 347                     value   => DBM::Deep::Sector::File::Null->new({
 348                         engine => $engine,
 349                         data   => undef,
 350                     }),
 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( $StP{$engine->byte_size}, $new_index->offset ),
 363             );
 364         }
 365
 366         $sector->wipe;
 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         $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 # Look to hoist this method into a ::Reference trait
 405 sub data {
 406     my $self = shift;
 407     my ($args) = @_;
 408     $args ||= {};
 409
 410     my $engine = $self->engine;
 411 #    if ( !exists $engine->cache->{ $self->offset }{ $engine->trans_id } ) {
 412         my $obj = DBM::Deep->new({
 413             type        => $self->type,
 414             base_offset => $self->offset,
 415             staleness   => $self->staleness,
 416             storage     => $engine->storage,
 417             engine      => $engine,
 418         });
 419
 420 #        $engine->cache->{$self->offset}{ $engine->trans_id } = $obj;
 421 #    }
 422 #    my $obj = $engine->cache->{$self->offset}{ $engine->trans_id };
 423
 424     # We're not exporting, so just return.
 425     unless ( $args->{export} ) {
 426         if ( $engine->storage->{autobless} ) {
 427             my $classname = $self->get_classname;
 428             if ( defined $classname ) {
 429                 bless $obj, $classname;
 430             }
 431         }
 432
 433         return $obj;
 434     }
 435
 436     # We shouldn't export if this is still referred to.
 437     if ( $self->get_refcount > 1 ) {
 438         return $obj;
 439     }
 440
 441     return $obj->export;
 442 }
 443
 444 sub free {
 445     my $self = shift;
 446
 447     # We're not ready to be removed yet.
 448     return if $self->decrement_refcount > 0;
 449
 450     my $e = $self->engine;
 451
 452     # Rebless the object into DBM::Deep::Null.
 453 #    eval { %{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); };
 454 #    eval { @{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); };
 455 #    bless $e->cache->{ $self->offset }{ $e->trans_id }, 'DBM::Deep::Null';
 456 #    delete $e->cache->{ $self->offset }{ $e->trans_id };
 457
 458     my $blist_loc = $self->get_blist_loc;
 459     $e->load_sector( $blist_loc )->free if $blist_loc;
 460
 461     my $class_loc = $self->get_class_offset;
 462     $e->load_sector( $class_loc )->free if $class_loc;
 463
 464     $self->SUPER::free();
 465 }
 466
 467 sub increment_refcount {
 468     my $self = shift;
 469
 470     my $refcount = $self->get_refcount;
 471
 472     $refcount++;
 473
 474     $self->write_refcount( $refcount );
 475
 476     return $refcount;
 477 }
 478
 479 sub decrement_refcount {
 480     my $self = shift;
 481
 482     my $refcount = $self->get_refcount;
 483
 484     $refcount--;
 485
 486     $self->write_refcount( $refcount );
 487
 488     return $refcount;
 489 }
 490
 491 sub get_refcount {
 492     my $self = shift;
 493
 494     my $e = $self->engine;
 495     return unpack(
 496         $StP{$e->byte_size},
 497         $e->storage->read_at(
 498             $self->offset + $self->base_size + 2 * $e->byte_size, $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     $e->storage->print_at(
 509         $self->offset + $self->base_size + 2 * $e->byte_size,
 510         pack( $StP{$e->byte_size}, $num ),
 511     );
 512 }
 513
 514 sub clear {
 515     my $self = shift;
 516
 517     my $blist_loc = $self->get_blist_loc or return;
 518
 519     my $engine = $self->engine;
 520
 521     # This won't work with autoblessed items.
 522     if ($engine->get_running_txn_ids) {
 523         # ~~~ Temporary; the code below this block needs to be modified to
 524         #     take transactions into account.
 525         $self->data->_get_self->_clear;
 526         return;
 527     }
 528
 529     my $sector = $engine->load_sector( $blist_loc )
 530         or DBM::Deep->_throw_error(
 531            "Cannot read sector at $blist_loc in clear()"
 532         );
 533
 534     # Set blist offset to 0
 535     $engine->storage->print_at( $self->offset + $self->base_size,
 536         pack( $StP{$engine->byte_size}, 0 ),
 537     );
 538
 539     # Free the blist
 540     $sector->free;
 541
 542     return;
 543 }
 544
 545 1;
 546 __END__