7edcd0553a99323bf46ced29c2fa3e84eec70f04
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Engine.pm
1 package DBM::Deep::Engine;
2
3 use 5.006_000;
4
5 use strict;
6 use warnings FATAL => 'all';
7
8 # Never import symbols into our namespace. We are a class, not a library.
9 # -RobK, 2008-05-27
10 use Scalar::Util ();
11
12 #use Data::Dumper ();
13
14 # File-wide notes:
15 # * Every method in here assumes that the storage has been appropriately
16 #   safeguarded. This can be anything from flock() to some sort of manual
17 #   mutex. But, it's the caller's responsability to make sure that this has
18 #   been done.
19
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'    }
30 sub SIG_SIZE     () {  1     }
31
32 our $STALE_SIZE = 2;
33
34 # Please refer to the pack() documentation for further information
35 my %StP = (
36     1 => 'C', # Unsigned char value (no order needed as it's just one byte)
37     2 => 'n', # Unsigned short in "network" (big-endian) order
38     4 => 'N', # Unsigned long in "network" (big-endian) order
39     8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
40 );
41 sub StP { $StP{$_[1]} }
42
43 # Import these after the SIG_* definitions because those definitions are used
44 # in the headers of these classes. -RobK, 2008-06-20
45 use DBM::Deep::Engine::Sector::BucketList;
46 use DBM::Deep::Engine::Sector::FileHeader;
47 use DBM::Deep::Engine::Sector::Index;
48 use DBM::Deep::Engine::Sector::Null;
49 use DBM::Deep::Engine::Sector::Reference;
50 use DBM::Deep::Engine::Sector::Scalar;
51 use DBM::Deep::Iterator;
52
53 ################################################################################
54
55 sub new {
56     my $class = shift;
57     my ($args) = @_;
58
59     $args->{storage} = DBM::Deep::File->new( $args )
60         unless exists $args->{storage};
61
62     my $self = bless {
63         byte_size   => 4,
64
65         digest      => undef,
66         hash_size   => 16,  # In bytes
67         hash_chars  => 256, # Number of chars the algorithm uses per byte
68         max_buckets => 16,
69         num_txns    => 1,   # The HEAD
70         trans_id    => 0,   # Default to the HEAD
71
72         data_sector_size => 64, # Size in bytes of each data sector
73
74         entries => {}, # This is the list of entries for transactions
75         storage => undef,
76     }, $class;
77
78     # Never allow byte_size to be set directly.
79     delete $args->{byte_size};
80     if ( defined $args->{pack_size} ) {
81         if ( lc $args->{pack_size} eq 'small' ) {
82             $args->{byte_size} = 2;
83         }
84         elsif ( lc $args->{pack_size} eq 'medium' ) {
85             $args->{byte_size} = 4;
86         }
87         elsif ( lc $args->{pack_size} eq 'large' ) {
88             $args->{byte_size} = 8;
89         }
90         else {
91             DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
92         }
93     }
94
95     # Grab the parameters we want to use
96     foreach my $param ( keys %$self ) {
97         next unless exists $args->{$param};
98         $self->{$param} = $args->{$param};
99     }
100
101     my %validations = (
102         max_buckets      => { floor => 16, ceil => 256 },
103         num_txns         => { floor => 1,  ceil => 255 },
104         data_sector_size => { floor => 32, ceil => 256 },
105     );
106
107     while ( my ($attr, $c) = each %validations ) {
108         if (   !defined $self->{$attr}
109             || !length $self->{$attr}
110             || $self->{$attr} =~ /\D/
111             || $self->{$attr} < $c->{floor}
112         ) {
113             $self->{$attr} = '(undef)' if !defined $self->{$attr};
114             warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
115             $self->{$attr} = $c->{floor};
116         }
117         elsif ( $self->{$attr} > $c->{ceil} ) {
118             warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
119             $self->{$attr} = $c->{ceil};
120         }
121     }
122
123     if ( !$self->{digest} ) {
124         require Digest::MD5;
125         $self->{digest} = \&Digest::MD5::md5;
126     }
127
128     return $self;
129 }
130
131 ################################################################################
132
133 sub read_value {
134     my $self = shift;
135     my ($obj, $key) = @_;
136
137     # This will be a Reference sector
138     my $sector = $self->_load_sector( $obj->_base_offset )
139         or return;
140
141     if ( $sector->staleness != $obj->_staleness ) {
142         return;
143     }
144
145     my $key_md5 = $self->_apply_digest( $key );
146
147     my $value_sector = $sector->get_data_for({
148         key_md5    => $key_md5,
149         allow_head => 1,
150     });
151
152     unless ( $value_sector ) {
153         $value_sector = DBM::Deep::Engine::Sector::Null->new({
154             engine => $self,
155             data   => undef,
156         });
157
158         $sector->write_data({
159             key_md5 => $key_md5,
160             key     => $key,
161             value   => $value_sector,
162         });
163     }
164
165     return $value_sector->data;
166 }
167
168 sub get_classname {
169     my $self = shift;
170     my ($obj) = @_;
171
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')?!" );
175
176     if ( $sector->staleness != $obj->_staleness ) {
177         return;
178     }
179
180     return $sector->get_classname;
181 }
182
183 sub make_reference {
184     my $self = shift;
185     my ($obj, $old_key, $new_key) = @_;
186
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')?!" );
190
191     if ( $sector->staleness != $obj->_staleness ) {
192         return;
193     }
194
195     my $old_md5 = $self->_apply_digest( $old_key );
196
197     my $value_sector = $sector->get_data_for({
198         key_md5    => $old_md5,
199         allow_head => 1,
200     });
201
202     unless ( $value_sector ) {
203         $value_sector = DBM::Deep::Engine::Sector::Null->new({
204             engine => $self,
205             data   => undef,
206         });
207
208         $sector->write_data({
209             key_md5 => $old_md5,
210             key     => $old_key,
211             value   => $value_sector,
212         });
213     }
214
215     if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
216         $sector->write_data({
217             key     => $new_key,
218             key_md5 => $self->_apply_digest( $new_key ),
219             value   => $value_sector,
220         });
221         $value_sector->increment_refcount;
222     }
223     else {
224         $sector->write_data({
225             key     => $new_key,
226             key_md5 => $self->_apply_digest( $new_key ),
227             value   => $value_sector->clone,
228         });
229     }
230 }
231
232 sub key_exists {
233     my $self = shift;
234     my ($obj, $key) = @_;
235
236     # This will be a Reference sector
237     my $sector = $self->_load_sector( $obj->_base_offset )
238         or return '';
239
240     if ( $sector->staleness != $obj->_staleness ) {
241         return '';
242     }
243
244     my $data = $sector->get_data_for({
245         key_md5    => $self->_apply_digest( $key ),
246         allow_head => 1,
247     });
248
249     # exists() returns 1 or '' for true/false.
250     return $data ? 1 : '';
251 }
252
253 sub delete_key {
254     my $self = shift;
255     my ($obj, $key) = @_;
256
257     my $sector = $self->_load_sector( $obj->_base_offset )
258         or return;
259
260     if ( $sector->staleness != $obj->_staleness ) {
261         return;
262     }
263
264     return $sector->delete_key({
265         key_md5    => $self->_apply_digest( $key ),
266         allow_head => 0,
267     });
268 }
269
270 sub write_value {
271     my $self = shift;
272     my ($obj, $key, $value) = @_;
273
274     my $r = Scalar::Util::reftype( $value ) || '';
275     {
276         last if $r eq '';
277         last if $r eq 'HASH';
278         last if $r eq 'ARRAY';
279
280         DBM::Deep->_throw_error(
281             "Storage of references of type '$r' is not supported."
282         );
283     }
284
285     # This will be a Reference sector
286     my $sector = $self->_load_sector( $obj->_base_offset )
287         or DBM::Deep->_throw_error( "1: Cannot write to a deleted spot in DBM::Deep." );
288
289     if ( $sector->staleness != $obj->_staleness ) {
290         DBM::Deep->_throw_error( "2: Cannot write to a deleted spot in DBM::Deep." );
291     }
292
293     my ($class, $type);
294     if ( !defined $value ) {
295         $class = 'DBM::Deep::Engine::Sector::Null';
296     }
297     elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
298         my $tmpvar;
299         if ( $r eq 'ARRAY' ) {
300             $tmpvar = tied @$value;
301         } elsif ( $r eq 'HASH' ) {
302             $tmpvar = tied %$value;
303         }
304
305         if ( $tmpvar ) {
306             my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
307
308             unless ( $is_dbm_deep ) {
309                 DBM::Deep->_throw_error( "Cannot store something that is tied." );
310             }
311
312             unless ( $tmpvar->_engine->storage == $self->storage ) {
313                 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
314             }
315
316             # First, verify if we're storing the same thing to this spot. If we are, then
317             # this should be a no-op. -EJS, 2008-05-19
318             my $loc = $sector->get_data_location_for({
319                 key_md5 => $self->_apply_digest( $key ),
320                 allow_head => 1,
321             });
322
323             if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
324                 return 1;
325             }
326
327             #XXX Can this use $loc?
328             my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
329             $sector->write_data({
330                 key     => $key,
331                 key_md5 => $self->_apply_digest( $key ),
332                 value   => $value_sector,
333             });
334             $value_sector->increment_refcount;
335
336             return 1;
337         }
338
339         $class = 'DBM::Deep::Engine::Sector::Reference';
340         $type = substr( $r, 0, 1 );
341     }
342     else {
343         if ( tied($value) ) {
344             DBM::Deep->_throw_error( "Cannot store something that is tied." );
345         }
346         $class = 'DBM::Deep::Engine::Sector::Scalar';
347     }
348
349     # Create this after loading the reference sector in case something bad happens.
350     # This way, we won't allocate value sector(s) needlessly.
351     my $value_sector = $class->new({
352         engine => $self,
353         data   => $value,
354         type   => $type,
355     });
356
357     $sector->write_data({
358         key     => $key,
359         key_md5 => $self->_apply_digest( $key ),
360         value   => $value_sector,
361     });
362
363     # This code is to make sure we write all the values in the $value to the disk
364     # and to make sure all changes to $value after the assignment are reflected
365     # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
366     #   NOTE - simply tying $value won't perform a STORE on each value. Hence, the
367     # copy to a temp value.
368     if ( $r eq 'ARRAY' ) {
369         my @temp = @$value;
370         tie @$value, 'DBM::Deep', {
371             base_offset => $value_sector->offset,
372             staleness   => $value_sector->staleness,
373             storage     => $self->storage,
374             engine      => $self,
375         };
376         @$value = @temp;
377         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
378     }
379     elsif ( $r eq 'HASH' ) {
380         my %temp = %$value;
381         tie %$value, 'DBM::Deep', {
382             base_offset => $value_sector->offset,
383             staleness   => $value_sector->staleness,
384             storage     => $self->storage,
385             engine      => $self,
386         };
387
388         %$value = %temp;
389         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
390     }
391
392     return 1;
393 }
394
395 # XXX Add staleness here
396 sub get_next_key {
397     my $self = shift;
398     my ($obj, $prev_key) = @_;
399
400     # XXX Need to add logic about resetting the iterator if any key in the reference has changed
401     unless ( $prev_key ) {
402         $obj->{iterator} = DBM::Deep::Iterator->new({
403             base_offset => $obj->_base_offset,
404             engine      => $self,
405         });
406     }
407
408     return $obj->{iterator}->get_next_key( $obj );
409 }
410
411 ################################################################################
412
413 sub setup_fh {
414     my $self = shift;
415     my ($obj) = @_;
416
417     return 1 if $obj->_base_offset;
418
419     my $header = $self->_load_header;
420
421     # Creating a new file
422     if ( $header->is_new ) {
423         # 1) Create Array/Hash entry
424         my $sector = DBM::Deep::Engine::Sector::Reference->new({
425             engine => $self,
426             type   => $obj->_type,
427         });
428         $obj->{base_offset} = $sector->offset;
429         $obj->{staleness} = $sector->staleness;
430
431         $self->flush;
432     }
433     # Reading from an existing file
434     else {
435         $obj->{base_offset} = $header->size;
436         my $sector = DBM::Deep::Engine::Sector::Reference->new({
437             engine => $self,
438             offset => $obj->_base_offset,
439         });
440         unless ( $sector ) {
441             DBM::Deep->_throw_error("Corrupted file, no master index record");
442         }
443
444         unless ($obj->_type eq $sector->type) {
445             DBM::Deep->_throw_error("File type mismatch");
446         }
447
448         $obj->{staleness} = $sector->staleness;
449     }
450
451     $self->storage->set_inode;
452
453     return 1;
454 }
455
456 sub begin_work {
457     my $self = shift;
458     my ($obj) = @_;
459
460     if ( $self->trans_id ) {
461         DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
462     }
463
464     my @slots = $self->read_txn_slots;
465     my $found;
466     for my $i ( 0 .. $#slots ) {
467         next if $slots[$i];
468
469         $slots[$i] = 1;
470         $self->set_trans_id( $i + 1 );
471         $found = 1;
472         last;
473     }
474     unless ( $found ) {
475         DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
476     }
477     $self->write_txn_slots( @slots );
478
479     if ( !$self->trans_id ) {
480         DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
481     }
482
483     return;
484 }
485
486 sub rollback {
487     my $self = shift;
488     my ($obj) = @_;
489
490     if ( !$self->trans_id ) {
491         DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
492     }
493
494     # Each entry is the file location for a bucket that has a modification for
495     # this transaction. The entries need to be expunged.
496     foreach my $entry (@{ $self->get_entries } ) {
497         # Remove the entry here
498         my $read_loc = $entry
499           + $self->hash_size
500           + $self->byte_size
501           + $self->byte_size
502           + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
503
504         my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
505         $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
506         $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
507
508         if ( $data_loc > 1 ) {
509             $self->_load_sector( $data_loc )->free;
510         }
511     }
512
513     $self->clear_entries;
514
515     my @slots = $self->read_txn_slots;
516     $slots[$self->trans_id-1] = 0;
517     $self->write_txn_slots( @slots );
518     $self->inc_txn_staleness_counter( $self->trans_id );
519     $self->set_trans_id( 0 );
520
521     return 1;
522 }
523
524 sub commit {
525     my $self = shift;
526     my ($obj) = @_;
527
528     if ( !$self->trans_id ) {
529         DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
530     }
531
532     foreach my $entry (@{ $self->get_entries } ) {
533         # Overwrite the entry in head with the entry in trans_id
534         my $base = $entry
535           + $self->hash_size
536           + $self->byte_size;
537
538         my $head_loc = $self->storage->read_at( $base, $self->byte_size );
539         $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
540
541         my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
542         my $trans_loc = $self->storage->read_at(
543             $spot, $self->byte_size,
544         );
545
546         $self->storage->print_at( $base, $trans_loc );
547         $self->storage->print_at(
548             $spot,
549             pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
550         );
551
552         if ( $head_loc > 1 ) {
553             $self->_load_sector( $head_loc )->free;
554         }
555     }
556
557     $self->clear_entries;
558
559     my @slots = $self->read_txn_slots;
560     $slots[$self->trans_id-1] = 0;
561     $self->write_txn_slots( @slots );
562     $self->inc_txn_staleness_counter( $self->trans_id );
563     $self->set_trans_id( 0 );
564
565     return 1;
566 }
567
568 sub read_txn_slots {
569     my $self = shift;
570     return $self->_load_header->read_txn_slots;
571 }
572
573 sub write_txn_slots {
574     my $self = shift;
575     my $num_bits = $self->txn_bitfield_len * 8;
576     $self->storage->print_at( $self->trans_loc,
577         pack( 'b'.$num_bits, join('', @_) ),
578     );
579 }
580
581 sub get_running_txn_ids {
582     my $self = shift;
583     my @transactions = $self->read_txn_slots;
584     my @trans_ids = map { $_+1} grep { $transactions[$_] } 0 .. $#transactions;
585 }
586
587 sub get_txn_staleness_counter {
588     my $self = shift;
589     my ($trans_id) = @_;
590
591     # Hardcode staleness of 0 for the HEAD
592     return 0 unless $trans_id;
593
594     return unpack( $StP{$STALE_SIZE},
595         $self->storage->read_at(
596             $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
597             $STALE_SIZE,
598         )
599     );
600 }
601
602 sub inc_txn_staleness_counter {
603     my $self = shift;
604     my ($trans_id) = @_;
605
606     # Hardcode staleness of 0 for the HEAD
607     return 0 unless $trans_id;
608
609     $self->storage->print_at(
610         $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
611         pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
612     );
613 }
614
615 sub get_entries {
616     my $self = shift;
617     return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
618 }
619
620 sub add_entry {
621     my $self = shift;
622     my ($trans_id, $loc) = @_;
623
624     $self->{entries}{$trans_id} ||= {};
625     $self->{entries}{$trans_id}{$loc} = undef;
626 }
627
628 # If the buckets are being relocated because of a reindexing, the entries
629 # mechanism needs to be made aware of it.
630 sub reindex_entry {
631     my $self = shift;
632     my ($old_loc, $new_loc) = @_;
633
634     TRANS:
635     while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
636         if ( exists $locs->{$old_loc} ) {
637             delete $locs->{$old_loc};
638             $locs->{$new_loc} = undef;
639             next TRANS;
640         }
641     }
642 }
643
644 sub clear_entries {
645     my $self = shift;
646     delete $self->{entries}{$self->trans_id};
647 }
648
649 ################################################################################
650
651 sub _apply_digest {
652     my $self = shift;
653     return $self->{digest}->(@_);
654 }
655
656 sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
657 sub _add_free_data_sector  { shift->_add_free_sector( 1, @_ ) }
658 sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
659 sub _add_free_sector       { shift->_load_header->add_free_sector( @_ ) }
660
661 sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
662 sub _request_data_sector  { shift->_request_sector( 1, @_ ) }
663 sub _request_index_sector { shift->_request_sector( 2, @_ ) }
664 sub _request_sector       { shift->_load_header->request_sector( @_ ) }
665
666 ################################################################################
667
668 {
669     my %t = (
670         SIG_ARRAY => 'Reference',
671         SIG_HASH  => 'Reference',
672         SIG_BLIST => 'BucketList',
673         SIG_INDEX => 'Index',
674         SIG_NULL  => 'Null',
675         SIG_DATA  => 'Scalar',
676     );
677
678     my %class_for;
679     while ( my ($k,$v) = each %t ) {
680         $class_for{ DBM::Deep::Engine->$k } = "DBM::Deep::Engine::Sector::$v";
681     }
682
683     sub load_sector {
684         my $self = shift;
685         my ($offset) = @_;
686
687         my $data = $self->get_data( $offset )
688             or return;#die "Cannot read from '$offset'\n";
689         my $type = substr( $$data, 0, 1 );
690         my $class = $class_for{ $type };
691         return $class->new({
692             engine => $self,
693             type   => $type,
694             offset => $offset,
695         });
696     }
697     *_load_sector = \&load_sector;
698
699     sub load_header {
700         my $self = shift;
701
702         #XXX Does this mean we make too many objects? -RobK, 2008-06-23
703         return DBM::Deep::Engine::Sector::FileHeader->new({
704             engine => $self,
705             offset => 0,
706         });
707     }
708     *_load_header = \&load_header;
709
710     sub get_data {
711         my $self = shift;
712         my ($offset, $size) = @_;
713         return unless defined $offset;
714
715         unless ( exists $self->sector_cache->{$offset} ) {
716             # Don't worry about the header sector. It will manage itself.
717             return unless $offset;
718
719             if ( !defined $size ) {
720                 my $type = $self->storage->read_at( $offset, 1 )
721                     or die "($offset): Cannot read from '$offset' to find the type\n";
722
723                 if ( $type eq $self->SIG_FREE ) {
724                     return;
725                 }
726
727                 my $class = $class_for{$type}
728                     or die "($offset): Cannot find class for '$type'\n";
729                 $size = $class->size( $self )
730                     or die "($offset): '$class' doesn't return a size\n";
731                 $self->sector_cache->{$offset} = $type . $self->storage->read_at( undef, $size - 1 );
732             }
733             else {
734                 $self->sector_cache->{$offset} = $self->storage->read_at( $offset, $size )
735                     or return;
736             }
737         }
738
739         return \$self->sector_cache->{$offset};
740     }
741 }
742
743 sub sector_cache {
744     my $self = shift;
745     return $self->{sector_cache} ||= {};
746 }
747
748 sub clear_sector_cache {
749     my $self = shift;
750     $self->{sector_cache} = {};
751 }
752
753 sub dirty_sectors {
754     my $self = shift;
755     return $self->{dirty_sectors} ||= {};
756 }
757
758 sub clear_dirty_sectors {
759     my $self = shift;
760     $self->{dirty_sectors} = {};
761 }
762
763 sub add_dirty_sector {
764     my $self = shift;
765     my ($offset) = @_;
766
767     $self->dirty_sectors->{ $offset } = undef;
768 }
769
770 sub flush {
771     my $self = shift;
772
773     my $sectors = $self->dirty_sectors;
774     for my $offset (sort { $a <=> $b } keys %{ $sectors }) {
775         $self->storage->print_at( $offset, $self->sector_cache->{$offset} );
776     }
777
778     $self->clear_dirty_sectors;
779
780     $self->clear_sector_cache;
781 }
782
783 ################################################################################
784
785 sub lock_exclusive {
786     my $self = shift;
787     my ($obj) = @_;
788     return $self->storage->lock_exclusive( $obj );
789 }
790
791 sub lock_shared {
792     my $self = shift;
793     my ($obj) = @_;
794     return $self->storage->lock_shared( $obj );
795 }
796
797 sub unlock {
798     my $self = shift;
799     my ($obj) = @_;
800
801     my $rv = $self->storage->unlock( $obj );
802
803     $self->flush if $rv;
804
805     return $rv;
806 }
807
808 ################################################################################
809
810 sub storage     { $_[0]{storage} }
811 sub byte_size   { $_[0]{byte_size} }
812 sub hash_size   { $_[0]{hash_size} }
813 sub hash_chars  { $_[0]{hash_chars} }
814 sub num_txns    { $_[0]{num_txns} }
815 sub max_buckets { $_[0]{max_buckets} }
816 sub blank_md5   { chr(0) x $_[0]->hash_size }
817 sub data_sector_size { $_[0]{data_sector_size} }
818
819 # This is a calculated value
820 sub txn_bitfield_len {
821     my $self = shift;
822     unless ( exists $self->{txn_bitfield_len} ) {
823         my $temp = ($self->num_txns) / 8;
824         if ( $temp > int( $temp ) ) {
825             $temp = int( $temp ) + 1;
826         }
827         $self->{txn_bitfield_len} = $temp;
828     }
829     return $self->{txn_bitfield_len};
830 }
831
832 sub trans_id     { $_[0]{trans_id} }
833 sub set_trans_id { $_[0]{trans_id} = $_[1] }
834
835 sub trans_loc     { $_[0]{trans_loc} }
836 sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
837
838 sub chains_loc     { $_[0]{chains_loc} }
839 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
840
841 sub cache       { $_[0]{cache} ||= {} }
842 sub clear_cache { %{$_[0]->cache} = () }
843
844 sub _dump_file {
845     my $self = shift;
846     $self->flush;
847
848     # Read the header
849     my $header_sector = DBM::Deep::Engine::Sector::FileHeader->new({
850         engine => $self,
851     });
852
853     my %types = (
854         0 => 'B',
855         1 => 'D',
856         2 => 'I',
857     );
858
859     my %sizes = (
860         'D' => $self->data_sector_size,
861         'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
862         'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
863     );
864
865     my $return = "";
866
867     # Filesize
868     $return .= "Size: " . (-s $self->storage->{fh}) . $/;
869
870     # Header values
871     $return .= "NumTxns: " . $self->num_txns . $/;
872
873     # Read the free sector chains
874     my %sectors;
875     foreach my $multiple ( 0 .. 2 ) {
876         $return .= "Chains($types{$multiple}):";
877         my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
878         while ( 1 ) {
879             my $loc = unpack(
880                 $StP{$self->byte_size},
881                 $self->storage->read_at( $old_loc, $self->byte_size ),
882             );
883
884             # We're now out of free sectors of this kind.
885             unless ( $loc ) {
886                 last;
887             }
888
889             $sectors{ $types{$multiple} }{ $loc } = undef;
890             $old_loc = $loc + SIG_SIZE + $STALE_SIZE;
891             $return .= " $loc";
892         }
893         $return .= $/;
894     }
895
896     my $spot = $header_sector->size;
897     SECTOR:
898     while ( $spot < $self->storage->{end} ) {
899         # Read each sector in order.
900         my $sector = $self->_load_sector( $spot );
901         if ( !$sector ) {
902             # Find it in the free-sectors that were found already
903             foreach my $type ( keys %sectors ) {
904                 if ( exists $sectors{$type}{$spot} ) {
905                     my $size = $sizes{$type};
906                     $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
907                     $spot += $size;
908                     next SECTOR;
909                 }
910             }
911
912             die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
913         }
914         else {
915             $return .= sprintf "%08d: %s  %04d", $spot, $sector->type, $sector->size;
916             if ( $sector->type eq 'D' ) {
917                 $return .= ' ' . $sector->data;
918             }
919             elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
920                 $return .= ' REF: ' . $sector->get_refcount;
921             }
922             elsif ( $sector->type eq 'B' ) {
923                 foreach my $bucket ( $sector->chopped_up ) {
924                     $return .= "\n    ";
925                     $return .= sprintf "%08d", unpack($StP{$self->byte_size},
926                         substr( $bucket->[-1], $self->hash_size, $self->byte_size),
927                     );
928                     my $l = unpack( $StP{$self->byte_size},
929                         substr( $bucket->[-1],
930                             $self->hash_size + $self->byte_size,
931                             $self->byte_size,
932                         ),
933                     );
934                     $return .= sprintf " %08d", $l;
935                     foreach my $txn ( 0 .. $self->num_txns - 2 ) {
936                         my $l = unpack( $StP{$self->byte_size},
937                             substr( $bucket->[-1],
938                                 $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
939                                 $self->byte_size,
940                             ),
941                         );
942                         $return .= sprintf " %08d", $l;
943                     }
944                 }
945             }
946             $return .= $/;
947
948             $spot += $sector->size;
949         }
950     }
951
952     return $return;
953 }
954
955 1;
956 __END__