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     # XXX What should happen if this fails?
 112     my $blist = $sector->get_bucket_list({
 113         key_md5 => $key_md5,
 114         create  => 1,
 115     }) or die "How did read_value fail (no blist)?!\n";
 116
 117     my $value_sector = $blist->get_data_for( $key_md5, { allow_head => 1 } );
 118     if ( !$value_sector ) {
 119         # Autovivification
 120         $value_sector = DBM::Deep::Engine::Sector::Null->new({
 121             engine => $self,
 122             data   => undef,
 123         });
 124
 125         $blist->write_md5( $key_md5, $key, $value_sector->offset );
 126     }
 127
 128     return $value_sector->data;
 129 }
 130
 131 sub get_classname {
 132     my $self = shift;
 133     my ($obj) = @_;
 134
 135     # This will be a Reference sector
 136     my $sector = $self->_load_sector( $obj->_base_offset )
 137         or die "How did read_value fail (no sector for '$obj')?!\n";
 138
 139     return $sector->get_classname;
 140 }
 141
 142 sub key_exists {
 143     my $self = shift;
 144     my ($obj, $key) = @_;
 145
 146     # This will be a Reference sector
 147     my $sector = $self->_load_sector( $obj->_base_offset )
 148         or die "How did key_exists fail (no sector for '$obj')?!\n";
 149
 150     my $key_md5 = $self->_apply_digest( $key );
 151
 152     # XXX What should happen if this fails?
 153     my $blist = $sector->get_bucket_list({
 154         key_md5 => $key_md5,
 155     }) or die "How did key_exists fail (no blist)?!\n";
 156
 157     # exists() returns 1 or '' for true/false.
 158     return $blist->has_md5( $key_md5, { allow_head => 1 } ) ? 1 : '';
 159 }
 160
 161 sub delete_key {
 162     my $self = shift;
 163     my ($obj, $key) = @_;
 164
 165     my $sector = $self->_load_sector( $obj->_base_offset )
 166         or die "How did delete_key fail (no sector for '$obj')?!\n";
 167
 168     my $key_md5 = $self->_apply_digest( $key );
 169
 170     # XXX What should happen if this fails?
 171     my $blist = $sector->get_bucket_list({
 172         key_md5 => $key_md5,
 173     }) or die "How did delete_key fail (no blist)?!\n";
 174
 175     return $blist->delete_md5( $key_md5 );
 176 }
 177
 178 sub write_value {
 179     my $self = shift;
 180     my ($obj, $key, $value) = @_;
 181
 182     # This will be a Reference sector
 183     my $sector = $self->_load_sector( $obj->_base_offset )
 184         or die "How did write_value fail (no sector for '$obj')?!\n";
 185
 186     my $key_md5 = $self->_apply_digest( $key );
 187
 188     # XXX What should happen if this fails?
 189     my $blist = $sector->get_bucket_list({
 190         key_md5 => $key_md5,
 191         create  => 1,
 192     }) or die "How did write_value fail (no blist)?!\n";
 193
 194     my $r = Scalar::Util::reftype( $value ) || '';
 195     {
 196         last if $r eq '';
 197         last if $r eq 'HASH';
 198         last if $r eq 'ARRAY';
 199
 200         DBM::Deep->_throw_error(
 201             "Storage of references of type '$r' is not supported."
 202         );
 203     }
 204
 205     my ($class, $type);
 206     if ( !defined $value ) {
 207         $class = 'DBM::Deep::Engine::Sector::Null';
 208     }
 209     elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
 210         if ( $r eq 'ARRAY' && tied(@$value) ) {
 211             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 212         }
 213         if ( $r eq 'HASH' && tied(%$value) ) {
 214             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 215         }
 216         $class = 'DBM::Deep::Engine::Sector::Reference';
 217         $type = substr( $r, 0, 1 );
 218     }
 219     else {
 220         $class = 'DBM::Deep::Engine::Sector::Scalar';
 221     }
 222
 223     if ( $blist->has_md5( $key_md5 ) ) {
 224         $blist->get_data_for( $key_md5, { allow_head => 0 } )->free;
 225     }
 226
 227     my $value_sector = $class->new({
 228         engine => $self,
 229         data   => $value,
 230         type   => $type,
 231     });
 232
 233     $blist->write_md5( $key_md5, $key, $value_sector->offset );
 234
 235     # This code is to make sure we write all the values in the $value to the disk
 236     # and to make sure all changes to $value after the assignment are reflected
 237     # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
 238     #   NOTE - simply tying $value won't perform a STORE on each value. Hence, the
 239     # copy to a temp value.
 240     if ( $r eq 'ARRAY' ) {
 241         my @temp = @$value;
 242         tie @$value, 'DBM::Deep', {
 243             base_offset => $value_sector->offset,
 244             storage     => $self->storage,
 245             engine      => $self,
 246         };
 247         @$value = @temp;
 248         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
 249     }
 250     elsif ( $r eq 'HASH' ) {
 251         my %temp = %$value;
 252         tie %$value, 'DBM::Deep', {
 253             base_offset => $value_sector->offset,
 254             storage     => $self->storage,
 255             engine      => $self,
 256         };
 257
 258         %$value = %temp;
 259         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
 260     }
 261
 262     return 1;
 263 }
 264
 265 sub get_next_key {
 266     my $self = shift;
 267     my ($obj, $prev_key) = @_;
 268
 269     # XXX Need to add logic about resetting the iterator if any key in the reference has changed
 270     unless ( $prev_key ) {
 271         $obj->{iterator} = DBM::Deep::Engine::Iterator->new({
 272             base_offset => $obj->_base_offset,
 273             engine      => $self,
 274         });
 275     }
 276
 277     return $obj->{iterator}->get_next_key;
 278 }
 279
 280 ################################################################################
 281
 282 sub setup_fh {
 283     my $self = shift;
 284     my ($obj) = @_;
 285
 286     # We're opening the file.
 287     unless ( $obj->_base_offset ) {
 288         my $bytes_read = $self->_read_file_header;
 289
 290         # Creating a new file
 291         unless ( $bytes_read ) {
 292             $self->_write_file_header;
 293
 294             # 1) Create Array/Hash entry
 295             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 296                 engine => $self,
 297                 type   => $obj->_type,
 298             });
 299             $obj->{base_offset} = $initial_reference->offset;
 300
 301             $self->storage->flush;
 302         }
 303         # Reading from an existing file
 304         else {
 305             $obj->{base_offset} = $bytes_read;
 306             my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
 307                 engine => $self,
 308                 offset => $obj->_base_offset,
 309             });
 310             unless ( $initial_reference ) {
 311                 DBM::Deep->_throw_error("Corrupted file, no master index record");
 312             }
 313
 314             unless ($obj->_type eq $initial_reference->type) {
 315                 DBM::Deep->_throw_error("File type mismatch");
 316             }
 317         }
 318     }
 319
 320     return 1;
 321 }
 322
 323 sub begin_work {
 324     my $self = shift;
 325     my ($obj) = @_;
 326
 327     if ( $self->trans_id ) {
 328         DBM::Deep->throw_error( "Cannot begin_work within a transaction" );
 329     }
 330
 331     my @slots = $self->read_transaction_slots;
 332     for my $i ( 1 .. @slots ) {
 333         next if $slots[$i];
 334         $slots[$i] = 1;
 335         $self->set_trans_id( $i );
 336         last;
 337     }
 338     $self->write_transaction_slots( @slots );
 339
 340     if ( !$self->trans_id ) {
 341         DBM::Deep->throw_error( "Cannot begin_work - no available transactions" );
 342     }
 343
 344     return;
 345 }
 346
 347 sub rollback {
 348     my $self = shift;
 349     my ($obj) = @_;
 350
 351     if ( !$self->trans_id ) {
 352         DBM::Deep->throw_error( "Cannot rollback without a transaction" );
 353     }
 354 }
 355
 356 sub commit {
 357     my $self = shift;
 358     my ($obj) = @_;
 359
 360     if ( !$self->trans_id ) {
 361         DBM::Deep->throw_error( "Cannot commit without a transaction" );
 362     }
 363 }
 364
 365 sub read_transaction_slots {
 366     my $self = shift;
 367     return split '', unpack( "b32", $self->storage->read_at( $self->trans_loc, 4 ) );
 368 }
 369
 370 sub write_transaction_slots {
 371     my $self = shift;
 372     $self->storage->print_at( $self->trans_loc,
 373         pack( "b32", join('', @_) ),
 374     );
 375 }
 376
 377 ################################################################################
 378
 379 {
 380     my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
 381
 382     sub _write_file_header {
 383         my $self = shift;
 384
 385         my $header_var = 1 + 1 + 4 + 2 * $self->byte_size;
 386
 387         my $loc = $self->storage->request_space( $header_fixed + $header_var );
 388
 389         $self->storage->print_at( $loc,
 390             SIG_FILE,
 391             SIG_HEADER,
 392             pack('N', 1),           # header version - at this point, we're at 9 bytes
 393             pack('N', $header_var), # header size
 394             # --- Above is $header_fixed. Below is $header_var
 395             pack('C', $self->byte_size),
 396             pack('C', $self->max_buckets),
 397             pack('N', 0 ),                   # Running transactions
 398             pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
 399             pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
 400         );
 401
 402         $self->set_trans_loc( $header_fixed + 2 );
 403         $self->set_chains_loc( $header_fixed + 6 );
 404
 405         return;
 406     }
 407
 408     sub _read_file_header {
 409         my $self = shift;
 410
 411         my $buffer = $self->storage->read_at( 0, $header_fixed );
 412         return unless length($buffer);
 413
 414         my ($file_signature, $sig_header, $header_version, $size) = unpack(
 415             'A4 A N N', $buffer
 416         );
 417
 418         unless ( $file_signature eq SIG_FILE ) {
 419             $self->storage->close;
 420             DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
 421         }
 422
 423         unless ( $sig_header eq SIG_HEADER ) {
 424             $self->storage->close;
 425             DBM::Deep->_throw_error( "Old file version found." );
 426         }
 427
 428         my $buffer2 = $self->storage->read_at( undef, $size );
 429         my @values = unpack( 'C C', $buffer2 );
 430
 431         $self->set_trans_loc( $header_fixed + 2 );
 432         $self->set_chains_loc( $header_fixed + 6 );
 433
 434         if ( @values < 2 || grep { !defined } @values ) {
 435             $self->storage->close;
 436             DBM::Deep->_throw_error("Corrupted file - bad header");
 437         }
 438
 439         #XXX Add warnings if values weren't set right
 440         @{$self}{qw(byte_size max_buckets)} = @values;
 441
 442         my $header_var = 1 + 1 + 4 + 2 * $self->byte_size;
 443         unless ( $size eq $header_var ) {
 444             $self->storage->close;
 445             DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
 446         }
 447
 448         return length($buffer) + length($buffer2);
 449     }
 450 }
 451
 452 sub _load_sector {
 453     my $self = shift;
 454     my ($offset) = @_;
 455
 456     my $type = $self->storage->read_at( $offset, 1 );
 457     return if $type eq chr(0);
 458
 459     if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
 460         return DBM::Deep::Engine::Sector::Reference->new({
 461             engine => $self,
 462             type   => $type,
 463             offset => $offset,
 464         });
 465     }
 466     elsif ( $type eq $self->SIG_BLIST ) {
 467         return DBM::Deep::Engine::Sector::BucketList->new({
 468             engine => $self,
 469             type   => $type,
 470             offset => $offset,
 471         });
 472     }
 473     elsif ( $type eq $self->SIG_NULL ) {
 474         return DBM::Deep::Engine::Sector::Null->new({
 475             engine => $self,
 476             type   => $type,
 477             offset => $offset,
 478         });
 479     }
 480     elsif ( $type eq $self->SIG_DATA ) {
 481         return DBM::Deep::Engine::Sector::Scalar->new({
 482             engine => $self,
 483             type   => $type,
 484             offset => $offset,
 485         });
 486     }
 487     # This was deleted from under us, so just return and let the caller figure it out.
 488     elsif ( $type eq $self->SIG_FREE ) {
 489         return;
 490     }
 491
 492     die "'$offset': Don't know what to do with type '$type'\n";
 493 }
 494
 495 sub _apply_digest {
 496     my $self = shift;
 497     return $self->{digest}->(@_);
 498 }
 499
 500 sub _add_free_sector {
 501     my $self = shift;
 502     my ($offset, $size) = @_;
 503
 504     my $chains_offset;
 505     # Data sector
 506     if ( $size == 256 ) {
 507         $chains_offset = $self->byte_size;
 508     }
 509     # Blist sector
 510     else {
 511         $chains_offset = 0;
 512     }
 513
 514     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 515
 516     $self->storage->print_at( $self->chains_loc + $chains_offset,
 517         pack( $StP{$self->byte_size}, $offset ),
 518     );
 519
 520     # Record the old head in the new sector after the signature
 521     $self->storage->print_at( $offset + 1, $old_head );
 522 }
 523
 524 sub _request_sector {
 525     my $self = shift;
 526     my ($size) = @_;
 527
 528     my $chains_offset;
 529     # Data sector
 530     if ( $size == 256 ) {
 531         $chains_offset = $self->byte_size;
 532     }
 533     # Blist sector
 534     else {
 535         $chains_offset = 0;
 536     }
 537
 538     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
 539     my $loc = unpack( $StP{$self->byte_size}, $old_head );
 540
 541     # We don't have any free sectors of the right size, so allocate a new one.
 542     unless ( $loc ) {
 543         return $self->storage->request_space( $size );
 544     }
 545
 546     my $new_head = $self->storage->read_at( $loc + 1, $self->byte_size );
 547     $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
 548
 549     return $loc;
 550 }
 551
 552 ################################################################################
 553
 554 sub storage     { $_[0]{storage} }
 555 sub byte_size   { $_[0]{byte_size} }
 556 sub hash_size   { $_[0]{hash_size} }
 557 sub num_txns    { $_[0]{num_txns} }
 558 sub max_buckets { $_[0]{max_buckets} }
 559 sub blank_md5   { chr(0) x $_[0]->hash_size }
 560
 561 sub trans_id     { $_[0]{trans_id} }
 562 sub set_trans_id { $_[0]{trans_id} = $_[1] }
 563
 564 sub trans_loc     { $_[0]{trans_loc} }
 565 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
 566
 567 sub chains_loc     { $_[0]{chains_loc} }
 568 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
 569
 570 ################################################################################
 571
 572 package DBM::Deep::Engine::Iterator;
 573
 574 sub new {
 575     my $class = shift;
 576     my ($args) = @_;
 577
 578     my $self = bless {
 579         breadcrumbs => [],
 580         engine      => $args->{engine},
 581         base_offset => $args->{base_offset},
 582         trans_id    => $args->{trans_id},
 583     }, $class;
 584
 585     Scalar::Util::weaken( $self->{engine} );
 586
 587     return $self;
 588 }
 589
 590 sub reset {
 591     my $self = shift;
 592     $self->{breadcrumbs} = [];
 593 }
 594
 595 sub get_next_key {
 596     my $self = shift;
 597
 598     my $crumbs = $self->{breadcrumbs};
 599
 600     unless ( @$crumbs ) {
 601         # This will be a Reference sector
 602         my $sector = $self->{engine}->_load_sector( $self->{base_offset} )
 603             # or die "Iterator: How did this fail (no ref sector for '$self->{base_offset}')?!\n";
 604             # If no sector is found, thist must have been deleted from under us.
 605             or return;
 606         push @$crumbs, [ $sector->get_blist_loc, 0 ];
 607     }
 608
 609     my $key;
 610     while ( 1 ) {
 611         my ($offset, $idx) = @{ $crumbs->[-1] };
 612         unless ( $offset ) {
 613             $self->reset;
 614             last;
 615         }
 616
 617         my $sector = $self->{engine}->_load_sector( $offset )
 618             or die "Iterator: How did this fail (no blist sector for '$offset')?!\n";
 619
 620         my $key_sector = $sector->get_key_for( $idx );
 621         unless ( $key_sector ) {
 622             $self->reset;
 623             last;
 624         }
 625
 626         $crumbs->[-1][1]++;
 627         $key = $key_sector->data;
 628         last;
 629     }
 630
 631     return $key;
 632 }
 633
 634 package DBM::Deep::Engine::Sector;
 635
 636 sub new {
 637     my $self = bless $_[1], $_[0];
 638     Scalar::Util::weaken( $self->{engine} );
 639     $self->_init;
 640     return $self;
 641 }
 642 sub _init {}
 643
 644 sub engine { $_[0]{engine} }
 645 sub offset { $_[0]{offset} }
 646 sub type   { $_[0]{type} }
 647
 648 sub free {
 649     my $self = shift;
 650
 651     $self->engine->storage->print_at( $self->offset,
 652         $self->engine->SIG_FREE,
 653         chr(0) x ($self->size - 1),
 654     );
 655
 656     $self->engine->_add_free_sector(
 657         $self->offset, $self->size,
 658     );
 659
 660     return;
 661 }
 662
 663 package DBM::Deep::Engine::Sector::Data;
 664
 665 our @ISA = qw( DBM::Deep::Engine::Sector );
 666
 667 # This is in bytes
 668 sub size { return 256 }
 669
 670 package DBM::Deep::Engine::Sector::Scalar;
 671
 672 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
 673
 674 sub free {
 675     my $self = shift;
 676
 677     my $chain_loc = $self->chain_loc;
 678
 679     $self->SUPER::free();
 680
 681     if ( $chain_loc ) {
 682         $self->engine->_load_sector( $chain_loc )->free;
 683     }
 684
 685     return;
 686 }
 687
 688 sub type { $_[0]{engine}->SIG_DATA }
 689 sub _init {
 690     my $self = shift;
 691
 692     my $engine = $self->engine;
 693
 694     unless ( $self->offset ) {
 695         my $data_section = $self->size - 3 - 1 * $engine->byte_size;
 696
 697         my $data = delete $self->{data};
 698
 699         $self->{offset} = $engine->_request_sector( $self->size );
 700
 701         my $dlen = length $data;
 702         my $continue = 1;
 703         my $curr_offset = $self->offset;
 704         while ( $continue ) {
 705
 706             my $next_offset = 0;
 707
 708             my ($leftover, $this_len, $chunk);
 709             if ( $dlen > $data_section ) {
 710                 $leftover = 0;
 711                 $this_len = $data_section;
 712                 $chunk = substr( $data, 0, $this_len );
 713
 714                 $dlen -= $data_section;
 715                 $next_offset = $engine->_request_sector( $self->size );
 716                 $data = substr( $data, $this_len );
 717             }
 718             else {
 719                 $leftover = $data_section - $dlen;
 720                 $this_len = $dlen;
 721                 $chunk = $data;
 722
 723                 $continue = 0;
 724             }
 725
 726             $engine->storage->print_at( $curr_offset,
 727                 $self->type,                                     # Sector type
 728                 pack( $StP{1}, 0 ),                              # Recycled counter
 729                 pack( $StP{$engine->byte_size}, $next_offset ),  # Chain loc
 730                 pack( $StP{1}, $this_len ),                      # Data length
 731                 $chunk,                                          # Data to be stored in this sector
 732                 chr(0) x $leftover,                              # Zero-fill the rest
 733             );
 734
 735             $curr_offset = $next_offset;
 736         }
 737
 738         return;
 739     }
 740 }
 741
 742 sub data_length {
 743     my $self = shift;
 744
 745     my $buffer = $self->engine->storage->read_at(
 746         $self->offset + 2 + $self->engine->byte_size, 1
 747     );
 748
 749     return unpack( $StP{1}, $buffer );
 750 }
 751
 752 sub chain_loc {
 753     my $self = shift;
 754     my $chain_loc = $self->engine->storage->read_at(
 755         $self->offset + 2, $self->engine->byte_size,
 756     );
 757     return unpack( $StP{$self->engine->byte_size}, $chain_loc );
 758 }
 759
 760 sub data {
 761     my $self = shift;
 762
 763     my $data;
 764     while ( 1 ) {
 765         my $chain_loc = $self->chain_loc;
 766
 767         $data .= $self->engine->storage->read_at(
 768             $self->offset + 2 + $self->engine->byte_size + 1, $self->data_length,
 769         );
 770
 771         last unless $chain_loc;
 772
 773         $self = $self->engine->_load_sector( $chain_loc );
 774     }
 775
 776     return $data;
 777 }
 778
 779 package DBM::Deep::Engine::Sector::Null;
 780
 781 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
 782
 783 sub type { $_[0]{engine}->SIG_NULL }
 784 sub data_length { 0 }
 785 sub data { return }
 786
 787 sub _init {
 788     my $self = shift;
 789
 790     my $engine = $self->engine;
 791
 792     unless ( $self->offset ) {
 793         my $leftover = $self->size - 3 - 1 * $engine->byte_size;
 794
 795         $self->{offset} = $engine->_request_sector( $self->size );
 796         $engine->storage->print_at( $self->offset,
 797             $self->type,                          # Sector type
 798             pack( $StP{1}, 0 ),                   # Recycled counter
 799             pack( $StP{$engine->byte_size}, 0 ),  # Chain loc
 800             pack( $StP{1}, $self->data_length ),  # Data length
 801             chr(0) x $leftover,                   # Zero-fill the rest
 802         );
 803
 804         return;
 805     }
 806 }
 807
 808 package DBM::Deep::Engine::Sector::Reference;
 809
 810 our @ISA = qw( DBM::Deep::Engine::Sector::Data );
 811
 812 sub _init {
 813     my $self = shift;
 814
 815     my $engine = $self->engine;
 816
 817     unless ( $self->offset ) {
 818         my $classname = Scalar::Util::blessed( delete $self->{data} );
 819         my $leftover = $self->size - 4 - 2 * $engine->byte_size;
 820
 821         my $class_offset = 0;
 822         if ( defined $classname ) {
 823             my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
 824                 engine => $self->engine,
 825                 data   => $classname,
 826             });
 827             $class_offset = $class_sector->offset;
 828         }
 829
 830         $self->{offset} = $engine->_request_sector( $self->size );
 831         $engine->storage->print_at( $self->offset,
 832             $self->type,                                     # Sector type
 833             pack( $StP{1}, 0 ),                              # Recycled counter
 834             pack( $StP{$engine->byte_size}, 0 ),             # Index/BList loc
 835             pack( $StP{$engine->byte_size}, $class_offset ), # Classname loc
 836             chr(0) x $leftover,                              # Zero-fill the rest
 837         );
 838
 839         return;
 840     }
 841
 842     $self->{type} = $engine->storage->read_at( $self->offset, 1 );
 843
 844     return;
 845 }
 846
 847 sub get_blist_loc {
 848     my $self = shift;
 849
 850     my $engine = $self->engine;
 851     my $blist_loc = $engine->storage->read_at( $self->offset + 2, $engine->byte_size );
 852     return unpack( $StP{$engine->byte_size}, $blist_loc );
 853 }
 854
 855 sub get_bucket_list {
 856     my $self = shift;
 857     my ($args) = @_;
 858     $args ||= {};
 859
 860     # XXX Add in check here for recycling?
 861
 862     my $engine = $self->engine;
 863
 864     my $blist_loc = $self->get_blist_loc;
 865
 866     # There's no index or blist yet
 867     unless ( $blist_loc ) {
 868         return unless $args->{create};
 869
 870         my $blist = DBM::Deep::Engine::Sector::BucketList->new({
 871             engine => $engine,
 872         });
 873         $engine->storage->print_at( $self->offset + 2,
 874             pack( $StP{$engine->byte_size}, $blist->offset ),
 875         );
 876         return $blist;
 877     }
 878
 879     return DBM::Deep::Engine::Sector::BucketList->new({
 880         engine => $engine,
 881         offset => $blist_loc,
 882     });
 883 }
 884
 885 sub get_classname {
 886     my $self = shift;
 887
 888     my $class_offset = $self->engine->storage->read_at(
 889         $self->offset + 2 + 1 * $self->engine->byte_size, $self->engine->byte_size,
 890     );
 891     $class_offset = unpack ( $StP{$self->engine->byte_size}, $class_offset );
 892
 893     return unless $class_offset;
 894
 895     return $self->engine->_load_sector( $class_offset )->data;
 896 }
 897
 898 sub data {
 899     my $self = shift;
 900
 901     my $new_obj = DBM::Deep->new({
 902         type        => $self->type,
 903         base_offset => $self->offset,
 904         storage     => $self->engine->storage,
 905         engine      => $self->engine,
 906     });
 907
 908     if ( $self->engine->storage->{autobless} ) {
 909         my $classname = $self->get_classname;
 910         if ( defined $classname ) {
 911             bless $new_obj, $classname;
 912         }
 913     }
 914
 915     return $new_obj;
 916 }
 917
 918 package DBM::Deep::Engine::Sector::BucketList;
 919
 920 our @ISA = qw( DBM::Deep::Engine::Sector );
 921
 922 sub idx_for_txn { return $_[1] + 1 }
 923
 924 sub _init {
 925     my $self = shift;
 926
 927     my $engine = $self->engine;
 928
 929     unless ( $self->offset ) {
 930         my $leftover = $self->size - $self->base_size;
 931
 932         $self->{offset} = $engine->_request_sector( $self->size );
 933         $engine->storage->print_at( $self->offset,
 934             $engine->SIG_BLIST, # Sector type
 935             pack( $StP{1}, 0 ), # Recycled counter
 936             chr(0) x $leftover, # Zero-fill the data
 937         );
 938     }
 939
 940     return $self;
 941 }
 942
 943 sub base_size { 2 } # Sig + recycled counter
 944
 945 sub size {
 946     my $self = shift;
 947     my $e = $self->engine;
 948     return $self->base_size + $e->max_buckets * $self->bucket_size; # Base + numbuckets * bucketsize
 949 }
 950
 951 sub bucket_size {
 952     my $self = shift;
 953     my $e = $self->engine;
 954     # Key + transactions
 955     my $locs_size = (1 + $e->num_txns ) * $e->byte_size;
 956     return $e->hash_size + $locs_size;
 957 }
 958
 959 sub has_md5 {
 960     my $self = shift;
 961     my ($found, $idx) = $self->find_md5( @_ );
 962     return $found;
 963 }
 964
 965 sub find_md5 {
 966     my $self = shift;
 967     my ($md5, $opts) = @_;
 968     $opts ||= {};
 969
 970     foreach my $idx ( 0 .. $self->engine->max_buckets - 1 ) {
 971         my $potential = $self->engine->storage->read_at(
 972             $self->offset + $self->base_size + $idx * $self->bucket_size, $self->engine->hash_size,
 973         );
 974
 975         return (undef, $idx) if $potential eq $self->engine->blank_md5;
 976         if ( $md5 eq $potential ) {
 977             my $location = $self->get_data_location_for(
 978                 $self->engine->trans_id, $idx, $opts,
 979             );
 980
 981             if ( $location > 1 ) {
 982                 return (1, $idx);
 983             }
 984
 985             return (undef, $idx);
 986         }
 987     }
 988
 989     return;
 990 }
 991
 992 sub write_md5 {
 993     my $self = shift;
 994     my ($md5, $key, $value_loc) = @_;
 995
 996     my $engine = $self->engine;
 997     my ($found, $idx) = $self->find_md5( $md5, { allow_head => 0 } );
 998     my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size;
 999
1000     unless ($found) {
1001         my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({
1002             engine => $self->engine,
1003             data   => $key,
1004         });
1005
1006         $engine->storage->print_at( $spot,
1007             $md5,
1008             pack( $StP{$self->engine->byte_size}, $key_sector->offset ),
1009         );
1010     }
1011
1012     $engine->storage->print_at(
1013         $spot
1014       + $self->engine->hash_size
1015       + $self->engine->byte_size
1016       + $self->engine->trans_id * $self->engine->byte_size,
1017         pack( $StP{$engine->byte_size}, $value_loc ), # The pointer to the data in the HEAD
1018     );
1019 }
1020
1021 sub delete_md5 {
1022     my $self = shift;
1023     my ($md5) = @_;
1024
1025     my $engine = $self->engine;
1026     my ($found, $idx) = $self->find_md5( $md5, { allow_head => 0 } );
1027     return undef unless $found;
1028
1029     # Save the location so that we can free the data
1030     my $location = $self->get_data_location_for( $self->engine->trans_id, $idx, { allow_head => 0 } );
1031     my $key_sector = $self->get_key_for( $idx );
1032
1033     my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size;
1034     $engine->storage->print_at( $spot,
1035         $engine->storage->read_at(
1036             $spot + $self->bucket_size,
1037             $self->bucket_size * ( $engine->num_txns - $idx - 1 ),
1038         ),
1039         chr(0) x $self->bucket_size,
1040     );
1041
1042     $key_sector->free;
1043
1044     my $data_sector = $self->engine->_load_sector( $location );
1045     my $data = $data_sector->data;
1046     $data_sector->free;
1047
1048     return $data;
1049 }
1050
1051 sub get_data_location_for {
1052     my $self = shift;
1053     my ($trans_id, $idx, $opts) = @_;
1054     $opts ||= {};
1055
1056     my $location = $self->engine->storage->read_at(
1057         $self->offset + $self->base_size
1058       + $idx * $self->bucket_size
1059       + $self->engine->hash_size
1060       + $self->engine->byte_size
1061       + $trans_id * $self->engine->byte_size,
1062         $self->engine->byte_size,
1063     );
1064     my $loc = unpack( $StP{$self->engine->byte_size}, $location );
1065
1066     # If we're in a transaction and we never wrote to this location, try the
1067     # HEAD instead.
1068     if ( $trans_id && !$loc && $opts->{allow_head} ) {
1069         return $self->get_data_location_for( 0, $idx );
1070     }
1071     return $loc;
1072 }
1073
1074 sub get_data_for {
1075     my $self = shift;
1076     my ($md5, $opts) = @_;
1077     $opts ||= {};
1078
1079     my ($found, $idx) = $self->find_md5( $md5, $opts );
1080     return unless $found;
1081     my $location = $self->get_data_location_for( $self->engine->trans_id, $idx, $opts );
1082     return $self->engine->_load_sector( $location );
1083 }
1084
1085 sub get_key_for {
1086     my $self = shift;
1087     my ($idx) = @_;
1088
1089     my $location = $self->engine->storage->read_at(
1090         $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size,
1091         $self->engine->byte_size,
1092     );
1093     $location = unpack( $StP{$self->engine->byte_size}, $location );
1094     return unless $location;
1095     return $self->engine->_load_sector( $location );
1096 }
1097
1098 1;
1099 __END__