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