1 package DBM::Deep::Engine::File;
6 use warnings FATAL => 'all';
8 use base qw( DBM::Deep::Engine );
12 use DBM::Deep::Null ();
13 use DBM::Deep::Sector::File ();
14 use DBM::Deep::Storage::File ();
16 sub sector_type { 'DBM::Deep::Sector::File' }
17 sub iterator_class { 'DBM::Deep::Iterator::File' }
21 # Setup file and tag signatures. These should never change.
22 sub SIG_FILE () { 'DPDB' }
23 sub SIG_HEADER () { 'h' }
24 sub SIG_NULL () { 'N' }
25 sub SIG_DATA () { 'D' }
26 sub SIG_INDEX () { 'I' }
27 sub SIG_BLIST () { 'B' }
28 sub SIG_FREE () { 'F' }
30 # SIG_HASH and SIG_ARRAY are defined in DBM::Deep::Engine
32 # Please refer to the pack() documentation for further information
34 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
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)
42 DBM::Deep::Engine::File
46 This is the engine for use with L<DBM::Deep::Storage::File/>.
48 =head1 EXTERNAL METHODS
52 This takes a set of args. These args are described in the documentation for
61 $args->{storage} = DBM::Deep::Storage::File->new( $args )
62 unless exists $args->{storage};
68 hash_size => 16, # In bytes
69 hash_chars => 256, # Number of chars the algorithm uses per byte
71 num_txns => 1, # The HEAD
72 trans_id => 0, # Default to the HEAD
74 data_sector_size => 64, # Size in bytes of each data sector
76 entries => {}, # This is the list of entries for transactions
80 # Never allow byte_size to be set directly.
81 delete $args->{byte_size};
82 if ( defined $args->{pack_size} ) {
83 if ( lc $args->{pack_size} eq 'small' ) {
84 $args->{byte_size} = 2;
86 elsif ( lc $args->{pack_size} eq 'medium' ) {
87 $args->{byte_size} = 4;
89 elsif ( lc $args->{pack_size} eq 'large' ) {
90 $args->{byte_size} = 8;
93 DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
97 # Grab the parameters we want to use
98 foreach my $param ( keys %$self ) {
99 next unless exists $args->{$param};
100 $self->{$param} = $args->{$param};
104 max_buckets => { floor => 16, ceil => 256 },
105 num_txns => { floor => 1, ceil => 255 },
106 data_sector_size => { floor => 32, ceil => 256 },
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}
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};
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};
125 if ( !$self->{digest} ) {
127 $self->{digest} = \&Digest::MD5::md5;
135 my ($obj, $key) = @_;
137 # This will be a Reference sector
138 my $sector = $self->load_sector( $obj->_base_offset )
141 if ( $sector->staleness != $obj->_staleness ) {
145 my $key_md5 = $self->_apply_digest( $key );
147 my $value_sector = $sector->get_data_for({
152 unless ( $value_sector ) {
153 $value_sector = DBM::Deep::Sector::File::Null->new({
158 $sector->write_data({
161 value => $value_sector,
165 return $value_sector->data;
172 # This will be a Reference sector
173 my $sector = $self->load_sector( $obj->_base_offset )
174 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
176 if ( $sector->staleness != $obj->_staleness ) {
180 return $sector->get_classname;
185 my ($obj, $old_key, $new_key) = @_;
187 # This will be a Reference sector
188 my $sector = $self->load_sector( $obj->_base_offset )
189 or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
191 if ( $sector->staleness != $obj->_staleness ) {
195 my $old_md5 = $self->_apply_digest( $old_key );
197 my $value_sector = $sector->get_data_for({
202 unless ( $value_sector ) {
203 $value_sector = DBM::Deep::Sector::File::Null->new({
208 $sector->write_data({
211 value => $value_sector,
215 if ( $value_sector->isa( 'DBM::Deep::Sector::File::Reference' ) ) {
216 $sector->write_data({
218 key_md5 => $self->_apply_digest( $new_key ),
219 value => $value_sector,
221 $value_sector->increment_refcount;
224 $sector->write_data({
226 key_md5 => $self->_apply_digest( $new_key ),
227 value => $value_sector->clone,
234 # exists returns '', not undefined.
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 $data = $sector->get_data_for({
248 key_md5 => $self->_apply_digest( $key ),
252 # exists() returns 1 or '' for true/false.
253 return $data ? 1 : '';
258 my ($obj, $key) = @_;
260 my $sector = $self->load_sector( $obj->_base_offset )
263 if ( $sector->staleness != $obj->_staleness ) {
267 return $sector->delete_key({
268 key_md5 => $self->_apply_digest( $key ),
275 my ($obj, $key, $value) = @_;
277 my $r = Scalar::Util::reftype( $value ) || '';
280 last if $r eq 'HASH';
281 last if $r eq 'ARRAY';
283 DBM::Deep->_throw_error(
284 "Storage of references of type '$r' is not supported."
288 # This will be a Reference sector
289 my $sector = $self->load_sector( $obj->_base_offset )
290 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
292 if ( $sector->staleness != $obj->_staleness ) {
293 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
297 if ( !defined $value ) {
298 $class = 'DBM::Deep::Sector::File::Null';
300 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
302 if ( $r eq 'ARRAY' ) {
303 $tmpvar = tied @$value;
304 } elsif ( $r eq 'HASH' ) {
305 $tmpvar = tied %$value;
309 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
311 unless ( $is_dbm_deep ) {
312 DBM::Deep->_throw_error( "Cannot store something that is tied." );
315 unless ( $tmpvar->_engine->storage == $self->storage ) {
316 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
319 # First, verify if we're storing the same thing to this spot. If we
320 # are, then this should be a no-op. -EJS, 2008-05-19
321 my $loc = $sector->get_data_location_for({
322 key_md5 => $self->_apply_digest( $key ),
326 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
330 #XXX Can this use $loc?
331 my $value_sector = $self->load_sector( $tmpvar->_base_offset );
332 $sector->write_data({
334 key_md5 => $self->_apply_digest( $key ),
335 value => $value_sector,
337 $value_sector->increment_refcount;
342 $class = 'DBM::Deep::Sector::File::Reference';
343 $type = substr( $r, 0, 1 );
346 if ( tied($value) ) {
347 DBM::Deep->_throw_error( "Cannot store something that is tied." );
349 $class = 'DBM::Deep::Sector::File::Scalar';
352 # Create this after loading the reference sector in case something bad
353 # happens. This way, we won't allocate value sector(s) needlessly.
354 my $value_sector = $class->new({
360 $sector->write_data({
362 key_md5 => $self->_apply_digest( $key ),
363 value => $value_sector,
366 # This code is to make sure we write all the values in the $value to the
367 # disk and to make sure all changes to $value after the assignment are
368 # reflected on disk. This may be counter-intuitive at first, but it is
370 # NOTE - simply tying $value won't perform a STORE on each value. Hence,
371 # the copy to a temp value.
372 if ( $r eq 'ARRAY' ) {
374 tie @$value, 'DBM::Deep', {
375 base_offset => $value_sector->offset,
376 staleness => $value_sector->staleness,
377 storage => $self->storage,
381 bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
383 elsif ( $r eq 'HASH' ) {
385 tie %$value, 'DBM::Deep', {
386 base_offset => $value_sector->offset,
387 staleness => $value_sector->staleness,
388 storage => $self->storage,
393 bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
403 # We're opening the file.
404 unless ( $obj->_base_offset ) {
405 my $bytes_read = $self->_read_file_header;
407 # Creating a new file
408 unless ( $bytes_read ) {
409 $self->_write_file_header;
411 # 1) Create Array/Hash entry
412 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
416 $obj->{base_offset} = $initial_reference->offset;
417 $obj->{staleness} = $initial_reference->staleness;
419 $self->storage->flush;
421 # Reading from an existing file
423 $obj->{base_offset} = $bytes_read;
424 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
426 offset => $obj->_base_offset,
428 unless ( $initial_reference ) {
429 DBM::Deep->_throw_error("Corrupted file, no master index record");
432 unless ($obj->_type eq $initial_reference->type) {
433 DBM::Deep->_throw_error("File type mismatch");
436 $obj->{staleness} = $initial_reference->staleness;
440 $self->storage->set_inode;
449 if ( $self->trans_id ) {
450 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
453 my @slots = $self->read_txn_slots;
455 for my $i ( 0 .. $#slots ) {
459 $self->set_trans_id( $i + 1 );
464 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
466 $self->write_txn_slots( @slots );
468 if ( !$self->trans_id ) {
469 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
479 if ( !$self->trans_id ) {
480 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
483 # Each entry is the file location for a bucket that has a modification for
484 # this transaction. The entries need to be expunged.
485 foreach my $entry (@{ $self->get_entries } ) {
486 # Remove the entry here
487 my $read_loc = $entry
491 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
493 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
494 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
495 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
497 if ( $data_loc > 1 ) {
498 $self->load_sector( $data_loc )->free;
502 $self->clear_entries;
504 my @slots = $self->read_txn_slots;
505 $slots[$self->trans_id-1] = 0;
506 $self->write_txn_slots( @slots );
507 $self->inc_txn_staleness_counter( $self->trans_id );
508 $self->set_trans_id( 0 );
517 if ( !$self->trans_id ) {
518 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
521 foreach my $entry (@{ $self->get_entries } ) {
522 # Overwrite the entry in head with the entry in trans_id
527 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
528 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
530 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
531 my $trans_loc = $self->storage->read_at(
532 $spot, $self->byte_size,
535 $self->storage->print_at( $base, $trans_loc );
536 $self->storage->print_at(
538 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
541 if ( $head_loc > 1 ) {
542 $self->load_sector( $head_loc )->free;
546 $self->clear_entries;
548 my @slots = $self->read_txn_slots;
549 $slots[$self->trans_id-1] = 0;
550 $self->write_txn_slots( @slots );
551 $self->inc_txn_staleness_counter( $self->trans_id );
552 $self->set_trans_id( 0 );
557 =head1 INTERNAL METHODS
559 The following methods are internal-use-only to DBM::Deep::Engine::File.
563 =head2 read_txn_slots()
565 This takes no arguments.
567 This will return an array with a 1 or 0 in each slot. Each spot represents one
568 available transaction. If the slot is 1, that transaction is taken. If it is 0,
569 the transaction is available.
575 my $bl = $self->txn_bitfield_len;
576 my $num_bits = $bl * 8;
577 return split '', unpack( 'b'.$num_bits,
578 $self->storage->read_at(
579 $self->trans_loc, $bl,
584 =head2 write_txn_slots( @slots )
586 This takes an array of 1's and 0's. This array represents the transaction slots
587 returned by L</read_txn_slots()>. In other words, the following is true:
589 @x = read_txn_slots( write_txn_slots( @x ) );
591 (With the obviously missing object referents added back in.)
595 sub write_txn_slots {
597 my $num_bits = $self->txn_bitfield_len * 8;
598 $self->storage->print_at( $self->trans_loc,
599 pack( 'b'.$num_bits, join('', @_) ),
603 =head2 get_running_txn_ids()
605 This takes no arguments.
607 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
611 sub get_running_txn_ids {
613 my @transactions = $self->read_txn_slots;
614 my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
617 =head2 get_txn_staleness_counter( $trans_id )
619 This will return the staleness counter for the given transaction ID. Please see
620 L</TRANSACTION STALENESS> for more information.
624 sub get_txn_staleness_counter {
628 # Hardcode staleness of 0 for the HEAD
629 return 0 unless $trans_id;
631 return unpack( $StP{$STALE_SIZE},
632 $self->storage->read_at(
633 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
639 =head2 inc_txn_staleness_counter( $trans_id )
641 This will increment the staleness counter for the given transaction ID. Please see
642 L</TRANSACTION STALENESS> for more information.
646 sub inc_txn_staleness_counter {
650 # Hardcode staleness of 0 for the HEAD
651 return 0 unless $trans_id;
653 $self->storage->print_at(
654 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
655 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
661 This takes no arguments.
663 This returns a list of all the sectors that have been modified by this transaction.
669 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
672 =head2 add_entry( $trans_id, $location )
674 This takes a transaction ID and a file location and marks the sector at that
675 location as having been modified by the transaction identified by $trans_id.
677 This returns nothing.
679 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
680 C<< $trans_id != $self->trans_id >> for this method.
686 my ($trans_id, $loc) = @_;
688 $self->{entries}{$trans_id} ||= {};
689 $self->{entries}{$trans_id}{$loc} = undef;
692 =head2 reindex_entry( $old_loc, $new_loc )
694 This takes two locations (old and new, respectively). If a location that has
695 been modified by this transaction is subsequently reindexed due to a bucketlist
696 overflowing, then the entries hash needs to be made aware of this change.
698 This returns nothing.
704 my ($old_loc, $new_loc) = @_;
707 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
708 if ( exists $locs->{$old_loc} ) {
709 delete $locs->{$old_loc};
710 $locs->{$new_loc} = undef;
716 =head2 clear_entries()
718 This takes no arguments. It will clear the entries list for the running
721 This returns nothing.
727 delete $self->{entries}{$self->trans_id};
730 =head2 _write_file_header()
732 This writes the file header for a new file. This will write the various settings
733 that set how the file is interpreted.
735 =head2 _read_file_header()
737 This reads the file header from an existing file. This will read the various
738 settings that set how the file is interpreted.
743 my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
744 my $this_file_version = 3;
746 sub _write_file_header {
749 my $nt = $self->num_txns;
750 my $bl = $self->txn_bitfield_len;
752 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
754 my $loc = $self->storage->request_space( $header_fixed + $header_var );
756 $self->storage->print_at( $loc,
759 pack('N', $this_file_version), # At this point, we're at 9 bytes
760 pack('N', $header_var), # header size
761 # --- Above is $header_fixed. Below is $header_var
762 pack('C', $self->byte_size),
764 # These shenanigans are to allow a 256 within a C
765 pack('C', $self->max_buckets - 1),
766 pack('C', $self->data_sector_size - 1),
769 pack('C' . $bl, 0 ), # Transaction activeness bitfield
770 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
771 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
772 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
773 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
776 #XXX Set these less fragilely
777 $self->set_trans_loc( $header_fixed + 4 );
778 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
783 sub _read_file_header {
786 my $buffer = $self->storage->read_at( 0, $header_fixed );
787 return unless length($buffer);
789 my ($file_signature, $sig_header, $file_version, $size) = unpack(
793 unless ( $file_signature eq $self->SIG_FILE ) {
794 $self->storage->close;
795 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
798 unless ( $sig_header eq $self->SIG_HEADER ) {
799 $self->storage->close;
800 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
803 unless ( $file_version == $this_file_version ) {
804 $self->storage->close;
805 DBM::Deep->_throw_error(
806 "Wrong file version found - " . $file_version .
807 " - expected " . $this_file_version
811 my $buffer2 = $self->storage->read_at( undef, $size );
812 my @values = unpack( 'C C C C', $buffer2 );
814 if ( @values != 4 || grep { !defined } @values ) {
815 $self->storage->close;
816 DBM::Deep->_throw_error("Corrupted file - bad header");
819 #XXX Add warnings if values weren't set right
820 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
822 # These shenangians are to allow a 256 within a C
823 $self->{max_buckets} += 1;
824 $self->{data_sector_size} += 1;
826 my $bl = $self->txn_bitfield_len;
828 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
829 unless ( $size == $header_var ) {
830 $self->storage->close;
831 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
834 $self->set_trans_loc( $header_fixed + scalar(@values) );
835 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
837 return length($buffer) + length($buffer2);
841 =head2 _apply_digest( @stuff )
843 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
844 passed in and return the result.
850 return $self->{digest}->(@_);
853 =head2 _add_free_blist_sector( $offset, $size )
855 =head2 _add_free_data_sector( $offset, $size )
857 =head2 _add_free_index_sector( $offset, $size )
859 These methods are all wrappers around _add_free_sector(), providing the proper
860 chain offset ($multiple) for the sector type.
864 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
865 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
866 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
868 =head2 _add_free_sector( $multiple, $offset, $size )
870 _add_free_sector() takes the offset into the chains location, the offset of the
871 sector, and the size of that sector. It will mark the sector as a free sector
872 and put it into the list of sectors that are free of this type for use later.
874 This returns nothing.
876 B<NOTE>: $size is unused?
880 sub _add_free_sector {
882 my ($multiple, $offset, $size) = @_;
884 my $chains_offset = $multiple * $self->byte_size;
886 my $storage = $self->storage;
888 # Increment staleness.
889 # XXX Can this increment+modulo be done by "&= 0x1" ?
890 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
891 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
892 $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
894 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
896 $storage->print_at( $self->chains_loc + $chains_offset,
897 pack( $StP{$self->byte_size}, $offset ),
900 # Record the old head in the new sector after the signature and staleness counter
901 $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
904 =head2 _request_blist_sector( $size )
906 =head2 _request_data_sector( $size )
908 =head2 _request_index_sector( $size )
910 These methods are all wrappers around _request_sector(), providing the proper
911 chain offset ($multiple) for the sector type.
915 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
916 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
917 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
919 =head2 _request_sector( $multiple $size )
921 This takes the offset into the chains location and the size of that sector.
923 This returns the object with the sector. If there is an available free sector of
924 that type, then it will be reused. If there isn't one, then a new one will be
929 sub _request_sector {
931 my ($multiple, $size) = @_;
933 my $chains_offset = $multiple * $self->byte_size;
935 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
936 my $loc = unpack( $StP{$self->byte_size}, $old_head );
938 # We don't have any free sectors of the right size, so allocate a new one.
940 my $offset = $self->storage->request_space( $size );
942 # Zero out the new sector. This also guarantees correct increases
944 $self->storage->print_at( $offset, chr(0) x $size );
949 # Read the new head after the signature and the staleness counter
950 my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
951 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
952 $self->storage->print_at(
953 $loc + $self->SIG_SIZE + $STALE_SIZE,
954 pack( $StP{$self->byte_size}, 0 ),
962 The following are readonly attributes.
978 =item * data_sector_size
980 =item * txn_bitfield_len
986 sub byte_size { $_[0]{byte_size} }
987 sub hash_size { $_[0]{hash_size} }
988 sub hash_chars { $_[0]{hash_chars} }
989 sub num_txns { $_[0]{num_txns} }
990 sub max_buckets { $_[0]{max_buckets} }
991 sub blank_md5 { chr(0) x $_[0]->hash_size }
992 sub data_sector_size { $_[0]{data_sector_size} }
994 # This is a calculated value
995 sub txn_bitfield_len {
997 unless ( exists $self->{txn_bitfield_len} ) {
998 my $temp = ($self->num_txns) / 8;
999 if ( $temp > int( $temp ) ) {
1000 $temp = int( $temp ) + 1;
1002 $self->{txn_bitfield_len} = $temp;
1004 return $self->{txn_bitfield_len};
1009 The following are read/write attributes.
1013 =item * trans_id / set_trans_id( $new_id )
1015 =item * trans_loc / set_trans_loc( $new_loc )
1017 =item * chains_loc / set_chains_loc( $new_loc )
1023 sub trans_id { $_[0]{trans_id} }
1024 sub set_trans_id { $_[0]{trans_id} = $_[1] }
1026 sub trans_loc { $_[0]{trans_loc} }
1027 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1029 sub chains_loc { $_[0]{chains_loc} }
1030 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1034 This method takes no arguments. It's used to print out a textual representation
1035 of the DBM::Deep DB file. It assumes the file is not-corrupted.
1043 my $spot = $self->_read_file_header();
1052 'D' => $self->data_sector_size,
1053 'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
1054 'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
1060 $return .= "NumTxns: " . $self->num_txns . $/;
1062 # Read the free sector chains
1064 foreach my $multiple ( 0 .. 2 ) {
1065 $return .= "Chains($types{$multiple}):";
1066 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1069 $StP{$self->byte_size},
1070 $self->storage->read_at( $old_loc, $self->byte_size ),
1073 # We're now out of free sectors of this kind.
1078 $sectors{ $types{$multiple} }{ $loc } = undef;
1079 $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
1086 while ( $spot < $self->storage->{end} ) {
1087 # Read each sector in order.
1088 my $sector = $self->load_sector( $spot );
1090 # Find it in the free-sectors that were found already
1091 foreach my $type ( keys %sectors ) {
1092 if ( exists $sectors{$type}{$spot} ) {
1093 my $size = $sizes{$type};
1094 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1100 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1103 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1104 if ( $sector->type eq 'D' ) {
1105 $return .= ' ' . $sector->data;
1107 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1108 $return .= ' REF: ' . $sector->get_refcount;
1110 elsif ( $sector->type eq 'B' ) {
1111 foreach my $bucket ( $sector->chopped_up ) {
1113 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1114 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1116 my $l = unpack( $StP{$self->byte_size},
1117 substr( $bucket->[-1],
1118 $self->hash_size + $self->byte_size,
1122 $return .= sprintf " %08d", $l;
1123 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1124 my $l = unpack( $StP{$self->byte_size},
1125 substr( $bucket->[-1],
1126 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1130 $return .= sprintf " %08d", $l;
1136 $spot += $sector->size;