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