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