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