0af33b8bebb34427b8d9d985377452aaaee3b2b4
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Engine / File.pm
1 package DBM::Deep::Engine::File;
2
3 use 5.006_000;
4
5 use strict;
6 use warnings FATAL => 'all';
7 no warnings 'recursion';
8
9 use base qw( DBM::Deep::Engine );
10
11 use Scalar::Util ();
12
13 use DBM::Deep::Null ();
14 use DBM::Deep::Sector::File ();
15 use DBM::Deep::Storage::File ();
16
17 sub sector_type { 'DBM::Deep::Sector::File' }
18 sub iterator_class { 'DBM::Deep::Iterator::File' }
19
20 my $STALE_SIZE = 2;
21
22 # Setup file and tag signatures.  These should never change.
23 sub SIG_FILE     () { 'DPDB' }
24 sub SIG_HEADER   () { 'h'    }
25 sub SIG_NULL     () { 'N'    }
26 sub SIG_DATA     () { 'D'    }
27 sub SIG_INDEX    () { 'I'    }
28 sub SIG_BLIST    () { 'B'    }
29 sub SIG_FREE     () { 'F'    }
30 sub SIG_SIZE     () {  1     }
31 # SIG_HASH and SIG_ARRAY are defined in DBM::Deep::Engine
32
33 # Please refer to the pack() documentation for further information
34 my %StP = (
35     1 => 'C', # Unsigned char value (no order needed as it's just one byte)
36     2 => 'n', # Unsigned short in "network" (big-endian) order
37     4 => 'N', # Unsigned long in "network" (big-endian) order
38     8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
39 );
40
41 =head1 NAME
42
43 DBM::Deep::Engine::File
44
45 =head1 PURPOSE
46
47 This is the engine for use with L<DBM::Deep::Storage::File>.
48
49 =head1 EXTERNAL METHODS
50
51 =head2 new()
52
53 This takes a set of args. These args are described in the documentation for
54 L<DBM::Deep/new>.
55
56 =cut
57
58 sub new {
59     my $class = shift;
60     my ($args) = @_;
61
62     $args->{storage} = DBM::Deep::Storage::File->new( $args )
63         unless exists $args->{storage};
64
65     my $self = bless {
66         byte_size   => 4,
67
68         digest      => undef,
69         hash_size   => 16,  # In bytes
70         hash_chars  => 256, # Number of chars the algorithm uses per byte
71         max_buckets => 16,
72         num_txns    => 1,   # The HEAD
73         trans_id    => 0,   # Default to the HEAD
74
75         data_sector_size => 64, # Size in bytes of each data sector
76
77         entries => {}, # This is the list of entries for transactions
78         storage => undef,
79     }, $class;
80
81     # Never allow byte_size to be set directly.
82     delete $args->{byte_size};
83     if ( defined $args->{pack_size} ) {
84         if ( lc $args->{pack_size} eq 'small' ) {
85             $args->{byte_size} = 2;
86         }
87         elsif ( lc $args->{pack_size} eq 'medium' ) {
88             $args->{byte_size} = 4;
89         }
90         elsif ( lc $args->{pack_size} eq 'large' ) {
91             $args->{byte_size} = 8;
92         }
93         else {
94             DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
95         }
96     }
97
98     # Grab the parameters we want to use
99     foreach my $param ( keys %$self ) {
100         next unless exists $args->{$param};
101         $self->{$param} = $args->{$param};
102     }
103
104     my %validations = (
105         max_buckets      => { floor => 16, ceil => 256 },
106         num_txns         => { floor => 1,  ceil => 255 },
107         data_sector_size => { floor => 32, ceil => 256 },
108     );
109
110     while ( my ($attr, $c) = each %validations ) {
111         if (   !defined $self->{$attr}
112             || !length $self->{$attr}
113             || $self->{$attr} =~ /\D/
114             || $self->{$attr} < $c->{floor}
115         ) {
116             $self->{$attr} = '(undef)' if !defined $self->{$attr};
117             warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
118             $self->{$attr} = $c->{floor};
119         }
120         elsif ( $self->{$attr} > $c->{ceil} ) {
121             warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
122             $self->{$attr} = $c->{ceil};
123         }
124     }
125
126     if ( !$self->{digest} ) {
127         require Digest::MD5;
128         $self->{digest} = \&Digest::MD5::md5;
129     }
130
131     return $self;
132 }
133
134 sub read_value {
135     my $self = shift;
136     my ($obj, $key) = @_;
137
138     # This will be a Reference sector
139     my $sector = $self->load_sector( $obj->_base_offset )
140         or return;
141
142     if ( $sector->staleness != $obj->_staleness ) {
143         return;
144     }
145
146     my $key_md5 = $self->_apply_digest( $key );
147
148     my $value_sector = $sector->get_data_for({
149         key_md5    => $key_md5,
150         allow_head => 1,
151     });
152
153     unless ( $value_sector ) {
154         $value_sector = DBM::Deep::Sector::File::Null->new({
155             engine => $self,
156             data   => undef,
157         });
158
159         $sector->write_data({
160             key_md5 => $key_md5,
161             key     => $key,
162             value   => $value_sector,
163         });
164     }
165
166     return $value_sector->data;
167 }
168
169 sub get_classname {
170     my $self = shift;
171     my ($obj) = @_;
172
173     # This will be a Reference sector
174     my $sector = $self->load_sector( $obj->_base_offset )
175         or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
176
177     if ( $sector->staleness != $obj->_staleness ) {
178         return;
179     }
180
181     return $sector->get_classname;
182 }
183
184 sub make_reference {
185     my $self = shift;
186     my ($obj, $old_key, $new_key) = @_;
187
188     # This will be a Reference sector
189     my $sector = $self->load_sector( $obj->_base_offset )
190         or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
191
192     if ( $sector->staleness != $obj->_staleness ) {
193         return;
194     }
195
196     my $old_md5 = $self->_apply_digest( $old_key );
197
198     my $value_sector = $sector->get_data_for({
199         key_md5    => $old_md5,
200         allow_head => 1,
201     });
202
203     unless ( $value_sector ) {
204         $value_sector = DBM::Deep::Sector::File::Null->new({
205             engine => $self,
206             data   => undef,
207         });
208
209         $sector->write_data({
210             key_md5 => $old_md5,
211             key     => $old_key,
212             value   => $value_sector,
213         });
214     }
215
216     if ( $value_sector->isa( 'DBM::Deep::Sector::File::Reference' ) ) {
217         $sector->write_data({
218             key     => $new_key,
219             key_md5 => $self->_apply_digest( $new_key ),
220             value   => $value_sector,
221         });
222         $value_sector->increment_refcount;
223     }
224     else {
225         $sector->write_data({
226             key     => $new_key,
227             key_md5 => $self->_apply_digest( $new_key ),
228             value   => $value_sector->clone,
229         });
230     }
231
232     return;
233 }
234
235 # exists returns '', not undefined.
236 sub key_exists {
237     my $self = shift;
238     my ($obj, $key) = @_;
239
240     # This will be a Reference sector
241     my $sector = $self->load_sector( $obj->_base_offset )
242         or return '';
243
244     if ( $sector->staleness != $obj->_staleness ) {
245         return '';
246     }
247
248     my $data = $sector->get_data_for({
249         key_md5    => $self->_apply_digest( $key ),
250         allow_head => 1,
251     });
252
253     # exists() returns 1 or '' for true/false.
254     return $data ? 1 : '';
255 }
256
257 sub delete_key {
258     my $self = shift;
259     my ($obj, $key) = @_;
260
261     my $sector = $self->load_sector( $obj->_base_offset )
262         or return;
263
264     if ( $sector->staleness != $obj->_staleness ) {
265         return;
266     }
267
268     return $sector->delete_key({
269         key_md5    => $self->_apply_digest( $key ),
270         allow_head => 0,
271     });
272 }
273
274 sub write_value {
275     my $self = shift;
276     my ($obj, $key, $value) = @_;
277
278     my $r = Scalar::Util::reftype( $value ) || '';
279     {
280         last if $r eq '';
281         last if $r eq 'HASH';
282         last if $r eq 'ARRAY';
283
284         DBM::Deep->_throw_error(
285             "Storage of references of type '$r' is not supported."
286         );
287     }
288
289     # This will be a Reference sector
290     my $sector = $self->load_sector( $obj->_base_offset )
291         or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
292
293     if ( $sector->staleness != $obj->_staleness ) {
294         DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
295     }
296
297     my ($class, $type);
298     if ( !defined $value ) {
299         $class = 'DBM::Deep::Sector::File::Null';
300     }
301     elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
302         my $tmpvar;
303         if ( $r eq 'ARRAY' ) {
304             $tmpvar = tied @$value;
305         } elsif ( $r eq 'HASH' ) {
306             $tmpvar = tied %$value;
307         }
308
309         if ( $tmpvar ) {
310             my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
311
312             unless ( $is_dbm_deep ) {
313                 DBM::Deep->_throw_error( "Cannot store something that is tied." );
314             }
315
316             unless ( $tmpvar->_engine->storage == $self->storage ) {
317                 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
318             }
319
320             # First, verify if we're storing the same thing to this spot. If we
321             # are, then this should be a no-op. -EJS, 2008-05-19
322             my $loc = $sector->get_data_location_for({
323                 key_md5 => $self->_apply_digest( $key ),
324                 allow_head => 1,
325             });
326
327             if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
328                 return 1;
329             }
330
331             #XXX Can this use $loc?
332             my $value_sector = $self->load_sector( $tmpvar->_base_offset );
333             $sector->write_data({
334                 key     => $key,
335                 key_md5 => $self->_apply_digest( $key ),
336                 value   => $value_sector,
337             });
338             $value_sector->increment_refcount;
339
340             return 1;
341         }
342
343         $class = 'DBM::Deep::Sector::File::Reference';
344         $type = substr( $r, 0, 1 );
345     }
346     else {
347         if ( tied($value) ) {
348             DBM::Deep->_throw_error( "Cannot store something that is tied." );
349         }
350         $class = 'DBM::Deep::Sector::File::Scalar';
351     }
352
353     # Create this after loading the reference sector in case something bad
354     # happens. This way, we won't allocate value sector(s) needlessly.
355     my $value_sector = $class->new({
356         engine => $self,
357         data   => $value,
358         type   => $type,
359     });
360
361     $sector->write_data({
362         key     => $key,
363         key_md5 => $self->_apply_digest( $key ),
364         value   => $value_sector,
365     });
366
367     $self->_descend( $value, $value_sector );
368
369     return 1;
370 }
371
372 sub setup {
373     my $self = shift;
374     my ($obj) = @_;
375
376     # We're opening the file.
377     unless ( $obj->_base_offset ) {
378         my $bytes_read = $self->_read_file_header;
379
380         # Creating a new file
381         unless ( $bytes_read ) {
382             $self->_write_file_header;
383
384             # 1) Create Array/Hash entry
385             my $initial_reference = DBM::Deep::Sector::File::Reference->new({
386                 engine => $self,
387                 type   => $obj->_type,
388             });
389             $obj->{base_offset} = $initial_reference->offset;
390             $obj->{staleness} = $initial_reference->staleness;
391
392             $self->storage->flush;
393         }
394         # Reading from an existing file
395         else {
396             $obj->{base_offset} = $bytes_read;
397             my $initial_reference = DBM::Deep::Sector::File::Reference->new({
398                 engine => $self,
399                 offset => $obj->_base_offset,
400             });
401             unless ( $initial_reference ) {
402                 DBM::Deep->_throw_error("Corrupted file, no master index record");
403             }
404
405             unless ($obj->_type eq $initial_reference->type) {
406                 DBM::Deep->_throw_error("File type mismatch");
407             }
408
409             $obj->{staleness} = $initial_reference->staleness;
410         }
411     }
412
413     $self->storage->set_inode;
414
415     return 1;
416 }
417
418 sub begin_work {
419     my $self = shift;
420     my ($obj) = @_;
421
422     if ( $self->trans_id ) {
423         DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
424     }
425
426     my @slots = $self->read_txn_slots;
427     my $found;
428     for my $i ( 0 .. $#slots ) {
429         next if $slots[$i];
430
431         $slots[$i] = 1;
432         $self->set_trans_id( $i + 1 );
433         $found = 1;
434         last;
435     }
436     unless ( $found ) {
437         DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
438     }
439     $self->write_txn_slots( @slots );
440
441     if ( !$self->trans_id ) {
442         DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
443     }
444
445     return;
446 }
447
448 sub rollback {
449     my $self = shift;
450     my ($obj) = @_;
451
452     if ( !$self->trans_id ) {
453         DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
454     }
455
456     # Each entry is the file location for a bucket that has a modification for
457     # this transaction. The entries need to be expunged.
458     foreach my $entry (@{ $self->get_entries } ) {
459         # Remove the entry here
460         my $read_loc = $entry
461           + $self->hash_size
462           + $self->byte_size
463           + $self->byte_size
464           + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
465
466         my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
467         $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
468         $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
469
470         if ( $data_loc > 1 ) {
471             $self->load_sector( $data_loc )->free;
472         }
473     }
474
475     $self->clear_entries;
476
477     my @slots = $self->read_txn_slots;
478     $slots[$self->trans_id-1] = 0;
479     $self->write_txn_slots( @slots );
480     $self->inc_txn_staleness_counter( $self->trans_id );
481     $self->set_trans_id( 0 );
482
483     return 1;
484 }
485
486 sub commit {
487     my $self = shift;
488     my ($obj) = @_;
489
490     if ( !$self->trans_id ) {
491         DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
492     }
493
494     foreach my $entry (@{ $self->get_entries } ) {
495         # Overwrite the entry in head with the entry in trans_id
496         my $base = $entry
497           + $self->hash_size
498           + $self->byte_size;
499
500         my $head_loc = $self->storage->read_at( $base, $self->byte_size );
501         $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
502
503         my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
504         my $trans_loc = $self->storage->read_at(
505             $spot, $self->byte_size,
506         );
507
508         $self->storage->print_at( $base, $trans_loc );
509         $self->storage->print_at(
510             $spot,
511             pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
512         );
513
514         if ( $head_loc > 1 ) {
515             $self->load_sector( $head_loc )->free;
516         }
517     }
518
519     $self->clear_entries;
520
521     my @slots = $self->read_txn_slots;
522     $slots[$self->trans_id-1] = 0;
523     $self->write_txn_slots( @slots );
524     $self->inc_txn_staleness_counter( $self->trans_id );
525     $self->set_trans_id( 0 );
526
527     return 1;
528 }
529
530 =head1 INTERNAL METHODS
531
532 The following methods are internal-use-only to DBM::Deep::Engine::File.
533
534 =cut
535
536 =head2 read_txn_slots()
537
538 This takes no arguments.
539
540 This will return an array with a 1 or 0 in each slot. Each spot represents one
541 available transaction. If the slot is 1, that transaction is taken. If it is 0,
542 the transaction is available.
543
544 =cut
545
546 sub read_txn_slots {
547     my $self = shift;
548     my $bl = $self->txn_bitfield_len;
549     my $num_bits = $bl * 8;
550     return split '', unpack( 'b'.$num_bits,
551         $self->storage->read_at(
552             $self->trans_loc, $bl,
553         )
554     );
555 }
556
557 =head2 write_txn_slots( @slots )
558
559 This takes an array of 1's and 0's. This array represents the transaction slots
560 returned by L</read_txn_slots()>. In other words, the following is true:
561
562   @x = read_txn_slots( write_txn_slots( @x ) );
563
564 (With the obviously missing object referents added back in.)
565
566 =cut
567
568 sub write_txn_slots {
569     my $self = shift;
570     my $num_bits = $self->txn_bitfield_len * 8;
571     $self->storage->print_at( $self->trans_loc,
572         pack( 'b'.$num_bits, join('', @_) ),
573     );
574 }
575
576 =head2 get_running_txn_ids()
577
578 This takes no arguments.
579
580 This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
581
582 =cut
583
584 sub get_running_txn_ids {
585     my $self = shift;
586     my @transactions = $self->read_txn_slots;
587     my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
588 }
589
590 =head2 get_txn_staleness_counter( $trans_id )
591
592 This will return the staleness counter for the given transaction ID. Please see
593 L</TRANSACTION STALENESS> for more information.
594
595 =cut
596
597 sub get_txn_staleness_counter {
598     my $self = shift;
599     my ($trans_id) = @_;
600
601     # Hardcode staleness of 0 for the HEAD
602     return 0 unless $trans_id;
603
604     return unpack( $StP{$STALE_SIZE},
605         $self->storage->read_at(
606             $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
607             $STALE_SIZE,
608         )
609     );
610 }
611
612 =head2 inc_txn_staleness_counter( $trans_id )
613
614 This will increment the staleness counter for the given transaction ID. Please see
615 L</TRANSACTION STALENESS> for more information.
616
617 =cut
618
619 sub inc_txn_staleness_counter {
620     my $self = shift;
621     my ($trans_id) = @_;
622
623     # Hardcode staleness of 0 for the HEAD
624     return 0 unless $trans_id;
625
626     $self->storage->print_at(
627         $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
628         pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
629     );
630 }
631
632 =head2 get_entries()
633
634 This takes no arguments.
635
636 This returns a list of all the sectors that have been modified by this transaction.
637
638 =cut
639
640 sub get_entries {
641     my $self = shift;
642     return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
643 }
644
645 =head2 add_entry( $trans_id, $location )
646
647 This takes a transaction ID and a file location and marks the sector at that
648 location as having been modified by the transaction identified by $trans_id.
649
650 This returns nothing.
651
652 B<NOTE>: Unlike all the other _entries() methods, there are several cases where
653 C<< $trans_id != $self->trans_id >> for this method.
654
655 =cut
656
657 sub add_entry {
658     my $self = shift;
659     my ($trans_id, $loc) = @_;
660
661     $self->{entries}{$trans_id} ||= {};
662     $self->{entries}{$trans_id}{$loc} = undef;
663 }
664
665 =head2 reindex_entry( $old_loc, $new_loc )
666
667 This takes two locations (old and new, respectively). If a location that has
668 been modified by this transaction is subsequently reindexed due to a bucketlist
669 overflowing, then the entries hash needs to be made aware of this change.
670
671 This returns nothing.
672
673 =cut
674
675 sub reindex_entry {
676     my $self = shift;
677     my ($old_loc, $new_loc) = @_;
678
679     TRANS:
680     while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
681         if ( exists $locs->{$old_loc} ) {
682             delete $locs->{$old_loc};
683             $locs->{$new_loc} = undef;
684             next TRANS;
685         }
686     }
687 }
688
689 =head2 clear_entries()
690
691 This takes no arguments. It will clear the entries list for the running
692 transaction.
693
694 This returns nothing.
695
696 =cut
697
698 sub clear_entries {
699     my $self = shift;
700     delete $self->{entries}{$self->trans_id};
701 }
702
703 =head2 _write_file_header()
704
705 This writes the file header for a new file. This will write the various settings
706 that set how the file is interpreted.
707
708 =head2 _read_file_header()
709
710 This reads the file header from an existing file. This will read the various
711 settings that set how the file is interpreted.
712
713 =cut
714
715 {
716     my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
717     my $this_file_version = 3;
718
719     sub _write_file_header {
720         my $self = shift;
721
722         my $nt = $self->num_txns;
723         my $bl = $self->txn_bitfield_len;
724
725         my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
726
727         my $loc = $self->storage->request_space( $header_fixed + $header_var );
728
729         $self->storage->print_at( $loc,
730             $self->SIG_FILE,
731             $self->SIG_HEADER,
732             pack('N', $this_file_version), # At this point, we're at 9 bytes
733             pack('N', $header_var),        # header size
734             # --- Above is $header_fixed. Below is $header_var
735             pack('C', $self->byte_size),
736
737             # These shenanigans are to allow a 256 within a C
738             pack('C', $self->max_buckets - 1),
739             pack('C', $self->data_sector_size - 1),
740
741             pack('C', $nt),
742             pack('C' . $bl, 0 ),                           # Transaction activeness bitfield
743             pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
744             pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
745             pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
746             pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
747         );
748
749         #XXX Set these less fragilely
750         $self->set_trans_loc( $header_fixed + 4 );
751         $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
752
753         return;
754     }
755
756     sub _read_file_header {
757         my $self = shift;
758
759         my $buffer = $self->storage->read_at( 0, $header_fixed );
760         return unless length($buffer);
761
762         my ($file_signature, $sig_header, $file_version, $size) = unpack(
763             'A4 A N N', $buffer
764         );
765
766         unless ( $file_signature eq $self->SIG_FILE ) {
767             $self->storage->close;
768             DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
769         }
770
771         unless ( $sig_header eq $self->SIG_HEADER ) {
772             $self->storage->close;
773             DBM::Deep->_throw_error( "Pre-1.00 file version found" );
774         }
775
776         unless ( $file_version == $this_file_version ) {
777             $self->storage->close;
778             DBM::Deep->_throw_error(
779                 "Wrong file version found - " .  $file_version .
780                 " - expected " . $this_file_version
781             );
782         }
783
784         my $buffer2 = $self->storage->read_at( undef, $size );
785         my @values = unpack( 'C C C C', $buffer2 );
786
787         if ( @values != 4 || grep { !defined } @values ) {
788             $self->storage->close;
789             DBM::Deep->_throw_error("Corrupted file - bad header");
790         }
791
792         #XXX Add warnings if values weren't set right
793         @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
794
795         # These shenangians are to allow a 256 within a C
796         $self->{max_buckets} += 1;
797         $self->{data_sector_size} += 1;
798
799         my $bl = $self->txn_bitfield_len;
800
801         my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
802         unless ( $size == $header_var ) {
803             $self->storage->close;
804             DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
805         }
806
807         $self->set_trans_loc( $header_fixed + scalar(@values) );
808         $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
809
810         return length($buffer) + length($buffer2);
811     }
812 }
813
814 =head2 _apply_digest( @stuff )
815
816 This will apply the digest methd (default to Digest::MD5::md5) to the arguments
817 passed in and return the result.
818
819 =cut
820
821 sub _apply_digest {
822     my $self = shift;
823     return $self->{digest}->(@_);
824 }
825
826 =head2 _add_free_blist_sector( $offset, $size )
827
828 =head2 _add_free_data_sector( $offset, $size )
829
830 =head2 _add_free_index_sector( $offset, $size )
831
832 These methods are all wrappers around _add_free_sector(), providing the proper
833 chain offset ($multiple) for the sector type.
834
835 =cut
836
837 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
838 sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
839 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
840
841 =head2 _add_free_sector( $multiple, $offset, $size )
842
843 _add_free_sector() takes the offset into the chains location, the offset of the
844 sector, and the size of that sector. It will mark the sector as a free sector
845 and put it into the list of sectors that are free of this type for use later.
846
847 This returns nothing.
848
849 B<NOTE>: $size is unused?
850
851 =cut
852
853 sub _add_free_sector {
854     my $self = shift;
855     my ($multiple, $offset, $size) = @_;
856
857     my $chains_offset = $multiple * $self->byte_size;
858
859     my $storage = $self->storage;
860
861     # Increment staleness.
862     # XXX Can this increment+modulo be done by "&= 0x1" ?
863     my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
864     $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
865     $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
866
867     my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
868
869     $storage->print_at( $self->chains_loc + $chains_offset,
870         pack( $StP{$self->byte_size}, $offset ),
871     );
872
873     # Record the old head in the new sector after the signature and staleness counter
874     $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
875 }
876
877 =head2 _request_blist_sector( $size )
878
879 =head2 _request_data_sector( $size )
880
881 =head2 _request_index_sector( $size )
882
883 These methods are all wrappers around _request_sector(), providing the proper
884 chain offset ($multiple) for the sector type.
885
886 =cut
887
888 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
889 sub _request_data_sector { shift->_request_sector( 1, @_ ) }
890 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
891
892 =head2 _request_sector( $multiple $size )
893
894 This takes the offset into the chains location and the size of that sector.
895
896 This returns the object with the sector. If there is an available free sector of
897 that type, then it will be reused. If there isn't one, then a new one will be
898 allocated.
899
900 =cut
901
902 sub _request_sector {
903     my $self = shift;
904     my ($multiple, $size) = @_;
905
906     my $chains_offset = $multiple * $self->byte_size;
907
908     my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
909     my $loc = unpack( $StP{$self->byte_size}, $old_head );
910
911     # We don't have any free sectors of the right size, so allocate a new one.
912     unless ( $loc ) {
913         my $offset = $self->storage->request_space( $size );
914
915         # Zero out the new sector. This also guarantees correct increases
916         # in the filesize.
917         $self->storage->print_at( $offset, chr(0) x $size );
918
919         return $offset;
920     }
921
922     # Read the new head after the signature and the staleness counter
923     my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
924     $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
925     $self->storage->print_at(
926         $loc + $self->SIG_SIZE + $STALE_SIZE,
927         pack( $StP{$self->byte_size}, 0 ),
928     );
929
930     return $loc;
931 }
932
933 =head2 ACCESSORS
934
935 The following are readonly attributes.
936
937 =over 4
938
939 =item * byte_size
940
941 =item * hash_size
942
943 =item * hash_chars
944
945 =item * num_txns
946
947 =item * max_buckets
948
949 =item * blank_md5
950
951 =item * data_sector_size
952
953 =item * txn_bitfield_len
954
955 =back
956
957 =cut
958
959 sub byte_size   { $_[0]{byte_size} }
960 sub hash_size   { $_[0]{hash_size} }
961 sub hash_chars  { $_[0]{hash_chars} }
962 sub num_txns    { $_[0]{num_txns} }
963 sub max_buckets { $_[0]{max_buckets} }
964 sub blank_md5   { chr(0) x $_[0]->hash_size }
965 sub data_sector_size { $_[0]{data_sector_size} }
966
967 # This is a calculated value
968 sub txn_bitfield_len {
969     my $self = shift;
970     unless ( exists $self->{txn_bitfield_len} ) {
971         my $temp = ($self->num_txns) / 8;
972         if ( $temp > int( $temp ) ) {
973             $temp = int( $temp ) + 1;
974         }
975         $self->{txn_bitfield_len} = $temp;
976     }
977     return $self->{txn_bitfield_len};
978 }
979
980 =pod
981
982 The following are read/write attributes. 
983
984 =over 4
985
986 =item * trans_id / set_trans_id( $new_id )
987
988 =item * trans_loc / set_trans_loc( $new_loc )
989
990 =item * chains_loc / set_chains_loc( $new_loc )
991
992 =back
993
994 =cut
995
996 sub trans_id     { $_[0]{trans_id} }
997 sub set_trans_id { $_[0]{trans_id} = $_[1] }
998
999 sub trans_loc     { $_[0]{trans_loc} }
1000 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
1001
1002 sub chains_loc     { $_[0]{chains_loc} }
1003 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
1004
1005 sub supports {
1006     shift;
1007     my ($feature) = @_;
1008
1009     return 1 if $feature eq 'transactions';
1010     return if $feature eq 'singletones';
1011     return;
1012 }
1013
1014 sub clear {
1015     my $self = shift;
1016     my $obj = shift;
1017
1018     my $sector = $self->load_sector( $obj->_base_offset )
1019         or return;
1020
1021     return unless $sector->staleness == $obj->_staleness;
1022
1023     $sector->clear;
1024
1025     return;
1026 }
1027
1028 =head2 _dump_file()
1029
1030 This method takes no arguments. It's used to print out a textual representation
1031 of the DBM::Deep DB file. It assumes the file is not-corrupted.
1032
1033 =cut
1034
1035 sub _dump_file {
1036     my $self = shift;
1037
1038     # Read the header
1039     my $spot = $self->_read_file_header();
1040
1041     my %types = (
1042         0 => 'B',
1043         1 => 'D',
1044         2 => 'I',
1045     );
1046
1047     my %sizes = (
1048         'D' => $self->data_sector_size,
1049         'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
1050         'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
1051     );
1052
1053     my $return = "";
1054
1055     # Header values
1056     $return .= "NumTxns: " . $self->num_txns . $/;
1057
1058     # Read the free sector chains
1059     my %sectors;
1060     foreach my $multiple ( 0 .. 2 ) {
1061         $return .= "Chains($types{$multiple}):";
1062         my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
1063         while ( 1 ) {
1064             my $loc = unpack(
1065                 $StP{$self->byte_size},
1066                 $self->storage->read_at( $old_loc, $self->byte_size ),
1067             );
1068
1069             # We're now out of free sectors of this kind.
1070             unless ( $loc ) {
1071                 last;
1072             }
1073
1074             $sectors{ $types{$multiple} }{ $loc } = undef;
1075             $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
1076             $return .= " $loc";
1077         }
1078         $return .= $/;
1079     }
1080
1081     SECTOR:
1082     while ( $spot < $self->storage->{end} ) {
1083         # Read each sector in order.
1084         my $sector = $self->load_sector( $spot );
1085         if ( !$sector ) {
1086             # Find it in the free-sectors that were found already
1087             foreach my $type ( keys %sectors ) {
1088                 if ( exists $sectors{$type}{$spot} ) {
1089                     my $size = $sizes{$type};
1090                     $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
1091                     $spot += $size;
1092                     next SECTOR;
1093                 }
1094             }
1095
1096             die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
1097         }
1098         else {
1099             $return .= sprintf "%08d: %s  %04d", $spot, $sector->type, $sector->size;
1100             if ( $sector->type eq 'D' ) {
1101                 $return .= ' ' . $sector->data;
1102             }
1103             elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
1104                 $return .= ' REF: ' . $sector->get_refcount;
1105             }
1106             elsif ( $sector->type eq 'B' ) {
1107                 foreach my $bucket ( $sector->chopped_up ) {
1108                     $return .= "\n    ";
1109                     $return .= sprintf "%08d", unpack($StP{$self->byte_size},
1110                         substr( $bucket->[-1], $self->hash_size, $self->byte_size),
1111                     );
1112                     my $l = unpack( $StP{$self->byte_size},
1113                         substr( $bucket->[-1],
1114                             $self->hash_size + $self->byte_size,
1115                             $self->byte_size,
1116                         ),
1117                     );
1118                     $return .= sprintf " %08d", $l;
1119                     foreach my $txn ( 0 .. $self->num_txns - 2 ) {
1120                         my $l = unpack( $StP{$self->byte_size},
1121                             substr( $bucket->[-1],
1122                                 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
1123                                 $self->byte_size,
1124                             ),
1125                         );
1126                         $return .= sprintf " %08d", $l;
1127                     }
1128                 }
1129             }
1130             $return .= $/;
1131
1132             $spot += $sector->size;
1133         }
1134     }
1135
1136     return $return;
1137 }
1138
1139 1;
1140 __END__