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