File Coverage

blib/lib/DBM/Deep/Sector/File/BucketList.pm
Criterion Covered Total %
statement 161 164 98.1
branch 60 70 85.7
condition 10 12 83.3
subroutine 20 20 100.0
pod 0 15 0.0
total 251 281 89.3


line stmt bran cond sub pod time code
1             package DBM::Deep::Sector::File::BucketList;
2              
3 50     50   865 use 5.008_004;
  50         175  
4              
5 50     50   324 use strict;
  50         169  
  50         1538  
6 50     50   303 use warnings FATAL => 'all';
  50         154  
  50         1950  
7              
8 50     50   304 use base qw( DBM::Deep::Sector::File );
  50         139  
  50         126828  
9              
10             my $STALE_SIZE = 2;
11              
12             # Please refer to the pack() documentation for further information
13             my %StP = (
14             1 => 'C', # Unsigned char value (no order needed as it's just one byte)
15             2 => 'n', # Unsigned short in "network" (big-endian) order
16             4 => 'N', # Unsigned long in "network" (big-endian) order
17             8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
18             );
19              
20             sub _init {
21 6375     6375   10222 my $self = shift;
22              
23 6375         13064 my $engine = $self->engine;
24              
25 6375 100       14121 unless ( $self->offset ) {
26 607         1707 my $leftover = $self->size - $self->base_size;
27              
28 607         1482 $self->{offset} = $engine->_request_blist_sector( $self->size );
29 607         2022 $engine->storage->print_at( $self->offset, $engine->SIG_BLIST ); # Sector type
30             # Skip staleness counter
31 607         2163 $engine->storage->print_at( $self->offset + $self->base_size,
32             chr(0) x $leftover, # Zero-fill the data
33             );
34             }
35              
36 6375 100       15996 if ( $self->{key_md5} ) {
37 503         1414 $self->find_md5;
38             }
39              
40 6375         12485 return $self;
41             }
42              
43             sub wipe {
44 10     10 0 30 my $self = shift;
45 10         35 $self->engine->storage->print_at( $self->offset + $self->base_size,
46             chr(0) x ($self->size - $self->base_size), # Zero-fill the data
47             );
48             }
49              
50             sub size {
51 1303     1303 0 2053 my $self = shift;
52 1303 100       2782 unless ( $self->{size} ) {
53 645         1456 my $e = $self->engine;
54             # Base + numbuckets * bucketsize
55 645         1792 $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size;
56             }
57 1303         3639 return $self->{size};
58             }
59              
60 36     36 0 118 sub free_meth { '_add_free_blist_sector' }
61              
62             sub free {
63 36     36 0 101 my $self = shift;
64              
65 36         117 my $e = $self->engine;
66 36         126 foreach my $bucket ( $self->chopped_up ) {
67 65         136 my $rest = $bucket->[-1];
68              
69             # Delete the keysector
70 65         160 my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size, $e->byte_size ) );
71 65 50       208 my $s = $e->load_sector( $l ); $s->free if $s;
  65         306  
72              
73             # Delete the HEAD sector
74 65         208 $l = unpack( $StP{$e->byte_size},
75             substr( $rest,
76             $e->hash_size + $e->byte_size,
77             $e->byte_size,
78             ),
79             );
80 65 100       224 $s = $e->load_sector( $l ); $s->free if $s;
  65         355  
