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' }
20 # Setup file and tag signatures. These should never change.
21 sub SIG_FILE () { 'DPDB' }
22 sub SIG_HEADER () { 'h' }
23 sub SIG_HASH () { 'H' }
24 sub SIG_ARRAY () { 'A' }
25 sub SIG_NULL () { 'N' }
26 sub SIG_DATA () { 'D' }
27 sub SIG_INDEX () { 'I' }
28 sub SIG_BLIST () { 'B' }
29 sub SIG_FREE () { 'F' }
32 # 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,
236 my ($obj, $key) = @_;
238 # This will be a Reference sector
239 my $sector = $self->load_sector( $obj->_base_offset )
242 if ( $sector->staleness != $obj->_staleness ) {
246 my $data = $sector->get_data_for({
247 key_md5 => $self->_apply_digest( $key ),
251 # exists() returns 1 or '' for true/false.
252 return $data ? 1 : '';
257 my ($obj, $key) = @_;
259 my $sector = $self->load_sector( $obj->_base_offset )
262 if ( $sector->staleness != $obj->_staleness ) {
266 return $sector->delete_key({
267 key_md5 => $self->_apply_digest( $key ),
274 my ($obj, $key, $value) = @_;
276 my $r = Scalar::Util::reftype( $value ) || '';
279 last if $r eq 'HASH';
280 last if $r eq 'ARRAY';
282 DBM::Deep->_throw_error(
283 "Storage of references of type '$r' is not supported."
287 # This will be a Reference sector
288 my $sector = $self->load_sector( $obj->_base_offset )
289 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
291 if ( $sector->staleness != $obj->_staleness ) {
292 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
296 if ( !defined $value ) {
297 $class = 'DBM::Deep::Sector::File::Null';
299 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
301 if ( $r eq 'ARRAY' ) {
302 $tmpvar = tied @$value;
303 } elsif ( $r eq 'HASH' ) {
304 $tmpvar = tied %$value;
308 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
310 unless ( $is_dbm_deep ) {
311 DBM::Deep->_throw_error( "Cannot store something that is tied." );
314 unless ( $tmpvar->_engine->storage == $self->storage ) {
315 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
318 # First, verify if we're storing the same thing to this spot. If we
319 # are, then this should be a no-op. -EJS, 2008-05-19
320 my $loc = $sector->get_data_location_for({
321 key_md5 => $self->_apply_digest( $key ),
325 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
329 #XXX Can this use $loc?
330 my $value_sector = $self->load_sector( $tmpvar->_base_offset );
331 $sector->write_data({
333 key_md5 => $self->_apply_digest( $key ),
334 value => $value_sector,
336 $value_sector->increment_refcount;
341 $class = 'DBM::Deep::Sector::File::Reference';
342 $type = substr( $r, 0, 1 );
345 if ( tied($value) ) {
346 DBM::Deep->_throw_error( "Cannot store something that is tied." );
348 $class = 'DBM::Deep::Sector::File::Scalar';
351 # Create this after loading the reference sector in case something bad
352 # happens. This way, we won't allocate value sector(s) needlessly.
353 my $value_sector = $class->new({
359 $sector->write_data({
361 key_md5 => $self->_apply_digest( $key ),
362 value => $value_sector,
365 # This code is to make sure we write all the values in the $value to the
366 # disk and to make sure all changes to $value after the assignment are
367 # reflected on disk. This may be counter-intuitive at first, but it is
369 # NOTE - simply tying $value won't perform a STORE on each value. Hence,
370 # the copy to a temp value.
371 if ( $r eq 'ARRAY' ) {
373 tie @$value, 'DBM::Deep', {
374 base_offset => $value_sector->offset,
375 staleness => $value_sector->staleness,
376 storage => $self->storage,
380 bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
382 elsif ( $r eq 'HASH' ) {
384 tie %$value, 'DBM::Deep', {
385 base_offset => $value_sector->offset,
386 staleness => $value_sector->staleness,
387 storage => $self->storage,
392 bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
402 # We're opening the file.
403 unless ( $obj->_base_offset ) {
404 my $bytes_read = $self->_read_file_header;
406 # Creating a new file
407 unless ( $bytes_read ) {
408 $self->_write_file_header;
410 # 1) Create Array/Hash entry
411 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
415 $obj->{base_offset} = $initial_reference->offset;
416 $obj->{staleness} = $initial_reference->staleness;
418 $self->storage->flush;
420 # Reading from an existing file
422 $obj->{base_offset} = $bytes_read;
423 my $initial_reference = DBM::Deep::Sector::File::Reference->new({
425 offset => $obj->_base_offset,
427 unless ( $initial_reference ) {
428 DBM::Deep->_throw_error("Corrupted file, no master index record");
431 unless ($obj->_type eq $initial_reference->type) {
432 DBM::Deep->_throw_error("File type mismatch");
435 $obj->{staleness} = $initial_reference->staleness;
439 $self->storage->set_inode;
448 if ( $self->trans_id ) {
449 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
452 my @slots = $self->read_txn_slots;
454 for my $i ( 0 .. $#slots ) {
458 $self->set_trans_id( $i + 1 );
463 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
465 $self->write_txn_slots( @slots );
467 if ( !$self->trans_id ) {
468 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
478 if ( !$self->trans_id ) {
479 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
482 # Each entry is the file location for a bucket that has a modification for
483 # this transaction. The entries need to be expunged.
484 foreach my $entry (@{ $self->get_entries } ) {
485 # Remove the entry here
486 my $read_loc = $entry
490 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
492 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
493 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
494 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
496 if ( $data_loc > 1 ) {
497 $self->load_sector( $data_loc )->free;
501 $self->clear_entries;
503 my @slots = $self->read_txn_slots;
504 $slots[$self->trans_id-1] = 0;
505 $self->write_txn_slots( @slots );
506 $self->inc_txn_staleness_counter( $self->trans_id );
507 $self->set_trans_id( 0 );
516 if ( !$self->trans_id ) {
517 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
520 foreach my $entry (@{ $self->get_entries } ) {
521 # Overwrite the entry in head with the entry in trans_id
526 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
527 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
529 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
530 my $trans_loc = $self->storage->read_at(
531 $spot, $self->byte_size,
534 $self->storage->print_at( $base, $trans_loc );
535 $self->storage->print_at(
537 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
540 if ( $head_loc > 1 ) {
541 $self->load_sector( $head_loc )->free;
545 $self->clear_entries;
547 my @slots = $self->read_txn_slots;
548 $slots[$self->trans_id-1] = 0;
549 $self->write_txn_slots( @slots );
550 $self->inc_txn_staleness_counter( $self->trans_id );
551 $self->set_trans_id( 0 );
556 =head1 INTERNAL METHODS
558 The following methods are internal-use-only to DBM::Deep::Engine::File.
562 =head2 read_txn_slots()
564 This takes no arguments.
566 This will return an array with a 1 or 0 in each slot. Each spot represents one
567 available transaction. If the slot is 1, that transaction is taken. If it is 0,
568 the transaction is available.
574 my $bl = $self->txn_bitfield_len;
575 my $num_bits = $bl * 8;
576 return split '', unpack( 'b'.$num_bits,
577 $self->storage->read_at(
578 $self->trans_loc, $bl,
583 =head2 write_txn_slots( @slots )
585 This takes an array of 1's and 0's. This array represents the transaction slots
586 returned by L</read_txn_slots()>. In other words, the following is true:
588 @x = read_txn_slots( write_txn_slots( @x ) );
590 (With the obviously missing object referents added back in.)
594 sub write_txn_slots {
596 my $num_bits = $self->txn_bitfield_len * 8;
597 $self->storage->print_at( $self->trans_loc,
598 pack( 'b'.$num_bits, join('', @_) ),
602 =head2 get_running_txn_ids()
604 This takes no arguments.
606 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
610 sub get_running_txn_ids {
612 my @transactions = $self->read_txn_slots;
613 my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
616 =head2 get_txn_staleness_counter( $trans_id )
618 This will return the staleness counter for the given transaction ID. Please see
619 L</TRANSACTION STALENESS> for more information.
623 sub get_txn_staleness_counter {
627 # Hardcode staleness of 0 for the HEAD
628 return 0 unless $trans_id;
630 return unpack( $StP{$STALE_SIZE},
631 $self->storage->read_at(
632 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
638 =head2 inc_txn_staleness_counter( $trans_id )
640 This will increment the staleness counter for the given transaction ID. Please see
641 L</TRANSACTION STALENESS> for more information.
645 sub inc_txn_staleness_counter {
649 # Hardcode staleness of 0 for the HEAD
650 return 0 unless $trans_id;
652 $self->storage->print_at(
653 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
654 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
660 This takes no arguments.
662 This returns a list of all the sectors that have been modified by this transaction.
668 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
671 =head2 add_entry( $trans_id, $location )
673 This takes a transaction ID and a file location and marks the sector at that
674 location as having been modified by the transaction identified by $trans_id.
676 This returns nothing.
678 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
679 C<< $trans_id != $self->trans_id >> for this method.
685 my ($trans_id, $loc) = @_;
687 $self->{entries}{$trans_id} ||= {};
688 $self->{entries}{$trans_id}{$loc} = undef;
691 =head2 reindex_entry( $old_loc, $new_loc )
693 This takes two locations (old and new, respectively). If a location that has
694 been modified by this transaction is subsequently reindexed due to a bucketlist
695 overflowing, then the entries hash needs to be made aware of this change.
697 This returns nothing.
703 my ($old_loc, $new_loc) = @_;
706 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
707 if ( exists $locs->{$old_loc} ) {
708 delete $locs->{$old_loc};
709 $locs->{$new_loc} = undef;
715 =head2 clear_entries()
717 This takes no arguments. It will clear the entries list for the running
720 This returns nothing.
726 delete $self->{entries}{$self->trans_id};
729 =head2 _write_file_header()
731 This writes the file header for a new file. This will write the various settings
732 that set how the file is interpreted.
734 =head2 _read_file_header()
736 This reads the file header from an existing file. This will read the various
737 settings that set how the file is interpreted.
742 my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
743 my $this_file_version = 3;
745 sub _write_file_header {
748 my $nt = $self->num_txns;
749 my $bl = $self->txn_bitfield_len;
751 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
753 my $loc = $self->storage->request_space( $header_fixed + $header_var );
755 $self->storage->print_at( $loc,
758 pack('N', $this_file_version), # At this point, we're at 9 bytes
759 pack('N', $header_var), # header size
760 # --- Above is $header_fixed. Below is $header_var
761 pack('C', $self->byte_size),
763 # These shenanigans are to allow a 256 within a C
764 pack('C', $self->max_buckets - 1),
765 pack('C', $self->data_sector_size - 1),
768 pack('C' . $bl, 0 ), # Transaction activeness bitfield
769 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
770 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
771 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
772 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
775 #XXX Set these less fragilely
776 $self->set_trans_loc( $header_fixed + 4 );
777 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
782 sub _read_file_header {
785 my $buffer = $self->storage->read_at( 0, $header_fixed );
786 return unless length($buffer);
788 my ($file_signature, $sig_header, $file_version, $size) = unpack(
792 unless ( $file_signature eq $self->SIG_FILE ) {
793 $self->storage->close;
794 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
797 unless ( $sig_header eq $self->SIG_HEADER ) {
798 $self->storage->close;
799 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
802 unless ( $file_version == $this_file_version ) {
803 $self->storage->close;
804 DBM::Deep->_throw_error(
805 "Wrong file version found - " . $file_version .
806 " - expected " . $this_file_version
810 my $buffer2 = $self->storage->read_at( undef, $size );
811 my @values = unpack( 'C C C C', $buffer2 );
813 if ( @values != 4 || grep { !defined } @values ) {
814 $self->storage->close;
815 DBM::Deep->_throw_error("Corrupted file - bad header");
818 #XXX Add warnings if values weren't set right
819 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
821 # These shenangians are to allow a 256 within a C
822 $self->{max_buckets} += 1;
823 $self->{data_sector_size} += 1;
825 my $bl = $self->txn_bitfield_len;
827 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
828 unless ( $size == $header_var ) {
829 $self->storage->close;
830 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
833 $self->set_trans_loc( $header_fixed + scalar(@values) );
834 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
836 return length($buffer) + length($buffer2);
840 =head2 _apply_digest( @stuff )
842 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
843 passed in and return the result.
849 return $self->{digest}->(@_);
852 =head2 _add_free_blist_sector( $offset, $size )
854 =head2 _add_free_data_sector( $offset, $size )
856 =head2 _add_free_index_sector( $offset, $size )
858 These methods are all wrappers around _add_free_sector(), providing the proper
859 chain offset ($multiple) for the sector type.
863 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
864 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
865 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
867 =head2 _add_free_sector( $multiple, $offset, $size )
869 _add_free_sector() takes the offset into the chains location, the offset of the
870 sector, and the size of that sector. It will mark the sector as a free sector
871 and put it into the list of sectors that are free of this type for use later.
873 This returns nothing.
875 B<NOTE>: $size is unused?
879 sub _add_free_sector {
881 my ($multiple, $offset, $size) = @_;
883 my $chains_offset = $multiple * $self->byte_size;
885 my $storage = $self->storage;
887 # Increment staleness.
888 # XXX Can this increment+modulo be done by "&= 0x1" ?
889 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
890 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
891 $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
893 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
895 $storage->print_at( $self->chains_loc + $chains_offset,
896 pack( $StP{$self->byte_size}, $offset ),
899 # Record the old head in the new sector after the signature and staleness counter
900 $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
903 =head2 _request_blist_sector( $size )
905 =head2 _request_data_sector( $size )
907 =head2 _request_index_sector( $size )
909 These methods are all wrappers around _request_sector(), providing the proper
910 chain offset ($multiple) for the sector type.
914 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
915 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
916 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
918 =head2 _request_sector( $multiple $size )
920 This takes the offset into the chains location and the size of that sector.
922 This returns the object with the sector. If there is an available free sector of
923 that type, then it will be reused. If there isn't one, then a new one will be
928 sub _request_sector {
930 my ($multiple, $size) = @_;
932 my $chains_offset = $multiple * $self->byte_size;
934 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
935 my $loc = unpack( $StP{$self->byte_size}, $old_head );
937 # We don't have any free sectors of the right size, so allocate a new one.
939 my $offset = $self->storage->request_space( $size );
941 # Zero out the new sector. This also guarantees correct increases
943 $self->storage->print_at( $offset, chr(0) x $size );
948 # Read the new head after the signature and the staleness counter
949 my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
950 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
951 $self->storage->print_at(
952 $loc + $self->SIG_SIZE + $STALE_SIZE,
953 pack( $StP{$self->byte_size}, 0 ),
961 The following are readonly attributes.
977 =item * data_sector_size
979 =item * txn_bitfield_len
985 sub byte_size { $_[0]{byte_size} }
986 sub hash_size { $_[0]{hash_size} }
987 sub hash_chars { $_[0]{hash_chars} }
988 sub num_txns { $_[0]{num_txns} }
989 sub max_buckets { $_[0]{max_buckets} }
990 sub blank_md5 { chr(0) x $_[0]->hash_size }
991 sub data_sector_size { $_[0]{data_sector_size} }
993 # This is a calculated value
994 sub txn_bitfield_len {
996 unless ( exists $self->{txn_bitfield_len} ) {
997 my $temp = ($self->num_txns) / 8;
998 if ( $temp > int( $temp ) ) {
999 $temp = int( $temp ) + 1;
1001 $self->{txn_bitfield_len} = $temp;
1003 return $self->{txn_bitfield_len};
1008 The following are read/write attributes.
1012 =item * trans_id / set_trans_id( $new_id )
1014 =item * trans_loc / set_trans_loc( $new_loc )
1016 =item * chains_loc / set_chains_loc( $new_loc )
1022 sub trans_id { $_[0]{trans_id} }
1023 sub set_trans_id { $_[0]{trans_id} = $_[1] }
1025 sub trans_loc { $_[0]{trans_loc} }
1026 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1028 sub chains_loc { $_[0]{chains_loc} }
1029 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1031 sub cache { $_[0]{cache} ||= {} }
1032 sub clear_cache { %{$_[0]->cache} = () }
1036 This method takes no arguments. It's used to print out a textual representation
1037 of the DBM::Deep DB file. It assumes the file is not-corrupted.
1045 my $spot = $self->_read_file_header();
1054 'D' => $self->data_sector_size,
1055 'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
1056 'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
1062 $return .= "NumTxns: " . $self->num_txns . $/;
1064 # Read the free sector chains
1066 foreach my $multiple ( 0 .. 2 ) {
1067 $return .= "Chains($types{$multiple}):";
1068 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1071 $StP{$self->byte_size},
1072 $self->storage->read_at( $old_loc, $self->byte_size ),
1075 # We're now out of free sectors of this kind.
1080 $sectors{ $types{$multiple} }{ $loc } = undef;
1081 $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
1088 while ( $spot < $self->storage->{end} ) {
1089 # Read each sector in order.
1090 my $sector = $self->load_sector( $spot );
1092 # Find it in the free-sectors that were found already
1093 foreach my $type ( keys %sectors ) {
1094 if ( exists $sectors{$type}{$spot} ) {
1095 my $size = $sizes{$type};
1096 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1102 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1105 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1106 if ( $sector->type eq 'D' ) {
1107 $return .= ' ' . $sector->data;
1109 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1110 $return .= ' REF: ' . $sector->get_refcount;
1112 elsif ( $sector->type eq 'B' ) {
1113 foreach my $bucket ( $sector->chopped_up ) {
1115 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1116 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1118 my $l = unpack( $StP{$self->byte_size},
1119 substr( $bucket->[-1],
1120 $self->hash_size + $self->byte_size,
1124 $return .= sprintf " %08d", $l;
1125 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1126 my $l = unpack( $StP{$self->byte_size},
1127 substr( $bucket->[-1],
1128 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1132 $return .= sprintf " %08d", $l;
1138 $spot += $sector->size;