lib/DBM/Deep/Engine3.pm

   1 package DBM::Deep::Engine3;
   2
   3 use 5.6.0;
   4
   5 use strict;
   6
   7 our $VERSION = q(0.99_03);
   8
   9 use Scalar::Util ();
  10
  11 # File-wide notes:
  12 # * Every method in here assumes that the storage has been appropriately
  13 #   safeguarded. This can be anything from flock() to some sort of manual
  14 #   mutex. But, it's the caller's responsability to make sure that this has
  15 #   been done.
  16
  17 # Setup file and tag signatures.  These should never change.
  18 sub SIG_FILE     () { 'DPDB' }
  19 sub SIG_HEADER   () { 'h'    }
  20 sub SIG_INTERNAL () { 'i'    }
  21 sub SIG_HASH     () { 'H'    }
  22 sub SIG_ARRAY    () { 'A'    }
  23 sub SIG_NULL     () { 'N'    }
  24 sub SIG_DATA     () { 'D'    }
  25 sub SIG_INDEX    () { 'I'    }
  26 sub SIG_BLIST    () { 'B'    }
  27 sub SIG_FREE     () { 'F'    }
  28 sub SIG_KEYS     () { 'K'    }
  29 sub SIG_SIZE     () {  1     }
  30
  31 ################################################################################
  32
  33 # Please refer to the pack() documentation for further information
  34 my %StP = (
  35     1 => 'C', # Unsigned char value
  36     2 => 'n', # Unsigned short in "network" (big-endian) order
  37     4 => 'N', # Unsigned long in "network" (big-endian) order
  38     8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
  39 );
  40
  41 sub new {
  42     my $class = shift;
  43     my ($args) = @_;
  44
  45     my $self = bless {
  46         byte_size   => 4,
  47
  48         digest      => undef,
  49         hash_size   => 16, # In bytes
  50         max_buckets => 16,
  51         num_txns    => 16, # HEAD plus 15 running txns
  52         trans_id    => 0,  # Default to the HEAD
  53
  54         storage => undef,
  55     }, $class;
  56
  57     if ( defined $args->{pack_size} ) {
  58         if ( lc $args->{pack_size} eq 'small' ) {
  59             $args->{byte_size} = 2;
  60         }
  61         elsif ( lc $args->{pack_size} eq 'medium' ) {
  62             $args->{byte_size} = 4;
  63         }
  64         elsif ( lc $args->{pack_size} eq 'large' ) {
  65             $args->{byte_size} = 8;
  66         }
  67         else {
  68             die "Unknown pack_size value: '$args->{pack_size}'\n";
  69         }
  70     }
  71
  72     # Grab the parameters we want to use
  73     foreach my $param ( keys %$self ) {
  74         next unless exists $args->{$param};
  75         $self->{$param} = $args->{$param};
  76     }
  77
  78     $self->{byte_pack} = $StP{ $self->byte_size };
  79
  80     ##
  81     # Number of buckets per blist before another level of indexing is
  82     # done. Increase this value for slightly greater speed, but larger database
  83     # files. DO NOT decrease this value below 16, due to risk of recursive
  84     # reindex overrun.
  85     ##
  86     if ( $self->{max_buckets} < 16 ) {
  87         warn "Floor of max_buckets is 16. Setting it to 16 from '$self->{max_buckets}'\n";
  88         $self->{max_buckets} = 16;
  89     }
  90
  91     if ( !$self->{digest} ) {
  92         require Digest::MD5;
  93         $self->{digest} = \&Digest::MD5::md5;
  94     }
  95
  96     return $self;
  97 }
  98
  99 ################################################################################
 100
 101 sub read_value {
 102     my $self = shift;
 103     my ($obj, $key) = @_;
 104
 105     # This will be a Reference sector
 106     my $sector = $self->_load_sector( $obj->_base_offset )
 107         or die "How did read_value fail (no sector for '$obj')?!\n";
 108
 109     my $key_md5 = $self->_apply_digest( $key );
 110
 111     my $value_sector = $sector->get_data_for({
 112         key_md5    => $key_md5,
 113         allow_head => 1,
 114     });
 115
 116     unless ( $value_sector ) {
 117         $value_sector = DBM::Deep::Engine::Sector::Null->new({
 118             engine => $self,
 119             data   => undef,
 120         });
 121
 122         $sector->write_data({
 123             key_md5 => $key_md5,
 124             key     => $key,
 125             value   => $value_sector,
 126         });
 127     }
 128
 129     return $value_sector->data;
 130 }
 131
 132 sub get_classname {
 133     my $self = shift;
 134     my ($obj) = @_;
 135
 136     # This will be a Reference sector
 137     my $sector = $self->_load_sector( $obj->_base_offset )
 138         or die "How did read_value fail (no sector for '$obj')?!\n";
 139
 140     return $sector->get_classname;
 141 }
 142
 143 sub key_exists {
 144     my $self = shift;
 145     my ($obj, $key) = @_;
 146
 147     # This will be a Reference sector
 148     my $sector = $self->_load_sector( $obj->_base_offset )
 149         or die "How did key_exists fail (no sector for '$obj')?!\n";
 150
 151     my $data = $sector->get_data_for({
 152         key_md5    => $self->_apply_digest( $key ),
 153         allow_head => 1,
 154     });
 155
 156     # exists() returns 1 or '' for true/false.
 157     return $data ? 1 : '';
 158 }
 159
 160 sub delete_key {
 161     my $self = shift;
 162     my ($obj, $key) = @_;
 163
 164     my $sector = $self->_load_sector( $obj->_base_offset )
 165         or die "How did delete_key fail (no sector for '$obj')?!\n";
 166
 167     return $sector->delete_key({
 168         key_md5    => $self->_apply_digest( $key ),
 169         allow_head => 0,
 170     });
 171
 172     my $key_md5 = $self->_apply_digest( $key );
 173
 174     # XXX What should happen if this fails?
 175     my $blist = $sector->get_bucket_list({
 176         key_md5 => $key_md5,
 177     }) or die "How did delete_key fail (no blist)?!\n";
 178
 179     return $blist->delete_md5( $key_md5 );
 180 }
 181
 182 sub write_value {
 183     my $self = shift;
 184     my ($obj, $key, $value) = @_;
 185
 186     my $r = Scalar::Util::reftype( $value ) || '';
 187     {
 188         last if $r eq '';
 189         last if $r eq 'HASH';
 190         last if $r eq 'ARRAY';
 191
 192         DBM::Deep->_throw_error(
 193             "Storage of references of type '$r' is not supported."
 194         );
 195     }
 196
 197     my ($class, $type);
 198     if ( !defined $value ) {
 199         $class = 'DBM::Deep::Engine::Sector::Null';
 200     }
 201     elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
 202         if ( $r eq 'ARRAY' && tied(@$value) ) {
 203             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 204         }
 205         if ( $r eq 'HASH' && tied(%$value) ) {
 206             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 207         }
 208         $class = 'DBM::Deep::Engine::Sector::Reference';
 209         $type = substr( $r, 0, 1 );
 210     }
 211     else {
 212         $class = 'DBM::Deep::Engine::Sector::Scalar';
 213     }
 214
 215     # This will be a Reference sector
 216     my $sector = $self->_load_sector( $obj->_base_offset )
 217         or die "How did write_value fail (no sector for '$obj')?!\n";
 218
 219     # Create this after loading the reference sector in case something bad happens.
 220     # This way, we won't allocate value sector(s) needlessly.
 221     my $value_sector = $class->new({
 222         engine => $self,
 223         data   => $value,
 224         type   => $type,
 225     });
 226
 227     $sector->write_data({
 228         key     => $key,
 229         key_md5 => $self->_apply_digest( $key ),
 230         value   => $value_sector,
 231     });
 232
 233     # This code is to make sure we write all the values in the $value to the disk
 234     # and to make sure all changes to $value after the assignment are reflected
 235     # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
 236     #   NOTE - simply tying $value won't perform a STORE on each value. Hence, the
 237     # copy to a temp value.
 238     if ( $r eq 'ARRAY' ) {
 239         my @temp = @$value;
 240         tie @$value, 'DBM::Deep', {
 241             base_offset => $value_sector->offset,
 242             storage     => $self->storage,
 243             engine      => $self,
 244         };
 245         @$value = @temp;
 246         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
 247     }
 248     elsif ( $r eq 'HASH' ) {
 249         my %temp = %$value;
 250         tie %$value, 'DBM::Deep', {
 251             base_offset => $value_sector->offset,
 252             storage     => $self->storage,
 253             engine      => $self,
 254         };
 255
 256         %$value = %temp;
 257         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
 258     }
 259
 260     return 1;
 261 }
 262
 263 sub get_next_key {
 264     my $self = shift;
 265     my ($obj, $prev_key) = @_;
 266
 267     # XXX Need to add logic about resetting the iterator if any key in the reference has changed
 268     unless ( $prev_key ) {
 269         $obj->{iterator} = DBM::Deep::Engine::Iterator->new({
 270             base_offset => $obj->_base_offset,
 271             engine      => $self,
 272         });
 273     }
 274
 275     return $obj->{iterator}->get_next_key;
 276 }
 277
 278 ################################################################################
 279
 280 sub setup_fh {
 281     my $self = shift;
 282     my ($obj) = @_;
 283
 284     # We're opening the file.
 285     unless ( $obj->_base_offset ) {
 286         my $bytes_read = $self->_read_file_header;
 287
 288         # Creating a new file
 289         unless ( $bytes_read ) {
 290             $self->_write_file_header;
 291
 292             # 1) Create Array/Hash entry
 293             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 294                 engine => $self,
 295                 type   => $obj->_type,
 296             });
 297             $obj->{base_offset} = $initial_reference->offset;
 298
 299             $self->storage->flush;
 300         }
 301         # Reading from an existing file
 302         else {
 303             $obj->{base_offset} = $bytes_read;
 304             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 305                 engine => $self,
 306                 offset => $obj->_base_offset,
 307             });
 308             unless ( $initial_reference ) {
 309                 DBM::Deep->_throw_error("Corrupted file, no master index record");
 310             }
 311
 312             unless ($obj->_type eq $initial_reference->type) {
 313                 DBM::Deep->_throw_error("File type mismatch");
 314             }
 315         }
 316     }
 317
 318     return 1;
 319 }
 320
 321 sub begin_work {
 322     my $self = shift;
 323     my ($obj) = @_;
 324
 325     if ( $self->trans_id ) {
 326         DBM::Deep->throw_error( "Cannot begin_work within a transaction" );
 327     }
 328
 329     my @slots = $self->read_transaction_slots;
 330     for my $i ( 1 .. @slots ) {
 331         next if $slots[$i];
 332         $slots[$i] = 1;
 333         $self->set_trans_id( $i );
 334         last;
 335     }
 336     $self->write_transaction_slots( @slots );
 337
 338     if ( !$self->trans_id ) {
 339         DBM::Deep->throw_error( "Cannot begin_work - no available transactions" );
 340     }
 341
 342     return;
 343 }
 344
 345 sub rollback {
 346     my $self = shift;
 347     my ($obj) = @_;
 348
 349     if ( !$self->trans_id ) {
 350         DBM::Deep->throw_error( "Cannot rollback without a transaction" );
 351     }
 352 }
 353
 354 sub commit {
 355     my $self = shift;
 356     my ($obj) = @_;
 357
 358     if ( !$self->trans_id ) {
 359         DBM::Deep->throw_error( "Cannot commit without a transaction" );
 360     }
 361 }
 362
 363 sub read_transaction_slots {
 364     my $self = shift;
 365     return split '', unpack( "b32", $self->storage->read_at( $self->trans_loc, 4 ) );
 366 }
 367
 368 sub write_transaction_slots {
 369     my $self = shift;
 370     $self->storage->print_at( $self->trans_loc,
 371         pack( "b32", join('', @_) ),
 372     );
 373 }
 374
 375 ################################################################################
 376
 377 {
 378     my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
 379
 380     sub _write_file_header {
 381         my $self = shift;
 382
 383         my $header_var = 1 + 1 + 4 + 2 * $self->byte_size;
 384
 385         my $loc = $self->storage->request_space( $header_fixed + $header_var );
 386
 387         $self->storage->print_at( $loc,
 388             SIG_FILE,
 389             SIG_HEADER,
 390             pack('N', 1),           # header version - at this point, we're at 9 bytes
 391             pack('N', $header_var), # header size
 392             # --- Above is $header_fixed. Below is $header_var
 393             pack('C', $self->byte_size),
 394             pack('C', $self->max_buckets),
 395             pack('N', 0 ),                   # Running transactions
 396             pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
 397             pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
 398         );
 399
 400         $self->set_trans_loc( $header_fixed + 2 );
 401         $self->set_chains_loc( $header_fixed + 6 );
 402
 403         return;
 404     }
 405
 406     sub _read_file_header {
 407         my $self = shift;
 408
 409         my $buffer = $self->storage->read_at( 0, $header_fixed );
 410         return unless length($buffer);
 411
 412         my ($file_signature, $sig_header, $header_version, $size) = unpack(
 413             'A4 A N N', $buffer
 414         );
 415
 416         unless ( $file_signature eq SIG_FILE ) {
 417             $self->storage->close;
 418             DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
 419         }
 420
 421         unless ( $sig_header eq SIG_HEADER ) {
 422             $self->storage->close;
 423             DBM::Deep->_throw_error( "Old file version found." );
 424         }
 425
 426         my $buffer2 = $self->storage->read_at( undef, $size );
 427         my @values = unpack( 'C C', $buffer2 );
 428
 429         $self->set_trans_loc( $header_fixed + 2 );
 430         $self->set_chains_loc( $header_fixed + 6 );
 431
 432         if ( @values < 2 || grep { !defined } @values ) {
 433             $self->storage->close;
 434             DBM::Deep->_throw_error("Corrupted file - bad header");
 435         }
 436
 437         #XXX Add warnings if values weren't set right
 438         @{$self}{qw(byte_size max_buckets)} = @values;
 439
 440         my $header_var = 1 + 1 + 4 + 2 * $self->byte_size;
 441         unless ( $size eq $header_var ) {
 442             $self->storage->close;
 443             DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
 444         }
 445
 446         return length($buffer) + length($buffer2);
 447     }
 448 }
 449
 450 sub _load_sector {
 451     my $self = shift;
 452     my ($offset) = @_;
 453
 454     my $type = $self->storage->read_at( $offset, 1 );
 455     return if $type eq chr(0);
 456
 457     if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
 458         return DBM::Deep::Engine::Sector::Reference->new({
 459             engine => $self,
 460             type   => $type,
 461             offset => $offset,
 462         });
 463     }
 464     # XXX Don't we need key_md5 here?
 465     elsif ( $type eq $self->SIG_BLIST ) {
 466         return DBM::Deep::Engine::Sector::BucketList->new({
 467             engine => $self,
 468             type   => $type,
 469             offset => $offset,
 470         });
 471     }
 472     elsif ( $type eq $self->SIG_NULL ) {
 473         return DBM::Deep::Engine::Sector::Null->new({
 474             engine => $self,
 475             type   => $type,
 476             offset => $offset,
 477         });
 478     }
 479     elsif ( $type eq $self->SIG_DATA ) {
 480         return DBM::Deep::Engine::Sector::Scalar->new({
 481             engine => $self,
 482             type   => $type,
 483             offset => $offset,
 484         });
 485     }
 486     # This was deleted from under us, so just return and let the caller figure it out.
 487     elsif ( $type eq $self->SIG_FREE ) {
 488         return;
 489     }
 490
 491     die "'$offset': Don't know what to do with type '$type'\n";
 492 }
 493
 494 sub _apply_digest {
 495     my $self = shift;
 496     return $self->{digest}->(@_);
 497 }
 498
 499 sub _add_free_sector {
 500     my $self = shift;
 501     my ($offset, $size) = @_;
 502
 503     my $chains_offset;
 504     # Data sector
 505     if ( $size == 256 ) {
 506         $chains_offset = $self->byte_size;
 507     }
 508     # Blist sector
 509     else {
 510         $chains_offset = 0;
 511     }
 512
 513     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 514
 515     $self->storage->print_at( $self->chains_loc + $chains_offset,
 516         pack( $StP{$self->byte_size}, $offset ),
 517     );
 518
 519     # Record the old head in the new sector after the signature
 520     $self->storage->print_at( $offset + 1, $old_head );
 521 }
 522
 523 sub _request_sector {
 524     my $self = shift;
 525     my ($size) = @_;
 526
 527     my $chains_offset;
 528     # Data sector
 529     if ( $size == 256 ) {
 530         $chains_offset = $self->byte_size;
 531     }
 532     # Blist sector
 533     else {
 534         $chains_offset = 0;
 535     }
 536
 537     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 538     my $loc = unpack( $StP{$self->byte_size}, $old_head );
 539
 540     # We don't have any free sectors of the right size, so allocate a new one.
 541     unless ( $loc ) {
 542         return $self->storage->request_space( $size );
 543     }
 544
 545     my $new_head = $self->storage->read_at( $loc + 1, $self->byte_size );
 546     $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
 547
 548     return $loc;
 549 }
 550
 551 ################################################################################
 552
 553 sub storage     { $_[0]{storage} }
 554 sub byte_size   { $_[0]{byte_size} }
 555 sub hash_size   { $_[0]{hash_size} }
 556 sub num_txns    { $_[0]{num_txns} }
 557 sub max_buckets { $_[0]{max_buckets} }
 558 sub blank_md5   { chr(0) x $_[0]->hash_size }
 559
 560 sub trans_id     { $_[0]{trans_id} }
 561 sub set_trans_id { $_[0]{trans_id} = $_[1] }
 562
 563 sub trans_loc     { $_[0]{trans_loc} }
 564 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
 565
 566 sub chains_loc     { $_[0]{chains_loc} }
 567 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
 568
 569 ################################################################################
 570
 571 package DBM::Deep::Engine::Iterator;
 572
 573 sub new {
 574     my $class = shift;
 575     my ($args) = @_;
 576
 577     my $self = bless {
 578         breadcrumbs => [],
 579         engine      => $args->{engine},
 580         base_offset => $args->{base_offset},
 581     }, $class;
 582
 583     Scalar::Util::weaken( $self->{engine} );
 584
 585     return $self;
 586 }
 587
 588 sub reset {
 589     my $self = shift;
 590     $self->{breadcrumbs} = [];
 591 }
 592
 593 sub get_next_key {
 594     my $self = shift;
 595
 596     my $crumbs = $self->{breadcrumbs};
 597
 598     unless ( @$crumbs ) {
 599         # This will be a Reference sector
 600         my $sector = $self->{engine}->_load_sector( $self->{base_offset} )
 601             # or die "Iterator: How did this fail (no ref sector for '$self->{base_offset}')?!\n";
 602             # If no sector is found, thist must have been deleted from under us.
 603             or return;
 604         push @$crumbs, [ $sector->get_blist_loc, 0 ];
 605     }
 606
 607     my $key;
 608     while ( 1 ) {
 609         my ($offset, $idx) = @{ $crumbs->[-1] };
 610         unless ( $offset ) {
 611             $self->reset;
 612             last;
 613         }
 614
 615         if ( $idx >= $self->{engine}->max_buckets ) {
 616             $self->reset;
 617             last;
 618         }
 619
 620         my $sector = $self->{engine}->_load_sector( $offset )
 621             or die "Iterator: How did this fail (no blist sector for '$offset')?!\n";
 622
 623         #XXX Think this through!
 624         my $loc =  $sector->get_data_location_for({
 625             idx => $idx,
 626         });
 627         unless ( $loc ) {
 628             $crumbs->[-1][1]++;
 629             next;
 630         }
 631
 632         my $key_sector = $sector->get_key_for( $idx );
 633         unless ( $key_sector ) {
 634             $self->reset;
 635             last;
 636         }
 637
 638         $crumbs->[-1][1]++;
 639         $key = $key_sector->data;
 640         last;
 641     }
 642
 643     return $key;
 644 }
 645
 646 package DBM::Deep::Engine::Sector;
 647
 648 sub new {
 649     my $self = bless $_[1], $_[0];
 650     Scalar::Util::weaken( $self->{engine} );
 651     $self->_init;
 652     return $self;
 653 }
 654 sub _init {}
 655 sub clone { die "Must be implemented in the child class" }
 656
 657 sub engine { $_[0]{engine} }
 658 sub offset { $_[0]{offset} }
 659 sub type   { $_[0]{type} }
 660
 661 sub free {
 662     my $self = shift;
 663
 664     $self->engine->storage->print_at( $self->offset,
 665         $self->engine->SIG_FREE,
 666         chr(0) x ($self->size - 1),
 667     );
 668
 669     $self->engine->_add_free_sector(
 670         $self->offset, $self->size,
 671     );
 672
 673     return;
 674 }
 675
 676 package DBM::Deep::Engine::Sector::Data;
 677
 678 our @ISA = qw( DBM::Deep::Engine::Sector );
 679
 680 # This is in bytes
 681 sub size { return 256 }
 682
 683 sub clone {
 684     my $self = shift;
 685     return ref($self)->new({
 686         engine => $self->engine,
 687         data   => $self->data,
 688         type   => $self->type,
 689     });
 690 }
 691
 692 package DBM::Deep::Engine::Sector::Scalar;
 693
 694 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
 695
 696 sub free {
 697     my $self = shift;
 698
 699     my $chain_loc = $self->chain_loc;
 700
 701     $self->SUPER::free();
 702
 703     if ( $chain_loc ) {
 704         $self->engine->_load_sector( $chain_loc )->free;
 705     }
 706
 707     return;
 708 }
 709
 710 sub type { $_[0]{engine}->SIG_DATA }
 711 sub _init {
 712     my $self = shift;
 713
 714     my $engine = $self->engine;
 715
 716     unless ( $self->offset ) {
 717         my $data_section = $self->size - 3 - 1 * $engine->byte_size;
 718
 719         $self->{offset} = $engine->_request_sector( $self->size );
 720
 721         my $data = delete $self->{data};
 722         my $dlen = length $data;
 723         my $continue = 1;
 724         my $curr_offset = $self->offset;
 725         while ( $continue ) {
 726
 727             my $next_offset = 0;
 728
 729             my ($leftover, $this_len, $chunk);
 730             if ( $dlen > $data_section ) {
 731                 $leftover = 0;
 732                 $this_len = $data_section;
 733                 $chunk = substr( $data, 0, $this_len );
 734
 735                 $dlen -= $data_section;
 736                 $next_offset = $engine->_request_sector( $self->size );
 737                 $data = substr( $data, $this_len );
 738             }
 739             else {
 740                 $leftover = $data_section - $dlen;
 741                 $this_len = $dlen;
 742                 $chunk = $data;
 743
 744                 $continue = 0;
 745             }
 746
 747             $engine->storage->print_at( $curr_offset,
 748                 $self->type,                                     # Sector type
 749                 pack( $StP{1}, 0 ),                              # Recycled counter
 750                 pack( $StP{$engine->byte_size}, $next_offset ),  # Chain loc
 751                 pack( $StP{1}, $this_len ),                      # Data length
 752                 $chunk,                                          # Data to be stored in this sector
 753                 chr(0) x $leftover,                              # Zero-fill the rest
 754             );
 755
 756             $curr_offset = $next_offset;
 757         }
 758
 759         return;
 760     }
 761 }
 762
 763 sub data_length {
 764     my $self = shift;
 765
 766     my $buffer = $self->engine->storage->read_at(
 767         $self->offset + 2 + $self->engine->byte_size, 1
 768     );
 769
 770     return unpack( $StP{1}, $buffer );
 771 }
 772
 773 sub chain_loc {
 774     my $self = shift;
 775     my $chain_loc = $self->engine->storage->read_at(
 776         $self->offset + 2, $self->engine->byte_size,
 777     );
 778     return unpack( $StP{$self->engine->byte_size}, $chain_loc );
 779 }
 780
 781 sub data {
 782     my $self = shift;
 783
 784     my $data;
 785     while ( 1 ) {
 786         my $chain_loc = $self->chain_loc;
 787
 788         $data .= $self->engine->storage->read_at(
 789             $self->offset + 2 + $self->engine->byte_size + 1, $self->data_length,
 790         );
 791
 792         last unless $chain_loc;
 793
 794         $self = $self->engine->_load_sector( $chain_loc );
 795     }
 796
 797     return $data;
 798 }
 799
 800 package DBM::Deep::Engine::Sector::Null;
 801
 802 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
 803
 804 sub type { $_[0]{engine}->SIG_NULL }
 805 sub data_length { 0 }
 806 sub data { return }
 807
 808 sub _init {
 809     my $self = shift;
 810
 811     my $engine = $self->engine;
 812
 813     unless ( $self->offset ) {
 814         my $leftover = $self->size - 3 - 1 * $engine->byte_size;
 815
 816         $self->{offset} = $engine->_request_sector( $self->size );
 817         $engine->storage->print_at( $self->offset,
 818             $self->type,                          # Sector type
 819             pack( $StP{1}, 0 ),                   # Recycled counter
 820             pack( $StP{$engine->byte_size}, 0 ),  # Chain loc
 821             pack( $StP{1}, $self->data_length ),  # Data length
 822             chr(0) x $leftover,                   # Zero-fill the rest
 823         );
 824
 825         return;
 826     }
 827 }
 828
 829 package DBM::Deep::Engine::Sector::Reference;
 830
 831 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
 832
 833 sub _init {
 834     my $self = shift;
 835
 836     my $engine = $self->engine;
 837
 838     unless ( $self->offset ) {
 839         my $classname = Scalar::Util::blessed( delete $self->{data} );
 840         my $leftover = $self->size - 4 - 2 * $engine->byte_size;
 841
 842         my $class_offset = 0;
 843         if ( defined $classname ) {
 844             my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
 845                 engine => $self->engine,
 846                 data   => $classname,
 847             });
 848             $class_offset = $class_sector->offset;
 849         }
 850
 851         $self->{offset} = $engine->_request_sector( $self->size );
 852         $engine->storage->print_at( $self->offset,
 853             $self->type,                                     # Sector type
 854             pack( $StP{1}, 0 ),                              # Recycled counter
 855             pack( $StP{$engine->byte_size}, 0 ),             # Index/BList loc
 856             pack( $StP{$engine->byte_size}, $class_offset ), # Classname loc
 857             chr(0) x $leftover,                              # Zero-fill the rest
 858         );
 859
 860         return;
 861     }
 862
 863     $self->{type} = $engine->storage->read_at( $self->offset, 1 );
 864
 865     return;
 866 }
 867
 868 sub get_data_for {
 869     my $self = shift;
 870     my ($args) = @_;
 871
 872     # Assume that the head is not allowed unless otherwise specified.
 873     $args->{allow_head} = 0 unless exists $args->{allow_head};
 874
 875     # Assume we don't create a new blist location unless otherwise specified.
 876     $args->{create} = 0 unless exists $args->{create};
 877
 878     my $blist = $self->get_bucket_list({
 879         key_md5 => $args->{key_md5},
 880         create  => $args->{create},
 881     });
 882     return unless $blist && $blist->{found};
 883
 884     # At this point, $blist knows where the md5 is. What it -doesn't- know yet
 885     # is whether or not this transaction has this key. That's part of the next
 886     # function call.
 887     my $location = $blist->get_data_location_for({
 888         allow_head => $args->{allow_head},
 889     }) or return;
 890
 891     return $self->engine->_load_sector( $location );
 892 }
 893
 894 sub write_data {
 895     my $self = shift;
 896     my ($args) = @_;
 897
 898     my $blist = $self->get_bucket_list({
 899         key_md5 => $args->{key_md5},
 900         create  => 1,
 901     }) or die "How did write_value fail (no blist)?!\n";
 902
 903     # Handle any transactional bookkeeping.
 904     if ( $self->engine->trans_id ) {
 905         if ( ! $blist->{found} ) {
 906             $blist->mark_deleted({
 907                 trans_id => 0,
 908             });
 909         }
 910     }
 911     else {
 912         my @transactions = $self->engine->read_transaction_slots;
 913         my @trans_ids = grep { $transactions[$_] } 0 .. $#transactions;
 914         if ( $blist->{found} ) {
 915             if ( @trans_ids ) {
 916                 my $old_value = $blist->get_data_for;
 917                 foreach my $other_trans_id ( @trans_ids ) {
 918                     next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
 919                     $blist->write_md5({
 920                         trans_id => $other_trans_id,
 921                         key      => $args->{key},
 922                         key_md5  => $args->{key_md5},
 923                         value    => $old_value->clone,
 924                     });
 925                 }
 926             }
 927         }
 928         else {
 929             if ( @trans_ids ) {
 930                 foreach my $other_trans_id ( @trans_ids ) {
 931                     next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
 932                     $blist->mark_deleted({
 933                         trans_id => $other_trans_id,
 934                     });
 935                 }
 936             }
 937         }
 938     }
 939
 940     # Free the place we're about to write to.
 941     if ( $blist->get_data_location_for({ allow_head => 0 }) ) {
 942         $blist->get_data_for({ allow_head => 0 })->free;
 943     }
 944
 945     $blist->write_md5({
 946         key      => $args->{key},
 947         key_md5  => $args->{key_md5},
 948         value    => $args->{value},
 949     });
 950 }
 951
 952 sub delete_key {
 953     my $self = shift;
 954     my ($args) = @_;
 955
 956     # XXX What should happen if this fails?
 957     my $blist = $self->get_bucket_list({
 958         key_md5 => $args->{key_md5},
 959     }) or die "How did delete_key fail (no blist)?!\n";
 960
 961     return $blist->delete_md5( $args );
 962 }
 963
 964 sub get_blist_loc {
 965     my $self = shift;
 966
 967     my $e = $self->engine;
 968     my $blist_loc = $e->storage->read_at( $self->offset + 2, $e->byte_size );
 969     return unpack( $StP{$e->byte_size}, $blist_loc );
 970 }
 971
 972 sub get_bucket_list {
 973     my $self = shift;
 974     my ($args) = @_;
 975     $args ||= {};
 976
 977     # XXX Add in check here for recycling?
 978
 979     my $engine = $self->engine;
 980
 981     my $blist_loc = $self->get_blist_loc;
 982
 983     # There's no index or blist yet
 984     unless ( $blist_loc ) {
 985         return unless $args->{create};
 986
 987         my $blist = DBM::Deep::Engine::Sector::BucketList->new({
 988             engine  => $engine,
 989             key_md5 => $args->{key_md5},
 990         });
 991
 992         $engine->storage->print_at( $self->offset + 2,
 993             pack( $StP{$engine->byte_size}, $blist->offset ),
 994         );
 995
 996         return $blist;
 997     }
 998
 999     return DBM::Deep::Engine::Sector::BucketList->new({
1000         engine  => $engine,
1001         offset  => $blist_loc,
1002         key_md5 => $args->{key_md5},
1003     });
1004 }
1005
1006 sub get_classname {
1007     my $self = shift;
1008
1009     my $class_offset = $self->engine->storage->read_at(
1010         $self->offset + 2 + 1 * $self->engine->byte_size, $self->engine->byte_size,
1011     );
1012     $class_offset = unpack ( $StP{$self->engine->byte_size}, $class_offset );
1013
1014     return unless $class_offset;
1015
1016     return $self->engine->_load_sector( $class_offset )->data;
1017 }
1018
1019 sub data {
1020     my $self = shift;
1021
1022     my $new_obj = DBM::Deep->new({
1023         type        => $self->type,
1024         base_offset => $self->offset,
1025         storage     => $self->engine->storage,
1026         engine      => $self->engine,
1027     });
1028
1029     if ( $self->engine->storage->{autobless} ) {
1030         my $classname = $self->get_classname;
1031         if ( defined $classname ) {
1032             bless $new_obj, $classname;
1033         }
1034     }
1035
1036     return $new_obj;
1037 }
1038
1039 package DBM::Deep::Engine::Sector::BucketList;
1040
1041 our @ISA = qw( DBM::Deep::Engine::Sector );
1042
1043 sub idx_for_txn { return $_[1] + 1 }
1044
1045 sub _init {
1046     my $self = shift;
1047
1048     my $engine = $self->engine;
1049
1050     unless ( $self->offset ) {
1051         my $leftover = $self->size - $self->base_size;
1052
1053         $self->{offset} = $engine->_request_sector( $self->size );
1054         $engine->storage->print_at( $self->offset,
1055             $engine->SIG_BLIST, # Sector type
1056             pack( $StP{1}, 0 ), # Recycled counter
1057             chr(0) x $leftover, # Zero-fill the data
1058         );
1059     }
1060
1061     if ( $self->{key_md5} ) {
1062         $self->find_md5;
1063     }
1064
1065     return $self;
1066 }
1067
1068 sub base_size { 2 } # Sig + recycled counter
1069
1070 sub size {
1071     my $self = shift;
1072     unless ( $self->{size} ) {
1073         my $e = $self->engine;
1074         $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; # Base + numbuckets * bucketsize
1075     }
1076     return $self->{size};
1077 }
1078
1079 sub bucket_size {
1080     my $self = shift;
1081     unless ( $self->{bucket_size} ) {
1082         my $e = $self->engine;
1083         # Key + transactions
1084         my $locs_size = (1 + $e->num_txns ) * $e->byte_size;
1085         $self->{bucket_size} = $e->hash_size + $locs_size;
1086     }
1087     return $self->{bucket_size};
1088 }
1089
1090 sub has_md5 {
1091     my $self = shift;
1092     unless ( exists $self->{found} ) {
1093         $self->find_md5;
1094     }
1095     return $self->{found};
1096 }
1097
1098 sub find_md5 {
1099     my $self = shift;
1100
1101     $self->{found} = undef;
1102     $self->{idx}   = -1;
1103
1104     # If we don't have an MD5, then what are we supposed to do?
1105     unless ( exists $self->{key_md5} ) {
1106         DBM::Deep->throw( "Cannot find_md5 without a key_md5 set" );
1107     }
1108
1109     my $e = $self->engine;
1110     foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
1111         my $potential = $e->storage->read_at(
1112             $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size,
1113         );
1114
1115         if ( $potential eq $e->blank_md5 ) {
1116             $self->{idx} = $idx;
1117             return;
1118         }
1119
1120         if ( $potential eq $self->{key_md5} ) {
1121             $self->{found} = 1;
1122             $self->{idx} = $idx;
1123             return;
1124         }
1125     }
1126
1127     return;
1128 }
1129
1130 sub write_md5 {
1131     my $self = shift;
1132     my ($args) = @_;
1133     $args ||= {};
1134
1135     $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id};
1136
1137     my $engine = $self->engine;
1138     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
1139
1140     unless ($self->{found}) {
1141         my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({
1142             engine => $self->engine,
1143             data   => $args->{key},
1144         });
1145
1146         $engine->storage->print_at( $spot,
1147             $args->{key_md5},
1148             pack( $StP{$self->engine->byte_size}, $key_sector->offset ),
1149         );
1150     }
1151
1152     $engine->storage->print_at(
1153         $spot
1154       + $engine->hash_size
1155       + $engine->byte_size
1156       + $args->{trans_id} * $engine->byte_size,
1157         pack( $StP{$engine->byte_size}, $args->{value}->offset ),
1158     );
1159 }
1160
1161 sub mark_deleted {
1162     my $self = shift;
1163     my ($args) = @_;
1164
1165     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
1166     $self->engine->storage->print_at(
1167         $spot
1168       + $self->engine->hash_size
1169       + $self->engine->byte_size
1170       + $args->{trans_id} * $self->engine->byte_size,
1171         pack( $StP{$self->engine->byte_size}, 1 ), # 1 is the marker for deleted
1172     );
1173 }
1174
1175 sub delete_md5 {
1176     my $self = shift;
1177     my ($args) = @_;
1178
1179     my $engine = $self->engine;
1180     return undef unless $self->{found};
1181
1182     # Save the location so that we can free the data
1183     my $location = $self->get_data_location_for({
1184         allow_head => 0,
1185     });
1186     my $key_sector = $self->get_key_for;
1187
1188     my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
1189     $engine->storage->print_at( $spot,
1190         $engine->storage->read_at(
1191             $spot + $self->bucket_size,
1192             $self->bucket_size * ( $engine->num_txns - $self->{idx} - 1 ),
1193         ),
1194         chr(0) x $self->bucket_size,
1195     );
1196
1197     $key_sector->free;
1198
1199     my $data_sector = $self->engine->_load_sector( $location );
1200     my $data = $data_sector->data;
1201     $data_sector->free;
1202
1203     return $data;
1204 }
1205
1206 sub get_data_location_for {
1207     my $self = shift;
1208     my ($args) = @_;
1209     $args ||= {};
1210
1211     $args->{allow_head} = 0 unless exists $args->{allow_head};
1212     $args->{trans_id}   = $self->engine->trans_id unless exists $args->{trans_id};
1213     $args->{idx}        = $self->{idx} unless exists $args->{idx};
1214
1215     my $location = $self->engine->storage->read_at(
1216         $self->offset + $self->base_size
1217       + $args->{idx} * $self->bucket_size
1218       + $self->engine->hash_size
1219       + $self->engine->byte_size
1220       + $args->{trans_id} * $self->engine->byte_size,
1221         $self->engine->byte_size,
1222     );
1223     my $loc = unpack( $StP{$self->engine->byte_size}, $location );
1224
1225     # If we're in a transaction and we never wrote to this location, try the
1226     # HEAD instead.
1227     if ( $args->{trans_id} && !$loc && $args->{allow_head} ) {
1228         return $self->get_data_location_for({
1229             trans_id   => 0,
1230             allow_head => 1,
1231         });
1232     }
1233     return $loc <= 1 ? 0 : $loc;
1234 }
1235
1236 sub get_data_for {
1237     my $self = shift;
1238     my ($args) = @_;
1239     $args ||= {};
1240
1241     return unless $self->{found};
1242     my $location = $self->get_data_location_for({
1243         allow_head => $args->{allow_head},
1244     });
1245     return $self->engine->_load_sector( $location );
1246 }
1247
1248 sub get_key_for {
1249     my $self = shift;
1250     my ($idx) = @_;
1251     $idx = $self->{idx} unless defined $idx;
1252
1253     my $location = $self->engine->storage->read_at(
1254         $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size,
1255         $self->engine->byte_size,
1256     );
1257     $location = unpack( $StP{$self->engine->byte_size}, $location );
1258     return unless $location;
1259     return $self->engine->_load_sector( $location );
1260 }
1261
1262 1;
1263 __END__