1 package DBM::Deep::Engine;
6 use warnings FATAL => 'all';
8 # Never import symbols into our namespace. We are a class, not a library.
15 # * Every method in here assumes that the storage has been appropriately
16 # safeguarded. This can be anything from flock() to some sort of manual
17 # mutex. But, it's the caller's responsability to make sure that this has
20 # Setup file and tag signatures. These should never change.
21 sub SIG_FILE () { 'DPDB' }
22 sub SIG_HEADER () { 'h' }
23 sub SIG_HASH () { 'H' }
24 sub SIG_ARRAY () { 'A' }
25 sub SIG_NULL () { 'N' }
26 sub SIG_DATA () { 'D' }
27 sub SIG_INDEX () { 'I' }
28 sub SIG_BLIST () { 'B' }
29 sub SIG_FREE () { 'F' }
32 use DBM::Deep::Iterator ();
33 use DBM::Deep::Engine::Sector::Data ();
34 use DBM::Deep::Engine::Sector::BucketList ();
35 use DBM::Deep::Engine::Sector::Index ();
36 use DBM::Deep::Engine::Sector::Null ();
37 use DBM::Deep::Engine::Sector::Reference ();
38 use DBM::Deep::Engine::Sector::Scalar ();
39 use DBM::Deep::Null ();
43 # Please refer to the pack() documentation for further information
45 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
46 2 => 'n', # Unsigned short in "network" (big-endian) order
47 4 => 'N', # Unsigned long in "network" (big-endian) order
48 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
57 This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level
58 mapping between the L<DBM::Deep/> objects and the storage medium.
60 The purpose of this documentation is to provide low-level documentation for
61 developers. It is B<not> intended to be used by the general public. This
62 documentation and what it documents can and will change without notice.
66 The engine exposes an API to the DBM::Deep objects (DBM::Deep, DBM::Deep::Array,
67 and DBM::Deep::Hash) for their use to access the actual stored values. This API
78 =item * make_reference
96 =item * lock_exclusive
104 They are explained in their own sections below. These methods, in turn, may
105 provide some bounds-checking, but primarily act to instantiate objects in the
106 Engine::Sector::* hierarchy and dispatch to them.
110 Transactions in DBM::Deep are implemented using a variant of MVCC. This attempts
111 to keep the amount of actual work done against the file low while stil providing
112 Atomicity, Consistency, and Isolation. Durability, unfortunately, cannot be done
117 If another process uses a transaction slot and writes stuff to it, then terminates,
118 the data that process wrote it still within the file. In order to address this,
119 there is also a transaction staleness counter associated within every write.
120 Each time a transaction is started, that process increments that transaction's
121 staleness counter. If, when it reads a value, the staleness counters aren't
122 identical, DBM::Deep will consider the value on disk to be stale and discard it.
126 The fourth leg of ACID is Durability, the guarantee that when a commit returns,
127 the data will be there the next time you read from it. This should be regardless
128 of any crashes or powerdowns in between the commit and subsequent read. DBM::Deep
129 does provide that guarantee; once the commit returns, all of the data has been
130 transferred from the transaction shadow to the HEAD. The issue arises with partial
131 commits - a commit that is interrupted in some fashion. In keeping with DBM::Deep's
132 "tradition" of very light error-checking and non-existent error-handling, there is
133 no way to recover from a partial commit. (This is probably a failure in Consistency
134 as well as Durability.)
136 Other DBMSes use transaction logs (a separate file, generally) to achieve Durability.
137 As DBM::Deep is a single-file, we would have to do something similar to what SQLite
138 and BDB do in terms of committing using synchonized writes. To do this, we would have
139 to use a much higher RAM footprint and some serious programming that make my head
140 hurts just to think about it.
142 =head1 EXTERNAL METHODS
146 This takes a set of args. These args are described in the documentation for
155 $args->{storage} = DBM::Deep::File->new( $args )
156 unless exists $args->{storage};
162 hash_size => 16, # In bytes
163 hash_chars => 256, # Number of chars the algorithm uses per byte
165 num_txns => 1, # The HEAD
166 trans_id => 0, # Default to the HEAD
168 data_sector_size => 64, # Size in bytes of each data sector
170 entries => {}, # This is the list of entries for transactions
174 # Never allow byte_size to be set directly.
175 delete $args->{byte_size};
176 if ( defined $args->{pack_size} ) {
177 if ( lc $args->{pack_size} eq 'small' ) {
178 $args->{byte_size} = 2;
180 elsif ( lc $args->{pack_size} eq 'medium' ) {
181 $args->{byte_size} = 4;
183 elsif ( lc $args->{pack_size} eq 'large' ) {
184 $args->{byte_size} = 8;
187 DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
191 # Grab the parameters we want to use
192 foreach my $param ( keys %$self ) {
193 next unless exists $args->{$param};
194 $self->{$param} = $args->{$param};
198 max_buckets => { floor => 16, ceil => 256 },
199 num_txns => { floor => 1, ceil => 255 },
200 data_sector_size => { floor => 32, ceil => 256 },
203 while ( my ($attr, $c) = each %validations ) {
204 if ( !defined $self->{$attr}
205 || !length $self->{$attr}
206 || $self->{$attr} =~ /\D/
207 || $self->{$attr} < $c->{floor}
209 $self->{$attr} = '(undef)' if !defined $self->{$attr};
210 warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
211 $self->{$attr} = $c->{floor};
213 elsif ( $self->{$attr} > $c->{ceil} ) {
214 warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
215 $self->{$attr} = $c->{ceil};
219 if ( !$self->{digest} ) {
221 $self->{digest} = \&Digest::MD5::md5;
227 =head2 read_value( $obj, $key )
229 This takes an object that provides _base_offset() and a string. It returns the
230 value stored in the corresponding Sector::Value's data section.
236 my ($obj, $key) = @_;
238 # This will be a Reference sector
239 my $sector = $self->_load_sector( $obj->_base_offset )
242 if ( $sector->staleness != $obj->_staleness ) {
246 my $key_md5 = $self->_apply_digest( $key );
248 my $value_sector = $sector->get_data_for({
253 unless ( $value_sector ) {
254 $value_sector = DBM::Deep::Engine::Sector::Null->new({
259 $sector->write_data({
262 value => $value_sector,
266 return $value_sector->data;
269 =head2 get_classname( $obj )
271 This takes an object that provides _base_offset() and returns the classname (if any)
274 It delegates to Sector::Reference::get_classname() for the heavy lifting.
276 It performs a staleness check.
284 # This will be a Reference sector
285 my $sector = $self->_load_sector( $obj->_base_offset )
286 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
288 if ( $sector->staleness != $obj->_staleness ) {
292 return $sector->get_classname;
295 =head2 make_reference( $obj, $old_key, $new_key )
297 This takes an object that provides _base_offset() and two strings. The
298 strings correspond to the old key and new key, respectively. This operation
299 is equivalent to (given C<< $db->{foo} = []; >>) C<< $db->{bar} = $db->{foo}; >>.
301 This returns nothing.
307 my ($obj, $old_key, $new_key) = @_;
309 # This will be a Reference sector
310 my $sector = $self->_load_sector( $obj->_base_offset )
311 or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
313 if ( $sector->staleness != $obj->_staleness ) {
317 my $old_md5 = $self->_apply_digest( $old_key );
319 my $value_sector = $sector->get_data_for({
324 unless ( $value_sector ) {
325 $value_sector = DBM::Deep::Engine::Sector::Null->new({
330 $sector->write_data({
333 value => $value_sector,
337 if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
338 $sector->write_data({
340 key_md5 => $self->_apply_digest( $new_key ),
341 value => $value_sector,
343 $value_sector->increment_refcount;
346 $sector->write_data({
348 key_md5 => $self->_apply_digest( $new_key ),
349 value => $value_sector->clone,
356 =head2 key_exists( $obj, $key )
358 This takes an object that provides _base_offset() and a string for
359 the key to be checked. This returns 1 for true and "" for false.
365 my ($obj, $key) = @_;
367 # This will be a Reference sector
368 my $sector = $self->_load_sector( $obj->_base_offset )
371 if ( $sector->staleness != $obj->_staleness ) {
375 my $data = $sector->get_data_for({
376 key_md5 => $self->_apply_digest( $key ),
380 # exists() returns 1 or '' for true/false.
381 return $data ? 1 : '';
384 =head2 delete_key( $obj, $key )
386 This takes an object that provides _base_offset() and a string for
387 the key to be deleted. This returns the result of the Sector::Reference
394 my ($obj, $key) = @_;
396 my $sector = $self->_load_sector( $obj->_base_offset )
399 if ( $sector->staleness != $obj->_staleness ) {
403 return $sector->delete_key({
404 key_md5 => $self->_apply_digest( $key ),
409 =head2 write_value( $obj, $key, $value )
411 This takes an object that provides _base_offset(), a string for the
412 key, and a value. This value can be anything storable within L<DBM::Deep/>.
414 This returns 1 upon success.
420 my ($obj, $key, $value) = @_;
422 my $r = Scalar::Util::reftype( $value ) || '';
425 last if $r eq 'HASH';
426 last if $r eq 'ARRAY';
428 DBM::Deep->_throw_error(
429 "Storage of references of type '$r' is not supported."
433 # This will be a Reference sector
434 my $sector = $self->_load_sector( $obj->_base_offset )
435 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
437 if ( $sector->staleness != $obj->_staleness ) {
438 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
442 if ( !defined $value ) {
443 $class = 'DBM::Deep::Engine::Sector::Null';
445 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
447 if ( $r eq 'ARRAY' ) {
448 $tmpvar = tied @$value;
449 } elsif ( $r eq 'HASH' ) {
450 $tmpvar = tied %$value;
454 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
456 unless ( $is_dbm_deep ) {
457 DBM::Deep->_throw_error( "Cannot store something that is tied." );
460 unless ( $tmpvar->_engine->storage == $self->storage ) {
461 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
464 # First, verify if we're storing the same thing to this spot. If we are, then
465 # this should be a no-op. -EJS, 2008-05-19
466 my $loc = $sector->get_data_location_for({
467 key_md5 => $self->_apply_digest( $key ),
471 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
475 #XXX Can this use $loc?
476 my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
477 $sector->write_data({
479 key_md5 => $self->_apply_digest( $key ),
480 value => $value_sector,
482 $value_sector->increment_refcount;
487 $class = 'DBM::Deep::Engine::Sector::Reference';
488 $type = substr( $r, 0, 1 );
491 if ( tied($value) ) {
492 DBM::Deep->_throw_error( "Cannot store something that is tied." );
494 $class = 'DBM::Deep::Engine::Sector::Scalar';
497 # Create this after loading the reference sector in case something bad happens.
498 # This way, we won't allocate value sector(s) needlessly.
499 my $value_sector = $class->new({
505 $sector->write_data({
507 key_md5 => $self->_apply_digest( $key ),
508 value => $value_sector,
511 # This code is to make sure we write all the values in the $value to the disk
512 # and to make sure all changes to $value after the assignment are reflected
513 # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
514 # NOTE - simply tying $value won't perform a STORE on each value. Hence, the
515 # copy to a temp value.
516 if ( $r eq 'ARRAY' ) {
518 tie @$value, 'DBM::Deep', {
519 base_offset => $value_sector->offset,
520 staleness => $value_sector->staleness,
521 storage => $self->storage,
525 bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
527 elsif ( $r eq 'HASH' ) {
529 tie %$value, 'DBM::Deep', {
530 base_offset => $value_sector->offset,
531 staleness => $value_sector->staleness,
532 storage => $self->storage,
537 bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
543 =head2 get_next_key( $obj, $prev_key )
545 This takes an object that provides _base_offset() and an optional string
546 representing the prior key returned via a prior invocation of this method.
548 This method delegates to C<< DBM::Deep::Iterator->get_next_key() >>.
552 # XXX Add staleness here
555 my ($obj, $prev_key) = @_;
557 # XXX Need to add logic about resetting the iterator if any key in the reference has changed
558 unless ( $prev_key ) {
559 $obj->{iterator} = DBM::Deep::Iterator->new({
560 base_offset => $obj->_base_offset,
565 return $obj->{iterator}->get_next_key( $obj );
568 =head2 setup_fh( $obj )
570 This takes an object that provides _base_offset(). It will do everything needed
571 in order to properly initialize all values for necessary functioning. If this is
572 called upon an already initialized object, this will also reset the inode.
582 # We're opening the file.
583 unless ( $obj->_base_offset ) {
584 my $bytes_read = $self->_read_file_header;
586 # Creating a new file
587 unless ( $bytes_read ) {
588 $self->_write_file_header;
590 # 1) Create Array/Hash entry
591 my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
595 $obj->{base_offset} = $initial_reference->offset;
596 $obj->{staleness} = $initial_reference->staleness;
598 $self->storage->flush;
600 # Reading from an existing file
602 $obj->{base_offset} = $bytes_read;
603 my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
605 offset => $obj->_base_offset,
607 unless ( $initial_reference ) {
608 DBM::Deep->_throw_error("Corrupted file, no master index record");
611 unless ($obj->_type eq $initial_reference->type) {
612 DBM::Deep->_throw_error("File type mismatch");
615 $obj->{staleness} = $initial_reference->staleness;
619 $self->storage->set_inode;
624 =head2 begin_work( $obj )
626 This takes an object that provides _base_offset(). It will set up all necessary
627 bookkeeping in order to run all work within a transaction.
629 If $obj is already within a transaction, an error wiill be thrown. If there are
630 no more available transactions, an error will be thrown.
640 if ( $self->trans_id ) {
641 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
644 my @slots = $self->read_txn_slots;
646 for my $i ( 0 .. $#slots ) {
650 $self->set_trans_id( $i + 1 );
655 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
657 $self->write_txn_slots( @slots );
659 if ( !$self->trans_id ) {
660 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
666 =head2 rollback( $obj )
668 This takes an object that provides _base_offset(). It will revert all
669 actions taken within the running transaction.
671 If $obj is not within a transaction, an error will be thrown.
681 if ( !$self->trans_id ) {
682 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
685 # Each entry is the file location for a bucket that has a modification for
686 # this transaction. The entries need to be expunged.
687 foreach my $entry (@{ $self->get_entries } ) {
688 # Remove the entry here
689 my $read_loc = $entry
693 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
695 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
696 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
697 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
699 if ( $data_loc > 1 ) {
700 $self->_load_sector( $data_loc )->free;
704 $self->clear_entries;
706 my @slots = $self->read_txn_slots;
707 $slots[$self->trans_id-1] = 0;
708 $self->write_txn_slots( @slots );
709 $self->inc_txn_staleness_counter( $self->trans_id );
710 $self->set_trans_id( 0 );
715 =head2 commit( $obj )
717 This takes an object that provides _base_offset(). It will apply all
718 actions taken within the transaction to the HEAD.
720 If $obj is not within a transaction, an error will be thrown.
730 if ( !$self->trans_id ) {
731 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
734 foreach my $entry (@{ $self->get_entries } ) {
735 # Overwrite the entry in head with the entry in trans_id
740 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
741 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
743 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
744 my $trans_loc = $self->storage->read_at(
745 $spot, $self->byte_size,
748 $self->storage->print_at( $base, $trans_loc );
749 $self->storage->print_at(
751 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
754 if ( $head_loc > 1 ) {
755 $self->_load_sector( $head_loc )->free;
759 $self->clear_entries;
761 my @slots = $self->read_txn_slots;
762 $slots[$self->trans_id-1] = 0;
763 $self->write_txn_slots( @slots );
764 $self->inc_txn_staleness_counter( $self->trans_id );
765 $self->set_trans_id( 0 );
770 =head2 lock_exclusive()
772 This takes an object that provides _base_offset(). It will guarantee that
773 the storage has taken precautions to be safe for a write.
775 This returns nothing.
782 return $self->storage->lock_exclusive( $obj );
787 This takes an object that provides _base_offset(). It will guarantee that
788 the storage has taken precautions to be safe for a read.
790 This returns nothing.
797 return $self->storage->lock_shared( $obj );
802 This takes an object that provides _base_offset(). It will guarantee that
803 the storage has released all locks taken.
805 This returns nothing.
813 my $rv = $self->storage->unlock( $obj );
820 =head1 INTERNAL METHODS
822 The following methods are internal-use-only to DBM::Deep::Engine.
826 =head2 read_txn_slots()
828 This takes no arguments.
830 This will return an array with a 1 or 0 in each slot. Each spot represents one
831 available transaction. If the slot is 1, that transaction is taken. If it is 0,
832 the transaction is available.
838 my $bl = $self->txn_bitfield_len;
839 my $num_bits = $bl * 8;
840 return split '', unpack( 'b'.$num_bits,
841 $self->storage->read_at(
842 $self->trans_loc, $bl,
847 =head2 write_txn_slots( @slots )
849 This takes an array of 1's and 0's. This array represents the transaction slots
850 returned by L</read_txn_slots()>. In other words, the following is true:
852 @x = read_txn_slots( write_txn_slots( @x ) );
854 (With the obviously missing object referents added back in.)
858 sub write_txn_slots {
860 my $num_bits = $self->txn_bitfield_len * 8;
861 $self->storage->print_at( $self->trans_loc,
862 pack( 'b'.$num_bits, join('', @_) ),
866 =head2 get_running_txn_ids()
868 This takes no arguments.
870 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
874 sub get_running_txn_ids {
876 my @transactions = $self->read_txn_slots;
877 my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
880 =head2 get_txn_staleness_counter( $trans_id )
882 This will return the staleness counter for the given transaction ID. Please see
883 L</TRANSACTION STALENESS> for more information.
887 sub get_txn_staleness_counter {
891 # Hardcode staleness of 0 for the HEAD
892 return 0 unless $trans_id;
894 return unpack( $StP{$STALE_SIZE},
895 $self->storage->read_at(
896 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
902 =head2 inc_txn_staleness_counter( $trans_id )
904 This will increment the staleness counter for the given transaction ID. Please see
905 L</TRANSACTION STALENESS> for more information.
909 sub inc_txn_staleness_counter {
913 # Hardcode staleness of 0 for the HEAD
914 return 0 unless $trans_id;
916 $self->storage->print_at(
917 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
918 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
924 This takes no arguments.
926 This returns a list of all the sectors that have been modified by this transaction.
932 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
935 =head2 add_entry( $trans_id, $location )
937 This takes a transaction ID and a file location and marks the sector at that location
938 as having been modified by the transaction identified by $trans_id.
940 This returns nothing.
942 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
943 C<< $trans_id != $self->trans_id >> for this method.
949 my ($trans_id, $loc) = @_;
951 $self->{entries}{$trans_id} ||= {};
952 $self->{entries}{$trans_id}{$loc} = undef;
955 =head2 reindex_entry( $old_loc, $new_loc )
957 This takes two locations (old and new, respectively). If a location that has been
958 modified by this transaction is subsequently reindexed due to a bucketlist
959 overflowing, then the entries hash needs to be made aware of this change.
961 This returns nothing.
967 my ($old_loc, $new_loc) = @_;
970 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
971 if ( exists $locs->{$old_loc} ) {
972 delete $locs->{$old_loc};
973 $locs->{$new_loc} = undef;
979 =head2 clear_entries()
981 This takes no arguments. It will clear the entries list for the running transaction.
983 This returns nothing.
989 delete $self->{entries}{$self->trans_id};
992 =head2 _write_file_header()
994 This writes the file header for a new file. This will write the various settings
995 that set how the file is interpreted.
997 =head2 _read_file_header()
999 This reads the file header from an existing file. This will read the various
1000 settings that set how the file is interpreted.
1005 my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
1006 my $this_file_version = 3;
1008 sub _write_file_header {
1011 my $nt = $self->num_txns;
1012 my $bl = $self->txn_bitfield_len;
1014 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
1016 my $loc = $self->storage->request_space( $header_fixed + $header_var );
1018 $self->storage->print_at( $loc,
1021 pack('N', $this_file_version), # At this point, we're at 9 bytes
1022 pack('N', $header_var), # header size
1023 # --- Above is $header_fixed. Below is $header_var
1024 pack('C', $self->byte_size),
1026 # These shenanigans are to allow a 256 within a C
1027 pack('C', $self->max_buckets - 1),
1028 pack('C', $self->data_sector_size - 1),
1031 pack('C' . $bl, 0 ), # Transaction activeness bitfield
1032 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
1033 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
1034 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
1035 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
1038 #XXX Set these less fragilely
1039 $self->set_trans_loc( $header_fixed + 4 );
1040 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
1045 sub _read_file_header {
1048 my $buffer = $self->storage->read_at( 0, $header_fixed );
1049 return unless length($buffer);
1051 my ($file_signature, $sig_header, $file_version, $size) = unpack(
1055 unless ( $file_signature eq SIG_FILE ) {
1056 $self->storage->close;
1057 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
1060 unless ( $sig_header eq SIG_HEADER ) {
1061 $self->storage->close;
1062 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
1065 unless ( $file_version == $this_file_version ) {
1066 $self->storage->close;
1067 DBM::Deep->_throw_error(
1068 "Wrong file version found - " . $file_version .
1069 " - expected " . $this_file_version
1073 my $buffer2 = $self->storage->read_at( undef, $size );
1074 my @values = unpack( 'C C C C', $buffer2 );
1076 if ( @values != 4 || grep { !defined } @values ) {
1077 $self->storage->close;
1078 DBM::Deep->_throw_error("Corrupted file - bad header");
1081 #XXX Add warnings if values weren't set right
1082 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
1084 # These shenangians are to allow a 256 within a C
1085 $self->{max_buckets} += 1;
1086 $self->{data_sector_size} += 1;
1088 my $bl = $self->txn_bitfield_len;
1090 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
1091 unless ( $size == $header_var ) {
1092 $self->storage->close;
1093 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
1096 $self->set_trans_loc( $header_fixed + scalar(@values) );
1097 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
1099 return length($buffer) + length($buffer2);
1103 =head2 _load_sector( $offset )
1105 This will instantiate and return the sector object that represents the data found
1114 # Add a catch for offset of 0 or 1
1115 return if !$offset || $offset <= 1;
1117 my $type = $self->storage->read_at( $offset, 1 );
1118 return if $type eq chr(0);
1120 if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
1121 return DBM::Deep::Engine::Sector::Reference->new({
1127 # XXX Don't we need key_md5 here?
1128 elsif ( $type eq $self->SIG_BLIST ) {
1129 return DBM::Deep::Engine::Sector::BucketList->new({
1135 elsif ( $type eq $self->SIG_INDEX ) {
1136 return DBM::Deep::Engine::Sector::Index->new({
1142 elsif ( $type eq $self->SIG_NULL ) {
1143 return DBM::Deep::Engine::Sector::Null->new({
1149 elsif ( $type eq $self->SIG_DATA ) {
1150 return DBM::Deep::Engine::Sector::Scalar->new({
1156 # This was deleted from under us, so just return and let the caller figure it out.
1157 elsif ( $type eq $self->SIG_FREE ) {
1161 DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
1164 =head2 _apply_digest( @stuff )
1166 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
1167 passed in and return the result.
1173 return $self->{digest}->(@_);
1176 =head2 _add_free_blist_sector( $offset, $size )
1178 =head2 _add_free_data_sector( $offset, $size )
1180 =head2 _add_free_index_sector( $offset, $size )
1182 These methods are all wrappers around _add_free_sector(), providing the proper
1183 chain offset ($multiple) for the sector type.
1187 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
1188 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
1189 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
1191 =head2 _add_free_sector( $multiple, $offset, $size )
1193 _add_free_sector() takes the offset into the chains location, the offset of the
1194 sector, and the size of that sector. It will mark the sector as a free sector
1195 and put it into the list of sectors that are free of this type for use later.
1197 This returns nothing.
1199 B<NOTE>: $size is unused?
1203 sub _add_free_sector {
1205 my ($multiple, $offset, $size) = @_;
1207 my $chains_offset = $multiple * $self->byte_size;
1209 my $storage = $self->storage;
1211 # Increment staleness.
1212 # XXX Can this increment+modulo be done by "&= 0x1" ?
1213 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + SIG_SIZE, $STALE_SIZE ) );
1214 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
1215 $storage->print_at( $offset + SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
1217 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
1219 $storage->print_at( $self->chains_loc + $chains_offset,
1220 pack( $StP{$self->byte_size}, $offset ),
1223 # Record the old head in the new sector after the signature and staleness counter
1224 $storage->print_at( $offset + SIG_SIZE + $STALE_SIZE, $old_head );
1227 =head2 _request_blist_sector( $size )
1229 =head2 _request_data_sector( $size )
1231 =head2 _request_index_sector( $size )
1233 These methods are all wrappers around _request_sector(), providing the proper
1234 chain offset ($multiple) for the sector type.
1238 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
1239 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
1240 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
1242 =head2 _request_sector( $multiple $size )
1244 This takes the offset into the chains location and the size of that sector.
1246 This returns the object with the sector. If there is an available free sector of
1247 that type, then it will be reused. If there isn't one, then a new one will be
1252 sub _request_sector {
1254 my ($multiple, $size) = @_;
1256 my $chains_offset = $multiple * $self->byte_size;
1258 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
1259 my $loc = unpack( $StP{$self->byte_size}, $old_head );
1261 # We don't have any free sectors of the right size, so allocate a new one.
1263 my $offset = $self->storage->request_space( $size );
1265 # Zero out the new sector. This also guarantees correct increases
1267 $self->storage->print_at( $offset, chr(0) x $size );
1272 # Read the new head after the signature and the staleness counter
1273 my $new_head = $self->storage->read_at( $loc + SIG_SIZE + $STALE_SIZE, $self->byte_size );
1274 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
1275 $self->storage->print_at(
1276 $loc + SIG_SIZE + $STALE_SIZE,
1277 pack( $StP{$self->byte_size}, 0 ),
1285 This takes no arguments. It will do everything necessary to flush all things to
1286 disk. This is usually called during unlock() and setup_fh().
1288 This returns nothing.
1295 # Why do we need to have the storage flush? Shouldn't autoflush take care of things?
1297 $self->storage->flush;
1302 The following are readonly attributes.
1320 =item * data_sector_size
1322 =item * txn_bitfield_len
1328 sub storage { $_[0]{storage} }
1329 sub byte_size { $_[0]{byte_size} }
1330 sub hash_size { $_[0]{hash_size} }
1331 sub hash_chars { $_[0]{hash_chars} }
1332 sub num_txns { $_[0]{num_txns} }
1333 sub max_buckets { $_[0]{max_buckets} }
1334 sub blank_md5 { chr(0) x $_[0]->hash_size }
1335 sub data_sector_size { $_[0]{data_sector_size} }
1337 # This is a calculated value
1338 sub txn_bitfield_len {
1340 unless ( exists $self->{txn_bitfield_len} ) {
1341 my $temp = ($self->num_txns) / 8;
1342 if ( $temp > int( $temp ) ) {
1343 $temp = int( $temp ) + 1;
1345 $self->{txn_bitfield_len} = $temp;
1347 return $self->{txn_bitfield_len};
1352 The following are read/write attributes.
1356 =item * trans_id / set_trans_id( $new_id )
1358 =item * trans_loc / set_trans_loc( $new_loc )
1360 =item * chains_loc / set_chains_loc( $new_loc )
1366 sub trans_id { $_[0]{trans_id} }
1367 sub set_trans_id { $_[0]{trans_id} = $_[1] }
1369 sub trans_loc { $_[0]{trans_loc} }
1370 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1372 sub chains_loc { $_[0]{chains_loc} }
1373 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1375 sub cache { $_[0]{cache} ||= {} }
1376 sub clear_cache { %{$_[0]->cache} = () }
1380 This method takes no arguments. It's used to print out a textual representation of the DBM::Deep
1381 DB file. It assumes the file is not-corrupted.
1389 my $spot = $self->_read_file_header();
1398 'D' => $self->data_sector_size,
1399 'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
1400 'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
1406 $return .= "NumTxns: " . $self->num_txns . $/;
1408 # Read the free sector chains
1410 foreach my $multiple ( 0 .. 2 ) {
1411 $return .= "Chains($types{$multiple}):";
1412 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1415 $StP{$self->byte_size},
1416 $self->storage->read_at( $old_loc, $self->byte_size ),
1419 # We're now out of free sectors of this kind.
1424 $sectors{ $types{$multiple} }{ $loc } = undef;
1425 $old_loc = $loc + SIG_SIZE + $STALE_SIZE;
1432 while ( $spot < $self->storage->{end} ) {
1433 # Read each sector in order.
1434 my $sector = $self->_load_sector( $spot );
1436 # Find it in the free-sectors that were found already
1437 foreach my $type ( keys %sectors ) {
1438 if ( exists $sectors{$type}{$spot} ) {
1439 my $size = $sizes{$type};
1440 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1446 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1449 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1450 if ( $sector->type eq 'D' ) {
1451 $return .= ' ' . $sector->data;
1453 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1454 $return .= ' REF: ' . $sector->get_refcount;
1456 elsif ( $sector->type eq 'B' ) {
1457 foreach my $bucket ( $sector->chopped_up ) {
1459 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1460 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1462 my $l = unpack( $StP{$self->byte_size},
1463 substr( $bucket->[-1],
1464 $self->hash_size + $self->byte_size,
1468 $return .= sprintf " %08d", $l;
1469 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1470 my $l = unpack( $StP{$self->byte_size},
1471 substr( $bucket->[-1],
1472 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1476 $return .= sprintf " %08d", $l;
1482 $spot += $sector->size;