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