1 package DBM::Deep::Engine::File;
6 use warnings FATAL => 'all';
8 use base qw( DBM::Deep::Engine );
10 # Never import symbols into our namespace. We are a class, not a library.
13 use DBM::Deep::Storage::File ();
15 use DBM::Deep::Engine::Sector::Data ();
16 use DBM::Deep::Engine::Sector::BucketList ();
17 use DBM::Deep::Engine::Sector::Index ();
18 use DBM::Deep::Engine::Sector::Null ();
19 use DBM::Deep::Engine::Sector::Reference ();
20 use DBM::Deep::Engine::Sector::Scalar ();
21 use DBM::Deep::Null ();
25 # Please refer to the pack() documentation for further information
27 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
28 2 => 'n', # Unsigned short in "network" (big-endian) order
29 4 => 'N', # Unsigned long in "network" (big-endian) order
30 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
35 DBM::Deep::Engine::File
39 This is the engine for use with L<DBM::Deep::Storage::File/>.
41 =head1 EXTERNAL METHODS
45 This takes a set of args. These args are described in the documentation for
54 $args->{storage} = DBM::Deep::Storage::File->new( $args )
55 unless exists $args->{storage};
61 hash_size => 16, # In bytes
62 hash_chars => 256, # Number of chars the algorithm uses per byte
64 num_txns => 1, # The HEAD
65 trans_id => 0, # Default to the HEAD
67 data_sector_size => 64, # Size in bytes of each data sector
69 entries => {}, # This is the list of entries for transactions
73 # Never allow byte_size to be set directly.
74 delete $args->{byte_size};
75 if ( defined $args->{pack_size} ) {
76 if ( lc $args->{pack_size} eq 'small' ) {
77 $args->{byte_size} = 2;
79 elsif ( lc $args->{pack_size} eq 'medium' ) {
80 $args->{byte_size} = 4;
82 elsif ( lc $args->{pack_size} eq 'large' ) {
83 $args->{byte_size} = 8;
86 DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
90 # Grab the parameters we want to use
91 foreach my $param ( keys %$self ) {
92 next unless exists $args->{$param};
93 $self->{$param} = $args->{$param};
97 max_buckets => { floor => 16, ceil => 256 },
98 num_txns => { floor => 1, ceil => 255 },
99 data_sector_size => { floor => 32, ceil => 256 },
102 while ( my ($attr, $c) = each %validations ) {
103 if ( !defined $self->{$attr}
104 || !length $self->{$attr}
105 || $self->{$attr} =~ /\D/
106 || $self->{$attr} < $c->{floor}
108 $self->{$attr} = '(undef)' if !defined $self->{$attr};
109 warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
110 $self->{$attr} = $c->{floor};
112 elsif ( $self->{$attr} > $c->{ceil} ) {
113 warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
114 $self->{$attr} = $c->{ceil};
118 if ( !$self->{digest} ) {
120 $self->{digest} = \&Digest::MD5::md5;
128 my ($obj, $key) = @_;
130 # This will be a Reference sector
131 my $sector = $self->_load_sector( $obj->_base_offset )
134 if ( $sector->staleness != $obj->_staleness ) {
138 my $key_md5 = $self->_apply_digest( $key );
140 my $value_sector = $sector->get_data_for({
145 unless ( $value_sector ) {
146 $value_sector = DBM::Deep::Engine::Sector::Null->new({
151 $sector->write_data({
154 value => $value_sector,
158 return $value_sector->data;
165 # This will be a Reference sector
166 my $sector = $self->_load_sector( $obj->_base_offset )
167 or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
169 if ( $sector->staleness != $obj->_staleness ) {
173 return $sector->get_classname;
178 my ($obj, $old_key, $new_key) = @_;
180 # This will be a Reference sector
181 my $sector = $self->_load_sector( $obj->_base_offset )
182 or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
184 if ( $sector->staleness != $obj->_staleness ) {
188 my $old_md5 = $self->_apply_digest( $old_key );
190 my $value_sector = $sector->get_data_for({
195 unless ( $value_sector ) {
196 $value_sector = DBM::Deep::Engine::Sector::Null->new({
201 $sector->write_data({
204 value => $value_sector,
208 if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
209 $sector->write_data({
211 key_md5 => $self->_apply_digest( $new_key ),
212 value => $value_sector,
214 $value_sector->increment_refcount;
217 $sector->write_data({
219 key_md5 => $self->_apply_digest( $new_key ),
220 value => $value_sector->clone,
229 my ($obj, $key) = @_;
231 # This will be a Reference sector
232 my $sector = $self->_load_sector( $obj->_base_offset )
235 if ( $sector->staleness != $obj->_staleness ) {
239 my $data = $sector->get_data_for({
240 key_md5 => $self->_apply_digest( $key ),
244 # exists() returns 1 or '' for true/false.
245 return $data ? 1 : '';
250 my ($obj, $key) = @_;
252 my $sector = $self->_load_sector( $obj->_base_offset )
255 if ( $sector->staleness != $obj->_staleness ) {
259 return $sector->delete_key({
260 key_md5 => $self->_apply_digest( $key ),
267 my ($obj, $key, $value) = @_;
269 my $r = Scalar::Util::reftype( $value ) || '';
272 last if $r eq 'HASH';
273 last if $r eq 'ARRAY';
275 DBM::Deep->_throw_error(
276 "Storage of references of type '$r' is not supported."
280 # This will be a Reference sector
281 my $sector = $self->_load_sector( $obj->_base_offset )
282 or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
284 if ( $sector->staleness != $obj->_staleness ) {
285 DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
289 if ( !defined $value ) {
290 $class = 'DBM::Deep::Engine::Sector::Null';
292 elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
294 if ( $r eq 'ARRAY' ) {
295 $tmpvar = tied @$value;
296 } elsif ( $r eq 'HASH' ) {
297 $tmpvar = tied %$value;
301 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
303 unless ( $is_dbm_deep ) {
304 DBM::Deep->_throw_error( "Cannot store something that is tied." );
307 unless ( $tmpvar->_engine->storage == $self->storage ) {
308 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
311 # First, verify if we're storing the same thing to this spot. If we are, then
312 # this should be a no-op. -EJS, 2008-05-19
313 my $loc = $sector->get_data_location_for({
314 key_md5 => $self->_apply_digest( $key ),
318 if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
322 #XXX Can this use $loc?
323 my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
324 $sector->write_data({
326 key_md5 => $self->_apply_digest( $key ),
327 value => $value_sector,
329 $value_sector->increment_refcount;
334 $class = 'DBM::Deep::Engine::Sector::Reference';
335 $type = substr( $r, 0, 1 );
338 if ( tied($value) ) {
339 DBM::Deep->_throw_error( "Cannot store something that is tied." );
341 $class = 'DBM::Deep::Engine::Sector::Scalar';
344 # Create this after loading the reference sector in case something bad happens.
345 # This way, we won't allocate value sector(s) needlessly.
346 my $value_sector = $class->new({
352 $sector->write_data({
354 key_md5 => $self->_apply_digest( $key ),
355 value => $value_sector,
358 # This code is to make sure we write all the values in the $value to the disk
359 # and to make sure all changes to $value after the assignment are reflected
360 # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
361 # NOTE - simply tying $value won't perform a STORE on each value. Hence, the
362 # copy to a temp value.
363 if ( $r eq 'ARRAY' ) {
365 tie @$value, 'DBM::Deep', {
366 base_offset => $value_sector->offset,
367 staleness => $value_sector->staleness,
368 storage => $self->storage,
372 bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
374 elsif ( $r eq 'HASH' ) {
376 tie %$value, 'DBM::Deep', {
377 base_offset => $value_sector->offset,
378 staleness => $value_sector->staleness,
379 storage => $self->storage,
384 bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
394 # We're opening the file.
395 unless ( $obj->_base_offset ) {
396 my $bytes_read = $self->_read_file_header;
398 # Creating a new file
399 unless ( $bytes_read ) {
400 $self->_write_file_header;
402 # 1) Create Array/Hash entry
403 my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
407 $obj->{base_offset} = $initial_reference->offset;
408 $obj->{staleness} = $initial_reference->staleness;
410 $self->storage->flush;
412 # Reading from an existing file
414 $obj->{base_offset} = $bytes_read;
415 my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
417 offset => $obj->_base_offset,
419 unless ( $initial_reference ) {
420 DBM::Deep->_throw_error("Corrupted file, no master index record");
423 unless ($obj->_type eq $initial_reference->type) {
424 DBM::Deep->_throw_error("File type mismatch");
427 $obj->{staleness} = $initial_reference->staleness;
431 $self->storage->set_inode;
440 if ( $self->trans_id ) {
441 DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
444 my @slots = $self->read_txn_slots;
446 for my $i ( 0 .. $#slots ) {
450 $self->set_trans_id( $i + 1 );
455 DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
457 $self->write_txn_slots( @slots );
459 if ( !$self->trans_id ) {
460 DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
470 if ( !$self->trans_id ) {
471 DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
474 # Each entry is the file location for a bucket that has a modification for
475 # this transaction. The entries need to be expunged.
476 foreach my $entry (@{ $self->get_entries } ) {
477 # Remove the entry here
478 my $read_loc = $entry
482 + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
484 my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
485 $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
486 $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
488 if ( $data_loc > 1 ) {
489 $self->_load_sector( $data_loc )->free;
493 $self->clear_entries;
495 my @slots = $self->read_txn_slots;
496 $slots[$self->trans_id-1] = 0;
497 $self->write_txn_slots( @slots );
498 $self->inc_txn_staleness_counter( $self->trans_id );
499 $self->set_trans_id( 0 );
508 if ( !$self->trans_id ) {
509 DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
512 foreach my $entry (@{ $self->get_entries } ) {
513 # Overwrite the entry in head with the entry in trans_id
518 my $head_loc = $self->storage->read_at( $base, $self->byte_size );
519 $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
521 my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
522 my $trans_loc = $self->storage->read_at(
523 $spot, $self->byte_size,
526 $self->storage->print_at( $base, $trans_loc );
527 $self->storage->print_at(
529 pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
532 if ( $head_loc > 1 ) {
533 $self->_load_sector( $head_loc )->free;
537 $self->clear_entries;
539 my @slots = $self->read_txn_slots;
540 $slots[$self->trans_id-1] = 0;
541 $self->write_txn_slots( @slots );
542 $self->inc_txn_staleness_counter( $self->trans_id );
543 $self->set_trans_id( 0 );
548 =head1 INTERNAL METHODS
550 The following methods are internal-use-only to DBM::Deep::Engine::File.
554 =head2 read_txn_slots()
556 This takes no arguments.
558 This will return an array with a 1 or 0 in each slot. Each spot represents one
559 available transaction. If the slot is 1, that transaction is taken. If it is 0,
560 the transaction is available.
566 my $bl = $self->txn_bitfield_len;
567 my $num_bits = $bl * 8;
568 return split '', unpack( 'b'.$num_bits,
569 $self->storage->read_at(
570 $self->trans_loc, $bl,
575 =head2 write_txn_slots( @slots )
577 This takes an array of 1's and 0's. This array represents the transaction slots
578 returned by L</read_txn_slots()>. In other words, the following is true:
580 @x = read_txn_slots( write_txn_slots( @x ) );
582 (With the obviously missing object referents added back in.)
586 sub write_txn_slots {
588 my $num_bits = $self->txn_bitfield_len * 8;
589 $self->storage->print_at( $self->trans_loc,
590 pack( 'b'.$num_bits, join('', @_) ),
594 =head2 get_running_txn_ids()
596 This takes no arguments.
598 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
602 sub get_running_txn_ids {
604 my @transactions = $self->read_txn_slots;
605 my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
608 =head2 get_txn_staleness_counter( $trans_id )
610 This will return the staleness counter for the given transaction ID. Please see
611 L</TRANSACTION STALENESS> for more information.
615 sub get_txn_staleness_counter {
619 # Hardcode staleness of 0 for the HEAD
620 return 0 unless $trans_id;
622 return unpack( $StP{$STALE_SIZE},
623 $self->storage->read_at(
624 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
630 =head2 inc_txn_staleness_counter( $trans_id )
632 This will increment the staleness counter for the given transaction ID. Please see
633 L</TRANSACTION STALENESS> for more information.
637 sub inc_txn_staleness_counter {
641 # Hardcode staleness of 0 for the HEAD
642 return 0 unless $trans_id;
644 $self->storage->print_at(
645 $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
646 pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
652 This takes no arguments.
654 This returns a list of all the sectors that have been modified by this transaction.
660 return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
663 =head2 add_entry( $trans_id, $location )
665 This takes a transaction ID and a file location and marks the sector at that
666 location as having been modified by the transaction identified by $trans_id.
668 This returns nothing.
670 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
671 C<< $trans_id != $self->trans_id >> for this method.
677 my ($trans_id, $loc) = @_;
679 $self->{entries}{$trans_id} ||= {};
680 $self->{entries}{$trans_id}{$loc} = undef;
683 =head2 reindex_entry( $old_loc, $new_loc )
685 This takes two locations (old and new, respectively). If a location that has
686 been modified by this transaction is subsequently reindexed due to a bucketlist
687 overflowing, then the entries hash needs to be made aware of this change.
689 This returns nothing.
695 my ($old_loc, $new_loc) = @_;
698 while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
699 if ( exists $locs->{$old_loc} ) {
700 delete $locs->{$old_loc};
701 $locs->{$new_loc} = undef;
707 =head2 clear_entries()
709 This takes no arguments. It will clear the entries list for the running
712 This returns nothing.
718 delete $self->{entries}{$self->trans_id};
721 =head2 _write_file_header()
723 This writes the file header for a new file. This will write the various settings
724 that set how the file is interpreted.
726 =head2 _read_file_header()
728 This reads the file header from an existing file. This will read the various
729 settings that set how the file is interpreted.
734 my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
735 my $this_file_version = 3;
737 sub _write_file_header {
740 my $nt = $self->num_txns;
741 my $bl = $self->txn_bitfield_len;
743 my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
745 my $loc = $self->storage->request_space( $header_fixed + $header_var );
747 $self->storage->print_at( $loc,
750 pack('N', $this_file_version), # At this point, we're at 9 bytes
751 pack('N', $header_var), # header size
752 # --- Above is $header_fixed. Below is $header_var
753 pack('C', $self->byte_size),
755 # These shenanigans are to allow a 256 within a C
756 pack('C', $self->max_buckets - 1),
757 pack('C', $self->data_sector_size - 1),
760 pack('C' . $bl, 0 ), # Transaction activeness bitfield
761 pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
762 pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
763 pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
764 pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
767 #XXX Set these less fragilely
768 $self->set_trans_loc( $header_fixed + 4 );
769 $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
774 sub _read_file_header {
777 my $buffer = $self->storage->read_at( 0, $header_fixed );
778 return unless length($buffer);
780 my ($file_signature, $sig_header, $file_version, $size) = unpack(
784 unless ( $file_signature eq $self->SIG_FILE ) {
785 $self->storage->close;
786 DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
789 unless ( $sig_header eq $self->SIG_HEADER ) {
790 $self->storage->close;
791 DBM::Deep->_throw_error( "Pre-1.00 file version found" );
794 unless ( $file_version == $this_file_version ) {
795 $self->storage->close;
796 DBM::Deep->_throw_error(
797 "Wrong file version found - " . $file_version .
798 " - expected " . $this_file_version
802 my $buffer2 = $self->storage->read_at( undef, $size );
803 my @values = unpack( 'C C C C', $buffer2 );
805 if ( @values != 4 || grep { !defined } @values ) {
806 $self->storage->close;
807 DBM::Deep->_throw_error("Corrupted file - bad header");
810 #XXX Add warnings if values weren't set right
811 @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
813 # These shenangians are to allow a 256 within a C
814 $self->{max_buckets} += 1;
815 $self->{data_sector_size} += 1;
817 my $bl = $self->txn_bitfield_len;
819 my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
820 unless ( $size == $header_var ) {
821 $self->storage->close;
822 DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
825 $self->set_trans_loc( $header_fixed + scalar(@values) );
826 $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
828 return length($buffer) + length($buffer2);
832 =head2 _load_sector( $offset )
834 This will instantiate and return the sector object that represents the data found
843 # Add a catch for offset of 0 or 1
844 return if !$offset || $offset <= 1;
846 my $type = $self->storage->read_at( $offset, 1 );
847 return if $type eq chr(0);
849 if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
850 return DBM::Deep::Engine::Sector::Reference->new({
856 # XXX Don't we need key_md5 here?
857 elsif ( $type eq $self->SIG_BLIST ) {
858 return DBM::Deep::Engine::Sector::BucketList->new({
864 elsif ( $type eq $self->SIG_INDEX ) {
865 return DBM::Deep::Engine::Sector::Index->new({
871 elsif ( $type eq $self->SIG_NULL ) {
872 return DBM::Deep::Engine::Sector::Null->new({
878 elsif ( $type eq $self->SIG_DATA ) {
879 return DBM::Deep::Engine::Sector::Scalar->new({
885 # This was deleted from under us, so just return and let the caller figure it out.
886 elsif ( $type eq $self->SIG_FREE ) {
890 DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
893 =head2 _apply_digest( @stuff )
895 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
896 passed in and return the result.
902 return $self->{digest}->(@_);
905 =head2 _add_free_blist_sector( $offset, $size )
907 =head2 _add_free_data_sector( $offset, $size )
909 =head2 _add_free_index_sector( $offset, $size )
911 These methods are all wrappers around _add_free_sector(), providing the proper
912 chain offset ($multiple) for the sector type.
916 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
917 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
918 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
920 =head2 _add_free_sector( $multiple, $offset, $size )
922 _add_free_sector() takes the offset into the chains location, the offset of the
923 sector, and the size of that sector. It will mark the sector as a free sector
924 and put it into the list of sectors that are free of this type for use later.
926 This returns nothing.
928 B<NOTE>: $size is unused?
932 sub _add_free_sector {
934 my ($multiple, $offset, $size) = @_;
936 my $chains_offset = $multiple * $self->byte_size;
938 my $storage = $self->storage;
940 # Increment staleness.
941 # XXX Can this increment+modulo be done by "&= 0x1" ?
942 my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
943 $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
944 $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
946 my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
948 $storage->print_at( $self->chains_loc + $chains_offset,
949 pack( $StP{$self->byte_size}, $offset ),
952 # Record the old head in the new sector after the signature and staleness counter
953 $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
956 =head2 _request_blist_sector( $size )
958 =head2 _request_data_sector( $size )
960 =head2 _request_index_sector( $size )
962 These methods are all wrappers around _request_sector(), providing the proper
963 chain offset ($multiple) for the sector type.
967 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
968 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
969 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
971 =head2 _request_sector( $multiple $size )
973 This takes the offset into the chains location and the size of that sector.
975 This returns the object with the sector. If there is an available free sector of
976 that type, then it will be reused. If there isn't one, then a new one will be
981 sub _request_sector {
983 my ($multiple, $size) = @_;
985 my $chains_offset = $multiple * $self->byte_size;
987 my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
988 my $loc = unpack( $StP{$self->byte_size}, $old_head );
990 # We don't have any free sectors of the right size, so allocate a new one.
992 my $offset = $self->storage->request_space( $size );
994 # Zero out the new sector. This also guarantees correct increases
996 $self->storage->print_at( $offset, chr(0) x $size );
1001 # Read the new head after the signature and the staleness counter
1002 my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
1003 $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
1004 $self->storage->print_at(
1005 $loc + $self->SIG_SIZE + $STALE_SIZE,
1006 pack( $StP{$self->byte_size}, 0 ),
1014 The following are readonly attributes.
1032 =item * data_sector_size
1034 =item * txn_bitfield_len
1040 sub storage { $_[0]{storage} }
1041 sub byte_size { $_[0]{byte_size} }
1042 sub hash_size { $_[0]{hash_size} }
1043 sub hash_chars { $_[0]{hash_chars} }
1044 sub num_txns { $_[0]{num_txns} }
1045 sub max_buckets { $_[0]{max_buckets} }
1046 sub blank_md5 { chr(0) x $_[0]->hash_size }
1047 sub data_sector_size { $_[0]{data_sector_size} }
1049 # This is a calculated value
1050 sub txn_bitfield_len {
1052 unless ( exists $self->{txn_bitfield_len} ) {
1053 my $temp = ($self->num_txns) / 8;
1054 if ( $temp > int( $temp ) ) {
1055 $temp = int( $temp ) + 1;
1057 $self->{txn_bitfield_len} = $temp;
1059 return $self->{txn_bitfield_len};
1064 The following are read/write attributes.
1068 =item * trans_id / set_trans_id( $new_id )
1070 =item * trans_loc / set_trans_loc( $new_loc )
1072 =item * chains_loc / set_chains_loc( $new_loc )
1078 sub trans_id { $_[0]{trans_id} }
1079 sub set_trans_id { $_[0]{trans_id} = $_[1] }
1081 sub trans_loc { $_[0]{trans_loc} }
1082 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1084 sub chains_loc { $_[0]{chains_loc} }
1085 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1087 sub cache { $_[0]{cache} ||= {} }
1088 sub clear_cache { %{$_[0]->cache} = () }
1092 This method takes no arguments. It's used to print out a textual representation
1093 of the DBM::Deep DB file. It assumes the file is not-corrupted.
1101 my $spot = $self->_read_file_header();
1110 'D' => $self->data_sector_size,
1111 'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
1112 'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
1118 $return .= "NumTxns: " . $self->num_txns . $/;
1120 # Read the free sector chains
1122 foreach my $multiple ( 0 .. 2 ) {
1123 $return .= "Chains($types{$multiple}):";
1124 my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1127 $StP{$self->byte_size},
1128 $self->storage->read_at( $old_loc, $self->byte_size ),
1131 # We're now out of free sectors of this kind.
1136 $sectors{ $types{$multiple} }{ $loc } = undef;
1137 $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
1144 while ( $spot < $self->storage->{end} ) {
1145 # Read each sector in order.
1146 my $sector = $self->_load_sector( $spot );
1148 # Find it in the free-sectors that were found already
1149 foreach my $type ( keys %sectors ) {
1150 if ( exists $sectors{$type}{$spot} ) {
1151 my $size = $sizes{$type};
1152 $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1158 die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1161 $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
1162 if ( $sector->type eq 'D' ) {
1163 $return .= ' ' . $sector->data;
1165 elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1166 $return .= ' REF: ' . $sector->get_refcount;
1168 elsif ( $sector->type eq 'B' ) {
1169 foreach my $bucket ( $sector->chopped_up ) {
1171 $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1172 substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1174 my $l = unpack( $StP{$self->byte_size},
1175 substr( $bucket->[-1],
1176 $self->hash_size + $self->byte_size,
1180 $return .= sprintf " %08d", $l;
1181 foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1182 my $l = unpack( $StP{$self->byte_size},
1183 substr( $bucket->[-1],
1184 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1188 $return .= sprintf " %08d", $l;
1194 $spot += $sector->size;