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     #XXX Write this
 231     $self->_write_value({
 232         tag    => $key_tag,
 233         value  => $value,
 234     });
 235
 236     return 1;
 237 }
 238
 239 sub _find_value_offset {
 240     my $self = shift;
 241     my ($args) = @_;
 242
 243     my $key_tag = $self->load_tag( $args->{offset} );
 244
 245     my @head;
 246     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 247         my ($loc, $trans_id, $is_deleted) = unpack(
 248             "$self->{long_pack} C C",
 249             substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
 250         );
 251
 252         if ( $trans_id == HEAD ) {
 253             @head = ($loc, $is_deleted);
 254         }
 255
 256         next if $loc && $args->{trans_id} != $trans_id;
 257         return( $loc, $is_deleted );
 258     }
 259
 260     return @head if $args->{allow_head};
 261     return;
 262 }
 263
 264 #XXX Need to keep track of $bucket_tag->(ref_loc} and $bucket_tag->{ch}
 265 sub _find_key_offset {
 266     my $self = shift;
 267     my ($args) = @_;
 268
 269     my $bucket_tag = $self->load_tag( $args->{offset} )
 270         or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
 271
 272     # $bucket_tag->{ref_loc} and $bucket_tag->{ch} are used in split_index()
 273
 274     #XXX What happens when $ch >= $self->{hash_size} ??
 275     for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
 276         my $num = ord substr($args->{key_md5}, $ch, 1);
 277
 278         my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
 279         $bucket_tag = $self->index_lookup( $bucket_tag, $num );
 280
 281         if (!$bucket_tag) {
 282             return if !$args->{create};
 283
 284             my $loc = $self->_storage->request_space(
 285                 $self->tag_size( $self->{bucket_list_size} ),
 286             );
 287
 288             $self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
 289
 290             $bucket_tag = $self->write_tag(
 291                 $loc, SIG_BLIST,
 292                 chr(0)x$self->{bucket_list_size},
 293             );
 294
 295             $bucket_tag->{ref_loc} = $ref_loc;
 296             $bucket_tag->{ch} = $ch;
 297             $bucket_tag->{is_new} = 1;
 298
 299             last;
 300         }
 301
 302         $bucket_tag->{ch} = $ch;
 303         $bucket_tag->{ref_loc} = $ref_loc;
 304     }
 305
 306     # Need to create a new keytag, too
 307     if ( $bucket_tag->{is_new} ) {
 308         my $keytag_loc = $self->_storage->request_space(
 309             $self->tag_size( $self->{keyloc_size} ),
 310         );
 311
 312         substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
 313             $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
 314
 315         $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
 316
 317         $self->write_tag(
 318             $keytag_loc, SIG_KEYS,
 319             chr(0)x$self->{keyloc_size},
 320         );
 321
 322         return( $keytag_loc, $bucket_tag );
 323     }
 324     else {
 325         BUCKET:
 326         for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 327             my ($key, $subloc) = $self->_get_key_subloc(
 328                 $bucket_tag->{content}, $i,
 329             );
 330
 331             next BUCKET if $subloc && $key ne $args->{key_md5};
 332             #XXX Right here, I need to create a new value, if I can
 333             return( $subloc, $bucket_tag );
 334         }
 335         # Right here, it looks like split_index needs to happen
 336         # What happens here?
 337     }
 338
 339     return;
 340 }
 341
 342 sub _read_value {
 343     my $self = shift;
 344     my ($args) = @_;
 345
 346     return $self->read_from_loc( $args->{offset} );
 347 }
 348
 349 sub _mark_as_deleted {
 350     my $self = shift;
 351     my ($args) = @_;
 352
 353     my $is_changed;
 354     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 355         my ($loc, $trans_id, $is_deleted) = unpack(
 356             "$self->{long_pack} C C",
 357             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
 358         );
 359
 360
 361         if ( $trans_id == $args->{trans_id} ) {
 362             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
 363                 "$self->{long_pack} C C",
 364                 $loc, $trans_id, 1,
 365             )
 366         }
 367     }
 368
 369     if ( $is_changed ) {
 370         $self->_storage->print_at(
 371             $args->{tag}{offset}, $args->{tag}{content},
 372         );
 373     }
 374
 375     return 1;
 376 }
 377
 378 sub _has_keyloc_entry {
 379     my $self = shift;
 380     my ($args) = @_;
 381
 382     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 383         my ($loc, $trans_id, $is_deleted) = unpack(
 384             "$self->{long_pack} C C",
 385             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
 386         );
 387
 388         return 1 if $trans_id == $args->{trans_id};
 389     }
 390
 391     return;
 392 }
 393
 394 sub _remove_key_offset {
 395     my $self = shift;
 396     my ($args) = @_;
 397
 398     my $is_changed;
 399     for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
 400         my ($loc, $trans_id, $is_deleted) = unpack(
 401             "$self->{long_pack} C C",
 402             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
 403         );
 404
 405         if ( $trans_id == $args->{trans_id} ) {
 406             substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = '';
 407             $args->{tag}{content} .= chr(0) x $self->{key_size};
 408             $is_changed = 1;
 409             redo;
 410         }
 411     }
 412
 413     if ( $is_changed ) {
 414         $self->_storage->print_at(
 415             $args->{tag}{offset}, $args->{tag}{content},
 416         );
 417     }
 418
 419     return 1;
 420 }
 421
 422 sub _write_value {
 423     my $self = shift;
 424     my ($args) = @_;
 425
 426
 427 }
 428
 429 sub setup_fh {
 430     my $self = shift;
 431     my ($obj) = @_;
 432
 433     # Need to remove use of $fh here
 434     my $fh = $self->_storage->{fh};
 435     flock $fh, LOCK_EX;
 436
 437     #XXX The duplication of calculate_sizes needs to go away
 438     unless ( $obj->{base_offset} ) {
 439         my $bytes_read = $self->read_file_header;
 440
 441         $self->calculate_sizes;
 442
 443         ##
 444         # File is empty -- write header and master index
 445         ##
 446         if (!$bytes_read) {
 447             $self->_storage->audit( "# Database created on" );
 448
 449             $self->write_file_header;
 450
 451             $obj->{base_offset} = $self->_storage->request_space(
 452                 $self->tag_size( $self->{keyloc_size} ),
 453             );
 454
 455             my $value_spot = $self->_storage->request_space(
 456                 $self->tag_size( $self->{index_size} ),
 457             );
 458
 459             $self->write_tag(
 460                 $obj->{base_offset}, SIG_KEYS,
 461                 pack( "$self->{long_pack} C C", $obj->{base_offset}, 0, 0 ),
 462                 chr(0) x ($self->{index_size} - $self->{long_size} + 2),
 463             );
 464
 465             $self->write_tag(
 466                 $value_spot, $obj->_type,
 467                 chr(0)x$self->{index_size},
 468             );
 469
 470             # Flush the filehandle
 471             my $old_fh = select $fh;
 472             my $old_af = $|; $| = 1; $| = $old_af;
 473             select $old_fh;
 474         }
 475         else {
 476             $obj->{base_offset} = $bytes_read;
 477
 478             ##
 479             # Get our type from master index header
 480             ##
 481             my $tag = $self->load_tag($obj->_base_offset);
 482             unless ( $tag ) {
 483                 flock $fh, LOCK_UN;
 484                 $self->_throw_error("Corrupted file, no master index record");
 485             }
 486
 487             unless ($obj->_type eq $tag->{signature}) {
 488                 flock $fh, LOCK_UN;
 489                 $self->_throw_error("File type mismatch");
 490             }
 491         }
 492     }
 493     else {
 494         $self->calculate_sizes;
 495     }
 496
 497     #XXX We have to make sure we don't mess up when autoflush isn't turned on
 498     $self->_storage->set_inode;
 499
 500     flock $fh, LOCK_UN;
 501
 502     return 1;
 503 }
 504
 505 1;
 506 __END__