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

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