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::BucketList ();
33 use DBM::Deep::Iterator::Index ();
34 use DBM::Deep::Engine::Sector::Data ();
35 use DBM::Deep::Engine::Sector::BucketList ();
36 use DBM::Deep::Engine::Sector::Index ();
37 use DBM::Deep::Engine::Sector::Null ();
38 use DBM::Deep::Engine::Sector::Reference ();
39 use DBM::Deep::Engine::Sector::Scalar ();
40 use DBM::Deep::Null ();
44 # Please refer to the pack() documentation for further information
46 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
47 2 => 'n', # Unsigned short in "network" (big-endian) order
48 4 => 'N', # Unsigned long in "network" (big-endian) order
49 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
58 This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level
59 mapping between the L<DBM::Deep/> objects and the storage medium.
61 The purpose of this documentation is to provide low-level documentation for
62 developers. It is B<not> intended to be used by the general public. This
63 documentation and what it documents can and will change without notice.
67 The engine exposes an API to the DBM::Deep objects (DBM::Deep, DBM::Deep::Array,
68 and DBM::Deep::Hash) for their use to access the actual stored values. This API
79 =item * make_reference
97 =item * lock_exclusive
105 They are explained in their own sections below. These methods, in turn, may
106 provide some bounds-checking, but primarily act to instantiate objects in the
107 Engine::Sector::* hierarchy and dispatch to them.
111 Transactions in DBM::Deep are implemented using a variant of MVCC. This attempts
112 to keep the amount of actual work done against the file low while stil providing
113 Atomicity, Consistency, and Isolation. Durability, unfortunately, cannot be done
118 If another process uses a transaction slot and writes stuff to it, then terminates,
119 the data that process wrote it still within the file. In order to address this,
120 there is also a transaction staleness counter associated within every write.
121 Each time a transaction is started, that process increments that transaction's
122 staleness counter. If, when it reads a value, the staleness counters aren't
123 identical, DBM::Deep will consider the value on disk to be stale and discard it.
127 The fourth leg of ACID is Durability, the guarantee that when a commit returns,
128 the data will be there the next time you read from it. This should be regardless
129 of any crashes or powerdowns in between the commit and subsequent read. DBM::Deep
130 does provide that guarantee; once the commit returns, all of the data has been
131 transferred from the transaction shadow to the HEAD. The issue arises with partial
132 commits - a commit that is interrupted in some fashion. In keeping with DBM::Deep's
133 "tradition" of very light error-checking and non-existent error-handling, there is
134 no way to recover from a partial commit. (This is probably a failure in Consistency
135 as well as Durability.)
137 Other DBMSes use transaction logs (a separate file, generally) to achieve Durability.
138 As DBM::Deep is a single-file, we would have to do something similar to what SQLite
139 and BDB do in terms of committing using synchonized writes. To do this, we would have
140 to use a much higher RAM footprint and some serious programming that make my head
141 hurts just to think about it.
143 =head1 EXTERNAL METHODS
147 This takes a set of args. These args are described in the documentation for
156 $args->{storage} = DBM::Deep::File->new( $args )
157 unless exists $args->{storage};
163 hash_size => 16, # In bytes
164 hash_chars => 256, # Number of chars the algorithm uses per byte
166 num_txns => 1, # The HEAD
167 trans_id => 0, # Default to the HEAD
169 data_sector_size => 64, # Size in bytes of each data sector
171 entries => {}, # This is the list of entries for transactions
175 # Never allow byte_size to be set directly.
176 delete $args->{byte_size};
177 if ( defined $args->{pack_size} ) {
178 if ( lc $args->{pack_size} eq 'small' ) {
179 $args->{byte_size} = 2;
181 elsif ( lc $args->{pack_size} eq 'medium' ) {
182 $args->{byte_size} = 4;
184 elsif ( lc $args->{pack_size} eq 'large' ) {
185 $args->{byte_size} = 8;
188 DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
192 # Grab the parameters we want to use
193 foreach my $param ( keys %$self ) {
194 next unless exists $args->{$param};
195 $self->{$param} = $args->{$param};
199 max_buckets => { floor => 16, ceil => 256 },
200 num_txns => { floor => 1, ceil => 255 },
201 data_sector_size => { floor => 32, ceil => 256 },
204 while ( my ($attr, $c) = each %validations ) {
205 if ( !defined $self->{$attr}
206 || !length $self->{$attr}
207 || $self->{$attr} =~ /\D/
208 || $self->{$attr} < $c->{floor}
210 $self->{$attr} = '(undef)' if !defined $self->{$attr};
211 warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
212 $self->{$attr} = $c->{floor};
214 elsif ( $self->{$attr} > $c->{ceil} ) {
215 warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
216 $self->{$attr} = $c->{ceil};
220 if ( !$self->{digest} ) {
222 $self->{digest} = \&Digest::MD5::md5;
228 =head2 read_value( $obj, $key )
230 This takes an object that provides _base_offset() and a string. It returns the
231 value stored in the corresponding Sector::Value's data section.
237 my ($obj, $key) = @_;
239 # This will be a Reference sector
240 my $sector = $self->_load_sector( $obj->_base_offset )
243 if ( $sector->staleness != $obj->_staleness ) {
247 my $key_md5 = $self->_apply_digest( $key );
249 my $value_sector = $sector->get_data_for({
254 unless ( $value_sector ) {
255 $value_sector = DBM::Deep::Engine::Sector::Null->new({
260 $sector->write_data({
263 value => $value_sector,
267 return $value_sector->data;
270 =head2 get_classname( $obj )
272 This takes an object that provides _base_offset() and returns the classname (if any)
275 It delegates to Sector::Reference::get_classname() for the heavy lifting.
277 It performs a staleness check.
285 # This will be a Reference sector
286 my $sector = $self->_load_sector( $obj->_base_offset )
287 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
289 if ( $sector->staleness != $obj->_staleness ) {
293 return $sector->get_classname;
296 =head2 make_reference( $obj, $old_key, $new_key )
298 This takes an object that provides _base_offset() and two strings. The
299 strings correspond to the old key and new key, respectively. This operation
300 is equivalent to (given C<< $db->{foo} = []; >>) C<< $db->{bar} = $db->{foo}; >>.
302 This returns nothing.
308 my ($obj, $old_key, $new_key) = @_;
310 # This will be a Reference sector
311 my $sector = $self->_load_sector( $obj->_base_offset )
312 or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
314 if ( $sector->staleness != $obj->_staleness ) {
318 my $old_md5 = $self->_apply_digest( $old_key );
320 my $value_sector = $sector->get_data_for({
325 unless ( $value_sector ) {
326 $value_sector = DBM::Deep::Engine::Sector::Null->new({
331 $sector->write_data({
334 value => $value_sector,
338 if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
339 $sector->write_data({
341 key_md5 => $self->_apply_digest( $new_key ),
342 value => $value_sector,
344 $value_sector->increment_refcount;
347 $sector->write_data({
349 key_md5 => $self->_apply_digest( $new_key ),
350 value => $value_sector->clone,
357 =head2 key_exists( $obj, $key )
359 This takes an object that provides _base_offset() and a string for
360 the key to be checked. This returns 1 for true and "" for false.
366 my ($obj, $key) = @_;
368 # This will be a Reference sector
369 my $sector = $self->_load_sector( $obj->_base_offset )
372 if ( $sector->staleness != $obj->_staleness ) {
376 my $data = $sector->get_data_for({
377 key_md5 => $self->_apply_digest( $key ),
381 # exists() returns 1 or '' for true/false.
382 return $data ? 1 : '';
385 =head2 delete_key( $obj, $key )
387 This takes an object that provides _base_offset() and a string for
388 the key to be deleted. This returns the result of the Sector::Reference
395 my ($obj, $key) = @_;
397 my $sector = $self->_load_sector( $obj->_base_offset )
400 if ( $sector->staleness != $obj->_staleness ) {
404 return $sector->delete_key({
405 key_md5 => $self->_apply_digest( $key ),
410 =head2 write_value( $obj, $key, $value )
412 This takes an object that provides _base_offset(), a string for the
413 key, and a value. This value can be anything storable within L<DBM::Deep/>.
415 This returns 1 upon success.
421 my ($obj, $key, $value) = @_;
423 my $r = Scalar::Util::reftype( $value ) || '';
426 last if $r eq 'HASH';
427 last if $r eq 'ARRAY';
429 DBM::Deep->_throw_error(
430 "Storage of references of type '$r' is not supported."
434 # This will be a Reference sector
435 my $sector = $self->_load_sector( $obj->_base_offset )
436 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
438 if ( $sector->staleness != $obj->_staleness ) {
439 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
443 if ( !defined $value ) {
444 $class = 'DBM::Deep::Engine::Sector::Null';
446 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
448 if ( $r eq 'ARRAY' ) {
449 $tmpvar = tied @$value;
450 } elsif ( $r eq 'HASH' ) {
451 $tmpvar = tied %$value;
455 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
457 unless ( $is_dbm_deep ) {
458 DBM::Deep->_throw_error( "Cannot store something that is tied." );
461 unless ( $tmpvar->_engine->storage == $self->storage ) {
462 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
465 # First, verify if we're storing the same thing to this spot. If we are, then
466 # this should be a no-op. -EJS, 2008-05-19
467 my $loc = $sector->get_data_location_for({
468 key_md5 => $self->_apply_digest( $key ),
472 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
476 #XXX Can this use $loc?
477 my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
478 $sector->write_data({
480 key_md5 => $self->_apply_digest( $key ),
481 value => $value_sector,
483 $value_sector->increment_refcount;
488 $class = 'DBM::Deep::Engine::Sector::Reference';
489 $type = substr( $r, 0, 1 );
492 if ( tied($value) ) {
493 DBM::Deep->_throw_error( "Cannot store something that is tied." );
495 $class = 'DBM::Deep::Engine::Sector::Scalar';
498 # Create this after loading the reference sector in case something bad happens.
499 # This way, we won't allocate value sector(s) needlessly.
500 my $value_sector = $class->new({
506 $sector->write_data({
508 key_md5 => $self->_apply_digest( $key ),
509 value => $value_sector,
512 # This code is to make sure we write all the values in the $value to the disk
513 # and to make sure all changes to $value after the assignment are reflected
514 # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
515 # NOTE - simply tying $value won't perform a STORE on each value. Hence, the
516 # copy to a temp value.
517 if ( $r eq 'ARRAY' ) {
519 tie @$value, 'DBM::Deep', {
520 base_offset => $value_sector->offset,
521 staleness => $value_sector->staleness,
522 storage => $self->storage,
526 bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
528 elsif ( $r eq 'HASH' ) {
530 tie %$value, 'DBM::Deep', {
531 base_offset => $value_sector->offset,
532 staleness => $value_sector->staleness,
533 storage => $self->storage,
538 bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
544 =head2 get_next_key( $obj, $prev_key )
546 This takes an object that provides _base_offset() and an optional string
547 representing the prior key returned via a prior invocation of this method.
549 This method delegates to C<< DBM::Deep::Iterator->get_next_key() >>.
553 # XXX Add staleness here
556 my ($obj, $prev_key) = @_;
558 # XXX Need to add logic about resetting the iterator if any key in the reference has changed
559 unless ( $prev_key ) {
560 $obj->{iterator} = DBM::Deep::Iterator->new({
561 base_offset => $obj->_base_offset,
566 return $obj->{iterator}->get_next_key( $obj );
569 =head2 setup_fh( $obj )
571 This takes an object that provides _base_offset(). It will do everything needed
572 in order to properly initialize all values for necessary functioning. If this is
573 called upon an already initialized object, this will also reset the inode.
583 # We're opening the file.
584 unless ( $obj->_base_offset ) {
585 my $bytes_read = $self->_read_file_header;
587 # Creating a new file
588 unless ( $bytes_read ) {
589 $self->_write_file_header;
591 # 1) Create Array/Hash entry
592 my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
596 $obj->{base_offset} = $initial_reference->offset;
597 $obj->{staleness} = $initial_reference->staleness;
599 $self->storage->flush;
601 # Reading from an existing file
603 $obj->{base_offset} = $bytes_read;
604 my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
606 offset => $obj->_base_offset,
608 unless ( $initial_reference ) {
609 DBM::Deep->_throw_error("Corrupted file, no master index record");
612 unless ($obj->_type eq $initial_reference->type) {
613 DBM::Deep->_throw_error("File type mismatch");
616 $obj->{staleness} = $initial_reference->staleness;
620 $self->storage->set_inode;
625 =head2 begin_work( $obj )
627 This takes an object that provides _base_offset(). It will set up all necessary
628 bookkeeping in order to run all work within a transaction.
630 If $obj is already within a transaction, an error wiill be thrown. If there are
631 no more available transactions, an error will be thrown.
641 if ( $self->trans_id ) {
642 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
645 my @slots = $self->read_txn_slots;
647 for my $i ( 0 .. $#slots ) {
651 $self->set_trans_id( $i + 1 );
656 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
658 $self->write_txn_slots( @slots );
660 if ( !$self->trans_id ) {
661 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
667 =head2 rollback( $obj )
669 This takes an object that provides _base_offset(). It will revert all
670 actions taken within the running transaction.
672 If $obj is not within a transaction, an error will be thrown.
682 if ( !$self->trans_id ) {
683 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
686 # Each entry is the file location for a bucket that has a modification for
687 # this transaction. The entries need to be expunged.
688 foreach my $entry (@{ $self->get_entries } ) {
689 # Remove the entry here
690 my $read_loc = $entry
694 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
696 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
697 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
698 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
700 if ( $data_loc > 1 ) {
701 $self->_load_sector( $data_loc )->free;
705 $self->clear_entries;
707 my @slots = $self->read_txn_slots;
708 $slots[$self->trans_id-1] = 0;
709 $self->write_txn_slots( @slots );
710 $self->inc_txn_staleness_counter( $self->trans_id );
711 $self->set_trans_id( 0 );
716 =head2 commit( $obj )
718 This takes an object that provides _base_offset(). It will apply all
719 actions taken within the transaction to the HEAD.
721 If $obj is not within a transaction, an error will be thrown.
731 if ( !$self->trans_id ) {
732 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
735 foreach my $entry (@{ $self->get_entries } ) {
736 # Overwrite the entry in head with the entry in trans_id
741 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
742 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
744 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
745 my $trans_loc = $self->storage->read_at(
746 $spot, $self->byte_size,
749 $self->storage->print_at( $base, $trans_loc );
750 $self->storage->print_at(
752 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
755 if ( $head_loc > 1 ) {
756 $self->_load_sector( $head_loc )->free;
760 $self->clear_entries;
762 my @slots = $self->read_txn_slots;
763 $slots[$self->trans_id-1] = 0;
764 $self->write_txn_slots( @slots );
765 $self->inc_txn_staleness_counter( $self->trans_id );
766 $self->set_trans_id( 0 );
771 =head2 lock_exclusive()
773 This takes an object that provides _base_offset(). It will guarantee that
774 the storage has taken precautions to be safe for a write.
776 This returns nothing.
783 return $self->storage->lock_exclusive( $obj );
788 This takes an object that provides _base_offset(). It will guarantee that
789 the storage has taken precautions to be safe for a read.
791 This returns nothing.
798 return $self->storage->lock_shared( $obj );
803 This takes an object that provides _base_offset(). It will guarantee that
804 the storage has released all locks taken.
806 This returns nothing.
814 my $rv = $self->storage->unlock( $obj );
821 =head1 INTERNAL METHODS
823 The following methods are internal-use-only to DBM::Deep::Engine.
827 =head2 read_txn_slots()
829 This takes no arguments.
831 This will return an array with a 1 or 0 in each slot. Each spot represents one
832 available transaction. If the slot is 1, that transaction is taken. If it is 0,
833 the transaction is available.
839 my $bl = $self->txn_bitfield_len;
840 my $num_bits = $bl * 8;
841 return split '', unpack( 'b'.$num_bits,
842 $self->storage->read_at(
843 $self->trans_loc, $bl,
848 =head2 write_txn_slots( @slots )
850 This takes an array of 1's and 0's. This array represents the transaction slots
851 returned by L</read_txn_slots()>. In other words, the following is true:
853 @x = read_txn_slots( write_txn_slots( @x ) );
855 (With the obviously missing object referents added back in.)
859 sub write_txn_slots {
861 my $num_bits = $self->txn_bitfield_len * 8;
862 $self->storage->print_at( $self->trans_loc,
863 pack( 'b'.$num_bits, join('', @_) ),
867 =head2 get_running_txn_ids()
869 This takes no arguments.
871 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
875 sub get_running_txn_ids {
877 my @transactions = $self->read_txn_slots;
878 my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
881 =head2 get_txn_staleness_counter( $trans_id )
883 This will return the staleness counter for the given transaction ID. Please see
884 L</TRANSACTION STALENESS> for more information.
888 sub get_txn_staleness_counter {
892 # Hardcode staleness of 0 for the HEAD
893 return 0 unless $trans_id;
895 return unpack( $StP{$STALE_SIZE},
896 $self->storage->read_at(
897 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
903 =head2 inc_txn_staleness_counter( $trans_id )
905 This will increment the staleness counter for the given transaction ID. Please see
906 L</TRANSACTION STALENESS> for more information.
910 sub inc_txn_staleness_counter {
914 # Hardcode staleness of 0 for the HEAD
915 return 0 unless $trans_id;
917 $self->storage->print_at(
918 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
919 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
925 This takes no arguments.
927 This returns a list of all the sectors that have been modified by this transaction.
933 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
936 =head2 add_entry( $trans_id, $location )
938 This takes a transaction ID and a file location and marks the sector at that location
939 as having been modified by the transaction identified by $trans_id.
941 This returns nothing.
943 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
944 C<< $trans_id != $self->trans_id >> for this method.
950 my ($trans_id, $loc) = @_;
952 $self->{entries}{$trans_id} ||= {};
953 $self->{entries}{$trans_id}{$loc} = undef;
956 =head2 reindex_entry( $old_loc, $new_loc )
958 This takes two locations (old and new, respectively). If a location that has been
959 modified by this transaction is subsequently reindexed due to a bucketlist
960 overflowing, then the entries hash needs to be made aware of this change.
962 This returns nothing.
968 my ($old_loc, $new_loc) = @_;
971 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
972 if ( exists $locs->{$old_loc} ) {
973 delete $locs->{$old_loc};
974 $locs->{$new_loc} = undef;
980 =head2 clear_entries()
982 This takes no arguments. It will clear the entries list for the running transaction.
984 This returns nothing.
990 delete $self->{entries}{$self->trans_id};
993 =head2 _write_file_header()
995 This writes the file header for a new file. This will write the various settings
996 that set how the file is interpreted.
998 =head2 _read_file_header()
1000 This reads the file header from an existing file. This will read the various
1001 settings that set how the file is interpreted.
1006 my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
1007 my $this_file_version = 3;
1009 sub _write_file_header {
1012 my $nt = $self->num_txns;
1013 my $bl = $self->txn_bitfield_len;
1015 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
1017 my $loc = $self->storage->request_space( $header_fixed + $header_var );
1019 $self->storage->print_at( $loc,
1022 pack('N', $this_file_version), # At this point, we're at 9 bytes
1023 pack('N', $header_var), # header size
1024 # --- Above is $header_fixed. Below is $header_var
1025 pack('C', $self->byte_size),
1027 # These shenanigans are to allow a 256 within a C
1028 pack('C', $self->max_buckets - 1),
1029 pack('C', $self->data_sector_size - 1),
1032 pack('C' . $bl, 0 ), # Transaction activeness bitfield
1033 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
1034 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
1035 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
1036 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
1039 #XXX Set these less fragilely
1040 $self->set_trans_loc( $header_fixed + 4 );
1041 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
1046 sub _read_file_header {
1049 my $buffer = $self->storage->read_at( 0, $header_fixed );
1050 return unless length($buffer);
1052 my ($file_signature, $sig_header, $file_version, $size) = unpack(
1056 unless ( $file_signature eq SIG_FILE ) {
1057 $self->storage->close;
1058 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
1061 unless ( $sig_header eq SIG_HEADER ) {
1062 $self->storage->close;
1063 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
1066 unless ( $file_version == $this_file_version ) {
1067 $self->storage->close;
1068 DBM::Deep->_throw_error(
1069 "Wrong file version found - " . $file_version .
1070 " - expected " . $this_file_version
1074 my $buffer2 = $self->storage->read_at( undef, $size );
1075 my @values = unpack( 'C C C C', $buffer2 );
1077 if ( @values != 4 || grep { !defined } @values ) {
1078 $self->storage->close;
1079 DBM::Deep->_throw_error("Corrupted file - bad header");
1082 #XXX Add warnings if values weren't set right
1083 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
1085 # These shenangians are to allow a 256 within a C
1086 $self->{max_buckets} += 1;
1087 $self->{data_sector_size} += 1;
1089 my $bl = $self->txn_bitfield_len;
1091 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
1092 unless ( $size == $header_var ) {
1093 $self->storage->close;
1094 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
1097 $self->set_trans_loc( $header_fixed + scalar(@values) );
1098 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
1100 return length($buffer) + length($buffer2);
1104 =head2 _load_sector( $offset )
1106 This will instantiate and return the sector object that represents the data found
1115 # Add a catch for offset of 0 or 1
1116 return if !$offset || $offset <= 1;
1118 my $type = $self->storage->read_at( $offset, 1 );
1119 return if $type eq chr(0);
1121 if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
1122 return DBM::Deep::Engine::Sector::Reference->new({
1128 # XXX Don't we need key_md5 here?
1129 elsif ( $type eq $self->SIG_BLIST ) {
1130 return DBM::Deep::Engine::Sector::BucketList->new({
1136 elsif ( $type eq $self->SIG_INDEX ) {
1137 return DBM::Deep::Engine::Sector::Index->new({
1143 elsif ( $type eq $self->SIG_NULL ) {
1144 return DBM::Deep::Engine::Sector::Null->new({
1150 elsif ( $type eq $self->SIG_DATA ) {
1151 return DBM::Deep::Engine::Sector::Scalar->new({
1157 # This was deleted from under us, so just return and let the caller figure it out.
1158 elsif ( $type eq $self->SIG_FREE ) {
1162 DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
1165 =head2 _apply_digest( @stuff )
1167 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
1168 passed in and return the result.
1174 return $self->{digest}->(@_);
1177 =head2 _add_free_blist_sector( $offset, $size )
1179 =head2 _add_free_data_sector( $offset, $size )
1181 =head2 _add_free_index_sector( $offset, $size )
1183 These methods are all wrappers around _add_free_sector(), providing the proper
1184 chain offset ($multiple) for the sector type.
1188 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
1189 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
1190 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
1192 =head2 _add_free_sector( $multiple, $offset, $size )
1194 _add_free_sector() takes the offset into the chains location, the offset of the
1195 sector, and the size of that sector. It will mark the sector as a free sector
1196 and put it into the list of sectors that are free of this type for use later.
1198 This returns nothing.
1200 B<NOTE>: $size is unused?
1204 sub _add_free_sector {
1206 my ($multiple, $offset, $size) = @_;
1208 my $chains_offset = $multiple * $self->byte_size;
1210 my $storage = $self->storage;
1212 # Increment staleness.
1213 # XXX Can this increment+modulo be done by "&= 0x1" ?
1214 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + SIG_SIZE, $STALE_SIZE ) );
1215 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
1216 $storage->print_at( $offset + SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
1218 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
1220 $storage->print_at( $self->chains_loc + $chains_offset,
1221 pack( $StP{$self->byte_size}, $offset ),
1224 # Record the old head in the new sector after the signature and staleness counter
1225 $storage->print_at( $offset + SIG_SIZE + $STALE_SIZE, $old_head );
1228 =head2 _request_blist_sector( $size )
1230 =head2 _request_data_sector( $size )
1232 =head2 _request_index_sector( $size )
1234 These methods are all wrappers around _request_sector(), providing the proper
1235 chain offset ($multiple) for the sector type.
1239 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
1240 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
1241 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
1243 =head2 _request_sector( $multiple $size )
1245 This takes the offset into the chains location and the size of that sector.
1247 This returns the object with the sector. If there is an available free sector of
1248 that type, then it will be reused. If there isn't one, then a new one will be
1253 sub _request_sector {
1255 my ($multiple, $size) = @_;
1257 my $chains_offset = $multiple * $self->byte_size;
1259 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
1260 my $loc = unpack( $StP{$self->byte_size}, $old_head );
1262 # We don't have any free sectors of the right size, so allocate a new one.
1264 my $offset = $self->storage->request_space( $size );
1266 # Zero out the new sector. This also guarantees correct increases
1268 $self->storage->print_at( $offset, chr(0) x $size );
1273 # Read the new head after the signature and the staleness counter
1274 my $new_head = $self->storage->read_at( $loc + SIG_SIZE + $STALE_SIZE, $self->byte_size );
1275 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
1276 $self->storage->print_at(
1277 $loc + SIG_SIZE + $STALE_SIZE,
1278 pack( $StP{$self->byte_size}, 0 ),
1286 This takes no arguments. It will do everything necessary to flush all things to
1287 disk. This is usually called during unlock() and setup_fh().
1289 This returns nothing.
1296 # Why do we need to have the storage flush? Shouldn't autoflush take care of things?
1298 $self->storage->flush;
1303 The following are readonly attributes.
1321 =item * data_sector_size
1323 =item * txn_bitfield_len
1329 sub storage { $_[0]{storage} }
1330 sub byte_size { $_[0]{byte_size} }
1331 sub hash_size { $_[0]{hash_size} }
1332 sub hash_chars { $_[0]{hash_chars} }
1333 sub num_txns { $_[0]{num_txns} }
1334 sub max_buckets { $_[0]{max_buckets} }
1335 sub blank_md5 { chr(0) x $_[0]->hash_size }
1336 sub data_sector_size { $_[0]{data_sector_size} }
1338 # This is a calculated value
1339 sub txn_bitfield_len {
1341 unless ( exists $self->{txn_bitfield_len} ) {
1342 my $temp = ($self->num_txns) / 8;
1343 if ( $temp > int( $temp ) ) {
1344 $temp = int( $temp ) + 1;
1346 $self->{txn_bitfield_len} = $temp;
1348 return $self->{txn_bitfield_len};
1353 The following are read/write attributes.
1357 =item * trans_id / set_trans_id( $new_id )
1359 =item * trans_loc / set_trans_loc( $new_loc )
1361 =item * chains_loc / set_chains_loc( $new_loc )
1367 sub trans_id { $_[0]{trans_id} }
1368 sub set_trans_id { $_[0]{trans_id} = $_[1] }
1370 sub trans_loc { $_[0]{trans_loc} }
1371 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1373 sub chains_loc { $_[0]{chains_loc} }
1374 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1376 sub cache { $_[0]{cache} ||= {} }
1377 sub clear_cache { %{$_[0]->cache} = () }
1381 This method takes no arguments. It's used to print out a textual representation of the DBM::Deep
1382 DB file. It assumes the file is not-corrupted.
1390 my $spot = $self->_read_file_header();
1399 'D' => $self->data_sector_size,
1400 'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
1401 'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
1407 $return .= "NumTxns: " . $self->num_txns . $/;
1409 # Read the free sector chains
1411 foreach my $multiple ( 0 .. 2 ) {
1412 $return .= "Chains($types{$multiple}):";
1413 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1416 $StP{$self->byte_size},
1417 $self->storage->read_at( $old_loc, $self->byte_size ),
1420 # We're now out of free sectors of this kind.
1425 $sectors{ $types{$multiple} }{ $loc } = undef;
1426 $old_loc = $loc + SIG_SIZE + $STALE_SIZE;
1433 while ( $spot < $self->storage->{end} ) {
1434 # Read each sector in order.
1435 my $sector = $self->_load_sector( $spot );
1437 # Find it in the free-sectors that were found already
1438 foreach my $type ( keys %sectors ) {
1439 if ( exists $sectors{$type}{$spot} ) {
1440 my $size = $sizes{$type};
1441 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1447 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1450 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1451 if ( $sector->type eq 'D' ) {
1452 $return .= ' ' . $sector->data;
1454 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1455 $return .= ' REF: ' . $sector->get_refcount;
1457 elsif ( $sector->type eq 'B' ) {
1458 foreach my $bucket ( $sector->chopped_up ) {
1460 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1461 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1463 my $l = unpack( $StP{$self->byte_size},
1464 substr( $bucket->[-1],
1465 $self->hash_size + $self->byte_size,
1469 $return .= sprintf " %08d", $l;
1470 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1471 my $l = unpack( $StP{$self->byte_size},
1472 substr( $bucket->[-1],
1473 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1477 $return .= sprintf " %08d", $l;
1483 $spot += $sector->size;