1 package DBM::Deep::Engine;
6 use warnings FATAL => 'all';
8 use DBM::Deep::Engine::Sector::BucketList;
9 use DBM::Deep::Engine::Sector::Index;
10 use DBM::Deep::Engine::Sector::Null;
11 use DBM::Deep::Engine::Sector::Reference;
12 use DBM::Deep::Engine::Sector::Scalar;
13 use DBM::Deep::Iterator;
15 # Never import symbols into our namespace. We are a class, not a library.
22 # * Every method in here assumes that the storage has been appropriately
23 # safeguarded. This can be anything from flock() to some sort of manual
24 # mutex. But, it's the caller's responsability to make sure that this has
27 # Setup file and tag signatures. These should never change.
28 sub SIG_FILE () { 'DPDB' }
29 sub SIG_HEADER () { 'h' }
30 sub SIG_HASH () { 'H' }
31 sub SIG_ARRAY () { 'A' }
32 sub SIG_NULL () { 'N' }
33 sub SIG_DATA () { 'D' }
34 sub SIG_INDEX () { 'I' }
35 sub SIG_BLIST () { 'B' }
36 sub SIG_FREE () { 'F' }
41 # Please refer to the pack() documentation for further information
43 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
44 2 => 'n', # Unsigned short in "network" (big-endian) order
45 4 => 'N', # Unsigned long in "network" (big-endian) order
46 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
48 sub StP { $StP{$_[1]} }
50 ################################################################################
56 $args->{storage} = DBM::Deep::File->new( $args )
57 unless exists $args->{storage};
63 hash_size => 16, # In bytes
64 hash_chars => 256, # Number of chars the algorithm uses per byte
66 num_txns => 1, # The HEAD
67 trans_id => 0, # Default to the HEAD
69 data_sector_size => 64, # Size in bytes of each data sector
71 entries => {}, # This is the list of entries for transactions
75 # Never allow byte_size to be set directly.
76 delete $args->{byte_size};
77 if ( defined $args->{pack_size} ) {
78 if ( lc $args->{pack_size} eq 'small' ) {
79 $args->{byte_size} = 2;
81 elsif ( lc $args->{pack_size} eq 'medium' ) {
82 $args->{byte_size} = 4;
84 elsif ( lc $args->{pack_size} eq 'large' ) {
85 $args->{byte_size} = 8;
88 DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
92 # Grab the parameters we want to use
93 foreach my $param ( keys %$self ) {
94 next unless exists $args->{$param};
95 $self->{$param} = $args->{$param};
99 max_buckets => { floor => 16, ceil => 256 },
100 num_txns => { floor => 1, ceil => 255 },
101 data_sector_size => { floor => 32, ceil => 256 },
104 while ( my ($attr, $c) = each %validations ) {
105 if ( !defined $self->{$attr}
106 || !length $self->{$attr}
107 || $self->{$attr} =~ /\D/
108 || $self->{$attr} < $c->{floor}
110 $self->{$attr} = '(undef)' if !defined $self->{$attr};
111 warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
112 $self->{$attr} = $c->{floor};
114 elsif ( $self->{$attr} > $c->{ceil} ) {
115 warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
116 $self->{$attr} = $c->{ceil};
120 if ( !$self->{digest} ) {
122 $self->{digest} = \&Digest::MD5::md5;
128 ################################################################################
132 my ($obj, $key) = @_;
134 # This will be a Reference sector
135 my $sector = $self->_load_sector( $obj->_base_offset )
138 if ( $sector->staleness != $obj->_staleness ) {
142 my $key_md5 = $self->_apply_digest( $key );
144 my $value_sector = $sector->get_data_for({
149 unless ( $value_sector ) {
150 $value_sector = DBM::Deep::Engine::Sector::Null->new({
155 $sector->write_data({
158 value => $value_sector,
162 return $value_sector->data;
169 # This will be a Reference sector
170 my $sector = $self->_load_sector( $obj->_base_offset )
171 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
173 if ( $sector->staleness != $obj->_staleness ) {
177 return $sector->get_classname;
182 my ($obj, $old_key, $new_key) = @_;
184 # This will be a Reference sector
185 my $sector = $self->_load_sector( $obj->_base_offset )
186 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
188 if ( $sector->staleness != $obj->_staleness ) {
192 my $old_md5 = $self->_apply_digest( $old_key );
194 my $value_sector = $sector->get_data_for({
199 unless ( $value_sector ) {
200 $value_sector = DBM::Deep::Engine::Sector::Null->new({
205 $sector->write_data({
208 value => $value_sector,
212 if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
213 $sector->write_data({
215 key_md5 => $self->_apply_digest( $new_key ),
216 value => $value_sector,
218 $value_sector->increment_refcount;
221 $sector->write_data({
223 key_md5 => $self->_apply_digest( $new_key ),
224 value => $value_sector->clone,
231 my ($obj, $key) = @_;
233 # This will be a Reference sector
234 my $sector = $self->_load_sector( $obj->_base_offset )
237 if ( $sector->staleness != $obj->_staleness ) {
241 my $data = $sector->get_data_for({
242 key_md5 => $self->_apply_digest( $key ),
246 # exists() returns 1 or '' for true/false.
247 return $data ? 1 : '';
252 my ($obj, $key) = @_;
254 my $sector = $self->_load_sector( $obj->_base_offset )
257 if ( $sector->staleness != $obj->_staleness ) {
261 return $sector->delete_key({
262 key_md5 => $self->_apply_digest( $key ),
269 my ($obj, $key, $value) = @_;
271 my $r = Scalar::Util::reftype( $value ) || '';
274 last if $r eq 'HASH';
275 last if $r eq 'ARRAY';
277 DBM::Deep->_throw_error(
278 "Storage of references of type '$r' is not supported."
282 # This will be a Reference sector
283 my $sector = $self->_load_sector( $obj->_base_offset )
284 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
286 if ( $sector->staleness != $obj->_staleness ) {
287 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
291 if ( !defined $value ) {
292 $class = 'DBM::Deep::Engine::Sector::Null';
294 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
296 if ( $r eq 'ARRAY' ) {
297 $tmpvar = tied @$value;
298 } elsif ( $r eq 'HASH' ) {
299 $tmpvar = tied %$value;
303 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
305 unless ( $is_dbm_deep ) {
306 DBM::Deep->_throw_error( "Cannot store something that is tied." );
309 unless ( $tmpvar->_engine->storage == $self->storage ) {
310 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
313 # First, verify if we're storing the same thing to this spot. If we are, then
314 # this should be a no-op. -EJS, 2008-05-19
315 my $loc = $sector->get_data_location_for({
316 key_md5 => $self->_apply_digest( $key ),
320 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
324 #XXX Can this use $loc?
325 my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
326 $sector->write_data({
328 key_md5 => $self->_apply_digest( $key ),
329 value => $value_sector,
331 $value_sector->increment_refcount;
336 $class = 'DBM::Deep::Engine::Sector::Reference';
337 $type = substr( $r, 0, 1 );
340 if ( tied($value) ) {
341 DBM::Deep->_throw_error( "Cannot store something that is tied." );
343 $class = 'DBM::Deep::Engine::Sector::Scalar';
346 # Create this after loading the reference sector in case something bad happens.
347 # This way, we won't allocate value sector(s) needlessly.
348 my $value_sector = $class->new({
354 $sector->write_data({
356 key_md5 => $self->_apply_digest( $key ),
357 value => $value_sector,
360 # This code is to make sure we write all the values in the $value to the disk
361 # and to make sure all changes to $value after the assignment are reflected
362 # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
363 # NOTE - simply tying $value won't perform a STORE on each value. Hence, the
364 # copy to a temp value.
365 if ( $r eq 'ARRAY' ) {
367 tie @$value, 'DBM::Deep', {
368 base_offset => $value_sector->offset,
369 staleness => $value_sector->staleness,
370 storage => $self->storage,
374 bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
376 elsif ( $r eq 'HASH' ) {
378 tie %$value, 'DBM::Deep', {
379 base_offset => $value_sector->offset,
380 staleness => $value_sector->staleness,
381 storage => $self->storage,
386 bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
392 # XXX Add staleness here
395 my ($obj, $prev_key) = @_;
397 # XXX Need to add logic about resetting the iterator if any key in the reference has changed
398 unless ( $prev_key ) {
399 $obj->{iterator} = DBM::Deep::Iterator->new({
400 base_offset => $obj->_base_offset,
405 return $obj->{iterator}->get_next_key( $obj );
408 ################################################################################
414 # We're opening the file.
415 unless ( $obj->_base_offset ) {
416 my $bytes_read = $self->_read_file_header;
418 # Creating a new file
419 unless ( $bytes_read ) {
420 $self->_write_file_header;
422 # 1) Create Array/Hash entry
423 my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
427 $obj->{base_offset} = $initial_reference->offset;
428 $obj->{staleness} = $initial_reference->staleness;
430 $self->storage->flush;
432 # Reading from an existing file
434 $obj->{base_offset} = $bytes_read;
435 my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
437 offset => $obj->_base_offset,
439 unless ( $initial_reference ) {
440 DBM::Deep->_throw_error("Corrupted file, no master index record");
443 unless ($obj->_type eq $initial_reference->type) {
444 DBM::Deep->_throw_error("File type mismatch");
447 $obj->{staleness} = $initial_reference->staleness;
450 $self->storage->set_inode;
460 if ( $self->trans_id ) {
461 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
464 my @slots = $self->read_txn_slots;
466 for my $i ( 0 .. $#slots ) {
470 $self->set_trans_id( $i + 1 );
475 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
477 $self->write_txn_slots( @slots );
479 if ( !$self->trans_id ) {
480 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
490 if ( !$self->trans_id ) {
491 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
494 # Each entry is the file location for a bucket that has a modification for
495 # this transaction. The entries need to be expunged.
496 foreach my $entry (@{ $self->get_entries } ) {
497 # Remove the entry here
498 my $read_loc = $entry
502 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
504 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
505 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
506 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
508 if ( $data_loc > 1 ) {
509 $self->_load_sector( $data_loc )->free;
513 $self->clear_entries;
515 my @slots = $self->read_txn_slots;
516 $slots[$self->trans_id-1] = 0;
517 $self->write_txn_slots( @slots );
518 $self->inc_txn_staleness_counter( $self->trans_id );
519 $self->set_trans_id( 0 );
528 if ( !$self->trans_id ) {
529 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
532 foreach my $entry (@{ $self->get_entries } ) {
533 # Overwrite the entry in head with the entry in trans_id
538 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
539 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
541 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
542 my $trans_loc = $self->storage->read_at(
543 $spot, $self->byte_size,
546 $self->storage->print_at( $base, $trans_loc );
547 $self->storage->print_at(
549 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
552 if ( $head_loc > 1 ) {
553 $self->_load_sector( $head_loc )->free;
557 $self->clear_entries;
559 my @slots = $self->read_txn_slots;
560 $slots[$self->trans_id-1] = 0;
561 $self->write_txn_slots( @slots );
562 $self->inc_txn_staleness_counter( $self->trans_id );
563 $self->set_trans_id( 0 );
570 my $bl = $self->txn_bitfield_len;
571 my $num_bits = $bl * 8;
572 return split '', unpack( 'b'.$num_bits,
573 $self->storage->read_at(
574 $self->trans_loc, $bl,
579 sub write_txn_slots {
581 my $num_bits = $self->txn_bitfield_len * 8;
582 $self->storage->print_at( $self->trans_loc,
583 pack( 'b'.$num_bits, join('', @_) ),
587 sub get_running_txn_ids {
589 my @transactions = $self->read_txn_slots;
590 my @trans_ids = map { $_+1} grep { $transactions[$_] } 0 .. $#transactions;
593 sub get_txn_staleness_counter {
597 # Hardcode staleness of 0 for the HEAD
598 return 0 unless $trans_id;
600 return unpack( $StP{$STALE_SIZE},
601 $self->storage->read_at(
602 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
608 sub inc_txn_staleness_counter {
612 # Hardcode staleness of 0 for the HEAD
613 return 0 unless $trans_id;
615 $self->storage->print_at(
616 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
617 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
623 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
628 my ($trans_id, $loc) = @_;
630 $self->{entries}{$trans_id} ||= {};
631 $self->{entries}{$trans_id}{$loc} = undef;
634 # If the buckets are being relocated because of a reindexing, the entries
635 # mechanism needs to be made aware of it.
638 my ($old_loc, $new_loc) = @_;
641 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
642 if ( exists $locs->{$old_loc} ) {
643 delete $locs->{$old_loc};
644 $locs->{$new_loc} = undef;
652 delete $self->{entries}{$self->trans_id};
655 ################################################################################
658 my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
659 my $this_file_version = 3;
661 sub _write_file_header {
664 my $nt = $self->num_txns;
665 my $bl = $self->txn_bitfield_len;
667 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
669 my $loc = $self->storage->request_space( $header_fixed + $header_var );
671 $self->storage->print_at( $loc,
674 pack('N', $this_file_version), # At this point, we're at 9 bytes
675 pack('N', $header_var), # header size
676 # --- Above is $header_fixed. Below is $header_var
677 pack('C', $self->byte_size),
679 # These shenanigans are to allow a 256 within a C
680 pack('C', $self->max_buckets - 1),
681 pack('C', $self->data_sector_size - 1),
684 pack('C' . $bl, 0 ), # Transaction activeness bitfield
685 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
686 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
687 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
688 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
691 #XXX Set these less fragilely
692 $self->set_trans_loc( $header_fixed + 4 );
693 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
698 sub _read_file_header {
701 my $buffer = $self->storage->read_at( 0, $header_fixed );
702 return unless length($buffer);
704 my ($file_signature, $sig_header, $file_version, $size) = unpack(
708 unless ( $file_signature eq SIG_FILE ) {
709 $self->storage->close;
710 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
713 unless ( $sig_header eq SIG_HEADER ) {
714 $self->storage->close;
715 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
718 unless ( $file_version == $this_file_version ) {
719 $self->storage->close;
720 DBM::Deep->_throw_error(
721 "Wrong file version found - " . $file_version .
722 " - expected " . $this_file_version
726 my $buffer2 = $self->storage->read_at( undef, $size );
727 my @values = unpack( 'C C C C', $buffer2 );
729 if ( @values != 4 || grep { !defined } @values ) {
730 $self->storage->close;
731 DBM::Deep->_throw_error("Corrupted file - bad header");
734 #XXX Add warnings if values weren't set right
735 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
737 # These shenangians are to allow a 256 within a C
738 $self->{max_buckets} += 1;
739 $self->{data_sector_size} += 1;
741 my $bl = $self->txn_bitfield_len;
743 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
744 unless ( $size == $header_var ) {
745 $self->storage->close;
746 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
749 $self->set_trans_loc( $header_fixed + scalar(@values) );
750 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
752 return length($buffer) + length($buffer2);
760 # Add a catch for offset of 0 or 1
761 return if !$offset || $offset <= 1;
763 my $type = $self->storage->read_at( $offset, 1 );
764 return if $type eq chr(0);
766 if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
767 return DBM::Deep::Engine::Sector::Reference->new({
773 # XXX Don't we need key_md5 here?
774 elsif ( $type eq $self->SIG_BLIST ) {
775 return DBM::Deep::Engine::Sector::BucketList->new({
781 elsif ( $type eq $self->SIG_INDEX ) {
782 return DBM::Deep::Engine::Sector::Index->new({
788 elsif ( $type eq $self->SIG_NULL ) {
789 return DBM::Deep::Engine::Sector::Null->new({
795 elsif ( $type eq $self->SIG_DATA ) {
796 return DBM::Deep::Engine::Sector::Scalar->new({
802 # This was deleted from under us, so just return and let the caller figure it out.
803 elsif ( $type eq $self->SIG_FREE ) {
807 DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
812 return $self->{digest}->(@_);
815 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
816 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
817 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
819 sub _add_free_sector {
821 my ($multiple, $offset, $size) = @_;
823 my $chains_offset = $multiple * $self->byte_size;
825 my $storage = $self->storage;
827 # Increment staleness.
828 # XXX Can this increment+modulo be done by "&= 0x1" ?
829 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + SIG_SIZE, $STALE_SIZE ) );
830 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
831 $storage->print_at( $offset + SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
833 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
835 $storage->print_at( $self->chains_loc + $chains_offset,
836 pack( $StP{$self->byte_size}, $offset ),
839 # Record the old head in the new sector after the signature and staleness counter
840 $storage->print_at( $offset + SIG_SIZE + $STALE_SIZE, $old_head );
843 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
844 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
845 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
847 sub _request_sector {
849 my ($multiple, $size) = @_;
851 my $chains_offset = $multiple * $self->byte_size;
853 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
854 my $loc = unpack( $StP{$self->byte_size}, $old_head );
856 # We don't have any free sectors of the right size, so allocate a new one.
858 my $offset = $self->storage->request_space( $size );
860 # Zero out the new sector. This also guarantees correct increases
862 $self->storage->print_at( $offset, chr(0) x $size );
867 # Read the new head after the signature and the staleness counter
868 my $new_head = $self->storage->read_at( $loc + SIG_SIZE + $STALE_SIZE, $self->byte_size );
869 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
870 $self->storage->print_at(
871 $loc + SIG_SIZE + $STALE_SIZE,
872 pack( $StP{$self->byte_size}, 0 ),
878 ################################################################################
882 return $self->{dirty_sectors} ||= {};
885 sub add_dirty_sector {
889 # if ( exists $self->dirty_sectors->{ $sector->offset } ) {
890 # DBM::Deep->_throw_error( "We have a duplicate sector!! " . $sector->offset );
893 $self->dirty_sectors->{ $sector->offset } = $sector;
896 sub clear_dirty_sectors {
898 $self->{dirty_sectors} = {};
904 for (values %{ $self->dirty_sectors }) {
908 $self->clear_dirty_sectors;
911 ################################################################################
916 return $self->storage->lock_exclusive( $obj );
922 return $self->storage->lock_shared( $obj );
929 my $rv = $self->storage->unlock( $obj );
936 ################################################################################
938 sub storage { $_[0]{storage} }
939 sub byte_size { $_[0]{byte_size} }
940 sub hash_size { $_[0]{hash_size} }
941 sub hash_chars { $_[0]{hash_chars} }
942 sub num_txns { $_[0]{num_txns} }
943 sub max_buckets { $_[0]{max_buckets} }
944 sub blank_md5 { chr(0) x $_[0]->hash_size }
945 sub data_sector_size { $_[0]{data_sector_size} }
947 # This is a calculated value
948 sub txn_bitfield_len {
950 unless ( exists $self->{txn_bitfield_len} ) {
951 my $temp = ($self->num_txns) / 8;
952 if ( $temp > int( $temp ) ) {
953 $temp = int( $temp ) + 1;
955 $self->{txn_bitfield_len} = $temp;
957 return $self->{txn_bitfield_len};
960 sub trans_id { $_[0]{trans_id} }
961 sub set_trans_id { $_[0]{trans_id} = $_[1] }
963 sub trans_loc { $_[0]{trans_loc} }
964 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
966 sub chains_loc { $_[0]{chains_loc} }
967 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
969 sub cache { $_[0]{cache} ||= {} }
970 sub clear_cache { %{$_[0]->cache} = () }
976 my $spot = $self->_read_file_header();
985 'D' => $self->data_sector_size,
986 'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
987 'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
993 $return .= "Size: " . (-s $self->storage->{fh}) . $/;
996 $return .= "NumTxns: " . $self->num_txns . $/;
998 # Read the free sector chains
1000 foreach my $multiple ( 0 .. 2 ) {
1001 $return .= "Chains($types{$multiple}):";
1002 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1005 $StP{$self->byte_size},
1006 $self->storage->read_at( $old_loc, $self->byte_size ),
1009 # We're now out of free sectors of this kind.
1014 $sectors{ $types{$multiple} }{ $loc } = undef;
1015 $old_loc = $loc + SIG_SIZE + $STALE_SIZE;
1022 while ( $spot < $self->storage->{end} ) {
1023 # Read each sector in order.
1024 my $sector = $self->_load_sector( $spot );
1026 # Find it in the free-sectors that were found already
1027 foreach my $type ( keys %sectors ) {
1028 if ( exists $sectors{$type}{$spot} ) {
1029 my $size = $sizes{$type};
1030 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1036 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1039 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1040 if ( $sector->type eq 'D' ) {
1041 $return .= ' ' . $sector->data;
1043 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1044 $return .= ' REF: ' . $sector->get_refcount;
1046 elsif ( $sector->type eq 'B' ) {
1047 foreach my $bucket ( $sector->chopped_up ) {
1049 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1050 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1052 my $l = unpack( $StP{$self->byte_size},
1053 substr( $bucket->[-1],
1054 $self->hash_size + $self->byte_size,
1058 $return .= sprintf " %08d", $l;
1059 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1060 my $l = unpack( $StP{$self->byte_size},
1061 substr( $bucket->[-1],
1062 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1066 $return .= sprintf " %08d", $l;
1072 $spot += $sector->size;