lib/DBM/Deep/Engine2.pm

   1 package DBM::Deep::Engine2;
   2
   3 use base 'DBM::Deep::Engine';
   4
   5 use 5.6.0;
   6
   7 use strict;
   8 use warnings;
   9
  10 our $VERSION = q(0.99_03);
  11
  12 use Fcntl qw( :DEFAULT :flock );
  13 use Scalar::Util ();
  14
  15 # File-wide notes:
  16 # * Every method in here assumes that the _storage has been appropriately
  17 #   safeguarded. This can be anything from flock() to some sort of manual
  18 #   mutex. But, it's the caller's responsability to make sure that this has
  19 #   been done.
  20
  21 # Setup file and tag signatures.  These should never change.
  22 sub SIG_FILE     () { 'DPDB' }
  23 sub SIG_HEADER   () { 'h'    }
  24 sub SIG_INTERNAL () { 'i'    }
  25 sub SIG_HASH     () { 'H'    }
  26 sub SIG_ARRAY    () { 'A'    }
  27 sub SIG_NULL     () { 'N'    }
  28 sub SIG_DATA     () { 'D'    }
  29 sub SIG_INDEX    () { 'I'    }
  30 sub SIG_BLIST    () { 'B'    }
  31 sub SIG_FREE     () { 'F'    }
  32 sub SIG_KEYS     () { 'K'    }
  33 sub SIG_SIZE     () {  1     }
  34
  35 # This is the transaction ID for the HEAD
  36 sub HEAD () { 0 }
  37
  38 sub read_value {
  39     my $self = shift;
  40     my ($trans_id, $base_offset, $key) = @_;
  41
  42     my ($_val_offset, $_is_del) = $self->_find_value_offset({
  43         offset     => $base_offset,
  44         trans_id   => $trans_id,
  45         allow_head => 1,
  46     });
  47     die "Attempt to use a deleted value" if $_is_del;
  48     die "Internal error!" if !$_val_offset;
  49
  50     my ($key_offset) = $self->_find_key_offset({
  51         offset  => $_val_offset,
  52         key_md5 => $self->_apply_digest( $key ),
  53     });
  54     return if !$key_offset;
  55
  56     my ($val_offset, $is_del) = $self->_find_value_offset({
  57         offset     => $key_offset,
  58         trans_id   => $trans_id,
  59         allow_head => 1,
  60     });
  61     return if $is_del;
  62     die "Internal error!" if !$val_offset;
  63
  64     return $self->_read_value({
  65         offset => $val_offset,
  66     });
  67 }
  68
  69 sub key_exists {
  70     my $self = shift;
  71     my ($trans_id, $base_offset, $key) = @_;
  72
  73     my ($_val_offset, $_is_del) = $self->_find_value_offset({
  74         offset     => $base_offset,
  75         trans_id   => $trans_id,
  76         allow_head => 1,
  77     });
  78     die "Attempt to use a deleted value" if $_is_del;
  79     die "Internal error!" if !$_val_offset;
  80
  81     my ($key_offset) = $self->_find_key_offset({
  82         offset  => $_val_offset,
  83         key_md5 => $self->_apply_digest( $key ),
  84     });
  85     return if !$key_offset;
  86
  87     my ($val_offset, $is_del) = $self->_find_value_offset({
  88         offset     => $key_offset,
  89         trans_id   => $trans_id,
  90         allow_head => 1,
  91     });
  92
  93     return 1 if $is_del;
  94
  95     die "Internal error!" if !$_val_offset;
  96     return '';
  97 }
  98
  99 sub get_next_key {
 100     my $self = shift;
 101     my ($offset) = @_;
 102
 103     # If the previous key was not specifed, start at the top and
 104     # return the first one found.
 105     my $temp;
 106     if ( @_ > 1 ) {
 107         $temp = {
 108             prev_md5    => $self->apply_digest($_[1]),
 109             return_next => 0,
 110         };
 111     }
 112     else {
 113         $temp = {
 114             prev_md5    => chr(0) x $self->{hash_size},
 115             return_next => 1,
 116         };
 117     }
 118
 119     return $self->traverse_index( $temp, $offset, 0 );
 120 }
 121
 122 sub delete_key {
 123     my $self = shift;
 124     my ($trans_id, $base_offset, $key) = @_;
 125
 126     my ($_val_offset, $_is_del) = $self->_find_value_offset({
 127         offset     => $base_offset,
 128         trans_id   => $trans_id,
 129         allow_head => 1,
 130     });
 131     die "Attempt to use a deleted value" if $_is_del;
 132     die "Internal error!" if !$_val_offset;
 133
 134     my ($key_offset, $bucket_tag) = $self->_find_key_offset({
 135         offset  => $_val_offset,
 136         key_md5 => $self->_apply_digest( $key ),
 137     });
 138     return if !$key_offset;
 139
 140     my $key_tag = $self->load_tag( $key_offset );
 141
 142     if ( $trans_id ) {
 143         $self->_mark_as_deleted({
 144             tag      => $key_tag,
 145             trans_id => $trans_id,
 146         });
 147     }
 148     else {
 149         my $value = $self->read_value( $trans_id, $base_offset, $key );
 150         if ( my @transactions = $self->_storage->current_transactions ) {
 151             foreach my $other_trans_id ( @transactions ) {
 152                 next if $self->_has_keyloc_entry({
 153                     tag      => $key_tag,
 154                     trans_id => $other_trans_id,
 155                 });
 156                 $self->write_value( $other_trans_id, $base_offset, $key, $value );
 157             }
 158         }
 159         else {
 160             $self->_remove_key_offset({
 161                 offset  => $_val_offset,
 162                 key_md5 => $self->_apply_digest( $key ),
 163             });
 164         }
 165     }
 166
 167     return 1;
 168 }
 169
 170 sub write_value {
 171     my $self = shift;
 172     my ($trans_id, $base_offset, $key, $value) = @_;
 173
 174     # This verifies that only supported values will be stored.
 175     {
 176         my $r = Scalar::Util::reftype( $value );
 177
 178         last if !defined $r;
 179         last if $r eq 'HASH';
 180         last if $r eq 'ARRAY';
 181
 182         $self->_throw_error(
 183             "Storage of references of type '$r' is not supported."
 184         );
 185     }
 186
 187     my ($_val_offset, $_is_del) = $self->_find_value_offset({
 188         offset     => $base_offset,
 189         trans_id   => $trans_id,
 190         allow_head => 1,
 191     });
 192     die "Attempt to use a deleted value" if $_is_del;
 193     die "Internal error!" if !$_val_offset;
 194
 195     my ($key_offset, $bucket_tag) = $self->_find_key_offset({
 196         offset  => $_val_offset,
 197         key_md5 => $self->_apply_digest( $key ),
 198         create  => 1,
 199     });
 200     die "Cannot find/create new key offset!" if !$key_offset;
 201
 202     my $key_tag = $self->load_tag( $key_offset );
 203
 204     if ( $trans_id ) {
 205         if ( $bucket_tag->{is_new} ) {
 206             # Must mark the HEAD as deleted because it doesn't exist
 207             $self->_mark_as_deleted({
 208                 tag      => $key_tag,
 209                 trans_id => HEAD,
 210             });
 211         }
 212     }
 213     else {
 214         # If the HEAD isn't new, then we must take other transactions
 215         # into account. If it is, then there can be no other transactions.
 216         if ( !$bucket_tag->{is_new} ) {
 217             my $old_value = $self->read_value( $trans_id, $base_offset, $key );
 218             if ( my @transactions = $self->_storage->current_transactions ) {
 219                 foreach my $other_trans_id ( @transactions ) {
 220                     next if $self->_has_keyloc_entry({
 221                         tag      => $key_tag,
 222                         trans_id => $other_trans_id,
 223                     });
 224                     $self->write_value( $other_trans_id, $base_offset, $key, $old_value );
 225                 }
 226             }
 227         }
 228     }
 229
 230     my $value_loc = $self->_storage->request_space(
 231         $self->_length_needed( $value, $key ),
 232     );
 233
 234     $self->_add_key_offset({
 235         tag      => $key_tag,
 236         trans_id => $trans_id,
 237         loc      => $value_loc,
 238     });
 239
 240     $self->_write_value( $value_loc, $key, $value, $key );
 241
 242     return 1;
 243 }
 244
 245 sub _find_value_offset {
 246     my $self = shift;
 247     my ($args) = @_;
 248
 249     use Data::Dumper;warn Dumper $args;
 250
 251     my $key_tag = $self->load_tag( $args->{offset} );
 252
 253     my @head;
 254     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 255         my ($loc, $trans_id, $is_deleted) = unpack(
 256             "$self->{long_pack} C C",
 257             substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
 258         );
 259
 260         if ( $trans_id == HEAD ) {
 261             @head = ($loc, $is_deleted);
 262         }
 263
 264         next if $loc && $args->{trans_id} != $trans_id;
 265         return( $loc, $is_deleted );
 266     }
 267
 268     return @head if $args->{allow_head};
 269     return;
 270 }
 271
 272 #XXX Need to keep track of $bucket_tag->(ref_loc} and $bucket_tag->{ch}
 273 sub _find_key_offset {
 274     my $self = shift;
 275     my ($args) = @_;
 276
 277     my $bucket_tag = $self->load_tag( $args->{offset} )
 278         or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
 279
 280     #XXX What happens when $ch >= $self->{hash_size} ??
 281     for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
 282         my $num = ord substr($args->{key_md5}, $ch, 1);
 283
 284         my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
 285         $bucket_tag = $self->index_lookup( $bucket_tag, $num );
 286
 287         if (!$bucket_tag) {
 288             return if !$args->{create};
 289
 290             my $loc = $self->_storage->request_space(
 291                 $self->tag_size( $self->{bucket_list_size} ),
 292             );
 293
 294             $self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
 295
 296             $bucket_tag = $self->write_tag(
 297                 $loc, SIG_BLIST,
 298                 chr(0)x$self->{bucket_list_size},
 299             );
 300
 301             $bucket_tag->{ref_loc} = $ref_loc;
 302             $bucket_tag->{ch} = $ch;
 303             $bucket_tag->{is_new} = 1;
 304
 305             last;
 306         }
 307
 308         $bucket_tag->{ch} = $ch;
 309         $bucket_tag->{ref_loc} = $ref_loc;
 310     }
 311
 312     # Need to create a new keytag, too
 313     if ( $bucket_tag->{is_new} ) {
 314         my $keytag_loc = $self->_storage->request_space(
 315             $self->tag_size( $self->{keyloc_size} ),
 316         );
 317
 318         substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
 319             $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
 320
 321         $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
 322
 323         $self->write_tag(
 324             $keytag_loc, SIG_KEYS,
 325             chr(0)x$self->{keyloc_size},
 326         );
 327
 328         return( $keytag_loc, $bucket_tag );
 329     }
 330     else {
 331         my ($key, $subloc, $index);
 332         BUCKET:
 333         for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 334             ($key, $subloc) = $self->_get_key_subloc(
 335                 $bucket_tag->{content}, $i,
 336             );
 337
 338             next BUCKET if $subloc && $key ne $args->{key_md5};
 339
 340             # Keep track of where we are, in case we need to create a new
 341             # entry.
 342             $index = $i;
 343             last;
 344         }
 345
 346         # Either we have a subloc to return or we don't want to create a new
 347         # entry. Either way, we need to return now.
 348         return ($subloc, $bucket_tag) if $subloc || !$args->{create};
 349
 350         my $keytag_loc = $self->_storage->request_space(
 351             $self->tag_size( $self->{keyloc_size} ),
 352         );
 353
 354         # There's space left in this bucket
 355         if ( defined $index ) {
 356             substr( $bucket_tag->{content}, $index * $self->{key_size}, $self->{key_size} ) =
 357                 $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
 358
 359             $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
 360         }
 361         # We need to split the index
 362         else {
 363             $self->split_index( $bucket_tag, $args->{key_md5}, $keytag_loc );
 364         }
 365
 366         $self->write_tag(
 367             $keytag_loc, SIG_KEYS,
 368             chr(0)x$self->{keyloc_size},
 369         );
 370
 371         return( $keytag_loc, $bucket_tag );
 372     }
 373
 374     return;
 375 }
 376
 377 sub _read_value {
 378     my $self = shift;
 379     my ($args) = @_;
 380
 381     return $self->read_from_loc( $args->{offset} );
 382 }
 383
 384 sub _mark_as_deleted {
 385     my $self = shift;
 386     my ($args) = @_;
 387
 388     my $is_changed;
 389     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 390         my ($loc, $trans_id, $is_deleted) = unpack(
 391             "$self->{long_pack} C C",
 392             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
 393         );
 394
 395
 396         if ( $trans_id == $args->{trans_id} ) {
 397             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
 398                 "$self->{long_pack} C C",
 399                 $loc, $trans_id, 1,
 400             );
 401         }
 402     }
 403
 404     if ( $is_changed ) {
 405         $self->_storage->print_at(
 406             $args->{tag}{offset}, $args->{tag}{content},
 407         );
 408     }
 409
 410     return 1;
 411 }
 412
 413 sub _has_keyloc_entry {
 414     my $self = shift;
 415     my ($args) = @_;
 416
 417     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 418         my ($loc, $trans_id, $is_deleted) = unpack(
 419             "$self->{long_pack} C C",
 420             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
 421         );
 422
 423         return 1 if $trans_id == $args->{trans_id};
 424     }
 425
 426     return;
 427 }
 428
 429 sub _remove_key_offset {
 430     my $self = shift;
 431     my ($args) = @_;
 432
 433     my $is_changed;
 434     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 435         my ($loc, $trans_id, $is_deleted) = unpack(
 436             "$self->{long_pack} C C",
 437             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
 438         );
 439
 440         if ( $trans_id == $args->{trans_id} ) {
 441             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = '';
 442             $args->{tag}{content} .= chr(0) x $self->{key_size};
 443             $is_changed = 1;
 444             redo;
 445         }
 446     }
 447
 448     if ( $is_changed ) {
 449         $self->_storage->print_at(
 450             $args->{tag}{offset}, $args->{tag}{content},
 451         );
 452     }
 453
 454     return 1;
 455 }
 456
 457 sub _add_key_offset {
 458     my $self = shift;
 459     my ($args) = @_;
 460
 461     my $is_changed;
 462     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 463         my ($loc, $trans_id, $is_deleted) = unpack(
 464             "$self->{long_pack} C C",
 465             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
 466         );
 467
 468         if ( $trans_id == $args->{trans_id} || (!$loc && !$is_deleted) ) {
 469             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
 470                 "$self->{long_pack} C C",
 471                 $args->{loc}, $args->{trans_id}, 0,
 472             );
 473             $is_changed = 1;
 474             last;
 475         }
 476     }
 477
 478     if ( $is_changed ) {
 479         $self->_storage->print_at(
 480             $args->{tag}{offset}, $args->{tag}{content},
 481         );
 482     }
 483     else {
 484         die "Why didn't _add_key_offset() change something?!\n";
 485     }
 486
 487     return 1;
 488 }
 489
 490 sub setup_fh {
 491     my $self = shift;
 492     my ($obj) = @_;
 493
 494     # Need to remove use of $fh here
 495     my $fh = $self->_storage->{fh};
 496     flock $fh, LOCK_EX;
 497
 498     #XXX The duplication of calculate_sizes needs to go away
 499     unless ( $obj->{base_offset} ) {
 500         my $bytes_read = $self->read_file_header;
 501
 502         $self->calculate_sizes;
 503
 504         ##
 505         # File is empty -- write header and master index
 506         ##
 507         if (!$bytes_read) {
 508             $self->_storage->audit( "# Database created on" );
 509
 510             $self->write_file_header;
 511
 512             $obj->{base_offset} = $self->_storage->request_space(
 513                 $self->tag_size( $self->{keyloc_size} ),
 514             );
 515
 516             my $value_spot = $self->_storage->request_space(
 517                 $self->tag_size( $self->{index_size} ),
 518             );
 519
 520             $self->write_tag(
 521                 $obj->{base_offset}, SIG_KEYS,
 522                 pack( "$self->{long_pack} C C", $obj->{base_offset}, 0, 0 ),
 523                 chr(0) x ($self->{index_size} - $self->{long_size} + 2),
 524             );
 525
 526             $self->write_tag(
 527                 $value_spot, $obj->_type,
 528                 chr(0)x$self->{index_size},
 529             );
 530
 531             # Flush the filehandle
 532             my $old_fh = select $fh;
 533             my $old_af = $|; $| = 1; $| = $old_af;
 534             select $old_fh;
 535         }
 536         else {
 537             $obj->{base_offset} = $bytes_read;
 538
 539             ##
 540             # Get our type from master index header
 541             ##
 542             my $tag = $self->load_tag($obj->_base_offset);
 543             unless ( $tag ) {
 544                 flock $fh, LOCK_UN;
 545                 $self->_throw_error("Corrupted file, no master index record");
 546             }
 547
 548             unless ($obj->_type eq $tag->{signature}) {
 549                 flock $fh, LOCK_UN;
 550                 $self->_throw_error("File type mismatch");
 551             }
 552         }
 553     }
 554     else {
 555         $self->calculate_sizes;
 556     }
 557
 558     #XXX We have to make sure we don't mess up when autoflush isn't turned on
 559     $self->_storage->set_inode;
 560
 561     flock $fh, LOCK_UN;
 562
 563     return 1;
 564 }
 565
 566 1;
 567 __END__