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

   1 #TODO: Convert this to a string
   2 package DBM::Deep::Engine::Sector::BucketList;
   3
   4 use 5.006_000;
   5
   6 use strict;
   7 use warnings FATAL => 'all';
   8
   9 use DBM::Deep::Engine::Sector;
  10 our @ISA = qw( DBM::Deep::Engine::Sector );
  11
  12 sub _init {
  13     my $self = shift;
  14
  15     my $engine = $self->engine;
  16
  17     unless ( $self->offset ) {
  18         my $leftover = $self->size - $self->base_size;
  19
  20         $self->{offset} = $engine->_request_blist_sector( $self->size );
  21         $engine->storage->print_at( $self->offset, $engine->SIG_BLIST ); # Sector type
  22         # Skip staleness counter
  23         $engine->storage->print_at( $self->offset + $self->base_size,
  24             chr(0) x $leftover, # Zero-fill the data
  25         );
  26     }
  27
  28     if ( $self->{key_md5} ) {
  29         $self->find_md5;
  30     }
  31
  32     return $self;
  33 }
  34
  35 sub clear {
  36     my $self = shift;
  37     $self->engine->storage->print_at( $self->offset + $self->base_size,
  38         chr(0) x ($self->size - $self->base_size), # Zero-fill the data
  39     );
  40 }
  41
  42 sub size {
  43     my $self = shift;
  44     unless ( $self->{size} ) {
  45         my $e = $self->engine;
  46         # Base + numbuckets * bucketsize
  47         $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size;
  48     }
  49     return $self->{size};
  50 }
  51
  52 sub free_meth { return '_add_free_blist_sector' }
  53
  54 sub free {
  55     my $self = shift;
  56
  57     my $e = $self->engine;
  58     foreach my $bucket ( $self->chopped_up ) {
  59         my $rest = $bucket->[-1];
  60
  61         # Delete the keysector
  62         my $l = unpack( $e->StP($e->byte_size), substr( $rest, $e->hash_size, $e->byte_size ) );
  63         my $s = $e->_load_sector( $l ); $s->free if $s;
  64
  65         # Delete the HEAD sector
  66         $l = unpack( $e->StP($e->byte_size),
  67             substr( $rest,
  68                 $e->hash_size + $e->byte_size,
  69                 $e->byte_size,
  70             ),
  71         );
  72         $s = $e->_load_sector( $l ); $s->free if $s;
  73
  74         foreach my $txn ( 0 .. $e->num_txns - 2 ) {
  75             my $l = unpack( $e->StP($e->byte_size),
  76                 substr( $rest,
  77                     $e->hash_size + 2 * $e->byte_size + $txn * ($e->byte_size + $DBM::Deep::Engine::STALE_SIZE),
  78                     $e->byte_size,
  79                 ),
  80             );
  81             my $s = $e->_load_sector( $l ); $s->free if $s;
  82         }
  83     }
  84
  85     $self->SUPER::free();
  86 }
  87
  88 sub bucket_size {
  89     my $self = shift;
  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
  99 # XXX This is such a poor hack. I need to rethink this code.
 100 sub chopped_up {
 101     my $self = shift;
 102
 103     my $e = $self->engine;
 104
 105     my @buckets;
 106     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
 107         my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size;
 108         my $md5 = $e->storage->read_at( $spot, $e->hash_size );
 109
 110         #XXX If we're chopping, why would we ever have the blank_md5?
 111         last if $md5 eq $e->blank_md5;
 112
 113         my $rest = $e->storage->read_at( undef, $self->bucket_size - $e->hash_size );
 114         push @buckets, [ $spot, $md5 . $rest ];
 115     }
 116
 117     return @buckets;
 118 }
 119
 120 sub write_at_next_open {
 121     my $self = shift;
 122     my ($entry) = @_;
 123
 124     #XXX This is such a hack!
 125     $self->{_next_open} = 0 unless exists $self->{_next_open};
 126
 127     my $spot = $self->offset + $self->base_size + $self->{_next_open}++ * $self->bucket_size;
 128     $self->engine->storage->print_at( $spot, $entry );
 129
 130     return $spot;
 131 }
 132
 133 sub has_md5 {
 134     my $self = shift;
 135     unless ( exists $self->{found} ) {
 136         $self->find_md5;
 137     }
 138     return $self->{found};
 139 }
 140
 141 sub find_md5 {
 142     my $self = shift;
 143
 144     $self->{found} = undef;
 145     $self->{idx}   = -1;
 146
 147     if ( @_ ) {
 148         $self->{key_md5} = shift;
 149     }
 150
 151     # If we don't have an MD5, then what are we supposed to do?
 152     unless ( exists $self->{key_md5} ) {
 153         DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" );
 154     }
 155
 156     my $e = $self->engine;
 157     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
 158         my $potential = $e->storage->read_at(
 159             $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size,
 160         );
 161
 162         if ( $potential eq $e->blank_md5 ) {
 163             $self->{idx} = $idx;
 164             return;
 165         }
 166
 167         if ( $potential eq $self->{key_md5} ) {
 168             $self->{found} = 1;
 169             $self->{idx} = $idx;
 170             return;
 171         }
 172     }
 173
 174     return;
 175 }
 176
 177 sub write_md5 {
 178     my $self = shift;
 179     my ($args) = @_;
 180
 181     DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key};
 182     DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5};
 183     DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value};
 184
 185     my $engine = $self->engine;
 186
 187     $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id};
 188
 189     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
 190     $engine->add_entry( $args->{trans_id}, $spot );
 191
 192     unless ($self->{found}) {
 193         my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({
 194             engine => $engine,
 195             data   => $args->{key},
 196         });
 197
 198         $engine->storage->print_at( $spot,
 199             $args->{key_md5},
 200             pack( $engine->StP($engine->byte_size), $key_sector->offset ),
 201         );
 202     }
 203
 204     my $loc = $spot
 205       + $engine->hash_size
 206       + $engine->byte_size;
 207
 208     if ( $args->{trans_id} ) {
 209         $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 210
 211         $engine->storage->print_at( $loc,
 212             pack( $engine->StP($engine->byte_size), $args->{value}->offset ),
 213             pack( $engine->StP($DBM::Deep::Engine::STALE_SIZE), $engine->get_txn_staleness_counter( $args->{trans_id} ) ),
 214         );
 215     }
 216     else {
 217         $engine->storage->print_at( $loc,
 218             pack( $engine->StP($engine->byte_size), $args->{value}->offset ),
 219         );
 220     }
 221 }
 222
 223 sub mark_deleted {
 224     my $self = shift;
 225     my ($args) = @_;
 226     $args ||= {};
 227
 228     my $engine = $self->engine;
 229
 230     $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id};
 231
 232     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
 233     $engine->add_entry( $args->{trans_id}, $spot );
 234
 235     my $loc = $spot
 236       + $engine->hash_size
 237       + $engine->byte_size;
 238
 239     if ( $args->{trans_id} ) {
 240         $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $DBM::Deep::Engine::STALE_SIZE );
 241
 242         $engine->storage->print_at( $loc,
 243             pack( $engine->StP($engine->byte_size), 1 ), # 1 is the marker for deleted
 244             pack( $engine->StP($DBM::Deep::Engine::STALE_SIZE), $engine->get_txn_staleness_counter( $args->{trans_id} ) ),
 245         );
 246     }
 247     else {
 248         $engine->storage->print_at( $loc,
 249             pack( $engine->StP($engine->byte_size), 1 ), # 1 is the marker for deleted
 250         );
 251     }
 252
 253 }
 254
 255 sub delete_md5 {
 256     my $self = shift;
 257     my ($args) = @_;
 258
 259     my $engine = $self->engine;
 260     return undef unless $self->{found};
 261
 262     # Save the location so that we can free the data
 263     my $location = $self->get_data_location_for({
 264         allow_head => 0,
 265     });
 266     my $key_sector = $self->get_key_for;
 267
 268     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
 269     $engine->storage->print_at( $spot,
 270         $engine->storage->read_at(
 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->offset + $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 = $e->storage->read_at(
 307         $spot,
 308         $e->byte_size + $DBM::Deep::Engine::STALE_SIZE,
 309     );
 310     my ($loc, $staleness) = unpack( $e->StP($e->byte_size) . ' ' . $e->StP($DBM::Deep::Engine::STALE_SIZE), $buffer );
 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" );
 356     }
 357
 358     my $location = $self->engine->storage->read_at(
 359         $self->offset + $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 1;
 369 __END__