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     unless ( $self->{size} ) {
  39         # Base + numbuckets * bucketsize
  40         $self->{size} = $self->base_size + $self->engine->max_buckets * $self->bucket_size;
  41     }
  42     return $self->{size};
  43 }
  44
  45 sub free_meth { return '_add_free_blist_sector' }
  46
  47 sub free {
  48     my $self = shift;
  49
  50     my $e = $self->engine;
  51     foreach my $bucket ( $self->chopped_up ) {
  52         my $rest = $bucket->[-1];
  53
  54         # Delete the keysector
  55         my $l = unpack( $e->StP($e->byte_size), substr( $rest, $e->hash_size, $e->byte_size ) );
  56         my $s = $e->_load_sector( $l ); $s->free if $s;
  57
  58         # Delete the HEAD sector
  59         $l = unpack( $e->StP($e->byte_size),
  60             substr( $rest,
  61                 $e->hash_size + $e->byte_size,
  62                 $e->byte_size,
  63             ),
  64         );
  65         $s = $e->_load_sector( $l ); $s->free if $s;
  66
  67         foreach my $txn ( 0 .. $e->num_txns - 2 ) {
  68             my $l = unpack( $e->StP($e->byte_size),
  69                 substr( $rest,
  70                     $e->hash_size + 2 * $e->byte_size + $txn * ($e->byte_size + $DBM::Deep::Engine::STALE_SIZE),
  71                     $e->byte_size,
  72                 ),
  73             );
  74             my $s = $e->_load_sector( $l ); $s->free if $s;
  75         }
  76     }
  77
  78     $self->SUPER::free();
  79 }
  80
  81 sub bucket_size {
  82     my $self = shift;
  83     unless ( $self->{bucket_size} ) {
  84         my $e = $self->engine;
  85         # Key + head (location) + transactions (location + staleness-counter)
  86         my $location_size = $e->byte_size + $e->byte_size + ($e->num_txns - 1) * ($e->byte_size + $DBM::Deep::Engine::STALE_SIZE);
  87         $self->{bucket_size} = $e->hash_size + $location_size;
  88     }
  89     return $self->{bucket_size};
  90 }
  91
  92 # XXX This is such a poor hack. I need to rethink this code.
  93 sub chopped_up {
  94     my $self = shift;
  95
  96     my $e = $self->engine;
  97
  98     my @buckets;
  99     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
 100         my $spot = $self->base_size + $idx * $self->bucket_size;
 101         my $data = $self->read( $spot, $self->bucket_size );
 102
 103         # _dump_file() will run into the blank_md5. Otherwise, we should never run into it.
 104         # -RobK, 2008-06-18
 105         last if substr( $data, 0, $e->hash_size ) eq $e->blank_md5;
 106
 107         push @buckets, [ $spot, $data ];
 108     }
 109
 110     return @buckets;
 111 }
 112
 113 sub write_at_next_open {
 114     my $self = shift;
 115     my ($entry) = @_;
 116
 117     #XXX This is such a hack!
 118     $self->{_next_open} = 0 unless exists $self->{_next_open};
 119
 120     my $spot = $self->base_size + $self->{_next_open}++ * $self->bucket_size;
 121     $self->write( $spot, $entry );
 122
 123     return $spot;
 124 }
 125
 126 sub has_md5 {
 127     my $self = shift;
 128     unless ( exists $self->{found} ) {
 129         $self->find_md5;
 130     }
 131     return $self->{found};
 132 }
 133
 134 sub find_md5 {
 135     my $self = shift;
 136
 137     $self->{found} = undef;
 138     $self->{idx}   = -1;
 139
 140     if ( @_ ) {
 141         $self->{key_md5} = shift;
 142     }
 143
 144     # If we don't have an MD5, then what are we supposed to do?
 145     unless ( exists $self->{key_md5} ) {
 146         DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" );
 147     }
 148
 149     my $e = $self->engine;
 150     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
 151         my $potential = $self->read(
 152             $self->base_size + $idx * $self->bucket_size, $e->hash_size,
 153         );
 154
 155         if ( $potential eq $e->blank_md5 ) {
 156             $self->{idx} = $idx;
 157             return;
 158         }
 159
 160         if ( $potential eq $self->{key_md5} ) {
 161             $self->{found} = 1;
 162             $self->{idx} = $idx;
 163             return;
 164         }
 165     }
 166
 167     return;
 168 }
 169
 170 sub write_md5 {
 171     my $self = shift;
 172     my ($args) = @_;
 173
 174     DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key};
 175     DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5};
 176     DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value};
 177
 178     my $e = $self->engine;
 179
 180     $args->{trans_id} = $e->trans_id unless exists $args->{trans_id};
 181
 182     my $spot = $self->base_size + $self->{idx} * $self->bucket_size;
 183     $e->add_entry( $args->{trans_id}, $self->offset + $spot );
 184
 185     unless ($self->{found}) {
 186         my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({
 187             engine => $e,
 188             data   => $args->{key},
 189         });
 190
 191         $self->write( $spot, $args->{key_md5} . pack( $e->StP($e->byte_size), $key_sector->offset ) );
 192     }
 193
 194     my $loc = $spot + $e->hash_size + $e->byte_size;
 195
 196     if ( $args->{trans_id} ) {
 197         $loc += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 198
 199         $self->write( $loc,
 200             pack( $e->StP($e->byte_size), $args->{value}->offset )
 201           . pack( $e->StP($DBM::Deep::Engine::STALE_SIZE), $e->get_txn_staleness_counter( $args->{trans_id} ) ),
 202         );
 203     }
 204     else {
 205         $self->write( $loc, pack( $e->StP($e->byte_size), $args->{value}->offset ) );
 206     }
 207 }
 208
 209 sub mark_deleted {
 210     my $self = shift;
 211     my ($args) = @_;
 212     $args ||= {};
 213
 214     my $e = $self->engine;
 215
 216     $args->{trans_id} = $e->trans_id unless exists $args->{trans_id};
 217
 218     my $spot = $self->base_size + $self->{idx} * $self->bucket_size;
 219     $e->add_entry( $args->{trans_id}, $self->offset + $spot );
 220
 221     my $loc = $spot
 222       + $e->hash_size
 223       + $e->byte_size;
 224
 225     if ( $args->{trans_id} ) {
 226         $loc += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 227
 228         $self->write( $loc,
 229             pack( $e->StP($e->byte_size), 1 ) # 1 is the marker for deleted
 230           . pack( $e->StP($DBM::Deep::Engine::STALE_SIZE), $e->get_txn_staleness_counter( $args->{trans_id} ) ),
 231         );
 232     }
 233     else {
 234         # 1 is the marker for deleted
 235         $self->write( $loc, pack( $e->StP($e->byte_size), 1 ) );
 236     }
 237 }
 238
 239 sub delete_md5 {
 240     my $self = shift;
 241     my ($args) = @_;
 242
 243     my $engine = $self->engine;
 244     return undef unless $self->{found};
 245
 246     # Save the location so that we can free the data
 247     my $location = $self->get_data_location_for({
 248         allow_head => 0,
 249     });
 250     my $key_sector = $self->get_key_for;
 251
 252     my $spot = $self->base_size + $self->{idx} * $self->bucket_size;
 253
 254     # Shuffle everything down to cover the deleted bucket's spot.
 255     $self->write( $spot,
 256         $self->read(
 257             $spot + $self->bucket_size,
 258             $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ),
 259         )
 260       . chr(0) x $self->bucket_size,
 261     );
 262
 263     $key_sector->free;
 264
 265     my $data_sector = $self->engine->_load_sector( $location );
 266     my $data = $data_sector->data({ export => 1 });
 267     $data_sector->free;
 268
 269     return $data;
 270 }
 271
 272 sub get_data_location_for {
 273     my $self = shift;
 274     my ($args) = @_;
 275     $args ||= {};
 276
 277     $args->{allow_head} = 0 unless exists $args->{allow_head};
 278     $args->{trans_id}   = $self->engine->trans_id unless exists $args->{trans_id};
 279     $args->{idx}        = $self->{idx} unless exists $args->{idx};
 280
 281     my $e = $self->engine;
 282
 283     my $spot = $self->base_size
 284       + $args->{idx} * $self->bucket_size
 285       + $e->hash_size
 286       + $e->byte_size;
 287
 288     if ( $args->{trans_id} ) {
 289         $spot += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 290     }
 291
 292     my $buffer = $self->read( $spot, $e->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 293     my ($loc, $staleness) = unpack(
 294         $e->StP($e->byte_size) . ' ' . $e->StP($DBM::Deep::Engine::STALE_SIZE),
 295         $buffer,
 296     );
 297
 298     # XXX Merge the two if-clauses below
 299     if ( $args->{trans_id} ) {
 300         # We have found an entry that is old, so get rid of it
 301         if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) {
 302             $e->storage->print_at(
 303                 $spot,
 304                 pack( $e->StP($e->byte_size) . ' ' . $e->StP($DBM::Deep::Engine::STALE_SIZE), (0) x 2 ),
 305             );
 306             $loc = 0;
 307         }
 308     }
 309
 310     # If we're in a transaction and we never wrote to this location, try the
 311     # HEAD instead.
 312     if ( $args->{trans_id} && !$loc && $args->{allow_head} ) {
 313         return $self->get_data_location_for({
 314             trans_id   => 0,
 315             allow_head => 1,
 316             idx        => $args->{idx},
 317         });
 318     }
 319
 320     return $loc <= 1 ? 0 : $loc;
 321 }
 322
 323 sub get_data_for {
 324     my $self = shift;
 325     my ($args) = @_;
 326     $args ||= {};
 327
 328     return unless $self->{found};
 329     my $location = $self->get_data_location_for({
 330         allow_head => $args->{allow_head},
 331     });
 332     return $self->engine->_load_sector( $location );
 333 }
 334
 335 sub get_key_for {
 336     my $self = shift;
 337     my ($idx) = @_;
 338     $idx = $self->{idx} unless defined $idx;
 339
 340     if ( $idx >= $self->engine->max_buckets ) {
 341         DBM::Deep->_throw_error( "get_key_for(): Attempting to retrieve $idx" );
 342     }
 343
 344     my $location = $self->read(
 345         $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size,
 346         $self->engine->byte_size,
 347     );
 348     $location = unpack( $self->engine->StP($self->engine->byte_size), $location );
 349     DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location;
 350
 351     return $self->engine->_load_sector( $location );
 352 }
 353
 354 1;
 355 __END__