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

   1 package DBM::Deep::Engine::Sector::BucketList;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 use DBM::Deep::Engine::Sector;
   9 our @ISA = qw( DBM::Deep::Engine::Sector );
  10
  11 sub _init {
  12     my $self = shift;
  13
  14     my $engine = $self->engine;
  15
  16     unless ( $self->offset ) {
  17         $self->{offset} = $engine->_request_blist_sector( $self->size );
  18
  19         $self->write( 0, $engine->SIG_BLIST );
  20     }
  21
  22     if ( $self->{key_md5} ) {
  23         $self->find_md5;
  24     }
  25
  26     return $self;
  27 }
  28
  29 sub clear {
  30     my $self = shift;
  31
  32     # Zero-fill the data
  33     $self->write( $self->base_size, chr(0) x ($self->size - $self->base_size) );
  34 }
  35
  36 sub size {
  37     my $self = shift;
  38     if ( ref($self) ) {
  39         unless ( $self->{size} ) {
  40             # Base + numbuckets * bucketsize
  41             $self->{size} = $self->base_size + $self->engine->max_buckets * $self->bucket_size;
  42         }
  43         return $self->{size};
  44     }
  45     else {
  46         my $e = shift;
  47         return $self->base_size($e) + $e->max_buckets * $self->bucket_size($e);
  48     }
  49 }
  50
  51 sub free_meth { return '_add_free_blist_sector' }
  52
  53 sub free {
  54     my $self = shift;
  55
  56     my $e = $self->engine;
  57     foreach my $bucket ( $self->chopped_up ) {
  58         my $rest = $bucket->[-1];
  59
  60         # Delete the keysector
  61         my $l = unpack( $e->StP($e->byte_size), substr( $rest, $e->hash_size, $e->byte_size ) );
  62         my $s = $e->_load_sector( $l ); $s->free if $s;
  63
  64         # Delete the HEAD sector
  65         $l = unpack( $e->StP($e->byte_size),
  66             substr( $rest,
  67                 $e->hash_size + $e->byte_size,
  68                 $e->byte_size,
  69             ),
  70         );
  71         $s = $e->_load_sector( $l ); $s->free if $s;
  72
  73         foreach my $txn ( 0 .. $e->num_txns - 2 ) {
  74             my $l = unpack( $e->StP($e->byte_size),
  75                 substr( $rest,
  76                     $e->hash_size + 2 * $e->byte_size + $txn * ($e->byte_size + $DBM::Deep::Engine::STALE_SIZE),
  77                     $e->byte_size,
  78                 ),
  79             );
  80             my $s = $e->_load_sector( $l ); $s->free if $s;
  81         }
  82     }
  83
  84     $self->SUPER::free();
  85 }
  86
  87 sub bucket_size {
  88     my $self = shift;
  89     if ( ref($self) ) {
  90         unless ( $self->{bucket_size} ) {
  91             my $e = $self->engine;
  92             # Key + head (location) + transactions (location + staleness-counter)
  93             my $location_size = $e->byte_size + $e->byte_size + ($e->num_txns - 1) * ($e->byte_size + $DBM::Deep::Engine::STALE_SIZE);
  94             $self->{bucket_size} = $e->hash_size + $location_size;
  95         }
  96         return $self->{bucket_size};
  97     }
  98     else {
  99         my $e = shift;
 100         my $location_size = $e->byte_size + $e->byte_size + ($e->num_txns - 1) * ($e->byte_size + $DBM::Deep::Engine::STALE_SIZE);
 101         return $e->hash_size + $location_size;
 102     }
 103 }
 104
 105 # XXX This is such a poor hack. I need to rethink this code.
 106 sub chopped_up {
 107     my $self = shift;
 108
 109     my $e = $self->engine;
 110
 111     my @buckets;
 112     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
 113         my $spot = $self->base_size + $idx * $self->bucket_size;
 114         my $data = $self->read( $spot, $self->bucket_size );
 115
 116         # _dump_file() will run into the blank_md5. Otherwise, we should never run into it.
 117         # -RobK, 2008-06-18
 118         last if substr( $data, 0, $e->hash_size ) eq $e->blank_md5;
 119
 120         push @buckets, [ $spot, $data ];
 121     }
 122
 123     return @buckets;
 124 }
 125
 126 #XXX Call this append() instead? -RobK, 2008-06-30
 127 sub write_at_next_open {
 128     my $self = shift;
 129     my ($entry) = @_;
 130
 131     #XXX This is such a hack!
 132     $self->{_next_open} = 0 unless exists $self->{_next_open};
 133
 134     my $spot = $self->base_size + $self->{_next_open}++ * $self->bucket_size;
 135     $self->write( $spot, $entry );
 136
 137     return ($self->{_next_open} - 1);
 138 }
 139
 140 sub has_md5 {
 141     my $self = shift;
 142     unless ( exists $self->{found} ) {
 143         $self->find_md5;
 144     }
 145     return $self->{found};
 146 }
 147
 148 sub find_md5 {
 149     my $self = shift;
 150
 151     $self->{found} = undef;
 152     $self->{idx}   = -1;
 153
 154     if ( @_ ) {
 155         $self->{key_md5} = shift;
 156     }
 157
 158     # If we don't have an MD5, then what are we supposed to do?
 159     unless ( exists $self->{key_md5} ) {
 160         DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" );
 161     }
 162
 163     my $e = $self->engine;
 164     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
 165         my $potential = $self->read(
 166             $self->base_size + $idx * $self->bucket_size, $e->hash_size,
 167         );
 168
 169         if ( $potential eq $e->blank_md5 ) {
 170             $self->{idx} = $idx;
 171             return;
 172         }
 173
 174         if ( $potential eq $self->{key_md5} ) {
 175             $self->{found} = 1;
 176             $self->{idx} = $idx;
 177             return;
 178         }
 179     }
 180
 181     return;
 182 }
 183
 184 sub write_md5 {
 185     my $self = shift;
 186     my ($args) = @_;
 187
 188     DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key};
 189     DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5};
 190     DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value};
 191
 192     my $e = $self->engine;
 193
 194     $args->{trans_id} = $e->trans_id unless exists $args->{trans_id};
 195
 196     my $spot = $self->base_size + $self->{idx} * $self->bucket_size;
 197     $e->add_entry( $args->{trans_id}, $self->offset, $self->{idx} );
 198
 199     unless ($self->{found}) {
 200         my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({
 201             engine => $e,
 202             data   => $args->{key},
 203         });
 204
 205         $self->write( $spot, $args->{key_md5} . pack( $e->StP($e->byte_size), $key_sector->offset ) );
 206     }
 207
 208     my $loc = $spot + $e->hash_size + $e->byte_size;
 209
 210     if ( $args->{trans_id} ) {
 211         $loc += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 212
 213         $self->write( $loc,
 214             pack( $e->StP($e->byte_size), $args->{value}->offset )
 215           . pack( $e->StP($DBM::Deep::Engine::STALE_SIZE), $e->get_txn_staleness_counter( $args->{trans_id} ) ),
 216         );
 217     }
 218     else {
 219         $self->write( $loc, pack( $e->StP($e->byte_size), $args->{value}->offset ) );
 220     }
 221 }
 222
 223 sub mark_deleted {
 224     my $self = shift;
 225     my ($args) = @_;
 226     $args ||= {};
 227
 228     my $e = $self->engine;
 229
 230     $args->{trans_id} = $e->trans_id unless exists $args->{trans_id};
 231
 232     my $spot = $self->base_size + $self->{idx} * $self->bucket_size;
 233     $e->add_entry( $args->{trans_id}, $self->offset, $self->{idx} );
 234
 235     my $loc = $spot
 236       + $e->hash_size
 237       + $e->byte_size;
 238
 239     if ( $args->{trans_id} ) {
 240         $loc += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 241
 242         $self->write( $loc,
 243             pack( $e->StP($e->byte_size), 1 ) # 1 is the marker for deleted
 244           . pack( $e->StP($DBM::Deep::Engine::STALE_SIZE), $e->get_txn_staleness_counter( $args->{trans_id} ) ),
 245         );
 246     }
 247     else {
 248         # 1 is the marker for deleted
 249         $self->write( $loc, pack( $e->StP($e->byte_size), 1 ) );
 250     }
 251 }
 252
 253 sub delete_md5 {
 254     my $self = shift;
 255     my ($args) = @_;
 256
 257     my $engine = $self->engine;
 258     return undef unless $self->{found};
 259
 260     # Save the location so that we can free the data
 261     my $location = $self->get_data_location_for({
 262         allow_head => 0,
 263     });
 264     my $key_sector = $self->get_key_for;
 265
 266     my $spot = $self->base_size + $self->{idx} * $self->bucket_size;
 267
 268     # Shuffle everything down to cover the deleted bucket's spot.
 269     $self->write( $spot,
 270         $self->read(
 271             $spot + $self->bucket_size,
 272             $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ),
 273         )
 274       . chr(0) x $self->bucket_size,
 275     );
 276
 277     $key_sector->free;
 278
 279     my $data_sector = $self->engine->_load_sector( $location );
 280     my $data = $data_sector->data({ export => 1 });
 281     $data_sector->free;
 282
 283     return $data;
 284 }
 285
 286 sub get_data_location_for {
 287     my $self = shift;
 288     my ($args) = @_;
 289     $args ||= {};
 290
 291     $args->{allow_head} = 0 unless exists $args->{allow_head};
 292     $args->{trans_id}   = $self->engine->trans_id unless exists $args->{trans_id};
 293     $args->{idx}        = $self->{idx} unless exists $args->{idx};
 294
 295     my $e = $self->engine;
 296
 297     my $spot = $self->base_size
 298       + $args->{idx} * $self->bucket_size
 299       + $e->hash_size
 300       + $e->byte_size;
 301
 302     if ( $args->{trans_id} ) {
 303         $spot += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 304     }
 305
 306     my $buffer = $self->read( $spot, $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 307     my ($loc, $staleness) = unpack(
 308         $e->StP($e->byte_size) . ' ' . $e->StP($DBM::Deep::Engine::STALE_SIZE),
 309         $buffer,
 310     );
 311
 312     # XXX Merge the two if-clauses below
 313     if ( $args->{trans_id} ) {
 314         # We have found an entry that is old, so get rid of it
 315         if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) {
 316             $e->storage->print_at(
 317                 $spot,
 318                 pack( $e->StP($e->byte_size) . ' ' . $e->StP($DBM::Deep::Engine::STALE_SIZE), (0) x 2 ),
 319             );
 320             $loc = 0;
 321         }
 322     }
 323
 324     # If we're in a transaction and we never wrote to this location, try the
 325     # HEAD instead.
 326     if ( $args->{trans_id} && !$loc && $args->{allow_head} ) {
 327         return $self->get_data_location_for({
 328             trans_id   => 0,
 329             allow_head => 1,
 330             idx        => $args->{idx},
 331         });
 332     }
 333
 334     return $loc <= 1 ? 0 : $loc;
 335 }
 336
 337 sub get_data_for {
 338     my $self = shift;
 339     my ($args) = @_;
 340     $args ||= {};
 341
 342     return unless $self->{found};
 343     my $location = $self->get_data_location_for({
 344         allow_head => $args->{allow_head},
 345     });
 346     return $self->engine->_load_sector( $location );
 347 }
 348
 349 sub get_key_for {
 350     my $self = shift;
 351     my ($idx) = @_;
 352     $idx = $self->{idx} unless defined $idx;
 353
 354     if ( $idx >= $self->engine->max_buckets ) {
 355         DBM::Deep->_throw_error( "get_key_for(): Attempting to retrieve $idx beyond max_buckets" );
 356     }
 357
 358     my $location = $self->read(
 359         $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size,
 360         $self->engine->byte_size,
 361     );
 362     $location = unpack( $self->engine->StP($self->engine->byte_size), $location );
 363     DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location;
 364
 365     return $self->engine->_load_sector( $location );
 366 }
 367
 368 sub rollback {
 369     my $self = shift;
 370     my ($idx) = @_;
 371     my $e = $self->engine;
 372     my $trans_id = $e->trans_id;
 373
 374 #    warn "Rolling back $idx ($trans_id)\n";
 375
 376     my $base = $self->base_size + ($idx * $self->bucket_size) + $e->hash_size + $e->byte_size;
 377     my $spot = $base + $e->byte_size + ($trans_id - 1) * ( $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 378
 379     my $trans_loc = $self->read( $spot, $e->byte_size );
 380     $trans_loc = unpack( $e->StP($e->byte_size), $trans_loc );
 381 #    warn "$trans_loc\n";
 382
 383     $self->write( $spot, pack( $e->StP($e->byte_size), 0 ) );
 384
 385     if ( $trans_loc > 1 ) {
 386         $e->_load_sector( $trans_loc )->free;
 387     }
 388
 389     return;
 390 }
 391
 392 sub commit {
 393     my $self = shift;
 394     my ($idx) = @_;
 395     my $e = $self->engine;
 396     my $trans_id = $e->trans_id;
 397
 398     my $base = $self->base_size + ($idx * $self->bucket_size) + $e->hash_size + $e->byte_size;
 399
 400     my $head_loc = $self->read( $base, $e->byte_size );
 401     $head_loc = unpack( $e->StP($e->byte_size), $head_loc );
 402
 403     my $spot = $base + $e->byte_size + ($trans_id - 1) * ( $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 404     my $trans_loc = $self->read( $spot, $e->byte_size );
 405
 406     $self->write( $base, $trans_loc );
 407     $self->write( $spot, pack( $e->StP($e->byte_size) . ' ' . $e->StP($DBM::Deep::Engine::STALE_SIZE), (0) x 2 ) );
 408
 409     if ( $head_loc > 1 ) {
 410         $e->_load_sector( $head_loc )->free;
 411     }
 412
 413     return;
 414 }
 415
 416 1;
 417 __END__