1 package DBM::Deep::Engine::File;
6 use warnings FATAL => 'all';
7 no warnings 'recursion';
9 use base qw( DBM::Deep::Engine );
13 use DBM::Deep::Null ();
14 use DBM::Deep::Sector::File ();
15 use DBM::Deep::Storage::File ();
17 sub sector_type { 'DBM::Deep::Sector::File' }
18 sub iterator_class { 'DBM::Deep::Iterator::File' }
22 # Setup file and tag signatures. These should never change.
23 sub SIG_FILE () { 'DPDB' }
24 sub SIG_HEADER () { 'h' }
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' }
31 # SIG_HASH and SIG_ARRAY are defined in DBM::Deep::Engine
33 # Please refer to the pack() documentation for further information
35 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
36 2 => 'n', # Unsigned short in "network" (big-endian) order
37 4 => 'N', # Unsigned long in "network" (big-endian) order
38 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
43 DBM::Deep::Engine::File
47 This is the engine for use with L<DBM::Deep::Storage::File>.
49 =head1 EXTERNAL METHODS
53 This takes a set of args. These args are described in the documentation for
62 $args->{storage} = DBM::Deep::Storage::File->new( $args )
63 unless exists $args->{storage};
69 hash_size => 16, # In bytes
70 hash_chars => 256, # Number of chars the algorithm uses per byte
72 num_txns => 1, # The HEAD
73 trans_id => 0, # Default to the HEAD
75 data_sector_size => 64, # Size in bytes of each data sector
77 entries => {}, # This is the list of entries for transactions
81 # Never allow byte_size to be set directly.
82 delete $args->{byte_size};
83 if ( defined $args->{pack_size} ) {
84 if ( lc $args->{pack_size} eq 'small' ) {
85 $args->{byte_size} = 2;
87 elsif ( lc $args->{pack_size} eq 'medium' ) {
88 $args->{byte_size} = 4;
90 elsif ( lc $args->{pack_size} eq 'large' ) {
91 $args->{byte_size} = 8;
94 DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
98 # Grab the parameters we want to use
99 foreach my $param ( keys %$self ) {
100 next unless exists $args->{$param};
101 $self->{$param} = $args->{$param};
105 max_buckets => { floor => 16, ceil => 256 },
106 num_txns => { floor => 1, ceil => 255 },
107 data_sector_size => { floor => 32, ceil => 256 },
110 while ( my ($attr, $c) = each %validations ) {
111 if ( !defined $self->{$attr}
112 || !length $self->{$attr}
113 || $self->{$attr} =~ /\D/
114 || $self->{$attr} < $c->{floor}
116 $self->{$attr} = '(undef)' if !defined $self->{$attr};
117 warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
118 $self->{$attr} = $c->{floor};
120 elsif ( $self->{$attr} > $c->{ceil} ) {
121 warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
122 $self->{$attr} = $c->{ceil};
126 if ( !$self->{digest} ) {
128 $self->{digest} = \&Digest::MD5::md5;
136 my ($obj, $key) = @_;
138 # This will be a Reference sector
139 my $sector = $self->load_sector( $obj->_base_offset )
142 if ( $sector->staleness != $obj->_staleness ) {
146 my $key_md5 = $self->_apply_digest( $key );
148 my $value_sector = $sector->get_data_for({
153 unless ( $value_sector ) {
154 $value_sector = DBM::Deep::Sector::File::Null->new({
159 $sector->write_data({
162 value => $value_sector,
166 return $value_sector->data;
173 # This will be a Reference sector
174 my $sector = $self->load_sector( $obj->_base_offset )
175 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
177 if ( $sector->staleness != $obj->_staleness ) {
181 return $sector->get_classname;
186 my ($obj, $old_key, $new_key) = @_;
188 # This will be a Reference sector
189 my $sector = $self->load_sector( $obj->_base_offset )
190 or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
192 if ( $sector->staleness != $obj->_staleness ) {
196 my $old_md5 = $self->_apply_digest( $old_key );
198 my $value_sector = $sector->get_data_for({
203 unless ( $value_sector ) {
204 $value_sector = DBM::Deep::Sector::File::Null->new({
209 $sector->write_data({
212 value => $value_sector,
216 if ( $value_sector->isa( 'DBM::Deep::Sector::File::Reference' ) ) {
217 $sector->write_data({
219 key_md5 => $self->_apply_digest( $new_key ),
220 value => $value_sector,
222 $value_sector->increment_refcount;
225 $sector->write_data({
227 key_md5 => $self->_apply_digest( $new_key ),
228 value => $value_sector->clone,
235 # exists returns '', not undefined.
238 my ($obj, $key) = @_;
240 # This will be a Reference sector
241 my $sector = $self->load_sector( $obj->_base_offset )
244 if ( $sector->staleness != $obj->_staleness ) {
248 my $data = $sector->get_data_for({
249 key_md5 => $self->_apply_digest( $key ),
253 # exists() returns 1 or '' for true/false.
254 return $data ? 1 : '';
259 my ($obj, $key) = @_;
261 my $sector = $self->load_sector( $obj->_base_offset )
264 if ( $sector->staleness != $obj->_staleness ) {
268 return $sector->delete_key({
269 key_md5 => $self->_apply_digest( $key ),
276 my ($obj, $key, $value) = @_;
278 my $r = Scalar::Util::reftype( $value ) || '';
281 last if $r eq 'HASH';
282 last if $r eq 'ARRAY';
284 DBM::Deep->_throw_error(
285 "Storage of references of type '$r' is not supported."
289 # This will be a Reference sector
290 my $sector = $self->load_sector( $obj->_base_offset )
291 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
293 if ( $sector->staleness != $obj->_staleness ) {
294 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
298 if ( !defined $value ) {
299 $class = 'DBM::Deep::Sector::File::Null';
301 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
303 if ( $r eq 'ARRAY' ) {
304 $tmpvar = tied @$value;
305 } elsif ( $r eq 'HASH' ) {
306 $tmpvar = tied %$value;
310 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
312 unless ( $is_dbm_deep ) {
313 DBM::Deep->_throw_error( "Cannot store something that is tied." );
316 unless ( $tmpvar->_engine->storage == $self->storage ) {
317 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
320 # First, verify if we're storing the same thing to this spot. If we
321 # are, then this should be a no-op. -EJS, 2008-05-19
322 my $loc = $sector->get_data_location_for({
323 key_md5 => $self->_apply_digest( $key ),
327 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
331 #XXX Can this use $loc?
332 my $value_sector = $self->load_sector( $tmpvar->_base_offset );
333 $sector->write_data({
335 key_md5 => $self->_apply_digest( $key ),
336 value => $value_sector,
338 $value_sector->increment_refcount;
343 $class = 'DBM::Deep::Sector::File::Reference';
344 $type = substr( $r, 0, 1 );
347 if ( tied($value) ) {
348 DBM::Deep->_throw_error( "Cannot store something that is tied." );
350 $class = 'DBM::Deep::Sector::File::Scalar';
353 # Create this after loading the reference sector in case something bad
354 # happens. This way, we won't allocate value sector(s) needlessly.
355 my $value_sector = $class->new({
361 $sector->write_data({
363 key_md5 => $self->_apply_digest( $key ),
364 value => $value_sector,
367 $self->_descend( $value, $value_sector );
376 # We're opening the file.
377 unless ( $obj->_base_offset ) {
378 my $bytes_read = $self->_read_file_header;
380 # Creating a new file
381 unless ( $bytes_read ) {
382 $self->_write_file_header;
384 # 1) Create Array/Hash entry
385 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
389 $obj->{base_offset} = $initial_reference->offset;
390 $obj->{staleness} = $initial_reference->staleness;
392 $self->storage->flush;
394 # Reading from an existing file
396 $obj->{base_offset} = $bytes_read;
397 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
399 offset => $obj->_base_offset,
401 unless ( $initial_reference ) {
402 DBM::Deep->_throw_error("Corrupted file, no master index record");
405 unless ($obj->_type eq $initial_reference->type) {
406 DBM::Deep->_throw_error("File type mismatch");
409 $obj->{staleness} = $initial_reference->staleness;
413 $self->storage->set_inode;
422 if ( $self->trans_id ) {
423 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
426 my @slots = $self->read_txn_slots;
428 for my $i ( 0 .. $#slots ) {
432 $self->set_trans_id( $i + 1 );
437 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
439 $self->write_txn_slots( @slots );
441 if ( !$self->trans_id ) {
442 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
452 if ( !$self->trans_id ) {
453 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
456 # Each entry is the file location for a bucket that has a modification for
457 # this transaction. The entries need to be expunged.
458 foreach my $entry (@{ $self->get_entries } ) {
459 # Remove the entry here
460 my $read_loc = $entry
464 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
466 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
467 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
468 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
470 if ( $data_loc > 1 ) {
471 $self->load_sector( $data_loc )->free;
475 $self->clear_entries;
477 my @slots = $self->read_txn_slots;
478 $slots[$self->trans_id-1] = 0;
479 $self->write_txn_slots( @slots );
480 $self->inc_txn_staleness_counter( $self->trans_id );
481 $self->set_trans_id( 0 );
490 if ( !$self->trans_id ) {
491 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
494 foreach my $entry (@{ $self->get_entries } ) {
495 # Overwrite the entry in head with the entry in trans_id
500 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
501 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
503 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
504 my $trans_loc = $self->storage->read_at(
505 $spot, $self->byte_size,
508 $self->storage->print_at( $base, $trans_loc );
509 $self->storage->print_at(
511 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
514 if ( $head_loc > 1 ) {
515 $self->load_sector( $head_loc )->free;
519 $self->clear_entries;
521 my @slots = $self->read_txn_slots;
522 $slots[$self->trans_id-1] = 0;
523 $self->write_txn_slots( @slots );
524 $self->inc_txn_staleness_counter( $self->trans_id );
525 $self->set_trans_id( 0 );
530 =head1 INTERNAL METHODS
532 The following methods are internal-use-only to DBM::Deep::Engine::File.
536 =head2 read_txn_slots()
538 This takes no arguments.
540 This will return an array with a 1 or 0 in each slot. Each spot represents one
541 available transaction. If the slot is 1, that transaction is taken. If it is 0,
542 the transaction is available.
548 my $bl = $self->txn_bitfield_len;
549 my $num_bits = $bl * 8;
550 return split '', unpack( 'b'.$num_bits,
551 $self->storage->read_at(
552 $self->trans_loc, $bl,
557 =head2 write_txn_slots( @slots )
559 This takes an array of 1's and 0's. This array represents the transaction slots
560 returned by L</read_txn_slots()>. In other words, the following is true:
562 @x = read_txn_slots( write_txn_slots( @x ) );
564 (With the obviously missing object referents added back in.)
568 sub write_txn_slots {
570 my $num_bits = $self->txn_bitfield_len * 8;
571 $self->storage->print_at( $self->trans_loc,
572 pack( 'b'.$num_bits, join('', @_) ),
576 =head2 get_running_txn_ids()
578 This takes no arguments.
580 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
584 sub get_running_txn_ids {
586 my @transactions = $self->read_txn_slots;
587 my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
590 =head2 get_txn_staleness_counter( $trans_id )
592 This will return the staleness counter for the given transaction ID. Please see
593 L</TRANSACTION STALENESS> for more information.
597 sub get_txn_staleness_counter {
601 # Hardcode staleness of 0 for the HEAD
602 return 0 unless $trans_id;
604 return unpack( $StP{$STALE_SIZE},
605 $self->storage->read_at(
606 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
612 =head2 inc_txn_staleness_counter( $trans_id )
614 This will increment the staleness counter for the given transaction ID. Please see
615 L</TRANSACTION STALENESS> for more information.
619 sub inc_txn_staleness_counter {
623 # Hardcode staleness of 0 for the HEAD
624 return 0 unless $trans_id;
626 $self->storage->print_at(
627 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
628 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
634 This takes no arguments.
636 This returns a list of all the sectors that have been modified by this transaction.
642 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
645 =head2 add_entry( $trans_id, $location )
647 This takes a transaction ID and a file location and marks the sector at that
648 location as having been modified by the transaction identified by $trans_id.
650 This returns nothing.
652 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
653 C<< $trans_id != $self->trans_id >> for this method.
659 my ($trans_id, $loc) = @_;
661 $self->{entries}{$trans_id} ||= {};
662 $self->{entries}{$trans_id}{$loc} = undef;
665 =head2 reindex_entry( $old_loc, $new_loc )
667 This takes two locations (old and new, respectively). If a location that has
668 been modified by this transaction is subsequently reindexed due to a bucketlist
669 overflowing, then the entries hash needs to be made aware of this change.
671 This returns nothing.
677 my ($old_loc, $new_loc) = @_;
680 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
681 if ( exists $locs->{$old_loc} ) {
682 delete $locs->{$old_loc};
683 $locs->{$new_loc} = undef;
689 =head2 clear_entries()
691 This takes no arguments. It will clear the entries list for the running
694 This returns nothing.
700 delete $self->{entries}{$self->trans_id};
703 =head2 _write_file_header()
705 This writes the file header for a new file. This will write the various settings
706 that set how the file is interpreted.
708 =head2 _read_file_header()
710 This reads the file header from an existing file. This will read the various
711 settings that set how the file is interpreted.
716 my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
717 my $this_file_version = 3;
719 sub _write_file_header {
722 my $nt = $self->num_txns;
723 my $bl = $self->txn_bitfield_len;
725 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
727 my $loc = $self->storage->request_space( $header_fixed + $header_var );
729 $self->storage->print_at( $loc,
732 pack('N', $this_file_version), # At this point, we're at 9 bytes
733 pack('N', $header_var), # header size
734 # --- Above is $header_fixed. Below is $header_var
735 pack('C', $self->byte_size),
737 # These shenanigans are to allow a 256 within a C
738 pack('C', $self->max_buckets - 1),
739 pack('C', $self->data_sector_size - 1),
742 pack('C' . $bl, 0 ), # Transaction activeness bitfield
743 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
744 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
745 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
746 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
749 #XXX Set these less fragilely
750 $self->set_trans_loc( $header_fixed + 4 );
751 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
756 sub _read_file_header {
759 my $buffer = $self->storage->read_at( 0, $header_fixed );
760 return unless length($buffer);
762 my ($file_signature, $sig_header, $file_version, $size) = unpack(
766 unless ( $file_signature eq $self->SIG_FILE ) {
767 $self->storage->close;
768 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
771 unless ( $sig_header eq $self->SIG_HEADER ) {
772 $self->storage->close;
773 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
776 unless ( $file_version == $this_file_version ) {
777 $self->storage->close;
778 DBM::Deep->_throw_error(
779 "Wrong file version found - " . $file_version .
780 " - expected " . $this_file_version
784 my $buffer2 = $self->storage->read_at( undef, $size );
785 my @values = unpack( 'C C C C', $buffer2 );
787 if ( @values != 4 || grep { !defined } @values ) {
788 $self->storage->close;
789 DBM::Deep->_throw_error("Corrupted file - bad header");
792 #XXX Add warnings if values weren't set right
793 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
795 # These shenangians are to allow a 256 within a C
796 $self->{max_buckets} += 1;
797 $self->{data_sector_size} += 1;
799 my $bl = $self->txn_bitfield_len;
801 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
802 unless ( $size == $header_var ) {
803 $self->storage->close;
804 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
807 $self->set_trans_loc( $header_fixed + scalar(@values) );
808 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
810 return length($buffer) + length($buffer2);
814 =head2 _apply_digest( @stuff )
816 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
817 passed in and return the result.
823 return $self->{digest}->(@_);
826 =head2 _add_free_blist_sector( $offset, $size )
828 =head2 _add_free_data_sector( $offset, $size )
830 =head2 _add_free_index_sector( $offset, $size )
832 These methods are all wrappers around _add_free_sector(), providing the proper
833 chain offset ($multiple) for the sector type.
837 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
838 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
839 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
841 =head2 _add_free_sector( $multiple, $offset, $size )
843 _add_free_sector() takes the offset into the chains location, the offset of the
844 sector, and the size of that sector. It will mark the sector as a free sector
845 and put it into the list of sectors that are free of this type for use later.
847 This returns nothing.
849 B<NOTE>: $size is unused?
853 sub _add_free_sector {
855 my ($multiple, $offset, $size) = @_;
857 my $chains_offset = $multiple * $self->byte_size;
859 my $storage = $self->storage;
861 # Increment staleness.
862 # XXX Can this increment+modulo be done by "&= 0x1" ?
863 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
864 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
865 $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
867 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
869 $storage->print_at( $self->chains_loc + $chains_offset,
870 pack( $StP{$self->byte_size}, $offset ),
873 # Record the old head in the new sector after the signature and staleness counter
874 $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
877 =head2 _request_blist_sector( $size )
879 =head2 _request_data_sector( $size )
881 =head2 _request_index_sector( $size )
883 These methods are all wrappers around _request_sector(), providing the proper
884 chain offset ($multiple) for the sector type.
888 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
889 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
890 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
892 =head2 _request_sector( $multiple $size )
894 This takes the offset into the chains location and the size of that sector.
896 This returns the object with the sector. If there is an available free sector of
897 that type, then it will be reused. If there isn't one, then a new one will be
902 sub _request_sector {
904 my ($multiple, $size) = @_;
906 my $chains_offset = $multiple * $self->byte_size;
908 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
909 my $loc = unpack( $StP{$self->byte_size}, $old_head );
911 # We don't have any free sectors of the right size, so allocate a new one.
913 my $offset = $self->storage->request_space( $size );
915 # Zero out the new sector. This also guarantees correct increases
917 $self->storage->print_at( $offset, chr(0) x $size );
922 # Read the new head after the signature and the staleness counter
923 my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
924 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
925 $self->storage->print_at(
926 $loc + $self->SIG_SIZE + $STALE_SIZE,
927 pack( $StP{$self->byte_size}, 0 ),
935 The following are readonly attributes.
951 =item * data_sector_size
953 =item * txn_bitfield_len
959 sub byte_size { $_[0]{byte_size} }
960 sub hash_size { $_[0]{hash_size} }
961 sub hash_chars { $_[0]{hash_chars} }
962 sub num_txns { $_[0]{num_txns} }
963 sub max_buckets { $_[0]{max_buckets} }
964 sub blank_md5 { chr(0) x $_[0]->hash_size }
965 sub data_sector_size { $_[0]{data_sector_size} }
967 # This is a calculated value
968 sub txn_bitfield_len {
970 unless ( exists $self->{txn_bitfield_len} ) {
971 my $temp = ($self->num_txns) / 8;
972 if ( $temp > int( $temp ) ) {
973 $temp = int( $temp ) + 1;
975 $self->{txn_bitfield_len} = $temp;
977 return $self->{txn_bitfield_len};
982 The following are read/write attributes.
986 =item * trans_id / set_trans_id( $new_id )
988 =item * trans_loc / set_trans_loc( $new_loc )
990 =item * chains_loc / set_chains_loc( $new_loc )
996 sub trans_id { $_[0]{trans_id} }
997 sub set_trans_id { $_[0]{trans_id} = $_[1] }
999 sub trans_loc { $_[0]{trans_loc} }
1000 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1002 sub chains_loc { $_[0]{chains_loc} }
1003 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1009 return 1 if $feature eq 'transactions';
1010 return if $feature eq 'singletones';
1018 my $sector = $self->load_sector( $obj->_base_offset )
1021 return unless $sector->staleness == $obj->_staleness;
1030 This method takes no arguments. It's used to print out a textual representation
1031 of the DBM::Deep DB file. It assumes the file is not-corrupted.
1039 my $spot = $self->_read_file_header();
1048 'D' => $self->data_sector_size,
1049 'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
1050 'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
1056 $return .= "NumTxns: " . $self->num_txns . $/;
1058 # Read the free sector chains
1060 foreach my $multiple ( 0 .. 2 ) {
1061 $return .= "Chains($types{$multiple}):";
1062 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1065 $StP{$self->byte_size},
1066 $self->storage->read_at( $old_loc, $self->byte_size ),
1069 # We're now out of free sectors of this kind.
1074 $sectors{ $types{$multiple} }{ $loc } = undef;
1075 $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
1082 while ( $spot < $self->storage->{end} ) {
1083 # Read each sector in order.
1084 my $sector = $self->load_sector( $spot );
1086 # Find it in the free-sectors that were found already
1087 foreach my $type ( keys %sectors ) {
1088 if ( exists $sectors{$type}{$spot} ) {
1089 my $size = $sizes{$type};
1090 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1096 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1099 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1100 if ( $sector->type eq 'D' ) {
1101 $return .= ' ' . $sector->data;
1103 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1104 $return .= ' REF: ' . $sector->get_refcount;
1106 elsif ( $sector->type eq 'B' ) {
1107 foreach my $bucket ( $sector->chopped_up ) {
1109 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1110 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1112 my $l = unpack( $StP{$self->byte_size},
1113 substr( $bucket->[-1],
1114 $self->hash_size + $self->byte_size,
1118 $return .= sprintf " %08d", $l;
1119 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1120 my $l = unpack( $StP{$self->byte_size},
1121 substr( $bucket->[-1],
1122 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1126 $return .= sprintf " %08d", $l;
1132 $spot += $sector->size;