81              
82 65         225 foreach my $txn ( 0 .. $e->num_txns - 2 ) {
83 4         13 my $l = unpack( $StP{$e->byte_size},
84             substr( $rest,
85             $e->hash_size + 2 * $e->byte_size + $txn * ($e->byte_size + $STALE_SIZE),
86             $e->byte_size,
87             ),
88             );
89 4 100       13 my $s = $e->load_sector( $l ); $s->free if $s;
  4         26  
90             }
91             }
92              
93 36         237 $self->SUPER::free();
94             }
95              
96             sub bucket_size {
97 30765     30765 0 49195 my $self = shift;
98 30765 100       63544 unless ( $self->{bucket_size} ) {
99 6375         12469 my $e = $self->engine;
100             # Key + head (location) + transactions (location + staleness-counter)
101 6375         14519 my $location_size = $e->byte_size + $e->byte_size + ($e->num_txns - 1) * ($e->byte_size + $STALE_SIZE);
102 6375         14713 $self->{bucket_size} = $e->hash_size + $location_size;
103             }
104 30765         69484 return $self->{bucket_size};
105             }
106              
107             # XXX This is such a poor hack. I need to rethink this code.
108             sub chopped_up {
109 48     48 0 113 my $self = shift;
110              
111 48         118 my $e = $self->engine;
112              
113 48         117 my @buckets;
114 48         147 foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
115 266         687 my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size;
116 266         617 my $md5 = $e->storage->read_at( $spot, $e->hash_size );
117              
118             #XXX If we're chopping, why would we ever have the blank_md5?
119 266 100       911 last if $md5 eq $e->blank_md5;
120              
121 228         661 my $rest = $e->storage->read_at( undef, $self->bucket_size - $e->hash_size );
122 228         973 push @buckets, [ $spot, $md5 . $rest ];
123             }
124              
125 48         238 return @buckets;
126             }
127              
128             sub write_at_next_open {
129 160     160 0 279 my $self = shift;
130 160         351 my ($entry) = @_;
131              
132             #XXX This is such a hack!
133 160 100       419 $self->{_next_open} = 0 unless exists $self->{_next_open};
134              
135 160         376 my $spot = $self->offset + $self->base_size + $self->{_next_open}++ * $self->bucket_size;
136 160         356 $self->engine->storage->print_at( $spot, $entry );
137              
138 160         439 return $spot;
139             }
140              
141             sub has_md5 {
142 7218     7218 0 11807 my $self = shift;
143 7218 50       15694 unless ( exists $self->{found} ) {
144 0         0 $self->find_md5;
145             }
146 7218         24627 return $self->{found};
147             }
148              
149             sub find_md5 {
150 5923     5923 0 9261 my $self = shift;
151              
152 5923         10992 $self->{found} = undef;
153 5923         10640 $self->{idx} = -1;
154              
155 5923 100       14531 if ( @_ ) {
156 5420         10789 $self->{key_md5} = shift;
157             }
158              
159             # If we don't have an MD5, then what are we supposed to do?
160 5923 50       12143 unless ( exists $self->{key_md5} ) {
161 0         0 DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" );
162             }
163              
164 5923         12341 my $e = $self->engine;
165 5923         15310 foreach my $idx ( 0 .. $e->max_buckets - 1 ) {
166 15473         38478 my $potential = $e->storage->read_at(
167             $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size,
168             );
169              
170 15473 100       51716 if ( $potential eq $e->blank_md5 ) {
171 2466         4828 $self->{idx} = $idx;
172 2466         6056 return;
173             }
174              
175 13007 100       35331 if ( $potential eq $self->{key_md5} ) {
176 3449         5699 $self->{found} = 1;
177 3449         5540 $self->{idx} = $idx;
178 3449         9142 return;
179             }
180             }
181              
182 8         42 return;
183             }
184              
185             sub write_md5 {
186 1823     1823 0 3257 my $self = shift;
187 1823         3158 my ($args) = @_;
188              
189 1823 50       3858 DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key};
190 1823 50       3619 DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5};
191 1823 50       3790 DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value};
192              
193 1823         4293 my $engine = $self->engine;
194              
195 1823 100       5891 $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id};
196              
197 1823         3988 my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
198 1823         6195 $engine->add_entry( $args->{trans_id}, $spot );
199              
200 1823 100       4161 unless ($self->{found}) {
201             my $key_sector = DBM::Deep::Sector::File::Scalar->new({
202             engine => $engine,
203             data => $args->{key},
204 1629         6402 });
205              
206             $engine->storage->print_at( $spot,
207             $args->{key_md5},
208 1629         5090 pack( $StP{$engine->byte_size}, $key_sector->offset ),
209             );
210             }
211              
212 1823         6158 my $loc = $spot
213             + $engine->hash_size
214             + $engine->byte_size;
215              
216 1823 100       4523 if ( $args->{trans_id} ) {
217 73         160 $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $STALE_SIZE );
218              
219             $engine->storage->print_at( $loc,
220             pack( $StP{$engine->byte_size}, $args->{value}->offset ),
221 73         205 pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ),
222             );
223             }
224             else {
225             $engine->storage->print_at( $loc,
226 1750         4445 pack( $StP{$engine->byte_size}, $args->{value}->offset ),
227             );
228             }
229             }
230              
231             sub mark_deleted {
232 54     54 0 118 my $self = shift;
233 54         120 my ($args) = @_;
234 54   50     142 $args ||= {};
235              
236 54         162 my $engine = $self->engine;
237              
238 54 100       163 $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id};
239              
240 54         176 my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
241 54         224 $engine->add_entry( $args->{trans_id}, $spot );
242              
243 54         150 my $loc = $spot
244             + $engine->hash_size
245             + $engine->byte_size;
246              
247 54 100       155 if ( $args->{trans_id} ) {
248 13         46 $loc += $engine->byte_size + ($args->{trans_id} - 1) * ( $engine->byte_size + $STALE_SIZE );
249              
250             $engine->storage->print_at( $loc,
251             pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted
252 13         37 pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ),
253             );
254             }
255             else {
256             $engine->storage->print_at( $loc,
257 41         124 pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted
258             );
259             }
260             }
261              
262             sub delete_md5 {
263 50     50 0 86 my $self = shift;
264 50         116 my ($args) = @_;
265              
266 50         129 my $engine = $self->engine;
267 50 100       154 return undef unless $self->{found};
268              
269             # Save the location so that we can free the data
270 48         168 my $location = $self->get_data_location_for({
271             allow_head => 0,
272             });
273 48         192 my $key_sector = $self->get_key_for;
274              
275 48         149 my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size;
276             $engine->storage->print_at( $spot,
277             $engine->storage->read_at(
278             $spot + $self->bucket_size,
279 48         165 $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ),
280             ),
281             chr(0) x $self->bucket_size,
282             );
283              
284 48         259 $key_sector->free;
285              
286 48         156 my $data_sector = $self->engine->load_sector( $location );
287 48         244 my $data = $data_sector->data({ export => 1 });
288 48         236 $data_sector->free;
289              
290 48         268 return $data;
291             }
292              
293             sub get_data_location_for {
294 11492     11492 0 18309 my $self = shift;
295 11492         20407 my ($args) = @_;
296 11492   50     23036 $args ||= {};
297              
298 11492 50       22700 $args->{allow_head} = 0 unless exists $args->{allow_head};
299 11492 100       33748 $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id};
300 11492 100       25257 $args->{idx} = $self->{idx} unless exists $args->{idx};
301              
302 11492         23508 my $e = $self->engine;
303              
304             my $spot = $self->offset + $self->base_size
305 11492         23328 + $args->{idx} * $self->bucket_size
306             + $e->hash_size
307             + $e->byte_size;
308              
309 11492 100       25536 if ( $args->{trans_id} ) {
310 1103         2206 $spot += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $STALE_SIZE );
311             }
312              
313 11492         31029 my $buffer = $e->storage->read_at(
314             $spot,
315             $e->byte_size + $STALE_SIZE,
316             );
317 11492         41444 my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, $buffer );
318              
319             # XXX Merge the two if-clauses below
320 11492 100       31852 if ( $args->{trans_id} ) {
321             # We have found an entry that is old, so get rid of it
322 1103 100       2876 if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) {
323             $e->storage->print_at(
324             $spot,
325 283         880 pack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
326             );
327 283         655 $loc = 0;
328             }
329             }
330              
331             # If we're in a transaction and we never wrote to this location, try the
332             # HEAD instead.
333 11492 100 100     28882 if ( $args->{trans_id} && !$loc && $args->{allow_head} ) {
      100        
334             return $self->get_data_location_for({
335             trans_id => 0,
336             allow_head => 1,
337             idx => $args->{idx},
338 908         3921 });
339             }
340              
341 10584 100       47725 return $loc <= 1 ? 0 : $loc;
342             }
343              
344             sub get_data_for {
345 174     174 0 447 my $self = shift;
346 174         338 my ($args) = @_;
347 174   100     429 $args ||= {};
348              
349 174 50       455 return unless $self->{found};
350             my $location = $self->get_data_location_for({
351             allow_head => $args->{allow_head},
352 174         497 });
353 174         666 return $self->engine->load_sector( $location );
354             }
355              
356             sub get_key_for {
357 432     432 0 816 my $self = shift;
358 432         787 my ($idx) = @_;
359 432 100       982 $idx = $self->{idx} unless defined $idx;
360              
361 432 50       1144 if ( $idx >= $self->engine->max_buckets ) {
362 0         0 DBM::Deep->_throw_error( "get_key_for(): Attempting to retrieve $idx" );
363             }
364              
365 432         1086 my $location = $self->engine->storage->read_at(
366             $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size,
367             $self->engine->byte_size,
368             );
369 432         1550 $location = unpack( $StP{$self->engine->byte_size}, $location );
370 432 50       1214 DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location;
371              
372 432         1042 return $self->engine->load_sector( $location );
373             }
374              
375             1;
376             __END__