Moved a few things and started on the MySQL schema
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Engine / File.pm
CommitLineData
51e9eee3 1package DBM::Deep::Engine::File;
a20d9a3f 2
2120a181 3use 5.006_000;
460b1067 4
a20d9a3f 5use strict;
065b45be 6use warnings FATAL => 'all';
a20d9a3f 7
51e9eee3 8use base qw( DBM::Deep::Engine );
9
75a6a379 10use Scalar::Util ();
d6d8e27e 11
f0276afb 12use DBM::Deep::Null ();
2c70efe1 13use DBM::Deep::Sector::File ();
14use DBM::Deep::Storage::File ();
f0276afb 15
d6ecf579 16sub sector_type { 'DBM::Deep::Sector::File' }
17
9c87a079 18my $STALE_SIZE = 2;
8db25060 19
18bc2fa6 20# Setup file and tag signatures. These should never change.
21sub SIG_FILE () { 'DPDB' }
22sub SIG_HEADER () { 'h' }
23sub SIG_HASH () { 'H' }
24sub SIG_ARRAY () { 'A' }
25sub SIG_NULL () { 'N' }
26sub SIG_DATA () { 'D' }
27sub SIG_INDEX () { 'I' }
28sub SIG_BLIST () { 'B' }
29sub SIG_FREE () { 'F' }
30sub SIG_SIZE () { 1 }
31
2120a181 32# Please refer to the pack() documentation for further information
33my %StP = (
e9b0b5f0 34 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
2120a181 35 2 => 'n', # Unsigned short in "network" (big-endian) order
36 4 => 'N', # Unsigned long in "network" (big-endian) order
37 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
38);
00d9bd0b 39
ae6c15b8 40=head1 NAME
41
64a531e5 42DBM::Deep::Engine::File
ae6c15b8 43
44=head1 PURPOSE
45
64a531e5 46This is the engine for use with L<DBM::Deep::Storage::File/>.
ae6c15b8 47
48=head1 EXTERNAL METHODS
49
ae6c15b8 50=head2 new()
51
52This takes a set of args. These args are described in the documentation for
53L<DBM::Deep/new>.
54
55=cut
56
612969fb 57sub new {
58 my $class = shift;
59 my ($args) = @_;
60
d426259c 61 $args->{storage} = DBM::Deep::Storage::File->new( $args )
f1879fdc 62 unless exists $args->{storage};
63
612969fb 64 my $self = bless {
2120a181 65 byte_size => 4,
66
67 digest => undef,
68 hash_size => 16, # In bytes
69 hash_chars => 256, # Number of chars the algorithm uses per byte
612969fb 70 max_buckets => 16,
e9b0b5f0 71 num_txns => 1, # The HEAD
2120a181 72 trans_id => 0, # Default to the HEAD
460b1067 73
e9b0b5f0 74 data_sector_size => 64, # Size in bytes of each data sector
75
2120a181 76 entries => {}, # This is the list of entries for transactions
83371fe3 77 storage => undef,
612969fb 78 }, $class;
79
e9b0b5f0 80 # Never allow byte_size to be set directly.
81 delete $args->{byte_size};
e0098e7f 82 if ( defined $args->{pack_size} ) {
83 if ( lc $args->{pack_size} eq 'small' ) {
2120a181 84 $args->{byte_size} = 2;
e0098e7f 85 }
86 elsif ( lc $args->{pack_size} eq 'medium' ) {
2120a181 87 $args->{byte_size} = 4;
e0098e7f 88 }
89 elsif ( lc $args->{pack_size} eq 'large' ) {
2120a181 90 $args->{byte_size} = 8;
e0098e7f 91 }
92 else {
2120a181 93 DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
e0098e7f 94 }
95 }
96
fde3db1a 97 # Grab the parameters we want to use
98 foreach my $param ( keys %$self ) {
99 next unless exists $args->{$param};
3e9498a1 100 $self->{$param} = $args->{$param};
fde3db1a 101 }
102
e9b0b5f0 103 my %validations = (
104 max_buckets => { floor => 16, ceil => 256 },
105 num_txns => { floor => 1, ceil => 255 },
106 data_sector_size => { floor => 32, ceil => 256 },
107 );
108
109 while ( my ($attr, $c) = each %validations ) {
110 if ( !defined $self->{$attr}
111 || !length $self->{$attr}
112 || $self->{$attr} =~ /\D/
113 || $self->{$attr} < $c->{floor}
114 ) {
115 $self->{$attr} = '(undef)' if !defined $self->{$attr};
116 warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
117 $self->{$attr} = $c->{floor};
118 }
119 elsif ( $self->{$attr} > $c->{ceil} ) {
120 warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
121 $self->{$attr} = $c->{ceil};
122 }
e0098e7f 123 }
124
2120a181 125 if ( !$self->{digest} ) {
126 require Digest::MD5;
127 $self->{digest} = \&Digest::MD5::md5;
128 }
129
260a80b4 130 return $self;
131}
132
2120a181 133sub read_value {
c3aafc14 134 my $self = shift;
2120a181 135 my ($obj, $key) = @_;
136
137 # This will be a Reference sector
d6ecf579 138 my $sector = $self->load_sector( $obj->_base_offset )
2120a181 139 or return;
140
141 if ( $sector->staleness != $obj->_staleness ) {
142 return;
143 }
144
145 my $key_md5 = $self->_apply_digest( $key );
146
147 my $value_sector = $sector->get_data_for({
148 key_md5 => $key_md5,
149 allow_head => 1,
150 });
151
152 unless ( $value_sector ) {
2c70efe1 153 $value_sector = DBM::Deep::Sector::File::Null->new({
2120a181 154 engine => $self,
155 data => undef,
156 });
157
158 $sector->write_data({
159 key_md5 => $key_md5,
160 key => $key,
161 value => $value_sector,
162 });
163 }
164
165 return $value_sector->data;
c3aafc14 166}
167
2120a181 168sub get_classname {
260a80b4 169 my $self = shift;
2120a181 170 my ($obj) = @_;
260a80b4 171
2120a181 172 # This will be a Reference sector
d6ecf579 173 my $sector = $self->load_sector( $obj->_base_offset )
2120a181 174 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
612969fb 175
2120a181 176 if ( $sector->staleness != $obj->_staleness ) {
177 return;
178 }
ea2f6d67 179
2120a181 180 return $sector->get_classname;
1bf65be7 181}
182
1cff45d7 183sub make_reference {
184 my $self = shift;
185 my ($obj, $old_key, $new_key) = @_;
186
187 # This will be a Reference sector
d6ecf579 188 my $sector = $self->load_sector( $obj->_base_offset )
ae6c15b8 189 or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
1cff45d7 190
191 if ( $sector->staleness != $obj->_staleness ) {
192 return;
193 }
194
195 my $old_md5 = $self->_apply_digest( $old_key );
196
197 my $value_sector = $sector->get_data_for({
198 key_md5 => $old_md5,
199 allow_head => 1,
200 });
201
202 unless ( $value_sector ) {
2c70efe1 203 $value_sector = DBM::Deep::Sector::File::Null->new({
1cff45d7 204 engine => $self,
205 data => undef,
206 });
207
208 $sector->write_data({
209 key_md5 => $old_md5,
210 key => $old_key,
211 value => $value_sector,
212 });
213 }
214
2c70efe1 215 if ( $value_sector->isa( 'DBM::Deep::Sector::File::Reference' ) ) {
1cff45d7 216 $sector->write_data({
217 key => $new_key,
218 key_md5 => $self->_apply_digest( $new_key ),
219 value => $value_sector,
220 });
221 $value_sector->increment_refcount;
222 }
223 else {
224 $sector->write_data({
225 key => $new_key,
226 key_md5 => $self->_apply_digest( $new_key ),
227 value => $value_sector->clone,
228 });
229 }
ae6c15b8 230
231 return;
1cff45d7 232}
233
2120a181 234sub key_exists {
0d0f3d5d 235 my $self = shift;
2120a181 236 my ($obj, $key) = @_;
0d0f3d5d 237
2120a181 238 # This will be a Reference sector
d6ecf579 239 my $sector = $self->load_sector( $obj->_base_offset )
2120a181 240 or return '';
0d0f3d5d 241
2120a181 242 if ( $sector->staleness != $obj->_staleness ) {
243 return '';
244 }
0d0f3d5d 245
2120a181 246 my $data = $sector->get_data_for({
247 key_md5 => $self->_apply_digest( $key ),
248 allow_head => 1,
249 });
20b7f047 250
2120a181 251 # exists() returns 1 or '' for true/false.
252 return $data ? 1 : '';
0d0f3d5d 253}
254
2120a181 255sub delete_key {
e064ccd1 256 my $self = shift;
2120a181 257 my ($obj, $key) = @_;
e064ccd1 258
d6ecf579 259 my $sector = $self->load_sector( $obj->_base_offset )
2120a181 260 or return;
460b1067 261
2120a181 262 if ( $sector->staleness != $obj->_staleness ) {
263 return;
264 }
265
266 return $sector->delete_key({
267 key_md5 => $self->_apply_digest( $key ),
268 allow_head => 0,
269 });
270}
271
272sub write_value {
273 my $self = shift;
274 my ($obj, $key, $value) = @_;
275
276 my $r = Scalar::Util::reftype( $value ) || '';
277 {
278 last if $r eq '';
279 last if $r eq 'HASH';
280 last if $r eq 'ARRAY';
e064ccd1 281
2120a181 282 DBM::Deep->_throw_error(
283 "Storage of references of type '$r' is not supported."
284 );
460b1067 285 }
260a80b4 286
1cff45d7 287 # This will be a Reference sector
d6ecf579 288 my $sector = $self->load_sector( $obj->_base_offset )
9c87a079 289 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
1cff45d7 290
291 if ( $sector->staleness != $obj->_staleness ) {
9c87a079 292 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
1cff45d7 293 }
294
2120a181 295 my ($class, $type);
296 if ( !defined $value ) {
2c70efe1 297 $class = 'DBM::Deep::Sector::File::Null';
2120a181 298 }
299 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
75a6a379 300 my $tmpvar;
301 if ( $r eq 'ARRAY' ) {
302 $tmpvar = tied @$value;
303 } elsif ( $r eq 'HASH' ) {
304 $tmpvar = tied %$value;
305 }
5ef7542f 306
edd45134 307 if ( $tmpvar ) {
308 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
309
310 unless ( $is_dbm_deep ) {
311 DBM::Deep->_throw_error( "Cannot store something that is tied." );
312 }
313
d6d8e27e 314 unless ( $tmpvar->_engine->storage == $self->storage ) {
75a6a379 315 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
5ef7542f 316 }
5ef7542f 317
2c70efe1 318 # First, verify if we're storing the same thing to this spot. If we
319 # are, then this should be a no-op. -EJS, 2008-05-19
d6d8e27e 320 my $loc = $sector->get_data_location_for({
321 key_md5 => $self->_apply_digest( $key ),
322 allow_head => 1,
323 });
324
325 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
1cff45d7 326 return 1;
327 }
328
edd45134 329 #XXX Can this use $loc?
d6ecf579 330 my $value_sector = $self->load_sector( $tmpvar->_base_offset );
d6d8e27e 331 $sector->write_data({
332 key => $key,
333 key_md5 => $self->_apply_digest( $key ),
334 value => $value_sector,
335 });
336 $value_sector->increment_refcount;
337
338 return 1;
1cff45d7 339 }
edd45134 340
2c70efe1 341 $class = 'DBM::Deep::Sector::File::Reference';
2120a181 342 $type = substr( $r, 0, 1 );
343 }
344 else {
1cff45d7 345 if ( tied($value) ) {
346 DBM::Deep->_throw_error( "Cannot store something that is tied." );
347 }
2c70efe1 348 $class = 'DBM::Deep::Sector::File::Scalar';
460b1067 349 }
9b2370e0 350
2c70efe1 351 # Create this after loading the reference sector in case something bad
352 # happens. This way, we won't allocate value sector(s) needlessly.
2120a181 353 my $value_sector = $class->new({
354 engine => $self,
355 data => $value,
356 type => $type,
357 });
75a6a379 358
2120a181 359 $sector->write_data({
360 key => $key,
361 key_md5 => $self->_apply_digest( $key ),
362 value => $value_sector,
363 });
364
2c70efe1 365 # This code is to make sure we write all the values in the $value to the
366 # disk and to make sure all changes to $value after the assignment are
367 # reflected on disk. This may be counter-intuitive at first, but it is
368 # correct dwimmery.
369 # NOTE - simply tying $value won't perform a STORE on each value. Hence,
370 # the copy to a temp value.
2120a181 371 if ( $r eq 'ARRAY' ) {
372 my @temp = @$value;
373 tie @$value, 'DBM::Deep', {
374 base_offset => $value_sector->offset,
375 staleness => $value_sector->staleness,
376 storage => $self->storage,
377 engine => $self,
378 };
379 @$value = @temp;
380 bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
e064ccd1 381 }
2120a181 382 elsif ( $r eq 'HASH' ) {
383 my %temp = %$value;
384 tie %$value, 'DBM::Deep', {
385 base_offset => $value_sector->offset,
386 staleness => $value_sector->staleness,
387 storage => $self->storage,
388 engine => $self,
389 };
e064ccd1 390
2120a181 391 %$value = %temp;
392 bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
393 }
460b1067 394
2120a181 395 return 1;
e064ccd1 396}
397
f4d0ac97 398sub setup {
2120a181 399 my $self = shift;
400 my ($obj) = @_;
359a01ac 401
9c87a079 402 # We're opening the file.
403 unless ( $obj->_base_offset ) {
404 my $bytes_read = $self->_read_file_header;
118ba343 405
9c87a079 406 # Creating a new file
407 unless ( $bytes_read ) {
408 $self->_write_file_header;
118ba343 409
9c87a079 410 # 1) Create Array/Hash entry
2c70efe1 411 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
9c87a079 412 engine => $self,
413 type => $obj->_type,
414 });
415 $obj->{base_offset} = $initial_reference->offset;
416 $obj->{staleness} = $initial_reference->staleness;
118ba343 417
9c87a079 418 $self->storage->flush;
118ba343 419 }
9c87a079 420 # Reading from an existing file
421 else {
422 $obj->{base_offset} = $bytes_read;
2c70efe1 423 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
9c87a079 424 engine => $self,
425 offset => $obj->_base_offset,
426 });
427 unless ( $initial_reference ) {
428 DBM::Deep->_throw_error("Corrupted file, no master index record");
429 }
2120a181 430
9c87a079 431 unless ($obj->_type eq $initial_reference->type) {
432 DBM::Deep->_throw_error("File type mismatch");
433 }
f1879fdc 434
9c87a079 435 $obj->{staleness} = $initial_reference->staleness;
436 }
118ba343 437 }
2120a181 438
a5bdb1ac 439 $self->storage->set_inode;
440
2120a181 441 return 1;
442}
443
444sub begin_work {
445 my $self = shift;
446 my ($obj) = @_;
447
448 if ( $self->trans_id ) {
449 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
450 }
451
452 my @slots = $self->read_txn_slots;
e9b0b5f0 453 my $found;
454 for my $i ( 0 .. $#slots ) {
2120a181 455 next if $slots[$i];
e9b0b5f0 456
2120a181 457 $slots[$i] = 1;
e9b0b5f0 458 $self->set_trans_id( $i + 1 );
459 $found = 1;
2120a181 460 last;
461 }
e9b0b5f0 462 unless ( $found ) {
463 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
464 }
2120a181 465 $self->write_txn_slots( @slots );
466
467 if ( !$self->trans_id ) {
468 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
469 }
470
471 return;
472}
473
474sub rollback {
475 my $self = shift;
476 my ($obj) = @_;
477
478 if ( !$self->trans_id ) {
479 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
480 }
481
9c87a079 482 # Each entry is the file location for a bucket that has a modification for
483 # this transaction. The entries need to be expunged.
484 foreach my $entry (@{ $self->get_entries } ) {
485 # Remove the entry here
486 my $read_loc = $entry
487 + $self->hash_size
488 + $self->byte_size
489 + $self->byte_size
490 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
491
492 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
493 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
494 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
495
496 if ( $data_loc > 1 ) {
d6ecf579 497 $self->load_sector( $data_loc )->free;
9c87a079 498 }
db2eb673 499 }
500
2120a181 501 $self->clear_entries;
70b55428 502
2120a181 503 my @slots = $self->read_txn_slots;
e9b0b5f0 504 $slots[$self->trans_id-1] = 0;
2120a181 505 $self->write_txn_slots( @slots );
506 $self->inc_txn_staleness_counter( $self->trans_id );
507 $self->set_trans_id( 0 );
6fde4ed2 508
70b55428 509 return 1;
510}
511
2120a181 512sub commit {
16d1ad9b 513 my $self = shift;
2120a181 514 my ($obj) = @_;
515
516 if ( !$self->trans_id ) {
517 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
518 }
519
9c87a079 520 foreach my $entry (@{ $self->get_entries } ) {
521 # Overwrite the entry in head with the entry in trans_id
522 my $base = $entry
523 + $self->hash_size
524 + $self->byte_size;
525
526 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
527 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
528
529 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
530 my $trans_loc = $self->storage->read_at(
531 $spot, $self->byte_size,
532 );
533
534 $self->storage->print_at( $base, $trans_loc );
535 $self->storage->print_at(
536 $spot,
537 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
538 );
539
540 if ( $head_loc > 1 ) {
d6ecf579 541 $self->load_sector( $head_loc )->free;
9c87a079 542 }
db2eb673 543 }
544
2120a181 545 $self->clear_entries;
546
547 my @slots = $self->read_txn_slots;
e9b0b5f0 548 $slots[$self->trans_id-1] = 0;
2120a181 549 $self->write_txn_slots( @slots );
550 $self->inc_txn_staleness_counter( $self->trans_id );
551 $self->set_trans_id( 0 );
552
553 return 1;
16d1ad9b 554}
555
ae6c15b8 556=head1 INTERNAL METHODS
557
51e9eee3 558The following methods are internal-use-only to DBM::Deep::Engine::File.
ae6c15b8 559
560=cut
561
562=head2 read_txn_slots()
563
564This takes no arguments.
565
566This will return an array with a 1 or 0 in each slot. Each spot represents one
567available transaction. If the slot is 1, that transaction is taken. If it is 0,
568the transaction is available.
569
570=cut
571
2120a181 572sub read_txn_slots {
d4b1166e 573 my $self = shift;
9c87a079 574 my $bl = $self->txn_bitfield_len;
575 my $num_bits = $bl * 8;
576 return split '', unpack( 'b'.$num_bits,
577 $self->storage->read_at(
578 $self->trans_loc, $bl,
579 )
580 );
2120a181 581}
20f7b20c 582
ae6c15b8 583=head2 write_txn_slots( @slots )
584
585This takes an array of 1's and 0's. This array represents the transaction slots
586returned by L</read_txn_slots()>. In other words, the following is true:
587
588 @x = read_txn_slots( write_txn_slots( @x ) );
589
590(With the obviously missing object referents added back in.)
591
592=cut
593
2120a181 594sub write_txn_slots {
595 my $self = shift;
9c87a079 596 my $num_bits = $self->txn_bitfield_len * 8;
597 $self->storage->print_at( $self->trans_loc,
598 pack( 'b'.$num_bits, join('', @_) ),
599 );
2120a181 600}
601
ae6c15b8 602=head2 get_running_txn_ids()
603
604This takes no arguments.
605
606This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
607
608=cut
609
2120a181 610sub get_running_txn_ids {
611 my $self = shift;
612 my @transactions = $self->read_txn_slots;
ae6c15b8 613 my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
2120a181 614}
615
ae6c15b8 616=head2 get_txn_staleness_counter( $trans_id )
617
618This will return the staleness counter for the given transaction ID. Please see
619L</TRANSACTION STALENESS> for more information.
620
621=cut
622
2120a181 623sub get_txn_staleness_counter {
624 my $self = shift;
9c87a079 625 my ($trans_id) = @_;
626
627 # Hardcode staleness of 0 for the HEAD
628 return 0 unless $trans_id;
629
630 return unpack( $StP{$STALE_SIZE},
631 $self->storage->read_at(
632 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
633 $STALE_SIZE,
634 )
635 );
d4b1166e 636}
637
ae6c15b8 638=head2 inc_txn_staleness_counter( $trans_id )
639
640This will increment the staleness counter for the given transaction ID. Please see
641L</TRANSACTION STALENESS> for more information.
642
643=cut
644
2120a181 645sub inc_txn_staleness_counter {
d4b1166e 646 my $self = shift;
9c87a079 647 my ($trans_id) = @_;
648
649 # Hardcode staleness of 0 for the HEAD
650 return 0 unless $trans_id;
651
652 $self->storage->print_at(
653 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
654 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
655 );
2120a181 656}
20f7b20c 657
ae6c15b8 658=head2 get_entries()
659
660This takes no arguments.
661
662This returns a list of all the sectors that have been modified by this transaction.
663
664=cut
665
2120a181 666sub get_entries {
667 my $self = shift;
668 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
d4b1166e 669}
670
ae6c15b8 671=head2 add_entry( $trans_id, $location )
672
3b90cc56 673This takes a transaction ID and a file location and marks the sector at that
674location as having been modified by the transaction identified by $trans_id.
ae6c15b8 675
676This returns nothing.
677
678B<NOTE>: Unlike all the other _entries() methods, there are several cases where
679C<< $trans_id != $self->trans_id >> for this method.
680
681=cut
682
2120a181 683sub add_entry {
ea2f6d67 684 my $self = shift;
9c87a079 685 my ($trans_id, $loc) = @_;
97d40a0a 686
2120a181 687 $self->{entries}{$trans_id} ||= {};
9c87a079 688 $self->{entries}{$trans_id}{$loc} = undef;
2120a181 689}
ea2f6d67 690
ae6c15b8 691=head2 reindex_entry( $old_loc, $new_loc )
692
3b90cc56 693This takes two locations (old and new, respectively). If a location that has
694been modified by this transaction is subsequently reindexed due to a bucketlist
ae6c15b8 695overflowing, then the entries hash needs to be made aware of this change.
696
697This returns nothing.
698
699=cut
700
2120a181 701sub reindex_entry {
702 my $self = shift;
9c87a079 703 my ($old_loc, $new_loc) = @_;
2120a181 704
705 TRANS:
706 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
9c87a079 707 if ( exists $locs->{$old_loc} ) {
708 delete $locs->{$old_loc};
709 $locs->{$new_loc} = undef;
695c88b1 710 next TRANS;
2120a181 711 }
ea2f6d67 712 }
ea2f6d67 713}
714
ae6c15b8 715=head2 clear_entries()
716
3b90cc56 717This takes no arguments. It will clear the entries list for the running
718transaction.
ae6c15b8 719
720This returns nothing.
721
722=cut
723
2120a181 724sub clear_entries {
d4b1166e 725 my $self = shift;
2120a181 726 delete $self->{entries}{$self->trans_id};
727}
eea0d863 728
ae6c15b8 729=head2 _write_file_header()
730
731This writes the file header for a new file. This will write the various settings
732that set how the file is interpreted.
733
734=head2 _read_file_header()
735
736This reads the file header from an existing file. This will read the various
737settings that set how the file is interpreted.
738
739=cut
740
9c87a079 741{
51e9eee3 742 my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
9c87a079 743 my $this_file_version = 3;
16d1ad9b 744
9c87a079 745 sub _write_file_header {
746 my $self = shift;
75be6413 747
9c87a079 748 my $nt = $self->num_txns;
749 my $bl = $self->txn_bitfield_len;
75be6413 750
9c87a079 751 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
75be6413 752
9c87a079 753 my $loc = $self->storage->request_space( $header_fixed + $header_var );
75be6413 754
9c87a079 755 $self->storage->print_at( $loc,
51e9eee3 756 $self->SIG_FILE,
757 $self->SIG_HEADER,
9c87a079 758 pack('N', $this_file_version), # At this point, we're at 9 bytes
759 pack('N', $header_var), # header size
760 # --- Above is $header_fixed. Below is $header_var
761 pack('C', $self->byte_size),
75be6413 762
9c87a079 763 # These shenanigans are to allow a 256 within a C
764 pack('C', $self->max_buckets - 1),
765 pack('C', $self->data_sector_size - 1),
75be6413 766
9c87a079 767 pack('C', $nt),
768 pack('C' . $bl, 0 ), # Transaction activeness bitfield
769 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
770 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
771 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
772 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
773 );
75be6413 774
9c87a079 775 #XXX Set these less fragilely
776 $self->set_trans_loc( $header_fixed + 4 );
777 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
75be6413 778
9c87a079 779 return;
badf847c 780 }
7b1e1aa1 781
9c87a079 782 sub _read_file_header {
badf847c 783 my $self = shift;
75be6413 784
9c87a079 785 my $buffer = $self->storage->read_at( 0, $header_fixed );
786 return unless length($buffer);
2603d86e 787
9c87a079 788 my ($file_signature, $sig_header, $file_version, $size) = unpack(
789 'A4 A N N', $buffer
790 );
75be6413 791
51e9eee3 792 unless ( $file_signature eq $self->SIG_FILE ) {
9c87a079 793 $self->storage->close;
794 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
795 }
7b1e1aa1 796
51e9eee3 797 unless ( $sig_header eq $self->SIG_HEADER ) {
9c87a079 798 $self->storage->close;
799 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
800 }
801
802 unless ( $file_version == $this_file_version ) {
803 $self->storage->close;
804 DBM::Deep->_throw_error(
805 "Wrong file version found - " . $file_version .
806 " - expected " . $this_file_version
807 );
808 }
809
810 my $buffer2 = $self->storage->read_at( undef, $size );
811 my @values = unpack( 'C C C C', $buffer2 );
812
813 if ( @values != 4 || grep { !defined } @values ) {
814 $self->storage->close;
815 DBM::Deep->_throw_error("Corrupted file - bad header");
816 }
817
818 #XXX Add warnings if values weren't set right
819 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
820
821 # These shenangians are to allow a 256 within a C
822 $self->{max_buckets} += 1;
823 $self->{data_sector_size} += 1;
824
825 my $bl = $self->txn_bitfield_len;
826
827 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
828 unless ( $size == $header_var ) {
829 $self->storage->close;
830 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
badf847c 831 }
7b1e1aa1 832
9c87a079 833 $self->set_trans_loc( $header_fixed + scalar(@values) );
834 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
835
836 return length($buffer) + length($buffer2);
7b1e1aa1 837 }
75be6413 838}
839
ae6c15b8 840=head2 _apply_digest( @stuff )
841
842This will apply the digest methd (default to Digest::MD5::md5) to the arguments
843passed in and return the result.
844
845=cut
846
9c87a079 847sub _apply_digest {
a8d2331c 848 my $self = shift;
9c87a079 849 return $self->{digest}->(@_);
a8d2331c 850}
851
ae6c15b8 852=head2 _add_free_blist_sector( $offset, $size )
853
854=head2 _add_free_data_sector( $offset, $size )
855
856=head2 _add_free_index_sector( $offset, $size )
857
858These methods are all wrappers around _add_free_sector(), providing the proper
859chain offset ($multiple) for the sector type.
860
861=cut
862
9c87a079 863sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
864sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
865sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
866
ae6c15b8 867=head2 _add_free_sector( $multiple, $offset, $size )
868
869_add_free_sector() takes the offset into the chains location, the offset of the
870sector, and the size of that sector. It will mark the sector as a free sector
871and put it into the list of sectors that are free of this type for use later.
872
873This returns nothing.
874
875B<NOTE>: $size is unused?
876
877=cut
878
9c87a079 879sub _add_free_sector {
00d9bd0b 880 my $self = shift;
9c87a079 881 my ($multiple, $offset, $size) = @_;
882
883 my $chains_offset = $multiple * $self->byte_size;
884
885 my $storage = $self->storage;
886
887 # Increment staleness.
888 # XXX Can this increment+modulo be done by "&= 0x1" ?
51e9eee3 889 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
9c87a079 890 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
51e9eee3 891 $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
9c87a079 892
893 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
894
895 $storage->print_at( $self->chains_loc + $chains_offset,
896 pack( $StP{$self->byte_size}, $offset ),
897 );
898
899 # Record the old head in the new sector after the signature and staleness counter
51e9eee3 900 $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
00d9bd0b 901}
902
ae6c15b8 903=head2 _request_blist_sector( $size )
904
905=head2 _request_data_sector( $size )
906
907=head2 _request_index_sector( $size )
908
909These methods are all wrappers around _request_sector(), providing the proper
910chain offset ($multiple) for the sector type.
911
912=cut
913
9c87a079 914sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
915sub _request_data_sector { shift->_request_sector( 1, @_ ) }
916sub _request_index_sector { shift->_request_sector( 2, @_ ) }
917
ae6c15b8 918=head2 _request_sector( $multiple $size )
919
920This takes the offset into the chains location and the size of that sector.
921
922This returns the object with the sector. If there is an available free sector of
923that type, then it will be reused. If there isn't one, then a new one will be
924allocated.
925
926=cut
927
9c87a079 928sub _request_sector {
a8d2331c 929 my $self = shift;
9c87a079 930 my ($multiple, $size) = @_;
931
932 my $chains_offset = $multiple * $self->byte_size;
933
934 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
935 my $loc = unpack( $StP{$self->byte_size}, $old_head );
936
937 # We don't have any free sectors of the right size, so allocate a new one.
938 unless ( $loc ) {
939 my $offset = $self->storage->request_space( $size );
940
941 # Zero out the new sector. This also guarantees correct increases
942 # in the filesize.
943 $self->storage->print_at( $offset, chr(0) x $size );
a8d2331c 944
9c87a079 945 return $offset;
946 }
947
948 # Read the new head after the signature and the staleness counter
51e9eee3 949 my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
9c87a079 950 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
951 $self->storage->print_at(
51e9eee3 952 $loc + $self->SIG_SIZE + $STALE_SIZE,
9c87a079 953 pack( $StP{$self->byte_size}, 0 ),
954 );
955
956 return $loc;
a8d2331c 957}
958
f0276afb 959=head2 ACCESSORS
960
961The following are readonly attributes.
962
963=over 4
964
f0276afb 965=item * byte_size
966
967=item * hash_size
968
969=item * hash_chars
970
971=item * num_txns
972
973=item * max_buckets
974
975=item * blank_md5
976
977=item * data_sector_size
978
979=item * txn_bitfield_len
980
981=back
982
983=cut
f1879fdc 984
2120a181 985sub byte_size { $_[0]{byte_size} }
986sub hash_size { $_[0]{hash_size} }
987sub hash_chars { $_[0]{hash_chars} }
988sub num_txns { $_[0]{num_txns} }
989sub max_buckets { $_[0]{max_buckets} }
990sub blank_md5 { chr(0) x $_[0]->hash_size }
e9b0b5f0 991sub data_sector_size { $_[0]{data_sector_size} }
992
993# This is a calculated value
994sub txn_bitfield_len {
995 my $self = shift;
996 unless ( exists $self->{txn_bitfield_len} ) {
997 my $temp = ($self->num_txns) / 8;
998 if ( $temp > int( $temp ) ) {
999 $temp = int( $temp ) + 1;
1000 }
1001 $self->{txn_bitfield_len} = $temp;
1002 }
1003 return $self->{txn_bitfield_len};
1004}
8db25060 1005
f0276afb 1006=pod
1007
1008The following are read/write attributes.
1009
1010=over 4
1011
1012=item * trans_id / set_trans_id( $new_id )
1013
1014=item * trans_loc / set_trans_loc( $new_loc )
1015
1016=item * chains_loc / set_chains_loc( $new_loc )
1017
1018=back
1019
1020=cut
1021
2120a181 1022sub trans_id { $_[0]{trans_id} }
1023sub set_trans_id { $_[0]{trans_id} = $_[1] }
8db25060 1024
2120a181 1025sub trans_loc { $_[0]{trans_loc} }
1026sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1027
1028sub chains_loc { $_[0]{chains_loc} }
1029sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1030
c57b19c6 1031sub cache { $_[0]{cache} ||= {} }
1032sub clear_cache { %{$_[0]->cache} = () }
1033
f0276afb 1034=head2 _dump_file()
1035
3b90cc56 1036This method takes no arguments. It's used to print out a textual representation
1037of the DBM::Deep DB file. It assumes the file is not-corrupted.
f0276afb 1038
1039=cut
1040
888453b9 1041sub _dump_file {
1042 my $self = shift;
1043
1044 # Read the header
9c87a079 1045 my $spot = $self->_read_file_header();
888453b9 1046
1047 my %types = (
1048 0 => 'B',
1049 1 => 'D',
1050 2 => 'I',
1051 );
1052
1053 my %sizes = (
1054 'D' => $self->data_sector_size,
2c70efe1 1055 'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
1056 'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
888453b9 1057 );
1058
1059 my $return = "";
c57b19c6 1060
1061 # Header values
1062 $return .= "NumTxns: " . $self->num_txns . $/;
1063
888453b9 1064 # Read the free sector chains
1065 my %sectors;
1066 foreach my $multiple ( 0 .. 2 ) {
1067 $return .= "Chains($types{$multiple}):";
1068 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1069 while ( 1 ) {
1070 my $loc = unpack(
1071 $StP{$self->byte_size},
1072 $self->storage->read_at( $old_loc, $self->byte_size ),
1073 );
1074
1075 # We're now out of free sectors of this kind.
1076 unless ( $loc ) {
1077 last;
1078 }
1079
1080 $sectors{ $types{$multiple} }{ $loc } = undef;
51e9eee3 1081 $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
888453b9 1082 $return .= " $loc";
1083 }
1084 $return .= $/;
1085 }
1086
1087 SECTOR:
1088 while ( $spot < $self->storage->{end} ) {
1089 # Read each sector in order.
d6ecf579 1090 my $sector = $self->load_sector( $spot );
888453b9 1091 if ( !$sector ) {
1092 # Find it in the free-sectors that were found already
1093 foreach my $type ( keys %sectors ) {
1094 if ( exists $sectors{$type}{$spot} ) {
1095 my $size = $sizes{$type};
1096 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1097 $spot += $size;
1098 next SECTOR;
1099 }
1100 }
1101
1102 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1103 }
1104 else {
1105 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1106 if ( $sector->type eq 'D' ) {
1107 $return .= ' ' . $sector->data;
1108 }
1109 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1110 $return .= ' REF: ' . $sector->get_refcount;
1111 }
1112 elsif ( $sector->type eq 'B' ) {
1113 foreach my $bucket ( $sector->chopped_up ) {
1114 $return .= "\n ";
1115 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1116 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1117 );
c57b19c6 1118 my $l = unpack( $StP{$self->byte_size},
1119 substr( $bucket->[-1],
1120 $self->hash_size + $self->byte_size,
1121 $self->byte_size,
1122 ),
1123 );
1124 $return .= sprintf " %08d", $l;
1125 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
888453b9 1126 my $l = unpack( $StP{$self->byte_size},
1127 substr( $bucket->[-1],
c57b19c6 1128 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
888453b9 1129 $self->byte_size,
1130 ),
1131 );
1132 $return .= sprintf " %08d", $l;
1133 }
1134 }
1135 }
1136 $return .= $/;
1137
1138 $spot += $sector->size;
1139 }
1140 }
1141
1142 return $return;
1143}
1144
a20d9a3f 11451;
1146__END__