Phantom reads because transactional writes aren't deleted yet have been fixed
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Engine.pm
CommitLineData
a20d9a3f 1package DBM::Deep::Engine;
2
460b1067 3use 5.6.0;
4
a20d9a3f 5use strict;
460b1067 6use warnings;
a20d9a3f 7
633df1fd 8use Fcntl qw( :DEFAULT :flock );
359a01ac 9use Scalar::Util ();
a20d9a3f 10
21838116 11# File-wide notes:
20b7f047 12# * To add to bucket_size, make sure you modify the following:
13# - calculate_sizes()
14# - _get_key_subloc()
15# - add_bucket() - where the buckets are printed
21838116 16
8db25060 17##
18# Setup file and tag signatures. These should never change.
19##
20sub SIG_FILE () { 'DPDB' }
460b1067 21sub SIG_HEADER () { 'h' }
8db25060 22sub SIG_INTERNAL () { 'i' }
23sub SIG_HASH () { 'H' }
24sub SIG_ARRAY () { 'A' }
8db25060 25sub SIG_NULL () { 'N' }
26sub SIG_DATA () { 'D' }
27sub SIG_INDEX () { 'I' }
28sub SIG_BLIST () { 'B' }
7b1e1aa1 29sub SIG_FREE () { 'F' }
8db25060 30sub SIG_SIZE () { 1 }
31
612969fb 32sub new {
33 my $class = shift;
34 my ($args) = @_;
35
36 my $self = bless {
37 long_size => 4,
38 long_pack => 'N',
39 data_size => 4,
40 data_pack => 'N',
251dfd0e 41
612969fb 42 digest => \&Digest::MD5::md5,
43 hash_size => 16,
251dfd0e 44
81d16922 45 ##
d5d7c51d 46 # Maximum number of buckets per list before another level of indexing is
e0098e7f 47 # done. Increase this value for slightly greater speed, but larger database
d5d7c51d 48 # files. DO NOT decrease this value below 16, due to risk of recursive
49 # reindex overrun.
81d16922 50 ##
612969fb 51 max_buckets => 16,
460b1067 52
53 fileobj => undef,
359a01ac 54 obj => undef,
612969fb 55 }, $class;
56
e0098e7f 57 if ( defined $args->{pack_size} ) {
58 if ( lc $args->{pack_size} eq 'small' ) {
59 $args->{long_size} = 2;
c9b6d0d8 60 $args->{long_pack} = 'n';
e0098e7f 61 }
62 elsif ( lc $args->{pack_size} eq 'medium' ) {
63 $args->{long_size} = 4;
64 $args->{long_pack} = 'N';
65 }
66 elsif ( lc $args->{pack_size} eq 'large' ) {
67 $args->{long_size} = 8;
68 $args->{long_pack} = 'Q';
69 }
70 else {
71 die "Unknown pack_size value: '$args->{pack_size}'\n";
72 }
73 }
74
fde3db1a 75 # Grab the parameters we want to use
76 foreach my $param ( keys %$self ) {
77 next unless exists $args->{$param};
3e9498a1 78 $self->{$param} = $args->{$param};
fde3db1a 79 }
359a01ac 80 Scalar::Util::weaken( $self->{obj} ) if $self->{obj};
fde3db1a 81
e0098e7f 82 if ( $self->{max_buckets} < 16 ) {
83 warn "Floor of max_buckets is 16. Setting it to 16 from '$self->{max_buckets}'\n";
84 $self->{max_buckets} = 16;
85 }
86
260a80b4 87 return $self;
88}
89
460b1067 90sub _fileobj { return $_[0]{fileobj} }
460b1067 91
260a80b4 92sub calculate_sizes {
93 my $self = shift;
94
633df1fd 95 # The 2**8 here indicates the number of different characters in the
96 # current hashing algorithm
28394a1a 97 #XXX Does this need to be updated with different hashing algorithms?
e0098e7f 98 $self->{index_size} = (2**8) * $self->{long_size};
28394a1a 99 $self->{bucket_size} = $self->{hash_size} + $self->{long_size} * 3;
e0098e7f 100 $self->{bucket_list_size} = $self->{max_buckets} * $self->{bucket_size};
612969fb 101
260a80b4 102 return;
1bf65be7 103}
104
fde3db1a 105sub write_file_header {
0d0f3d5d 106 my $self = shift;
0d0f3d5d 107
019404df 108 my $loc = $self->_fileobj->request_space( length( SIG_FILE ) + 21 );
0d0f3d5d 109
019404df 110 $self->_fileobj->print_at( $loc,
260a80b4 111 SIG_FILE,
460b1067 112 SIG_HEADER,
113 pack('N', 1), # header version
114 pack('N', 12), # header size
15ba72cc 115 pack('N', 0), # currently running transaction IDs
c9b6d0d8 116 pack('n', $self->{long_size}),
260a80b4 117 pack('A', $self->{long_pack}),
c9b6d0d8 118 pack('n', $self->{data_size}),
260a80b4 119 pack('A', $self->{data_pack}),
c9b6d0d8 120 pack('n', $self->{max_buckets}),
260a80b4 121 );
0d0f3d5d 122
20b7f047 123 $self->_fileobj->set_transaction_offset( 13 );
124
0d0f3d5d 125 return;
126}
127
fde3db1a 128sub read_file_header {
e064ccd1 129 my $self = shift;
e064ccd1 130
7dcefff3 131 my $buffer = $self->_fileobj->read_at( 0, length(SIG_FILE) + 9 );
132 return unless length($buffer);
460b1067 133
134 my ($file_signature, $sig_header, $header_version, $size) = unpack(
135 'A4 A N N', $buffer
42f79e07 136 );
e064ccd1 137
460b1067 138 unless ( $file_signature eq SIG_FILE ) {
15ba72cc 139 $self->_fileobj->close;
e96daec8 140 $self->_throw_error( "Signature not found -- file is not a Deep DB" );
460b1067 141 }
260a80b4 142
460b1067 143 unless ( $sig_header eq SIG_HEADER ) {
15ba72cc 144 $self->_fileobj->close;
e96daec8 145 $self->_throw_error( "Old file version found." );
460b1067 146 }
9b2370e0 147
7dcefff3 148 my $buffer2 = $self->_fileobj->read_at( undef, $size );
c9b6d0d8 149 my ($running_transactions, @values) = unpack( 'N n A n A n', $buffer2 );
15ba72cc 150
151 $self->_fileobj->set_transaction_offset( 13 );
152
460b1067 153 if ( @values < 5 || grep { !defined } @values ) {
15ba72cc 154 $self->_fileobj->close;
e96daec8 155 $self->_throw_error("Corrupted file - bad header");
e064ccd1 156 }
157
460b1067 158 #XXX Add warnings if values weren't set right
159 @{$self}{qw(long_size long_pack data_size data_pack max_buckets)} = @values;
160
7dcefff3 161 return length($buffer) + length($buffer2);
e064ccd1 162}
163
460b1067 164sub setup_fh {
165 my $self = shift;
166 my ($obj) = @_;
70b55428 167
7dcefff3 168 # Need to remove use of $fh here
169 my $fh = $self->_fileobj->{fh};
6fde4ed2 170 flock $fh, LOCK_EX;
118ba343 171
260a80b4 172 #XXX The duplication of calculate_sizes needs to go away
6fde4ed2 173 unless ( $obj->{base_offset} ) {
e96daec8 174 my $bytes_read = $self->read_file_header;
118ba343 175
260a80b4 176 $self->calculate_sizes;
177
118ba343 178 ##
fde3db1a 179 # File is empty -- write header and master index
118ba343 180 ##
181 if (!$bytes_read) {
aa83bc1e 182 $self->_fileobj->audit( "# Database created on" );
359a01ac 183
e96daec8 184 $self->write_file_header;
118ba343 185
019404df 186 $obj->{base_offset} = $self->_fileobj->request_space( $self->tag_size( $self->{index_size} ) );
118ba343 187
9e4f83a0 188 $self->write_tag(
e96daec8 189 $obj->_base_offset, $obj->_type,
f37c15ab 190 chr(0)x$self->{index_size},
118ba343 191 );
192
193 # Flush the filehandle
194 my $old_fh = select $fh;
195 my $old_af = $|; $| = 1; $| = $old_af;
196 select $old_fh;
197 }
198 else {
199 $obj->{base_offset} = $bytes_read;
200
201 ##
fde3db1a 202 # Get our type from master index header
118ba343 203 ##
359a01ac 204 my $tag = $self->load_tag($obj->_base_offset);
205 unless ( $tag ) {
206 flock $fh, LOCK_UN;
207 $self->_throw_error("Corrupted file, no master index record");
208 }
118ba343 209
e96daec8 210 unless ($obj->_type eq $tag->{signature}) {
359a01ac 211 flock $fh, LOCK_UN;
e96daec8 212 $self->_throw_error("File type mismatch");
118ba343 213 }
214 }
118ba343 215 }
260a80b4 216 else {
217 $self->calculate_sizes;
218 }
e06824f8 219
673464d9 220 #XXX We have to make sure we don't mess up when autoflush isn't turned on
7dcefff3 221 $self->_fileobj->set_inode;
70b55428 222
6fde4ed2 223 flock $fh, LOCK_UN;
224
70b55428 225 return 1;
226}
227
16d1ad9b 228sub tag_size {
229 my $self = shift;
230 my ($size) = @_;
231 return SIG_SIZE + $self->{data_size} + $size;
232}
233
9e4f83a0 234sub write_tag {
20f7b20c 235 ##
236 # Given offset, signature and content, create tag and write to disk
237 ##
d4b1166e 238 my $self = shift;
e96daec8 239 my ($offset, $sig, $content) = @_;
f37c15ab 240 my $size = length( $content );
20f7b20c 241
7dcefff3 242 $self->_fileobj->print_at(
243 $offset,
244 $sig, pack($self->{data_pack}, $size), $content,
245 );
20f7b20c 246
f37c15ab 247 return unless defined $offset;
248
20f7b20c 249 return {
250 signature => $sig,
251 size => $size,
8db25060 252 offset => $offset + SIG_SIZE + $self->{data_size},
20f7b20c 253 content => $content
254 };
d4b1166e 255}
256
257sub load_tag {
20f7b20c 258 ##
259 # Given offset, load single tag and return signature, size and data
260 ##
d4b1166e 261 my $self = shift;
e96daec8 262 my ($offset) = @_;
20f7b20c 263
7dcefff3 264 my $fileobj = $self->_fileobj;
20f7b20c 265
7dcefff3 266 my $s = SIG_SIZE + $self->{data_size};
267 my $b = $fileobj->read_at( $offset, $s );
251dfd0e 268 my ($sig, $size) = unpack( "A $self->{data_pack}", $b );
20f7b20c 269
7dcefff3 270 my $buffer = $fileobj->read_at( undef, $size );
20f7b20c 271
272 return {
273 signature => $sig,
274 size => $size,
8db25060 275 offset => $offset + SIG_SIZE + $self->{data_size},
20f7b20c 276 content => $buffer
277 };
d4b1166e 278}
279
56ec4340 280sub _get_dbm_object {
281 my $item = shift;
282
283 my $obj = eval {
284 local $SIG{__DIE__};
285 if ($item->isa( 'DBM::Deep' )) {
286 return $item;
287 }
288 return;
289 };
290 return $obj if $obj;
291
292 my $r = Scalar::Util::reftype( $item ) || '';
293 if ( $r eq 'HASH' ) {
294 my $obj = eval {
295 local $SIG{__DIE__};
296 my $obj = tied(%$item);
297 if ($obj->isa( 'DBM::Deep' )) {
298 return $obj;
299 }
300 return;
301 };
302 return $obj if $obj;
303 }
304 elsif ( $r eq 'ARRAY' ) {
305 my $obj = eval {
306 local $SIG{__DIE__};
307 my $obj = tied(@$item);
308 if ($obj->isa( 'DBM::Deep' )) {
309 return $obj;
310 }
311 return;
312 };
313 return $obj if $obj;
314 }
315
316 return;
317}
318
29b01632 319sub _length_needed {
320 my $self = shift;
e96daec8 321 my ($value, $key) = @_;
29b01632 322
323 my $is_dbm_deep = eval {
324 local $SIG{'__DIE__'};
325 $value->isa( 'DBM::Deep' );
326 };
327
633df1fd 328 my $len = SIG_SIZE
329 + $self->{data_size} # size for value
330 + $self->{data_size} # size for key
331 + length( $key ); # length of key
29b01632 332
e96daec8 333 if ( $is_dbm_deep && $value->_fileobj eq $self->_fileobj ) {
633df1fd 334 # long_size is for the internal reference
f37c15ab 335 return $len + $self->{long_size};
29b01632 336 }
337
e96daec8 338 if ( $self->_fileobj->{autobless} ) {
9a187d8c 339 # This is for the bit saying whether or not this thing is blessed.
340 $len += 1;
341 }
342
633df1fd 343 my $r = Scalar::Util::reftype( $value ) || '';
29b01632 344 unless ( $r eq 'HASH' || $r eq 'ARRAY' ) {
f37c15ab 345 if ( defined $value ) {
346 $len += length( $value );
347 }
348 return $len;
29b01632 349 }
350
f37c15ab 351 $len += $self->{index_size};
29b01632 352
353 # if autobless is enabled, must also take into consideration
f37c15ab 354 # the class name as it is stored after the key.
e96daec8 355 if ( $self->_fileobj->{autobless} ) {
56ec4340 356 my $c = Scalar::Util::blessed($value);
357 if ( defined $c && !$is_dbm_deep ) {
358 $len += $self->{data_size} + length($c);
29b01632 359 }
360 }
361
f37c15ab 362 return $len;
29b01632 363}
364
20f7b20c 365sub add_bucket {
366 ##
367 # Adds one key/value pair to bucket list, given offset, MD5 digest of key,
368 # plain (undigested) key and value.
369 ##
d4b1166e 370 my $self = shift;
359a01ac 371 my ($tag, $md5, $plain_key, $value, $deleted, $orig_key) = @_;
c9b6d0d8 372 $deleted ||= 0;
75be6413 373
21838116 374 local($/,$\);
375
eea0d863 376 # This verifies that only supported values will be stored.
377 {
378 my $r = Scalar::Util::reftype( $value );
379 last if !defined $r;
380
381 last if $r eq 'HASH';
382 last if $r eq 'ARRAY';
383
e96daec8 384 $self->_throw_error(
eea0d863 385 "Storage of variables of type '$r' is not supported."
386 );
387 }
388
20f7b20c 389 my $location = 0;
390 my $result = 2;
391
019404df 392 my $fileobj = $self->_fileobj;
20f7b20c 393
e96daec8 394 my $actual_length = $self->_length_needed( $value, $plain_key );
20f7b20c 395
21838116 396 #ACID - This is a mutation. Must only find the exact transaction
c9b6d0d8 397 my ($subloc, $offset, $size,$is_deleted) = $self->_find_in_buckets( $tag, $md5, 1 );
398
399 my @transactions;
019404df 400 if ( $fileobj->transaction_id == 0 ) {
401 @transactions = $fileobj->current_transactions;
c9b6d0d8 402 }
75be6413 403
e96daec8 404# $self->_release_space( $size, $subloc );
386bab6c 405 # Updating a known md5
f9c33187 406#XXX This needs updating to use _release_space
386bab6c 407 if ( $subloc ) {
408 $result = 1;
20f7b20c 409
386bab6c 410 if ($actual_length <= $size) {
411 $location = $subloc;
20f7b20c 412 }
75be6413 413 else {
019404df 414 $location = $fileobj->request_space( $actual_length );
415
416 $fileobj->print_at( $tag->{offset} + $offset + $self->{hash_size},
417 pack($self->{long_pack}, $location ),
418 pack($self->{long_pack}, $actual_length ),
419 pack('n n', $fileobj->transaction_id, $deleted ),
386bab6c 420 );
75be6413 421 }
75be6413 422 }
386bab6c 423 # Adding a new md5
424 elsif ( defined $offset ) {
019404df 425 $location = $fileobj->request_space( $actual_length );
386bab6c 426
019404df 427 $fileobj->print_at( $tag->{offset} + $offset,
428 $md5,
429 pack($self->{long_pack}, $location ),
430 pack($self->{long_pack}, $actual_length ),
431 pack('n n', $fileobj->transaction_id, $deleted ),
432 );
c9b6d0d8 433
434 for ( @transactions ) {
435 my $tag2 = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
019404df 436 $fileobj->{transaction_id} = $_;
359a01ac 437 $self->add_bucket( $tag2, $md5, '', '', 1, $orig_key );
019404df 438 $fileobj->{transaction_id} = 0;
c9b6d0d8 439 }
386bab6c 440 }
441 # If bucket didn't fit into list, split into a new index level
019404df 442 # split_index() will do the _fileobj->request_space() call
386bab6c 443 else {
e96daec8 444 $location = $self->split_index( $md5, $tag );
386bab6c 445 }
20f7b20c 446
359a01ac 447 $self->write_value( $location, $plain_key, $value, $orig_key );
d5d7c51d 448
449 return $result;
450}
451
452sub write_value {
453 my $self = shift;
359a01ac 454 my ($location, $key, $value, $orig_key) = @_;
d5d7c51d 455
7dcefff3 456 my $fileobj = $self->_fileobj;
d5d7c51d 457
9d4fa373 458 my $dbm_deep_obj = _get_dbm_object( $value );
7dcefff3 459 if ( $dbm_deep_obj && $dbm_deep_obj->_fileobj ne $fileobj ) {
e96daec8 460 $self->_throw_error( "Cannot cross-reference. Use export() instead" );
9d4fa373 461 }
d5d7c51d 462
20f7b20c 463 ##
d5d7c51d 464 # Write signature based on content type, set content length and write
465 # actual value.
20f7b20c 466 ##
9d4fa373 467 my $r = Scalar::Util::reftype( $value ) || '';
468 if ( $dbm_deep_obj ) {
7dcefff3 469 $self->write_tag( $location, SIG_INTERNAL,pack($self->{long_pack}, $dbm_deep_obj->_base_offset) );
f37c15ab 470 }
471 elsif ($r eq 'HASH') {
9d4fa373 472 if ( !$dbm_deep_obj && tied %{$value} ) {
e96daec8 473 $self->_throw_error( "Cannot store something that is tied" );
019ab3a1 474 }
7dcefff3 475 $self->write_tag( $location, SIG_HASH, chr(0)x$self->{index_size} );
f37c15ab 476 }
477 elsif ($r eq 'ARRAY') {
9d4fa373 478 if ( !$dbm_deep_obj && tied @{$value} ) {
e96daec8 479 $self->_throw_error( "Cannot store something that is tied" );
019ab3a1 480 }
7dcefff3 481 $self->write_tag( $location, SIG_ARRAY, chr(0)x$self->{index_size} );
f37c15ab 482 }
483 elsif (!defined($value)) {
7dcefff3 484 $self->write_tag( $location, SIG_NULL, '' );
d5d7c51d 485 }
486 else {
7dcefff3 487 $self->write_tag( $location, SIG_DATA, $value );
d5d7c51d 488 }
20f7b20c 489
d5d7c51d 490 ##
491 # Plain key is stored AFTER value, as keys are typically fetched less often.
492 ##
7dcefff3 493 $fileobj->print_at( undef, pack($self->{data_pack}, length($key)) . $key );
20f7b20c 494
9a187d8c 495 # Internal references don't care about autobless
9d4fa373 496 return 1 if $dbm_deep_obj;
9a187d8c 497
d5d7c51d 498 ##
499 # If value is blessed, preserve class name
500 ##
7dcefff3 501 if ( $fileobj->{autobless} ) {
633df1fd 502 if ( defined( my $c = Scalar::Util::blessed($value) ) ) {
7dcefff3 503 $fileobj->print_at( undef, chr(1), pack($self->{data_pack}, length($c)) . $c );
20f7b20c 504 }
d5d7c51d 505 else {
7dcefff3 506 $fileobj->print_at( undef, chr(0) );
20f7b20c 507 }
d5d7c51d 508 }
20f7b20c 509
d5d7c51d 510 ##
56ec4340 511 # Tie the passed in reference so that changes to it are reflected in the
512 # datafile. The use of $location as the base_offset will act as the
513 # the linkage between parent and child.
514 #
515 # The overall assignment is a hack around the fact that just tying doesn't
516 # store the values. This may not be the wrong thing to do.
d5d7c51d 517 ##
9d4fa373 518 if ($r eq 'HASH') {
519 my %x = %$value;
520 tie %$value, 'DBM::Deep', {
521 base_offset => $location,
7dcefff3 522 fileobj => $fileobj,
359a01ac 523 parent => $self->{obj},
524 parent_key => $orig_key,
9d4fa373 525 };
526 %$value = %x;
527 }
528 elsif ($r eq 'ARRAY') {
529 my @x = @$value;
530 tie @$value, 'DBM::Deep', {
531 base_offset => $location,
7dcefff3 532 fileobj => $fileobj,
359a01ac 533 parent => $self->{obj},
534 parent_key => $orig_key,
9d4fa373 535 };
536 @$value = @x;
20f7b20c 537 }
d4b1166e 538
d5d7c51d 539 return 1;
d4b1166e 540}
541
75be6413 542sub split_index {
543 my $self = shift;
e96daec8 544 my ($md5, $tag) = @_;
75be6413 545
019404df 546 my $fileobj = $self->_fileobj;
21838116 547
019404df 548 my $loc = $fileobj->request_space(
e96daec8 549 $self->tag_size( $self->{index_size} ),
16d1ad9b 550 );
551
019404df 552 $fileobj->print_at( $tag->{ref_loc}, pack($self->{long_pack}, $loc) );
75be6413 553
9e4f83a0 554 my $index_tag = $self->write_tag(
e96daec8 555 $loc, SIG_INDEX,
f37c15ab 556 chr(0)x$self->{index_size},
75be6413 557 );
558
019404df 559 my $newtag_loc = $fileobj->request_space(
e96daec8 560 $self->tag_size( $self->{bucket_list_size} ),
f9c33187 561 );
75be6413 562
7b1e1aa1 563 my $keys = $tag->{content}
f9c33187 564 . $md5 . pack($self->{long_pack}, $newtag_loc)
28394a1a 565 . pack($self->{long_pack}, 0) # size
20b7f047 566 . pack($self->{long_pack}, 0); # transaction ID
75be6413 567
f9c33187 568 my @newloc = ();
75be6413 569 BUCKET:
633df1fd 570 # The <= here is deliberate - we have max_buckets+1 keys to iterate
571 # through, unlike every other loop that uses max_buckets as a stop.
75be6413 572 for (my $i = 0; $i <= $self->{max_buckets}; $i++) {
9a187d8c 573 my ($key, $old_subloc, $size) = $self->_get_key_subloc( $keys, $i );
75be6413 574
f9c33187 575 die "[INTERNAL ERROR]: No key in split_index()\n" unless $key;
576 die "[INTERNAL ERROR]: No subloc in split_index()\n" unless $old_subloc;
75be6413 577
75be6413 578 my $num = ord(substr($key, $tag->{ch} + 1, 1));
579
f9c33187 580 if ($newloc[$num]) {
7dcefff3 581 my $subkeys = $fileobj->read_at( $newloc[$num], $self->{bucket_list_size} );
75be6413 582
f9c33187 583 # This is looking for the first empty spot
7b1e1aa1 584 my ($subloc, $offset, $size) = $self->_find_in_buckets(
f9c33187 585 { content => $subkeys }, '',
7b1e1aa1 586 );
75be6413 587
633df1fd 588 $fileobj->print_at(
589 $newloc[$num] + $offset,
590 $key, pack($self->{long_pack}, $old_subloc),
591 );
7b1e1aa1 592
593 next;
75be6413 594 }
75be6413 595
019404df 596 my $loc = $fileobj->request_space(
e96daec8 597 $self->tag_size( $self->{bucket_list_size} ),
7b1e1aa1 598 );
2603d86e 599
019404df 600 $fileobj->print_at(
601 $index_tag->{offset} + ($num * $self->{long_size}),
602 pack($self->{long_pack}, $loc),
603 );
75be6413 604
7b1e1aa1 605 my $blist_tag = $self->write_tag(
e96daec8 606 $loc, SIG_BLIST,
7b1e1aa1 607 chr(0)x$self->{bucket_list_size},
608 );
609
019404df 610 $fileobj->print_at( $blist_tag->{offset}, $key . pack($self->{long_pack}, $old_subloc) );
7b1e1aa1 611
f9c33187 612 $newloc[$num] = $blist_tag->{offset};
7b1e1aa1 613 }
614
615 $self->_release_space(
e96daec8 616 $self->tag_size( $self->{bucket_list_size} ),
7b1e1aa1 617 $tag->{offset} - SIG_SIZE - $self->{data_size},
618 );
75be6413 619
f9c33187 620 return $newtag_loc;
75be6413 621}
622
8db25060 623sub read_from_loc {
624 my $self = shift;
359a01ac 625 my ($subloc, $orig_key) = @_;
8db25060 626
7dcefff3 627 my $fileobj = $self->_fileobj;
8db25060 628
7dcefff3 629 my $signature = $fileobj->read_at( $subloc, SIG_SIZE );
8db25060 630
631 ##
632 # If value is a hash or array, return new DBM::Deep object with correct offset
633 ##
634 if (($signature eq SIG_HASH) || ($signature eq SIG_ARRAY)) {
685e40f1 635 my $new_obj = DBM::Deep->new({
359a01ac 636 type => $signature,
8db25060 637 base_offset => $subloc,
e96daec8 638 fileobj => $self->_fileobj,
359a01ac 639 parent => $self->{obj},
640 parent_key => $orig_key,
685e40f1 641 });
8db25060 642
460b1067 643 if ($new_obj->_fileobj->{autobless}) {
8db25060 644 ##
645 # Skip over value and plain key to see if object needs
646 # to be re-blessed
647 ##
7dcefff3 648 $fileobj->increment_pointer( $self->{data_size} + $self->{index_size} );
8db25060 649
7dcefff3 650 my $size = $fileobj->read_at( undef, $self->{data_size} );
c6ea6b6c 651 $size = unpack($self->{data_pack}, $size);
7dcefff3 652 if ($size) { $fileobj->increment_pointer( $size ); }
8db25060 653
7dcefff3 654 my $bless_bit = $fileobj->read_at( undef, 1 );
8db25060 655 if (ord($bless_bit)) {
656 ##
657 # Yes, object needs to be re-blessed
658 ##
7dcefff3 659 my $size = $fileobj->read_at( undef, $self->{data_size} );
c6ea6b6c 660 $size = unpack($self->{data_pack}, $size);
7dcefff3 661
662 my $class_name;
663 if ($size) { $class_name = $fileobj->read_at( undef, $size ); }
664 if (defined $class_name) { $new_obj = bless( $new_obj, $class_name ); }
8db25060 665 }
666 }
667
685e40f1 668 return $new_obj;
8db25060 669 }
670 elsif ( $signature eq SIG_INTERNAL ) {
7dcefff3 671 my $size = $fileobj->read_at( undef, $self->{data_size} );
8db25060 672 $size = unpack($self->{data_pack}, $size);
673
674 if ( $size ) {
7dcefff3 675 my $new_loc = $fileobj->read_at( undef, $size );
676 $new_loc = unpack( $self->{long_pack}, $new_loc );
359a01ac 677 return $self->read_from_loc( $new_loc, $orig_key );
8db25060 678 }
679 else {
680 return;
681 }
682 }
683 ##
684 # Otherwise return actual value
685 ##
460b1067 686 elsif ( $signature eq SIG_DATA ) {
7dcefff3 687 my $size = $fileobj->read_at( undef, $self->{data_size} );
8db25060 688 $size = unpack($self->{data_pack}, $size);
689
690 my $value = '';
7dcefff3 691 if ($size) { $value = $fileobj->read_at( undef, $size ); }
8db25060 692 return $value;
693 }
694
695 ##
696 # Key exists, but content is null
697 ##
698 return;
699}
700
9020ee8c 701sub get_bucket_value {
beac1dff 702 ##
703 # Fetch single value given tag and MD5 digested key.
704 ##
705 my $self = shift;
359a01ac 706 my ($tag, $md5, $orig_key) = @_;
9020ee8c 707
21838116 708 #ACID - This is a read. Can find exact or HEAD
c9b6d0d8 709 my ($subloc, $offset, $size,$is_deleted) = $self->_find_in_buckets( $tag, $md5 );
710 if ( $subloc && !$is_deleted ) {
359a01ac 711 return $self->read_from_loc( $subloc, $orig_key );
386bab6c 712 }
beac1dff 713 return;
9020ee8c 714}
ab0e4957 715
716sub delete_bucket {
beac1dff 717 ##
718 # Delete single key/value pair given tag and MD5 digested key.
719 ##
720 my $self = shift;
a97c8f67 721 my ($tag, $md5, $orig_key) = @_;
ab0e4957 722
21838116 723 #ACID - This is a mutation. Must only find the exact transaction
633df1fd 724 my ($subloc, $offset, $size,$is_deleted) = $self->_find_in_buckets( $tag, $md5, 1 );
725
726 return if !$subloc;
727
728 my $fileobj = $self->_fileobj;
729
730 my @transactions;
731 if ( $fileobj->transaction_id == 0 ) {
732 @transactions = $fileobj->current_transactions;
733 }
734
735#XXX This code taken from add_bucket() as an example
736# for ( @transactions ) {
737# my $tag2 = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
738# $fileobj->{transaction_id} = $_;
739# $self->add_bucket( $tag2, $md5, '', '', 1, $orig_key );
740# $fileobj->{transaction_id} = 0;
741# }
742
743 #XXX This needs _release_space() for the value and anything below
744 if ( $fileobj->transaction_id == 0 ) {
745 my $value = $self->read_from_loc( $subloc, $orig_key );
746
747 for (@transactions) {
748# warn "Marking $_ $orig_key : $value as still there\n";
749 my $tag2 = $self->load_tag( $tag->{offset} - SIG_SIZE - $self->{data_size} );
750 $fileobj->{transaction_id} = $_;
751 #XXX Need to use real key
752 $self->add_bucket( $tag2, $md5, $orig_key, $value, 0, $orig_key );
753 $fileobj->{transaction_id} = 0;
754 }
755
756 $fileobj->print_at(
019404df 757 $tag->{offset} + $offset,
633df1fd 758 substr( $tag->{content}, $offset + $self->{bucket_size} ),
019404df 759 chr(0) x $self->{bucket_size},
760 );
386bab6c 761 }
633df1fd 762 else {
763 }
764
765 return 1;
ab0e4957 766}
767
912d50b1 768sub bucket_exists {
beac1dff 769 ##
770 # Check existence of single key given tag and MD5 digested key.
771 ##
772 my $self = shift;
e96daec8 773 my ($tag, $md5) = @_;
912d50b1 774
21838116 775 #ACID - This is a read. Can find exact or HEAD
c9b6d0d8 776 my ($subloc, $offset, $size, $is_deleted) = $self->_find_in_buckets( $tag, $md5 );
777 return ($subloc && !$is_deleted) && 1;
912d50b1 778}
779
6736c116 780sub find_bucket_list {
beac1dff 781 ##
782 # Locate offset for bucket list, given digested key
783 ##
784 my $self = shift;
e96daec8 785 my ($offset, $md5, $args) = @_;
d0b74c17 786 $args = {} unless $args;
787
21838116 788 local($/,$\);
789
beac1dff 790 ##
791 # Locate offset for bucket list using digest index system
792 ##
e96daec8 793 my $tag = $self->load_tag( $offset )
794 or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
d0b74c17 795
e5fc7e69 796 my $ch = 0;
8db25060 797 while ($tag->{signature} ne SIG_BLIST) {
d0b74c17 798 my $num = ord substr($md5, $ch, 1);
799
800 my $ref_loc = $tag->{offset} + ($num * $self->{long_size});
e96daec8 801 $tag = $self->index_lookup( $tag, $num );
d0b74c17 802
803 if (!$tag) {
29b01632 804 return if !$args->{create};
d0b74c17 805
019404df 806 my $loc = $self->_fileobj->request_space(
e96daec8 807 $self->tag_size( $self->{bucket_list_size} ),
16d1ad9b 808 );
809
019404df 810 $self->_fileobj->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
d0b74c17 811
9e4f83a0 812 $tag = $self->write_tag(
e96daec8 813 $loc, SIG_BLIST,
f37c15ab 814 chr(0)x$self->{bucket_list_size},
d5d7c51d 815 );
816
817 $tag->{ref_loc} = $ref_loc;
818 $tag->{ch} = $ch;
819
820 last;
d0b74c17 821 }
822
16d1ad9b 823 $tag->{ch} = $ch++;
d0b74c17 824 $tag->{ref_loc} = $ref_loc;
beac1dff 825 }
d0b74c17 826
beac1dff 827 return $tag;
6736c116 828}
829
d0b74c17 830sub index_lookup {
831 ##
832 # Given index tag, lookup single entry in index and return .
833 ##
834 my $self = shift;
e96daec8 835 my ($tag, $index) = @_;
d0b74c17 836
837 my $location = unpack(
838 $self->{long_pack},
839 substr(
840 $tag->{content},
841 $index * $self->{long_size},
842 $self->{long_size},
843 ),
844 );
845
846 if (!$location) { return; }
847
e96daec8 848 return $self->load_tag( $location );
d0b74c17 849}
850
6736c116 851sub traverse_index {
beac1dff 852 ##
853 # Scan index and recursively step into deeper levels, looking for next key.
854 ##
6736c116 855 my $self = shift;
856 my ($obj, $offset, $ch, $force_return_next) = @_;
d0b74c17 857
e96daec8 858 my $tag = $self->load_tag( $offset );
6736c116 859
8db25060 860 if ($tag->{signature} ne SIG_BLIST) {
beac1dff 861 my $content = $tag->{content};
e5fc7e69 862 my $start = $obj->{return_next} ? 0 : ord(substr($obj->{prev_md5}, $ch, 1));
d0b74c17 863
d5d7c51d 864 for (my $idx = $start; $idx < (2**8); $idx++) {
e5fc7e69 865 my $subloc = unpack(
866 $self->{long_pack},
e06824f8 867 substr(
868 $content,
869 $idx * $self->{long_size},
870 $self->{long_size},
871 ),
e5fc7e69 872 );
873
beac1dff 874 if ($subloc) {
e5fc7e69 875 my $result = $self->traverse_index(
876 $obj, $subloc, $ch + 1, $force_return_next,
877 );
878
beac1dff 879 if (defined($result)) { return $result; }
880 }
881 } # index loop
d0b74c17 882
beac1dff 883 $obj->{return_next} = 1;
884 } # tag is an index
d0b74c17 885
e5fc7e69 886 else {
beac1dff 887 my $keys = $tag->{content};
888 if ($force_return_next) { $obj->{return_next} = 1; }
d0b74c17 889
beac1dff 890 ##
891 # Iterate through buckets, looking for a key match
892 ##
8db25060 893 for (my $i = 0; $i < $self->{max_buckets}; $i++) {
9cec1360 894 my ($key, $subloc) = $self->_get_key_subloc( $keys, $i );
d0b74c17 895
8db25060 896 # End of bucket list -- return to outer loop
beac1dff 897 if (!$subloc) {
beac1dff 898 $obj->{return_next} = 1;
899 last;
900 }
8db25060 901 # Located previous key -- return next one found
beac1dff 902 elsif ($key eq $obj->{prev_md5}) {
beac1dff 903 $obj->{return_next} = 1;
904 next;
905 }
8db25060 906 # Seek to bucket location and skip over signature
beac1dff 907 elsif ($obj->{return_next}) {
7dcefff3 908 my $fileobj = $self->_fileobj;
d0b74c17 909
beac1dff 910 # Skip over value to get to plain key
7dcefff3 911 my $sig = $fileobj->read_at( $subloc, SIG_SIZE );
8db25060 912
7dcefff3 913 my $size = $fileobj->read_at( undef, $self->{data_size} );
e5fc7e69 914 $size = unpack($self->{data_pack}, $size);
7dcefff3 915 if ($size) { $fileobj->increment_pointer( $size ); }
d0b74c17 916
beac1dff 917 # Read in plain key and return as scalar
7dcefff3 918 $size = $fileobj->read_at( undef, $self->{data_size} );
e5fc7e69 919 $size = unpack($self->{data_pack}, $size);
7dcefff3 920 my $plain_key;
921 if ($size) { $plain_key = $fileobj->read_at( undef, $size); }
d0b74c17 922
beac1dff 923 return $plain_key;
924 }
8db25060 925 }
d0b74c17 926
beac1dff 927 $obj->{return_next} = 1;
928 } # tag is a bucket list
d0b74c17 929
beac1dff 930 return;
6736c116 931}
932
933sub get_next_key {
beac1dff 934 ##
935 # Locate next key, given digested previous one
936 ##
6736c116 937 my $self = shift;
938 my ($obj) = @_;
d0b74c17 939
beac1dff 940 $obj->{prev_md5} = $_[1] ? $_[1] : undef;
941 $obj->{return_next} = 0;
d0b74c17 942
beac1dff 943 ##
944 # If the previous key was not specifed, start at the top and
945 # return the first one found.
946 ##
947 if (!$obj->{prev_md5}) {
948 $obj->{prev_md5} = chr(0) x $self->{hash_size};
949 $obj->{return_next} = 1;
950 }
d0b74c17 951
beac1dff 952 return $self->traverse_index( $obj, $obj->_base_offset, 0 );
6736c116 953}
954
75be6413 955# Utilities
956
9cec1360 957sub _get_key_subloc {
75be6413 958 my $self = shift;
959 my ($keys, $idx) = @_;
960
c9b6d0d8 961 my ($key, $subloc, $size, $transaction_id, $is_deleted) = unpack(
28394a1a 962 # This is 'a', not 'A'. Please read the pack() documentation for the
963 # difference between the two and why it's important.
c9b6d0d8 964 "a$self->{hash_size} $self->{long_pack}2 n2",
75be6413 965 substr(
966 $keys,
9cec1360 967 ($idx * $self->{bucket_size}),
968 $self->{bucket_size},
75be6413 969 ),
970 );
971
c9b6d0d8 972 return ($key, $subloc, $size, $transaction_id, $is_deleted);
75be6413 973}
974
d608b06e 975sub _find_in_buckets {
976 my $self = shift;
21838116 977 my ($tag, $md5, $exact) = @_;
d608b06e 978
28394a1a 979 my $trans_id = $self->_fileobj->transaction_id;
980
21838116 981 my @zero;
982
d608b06e 983 BUCKET:
984 for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
c9b6d0d8 985 my ($key, $subloc, $size, $transaction_id, $is_deleted) = $self->_get_key_subloc(
9a187d8c 986 $tag->{content}, $i,
987 );
d608b06e 988
c9b6d0d8 989 my @rv = ($subloc, $i * $self->{bucket_size}, $size, $is_deleted);
21838116 990
991 unless ( $subloc ) {
633df1fd 992 if ( !$exact && @zero && $trans_id ) {
c9b6d0d8 993 @rv = ($zero[2], $zero[0] * $self->{bucket_size},$zero[3],$is_deleted);
20b7f047 994 }
21838116 995 return @rv;
996 }
997
998 next BUCKET if $key ne $md5;
d608b06e 999
21838116 1000 # Save off the HEAD in case we need it.
c9b6d0d8 1001 @zero = ($i,$key,$subloc,$size,$transaction_id,$is_deleted) if $transaction_id == 0;
d608b06e 1002
21838116 1003 next BUCKET if $transaction_id != $trans_id;
1004
1005 return @rv;
d608b06e 1006 }
1007
1008 return;
1009}
1010
994ccd8e 1011sub _release_space {
1012 my $self = shift;
e96daec8 1013 my ($size, $loc) = @_;
994ccd8e 1014
7b1e1aa1 1015 my $next_loc = 0;
1016
019404df 1017 $self->_fileobj->print_at( $loc,
1018 SIG_FREE,
1019 pack($self->{long_pack}, $size ),
1020 pack($self->{long_pack}, $next_loc ),
7b1e1aa1 1021 );
1022
994ccd8e 1023 return;
1024}
1025
e96daec8 1026sub _throw_error {
1027 die "DBM::Deep: $_[1]\n";
1028}
1029
a20d9a3f 10301;
1031__END__