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