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