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 ();
18 # Please refer to the pack() documentation for further information
20 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
21 2 => 'n', # Unsigned short in "network" (big-endian) order
22 4 => 'N', # Unsigned long in "network" (big-endian) order
23 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
28 DBM::Deep::Engine::File
32 This is the engine for use with L<DBM::Deep::Storage::File/>.
34 =head1 EXTERNAL METHODS
38 This takes a set of args. These args are described in the documentation for
47 $args->{storage} = DBM::Deep::Storage::File->new( $args )
48 unless exists $args->{storage};
54 hash_size => 16, # In bytes
55 hash_chars => 256, # Number of chars the algorithm uses per byte
57 num_txns => 1, # The HEAD
58 trans_id => 0, # Default to the HEAD
60 data_sector_size => 64, # Size in bytes of each data sector
62 entries => {}, # This is the list of entries for transactions
66 # Never allow byte_size to be set directly.
67 delete $args->{byte_size};
68 if ( defined $args->{pack_size} ) {
69 if ( lc $args->{pack_size} eq 'small' ) {
70 $args->{byte_size} = 2;
72 elsif ( lc $args->{pack_size} eq 'medium' ) {
73 $args->{byte_size} = 4;
75 elsif ( lc $args->{pack_size} eq 'large' ) {
76 $args->{byte_size} = 8;
79 DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
83 # Grab the parameters we want to use
84 foreach my $param ( keys %$self ) {
85 next unless exists $args->{$param};
86 $self->{$param} = $args->{$param};
90 max_buckets => { floor => 16, ceil => 256 },
91 num_txns => { floor => 1, ceil => 255 },
92 data_sector_size => { floor => 32, ceil => 256 },
95 while ( my ($attr, $c) = each %validations ) {
96 if ( !defined $self->{$attr}
97 || !length $self->{$attr}
98 || $self->{$attr} =~ /\D/
99 || $self->{$attr} < $c->{floor}
101 $self->{$attr} = '(undef)' if !defined $self->{$attr};
102 warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
103 $self->{$attr} = $c->{floor};
105 elsif ( $self->{$attr} > $c->{ceil} ) {
106 warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
107 $self->{$attr} = $c->{ceil};
111 if ( !$self->{digest} ) {
113 $self->{digest} = \&Digest::MD5::md5;
121 my ($obj, $key) = @_;
123 # This will be a Reference sector
124 my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
127 if ( $sector->staleness != $obj->_staleness ) {
131 my $key_md5 = $self->_apply_digest( $key );
133 my $value_sector = $sector->get_data_for({
138 unless ( $value_sector ) {
139 $value_sector = DBM::Deep::Sector::File::Null->new({
144 $sector->write_data({
147 value => $value_sector,
151 return $value_sector->data;
158 # This will be a Reference sector
159 my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
160 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
162 if ( $sector->staleness != $obj->_staleness ) {
166 return $sector->get_classname;
171 my ($obj, $old_key, $new_key) = @_;
173 # This will be a Reference sector
174 my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
175 or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
177 if ( $sector->staleness != $obj->_staleness ) {
181 my $old_md5 = $self->_apply_digest( $old_key );
183 my $value_sector = $sector->get_data_for({
188 unless ( $value_sector ) {
189 $value_sector = DBM::Deep::Sector::File::Null->new({
194 $sector->write_data({
197 value => $value_sector,
201 if ( $value_sector->isa( 'DBM::Deep::Sector::File::Reference' ) ) {
202 $sector->write_data({
204 key_md5 => $self->_apply_digest( $new_key ),
205 value => $value_sector,
207 $value_sector->increment_refcount;
210 $sector->write_data({
212 key_md5 => $self->_apply_digest( $new_key ),
213 value => $value_sector->clone,
222 my ($obj, $key) = @_;
224 # This will be a Reference sector
225 my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
228 if ( $sector->staleness != $obj->_staleness ) {
232 my $data = $sector->get_data_for({
233 key_md5 => $self->_apply_digest( $key ),
237 # exists() returns 1 or '' for true/false.
238 return $data ? 1 : '';
243 my ($obj, $key) = @_;
245 my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
248 if ( $sector->staleness != $obj->_staleness ) {
252 return $sector->delete_key({
253 key_md5 => $self->_apply_digest( $key ),
260 my ($obj, $key, $value) = @_;
262 my $r = Scalar::Util::reftype( $value ) || '';
265 last if $r eq 'HASH';
266 last if $r eq 'ARRAY';
268 DBM::Deep->_throw_error(
269 "Storage of references of type '$r' is not supported."
273 # This will be a Reference sector
274 my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
275 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
277 if ( $sector->staleness != $obj->_staleness ) {
278 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
282 if ( !defined $value ) {
283 $class = 'DBM::Deep::Sector::File::Null';
285 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
287 if ( $r eq 'ARRAY' ) {
288 $tmpvar = tied @$value;
289 } elsif ( $r eq 'HASH' ) {
290 $tmpvar = tied %$value;
294 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
296 unless ( $is_dbm_deep ) {
297 DBM::Deep->_throw_error( "Cannot store something that is tied." );
300 unless ( $tmpvar->_engine->storage == $self->storage ) {
301 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
304 # First, verify if we're storing the same thing to this spot. If we
305 # are, then this should be a no-op. -EJS, 2008-05-19
306 my $loc = $sector->get_data_location_for({
307 key_md5 => $self->_apply_digest( $key ),
311 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
315 #XXX Can this use $loc?
316 my $value_sector = DBM::Deep::Sector::File->load( $self, $tmpvar->_base_offset );
317 $sector->write_data({
319 key_md5 => $self->_apply_digest( $key ),
320 value => $value_sector,
322 $value_sector->increment_refcount;
327 $class = 'DBM::Deep::Sector::File::Reference';
328 $type = substr( $r, 0, 1 );
331 if ( tied($value) ) {
332 DBM::Deep->_throw_error( "Cannot store something that is tied." );
334 $class = 'DBM::Deep::Sector::File::Scalar';
337 # Create this after loading the reference sector in case something bad
338 # happens. This way, we won't allocate value sector(s) needlessly.
339 my $value_sector = $class->new({
345 $sector->write_data({
347 key_md5 => $self->_apply_digest( $key ),
348 value => $value_sector,
351 # This code is to make sure we write all the values in the $value to the
352 # disk and to make sure all changes to $value after the assignment are
353 # reflected on disk. This may be counter-intuitive at first, but it is
355 # NOTE - simply tying $value won't perform a STORE on each value. Hence,
356 # the copy to a temp value.
357 if ( $r eq 'ARRAY' ) {
359 tie @$value, 'DBM::Deep', {
360 base_offset => $value_sector->offset,
361 staleness => $value_sector->staleness,
362 storage => $self->storage,
366 bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
368 elsif ( $r eq 'HASH' ) {
370 tie %$value, 'DBM::Deep', {
371 base_offset => $value_sector->offset,
372 staleness => $value_sector->staleness,
373 storage => $self->storage,
378 bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
388 # We're opening the file.
389 unless ( $obj->_base_offset ) {
390 my $bytes_read = $self->_read_file_header;
392 # Creating a new file
393 unless ( $bytes_read ) {
394 $self->_write_file_header;
396 # 1) Create Array/Hash entry
397 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
401 $obj->{base_offset} = $initial_reference->offset;
402 $obj->{staleness} = $initial_reference->staleness;
404 $self->storage->flush;
406 # Reading from an existing file
408 $obj->{base_offset} = $bytes_read;
409 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
411 offset => $obj->_base_offset,
413 unless ( $initial_reference ) {
414 DBM::Deep->_throw_error("Corrupted file, no master index record");
417 unless ($obj->_type eq $initial_reference->type) {
418 DBM::Deep->_throw_error("File type mismatch");
421 $obj->{staleness} = $initial_reference->staleness;
425 $self->storage->set_inode;
434 if ( $self->trans_id ) {
435 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
438 my @slots = $self->read_txn_slots;
440 for my $i ( 0 .. $#slots ) {
444 $self->set_trans_id( $i + 1 );
449 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
451 $self->write_txn_slots( @slots );
453 if ( !$self->trans_id ) {
454 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
464 if ( !$self->trans_id ) {
465 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
468 # Each entry is the file location for a bucket that has a modification for
469 # this transaction. The entries need to be expunged.
470 foreach my $entry (@{ $self->get_entries } ) {
471 # Remove the entry here
472 my $read_loc = $entry
476 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
478 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
479 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
480 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
482 if ( $data_loc > 1 ) {
483 DBM::Deep::Sector::File->load( $self, $data_loc )->free;
487 $self->clear_entries;
489 my @slots = $self->read_txn_slots;
490 $slots[$self->trans_id-1] = 0;
491 $self->write_txn_slots( @slots );
492 $self->inc_txn_staleness_counter( $self->trans_id );
493 $self->set_trans_id( 0 );
502 if ( !$self->trans_id ) {
503 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
506 foreach my $entry (@{ $self->get_entries } ) {
507 # Overwrite the entry in head with the entry in trans_id
512 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
513 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
515 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
516 my $trans_loc = $self->storage->read_at(
517 $spot, $self->byte_size,
520 $self->storage->print_at( $base, $trans_loc );
521 $self->storage->print_at(
523 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
526 if ( $head_loc > 1 ) {
527 DBM::Deep::Sector::File->load( $self, $head_loc )->free;
531 $self->clear_entries;
533 my @slots = $self->read_txn_slots;
534 $slots[$self->trans_id-1] = 0;
535 $self->write_txn_slots( @slots );
536 $self->inc_txn_staleness_counter( $self->trans_id );
537 $self->set_trans_id( 0 );
542 =head1 INTERNAL METHODS
544 The following methods are internal-use-only to DBM::Deep::Engine::File.
548 =head2 read_txn_slots()
550 This takes no arguments.
552 This will return an array with a 1 or 0 in each slot. Each spot represents one
553 available transaction. If the slot is 1, that transaction is taken. If it is 0,
554 the transaction is available.
560 my $bl = $self->txn_bitfield_len;
561 my $num_bits = $bl * 8;
562 return split '', unpack( 'b'.$num_bits,
563 $self->storage->read_at(
564 $self->trans_loc, $bl,
569 =head2 write_txn_slots( @slots )
571 This takes an array of 1's and 0's. This array represents the transaction slots
572 returned by L</read_txn_slots()>. In other words, the following is true:
574 @x = read_txn_slots( write_txn_slots( @x ) );
576 (With the obviously missing object referents added back in.)
580 sub write_txn_slots {
582 my $num_bits = $self->txn_bitfield_len * 8;
583 $self->storage->print_at( $self->trans_loc,
584 pack( 'b'.$num_bits, join('', @_) ),
588 =head2 get_running_txn_ids()
590 This takes no arguments.
592 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
596 sub get_running_txn_ids {
598 my @transactions = $self->read_txn_slots;
599 my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
602 =head2 get_txn_staleness_counter( $trans_id )
604 This will return the staleness counter for the given transaction ID. Please see
605 L</TRANSACTION STALENESS> for more information.
609 sub get_txn_staleness_counter {
613 # Hardcode staleness of 0 for the HEAD
614 return 0 unless $trans_id;
616 return unpack( $StP{$STALE_SIZE},
617 $self->storage->read_at(
618 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
624 =head2 inc_txn_staleness_counter( $trans_id )
626 This will increment the staleness counter for the given transaction ID. Please see
627 L</TRANSACTION STALENESS> for more information.
631 sub inc_txn_staleness_counter {
635 # Hardcode staleness of 0 for the HEAD
636 return 0 unless $trans_id;
638 $self->storage->print_at(
639 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
640 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
646 This takes no arguments.
648 This returns a list of all the sectors that have been modified by this transaction.
654 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
657 =head2 add_entry( $trans_id, $location )
659 This takes a transaction ID and a file location and marks the sector at that
660 location as having been modified by the transaction identified by $trans_id.
662 This returns nothing.
664 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
665 C<< $trans_id != $self->trans_id >> for this method.
671 my ($trans_id, $loc) = @_;
673 $self->{entries}{$trans_id} ||= {};
674 $self->{entries}{$trans_id}{$loc} = undef;
677 =head2 reindex_entry( $old_loc, $new_loc )
679 This takes two locations (old and new, respectively). If a location that has
680 been modified by this transaction is subsequently reindexed due to a bucketlist
681 overflowing, then the entries hash needs to be made aware of this change.
683 This returns nothing.
689 my ($old_loc, $new_loc) = @_;
692 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
693 if ( exists $locs->{$old_loc} ) {
694 delete $locs->{$old_loc};
695 $locs->{$new_loc} = undef;
701 =head2 clear_entries()
703 This takes no arguments. It will clear the entries list for the running
706 This returns nothing.
712 delete $self->{entries}{$self->trans_id};
715 =head2 _write_file_header()
717 This writes the file header for a new file. This will write the various settings
718 that set how the file is interpreted.
720 =head2 _read_file_header()
722 This reads the file header from an existing file. This will read the various
723 settings that set how the file is interpreted.
728 my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
729 my $this_file_version = 3;
731 sub _write_file_header {
734 my $nt = $self->num_txns;
735 my $bl = $self->txn_bitfield_len;
737 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
739 my $loc = $self->storage->request_space( $header_fixed + $header_var );
741 $self->storage->print_at( $loc,
744 pack('N', $this_file_version), # At this point, we're at 9 bytes
745 pack('N', $header_var), # header size
746 # --- Above is $header_fixed. Below is $header_var
747 pack('C', $self->byte_size),
749 # These shenanigans are to allow a 256 within a C
750 pack('C', $self->max_buckets - 1),
751 pack('C', $self->data_sector_size - 1),
754 pack('C' . $bl, 0 ), # Transaction activeness bitfield
755 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
756 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
757 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
758 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
761 #XXX Set these less fragilely
762 $self->set_trans_loc( $header_fixed + 4 );
763 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
768 sub _read_file_header {
771 my $buffer = $self->storage->read_at( 0, $header_fixed );
772 return unless length($buffer);
774 my ($file_signature, $sig_header, $file_version, $size) = unpack(
778 unless ( $file_signature eq $self->SIG_FILE ) {
779 $self->storage->close;
780 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
783 unless ( $sig_header eq $self->SIG_HEADER ) {
784 $self->storage->close;
785 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
788 unless ( $file_version == $this_file_version ) {
789 $self->storage->close;
790 DBM::Deep->_throw_error(
791 "Wrong file version found - " . $file_version .
792 " - expected " . $this_file_version
796 my $buffer2 = $self->storage->read_at( undef, $size );
797 my @values = unpack( 'C C C C', $buffer2 );
799 if ( @values != 4 || grep { !defined } @values ) {
800 $self->storage->close;
801 DBM::Deep->_throw_error("Corrupted file - bad header");
804 #XXX Add warnings if values weren't set right
805 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
807 # These shenangians are to allow a 256 within a C
808 $self->{max_buckets} += 1;
809 $self->{data_sector_size} += 1;
811 my $bl = $self->txn_bitfield_len;
813 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
814 unless ( $size == $header_var ) {
815 $self->storage->close;
816 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
819 $self->set_trans_loc( $header_fixed + scalar(@values) );
820 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
822 return length($buffer) + length($buffer2);
826 =head2 _apply_digest( @stuff )
828 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
829 passed in and return the result.
835 return $self->{digest}->(@_);
838 =head2 _add_free_blist_sector( $offset, $size )
840 =head2 _add_free_data_sector( $offset, $size )
842 =head2 _add_free_index_sector( $offset, $size )
844 These methods are all wrappers around _add_free_sector(), providing the proper
845 chain offset ($multiple) for the sector type.
849 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
850 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
851 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
853 =head2 _add_free_sector( $multiple, $offset, $size )
855 _add_free_sector() takes the offset into the chains location, the offset of the
856 sector, and the size of that sector. It will mark the sector as a free sector
857 and put it into the list of sectors that are free of this type for use later.
859 This returns nothing.
861 B<NOTE>: $size is unused?
865 sub _add_free_sector {
867 my ($multiple, $offset, $size) = @_;
869 my $chains_offset = $multiple * $self->byte_size;
871 my $storage = $self->storage;
873 # Increment staleness.
874 # XXX Can this increment+modulo be done by "&= 0x1" ?
875 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
876 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
877 $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
879 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
881 $storage->print_at( $self->chains_loc + $chains_offset,
882 pack( $StP{$self->byte_size}, $offset ),
885 # Record the old head in the new sector after the signature and staleness counter
886 $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
889 =head2 _request_blist_sector( $size )
891 =head2 _request_data_sector( $size )
893 =head2 _request_index_sector( $size )
895 These methods are all wrappers around _request_sector(), providing the proper
896 chain offset ($multiple) for the sector type.
900 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
901 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
902 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
904 =head2 _request_sector( $multiple $size )
906 This takes the offset into the chains location and the size of that sector.
908 This returns the object with the sector. If there is an available free sector of
909 that type, then it will be reused. If there isn't one, then a new one will be
914 sub _request_sector {
916 my ($multiple, $size) = @_;
918 my $chains_offset = $multiple * $self->byte_size;
920 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
921 my $loc = unpack( $StP{$self->byte_size}, $old_head );
923 # We don't have any free sectors of the right size, so allocate a new one.
925 my $offset = $self->storage->request_space( $size );
927 # Zero out the new sector. This also guarantees correct increases
929 $self->storage->print_at( $offset, chr(0) x $size );
934 # Read the new head after the signature and the staleness counter
935 my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
936 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
937 $self->storage->print_at(
938 $loc + $self->SIG_SIZE + $STALE_SIZE,
939 pack( $StP{$self->byte_size}, 0 ),
947 The following are readonly attributes.
965 =item * data_sector_size
967 =item * txn_bitfield_len
973 sub storage { $_[0]{storage} }
974 sub byte_size { $_[0]{byte_size} }
975 sub hash_size { $_[0]{hash_size} }
976 sub hash_chars { $_[0]{hash_chars} }
977 sub num_txns { $_[0]{num_txns} }
978 sub max_buckets { $_[0]{max_buckets} }
979 sub blank_md5 { chr(0) x $_[0]->hash_size }
980 sub data_sector_size { $_[0]{data_sector_size} }
982 # This is a calculated value
983 sub txn_bitfield_len {
985 unless ( exists $self->{txn_bitfield_len} ) {
986 my $temp = ($self->num_txns) / 8;
987 if ( $temp > int( $temp ) ) {
988 $temp = int( $temp ) + 1;
990 $self->{txn_bitfield_len} = $temp;
992 return $self->{txn_bitfield_len};
997 The following are read/write attributes.
1001 =item * trans_id / set_trans_id( $new_id )
1003 =item * trans_loc / set_trans_loc( $new_loc )
1005 =item * chains_loc / set_chains_loc( $new_loc )
1011 sub trans_id { $_[0]{trans_id} }
1012 sub set_trans_id { $_[0]{trans_id} = $_[1] }
1014 sub trans_loc { $_[0]{trans_loc} }
1015 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1017 sub chains_loc { $_[0]{chains_loc} }
1018 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1020 sub cache { $_[0]{cache} ||= {} }
1021 sub clear_cache { %{$_[0]->cache} = () }
1025 This method takes no arguments. It's used to print out a textual representation
1026 of the DBM::Deep DB file. It assumes the file is not-corrupted.
1034 my $spot = $self->_read_file_header();
1043 'D' => $self->data_sector_size,
1044 'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
1045 'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
1051 $return .= "NumTxns: " . $self->num_txns . $/;
1053 # Read the free sector chains
1055 foreach my $multiple ( 0 .. 2 ) {
1056 $return .= "Chains($types{$multiple}):";
1057 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1060 $StP{$self->byte_size},
1061 $self->storage->read_at( $old_loc, $self->byte_size ),
1064 # We're now out of free sectors of this kind.
1069 $sectors{ $types{$multiple} }{ $loc } = undef;
1070 $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
1077 while ( $spot < $self->storage->{end} ) {
1078 # Read each sector in order.
1079 my $sector = DBM::Deep::Sector::File->load( $self, $spot );
1081 # Find it in the free-sectors that were found already
1082 foreach my $type ( keys %sectors ) {
1083 if ( exists $sectors{$type}{$spot} ) {
1084 my $size = $sizes{$type};
1085 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1091 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1094 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1095 if ( $sector->type eq 'D' ) {
1096 $return .= ' ' . $sector->data;
1098 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1099 $return .= ' REF: ' . $sector->get_refcount;
1101 elsif ( $sector->type eq 'B' ) {
1102 foreach my $bucket ( $sector->chopped_up ) {
1104 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1105 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1107 my $l = unpack( $StP{$self->byte_size},
1108 substr( $bucket->[-1],
1109 $self->hash_size + $self->byte_size,
1113 $return .= sprintf " %08d", $l;
1114 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1115 my $l = unpack( $StP{$self->byte_size},
1116 substr( $bucket->[-1],
1117 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1121 $return .= sprintf " %08d", $l;
1127 $spot += $sector->size;