Commit | Line | Data |
f0276afb |
1 | package DBM::Deep::Engine::Sector::BucketList; |
2 | |
3 | use 5.006_000; |
4 | |
5 | use strict; |
6 | use warnings FATAL => 'all'; |
7 | |
8 | use base qw( DBM::Deep::Engine::Sector ); |
9 | |
5ae752e2 |
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 | |
f0276afb |
20 | sub _init { |
21 | my $self = shift; |
22 | |
23 | my $engine = $self->engine; |
24 | |
25 | unless ( $self->offset ) { |
26 | my $leftover = $self->size - $self->base_size; |
27 | |
28 | $self->{offset} = $engine->_request_blist_sector( $self->size ); |
29 | $engine->storage->print_at( $self->offset, $engine->SIG_BLIST ); # Sector type |
30 | # Skip staleness counter |
31 | $engine->storage->print_at( $self->offset + $self->base_size, |
32 | chr(0) x $leftover, # Zero-fill the data |
33 | ); |
34 | } |
35 | |
36 | if ( $self->{key_md5} ) { |
37 | $self->find_md5; |
38 | } |
39 | |
40 | return $self; |
41 | } |
42 | |
43 | sub clear { |
44 | my $self = shift; |
45 | $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 | my $self = shift; |
52 | unless ( $self->{size} ) { |
53 | my $e = $self->engine; |
54 | # Base + numbuckets * bucketsize |
55 | $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; |
56 | } |
57 | return $self->{size}; |
58 | } |
59 | |
60 | sub free_meth { return '_add_free_blist_sector' } |
61 | |
62 | sub free { |
63 | my $self = shift; |
64 | |
65 | my $e = $self->engine; |
66 | foreach my $bucket ( $self->chopped_up ) { |
67 | my $rest = $bucket->[-1]; |
68 | |
69 | # Delete the keysector |
70 | my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size, $e->byte_size ) ); |
71 | my $s = $e->_load_sector( $l ); $s->free if $s; |
72 | |
73 | # Delete the HEAD sector |
74 | $l = unpack( $StP{$e->byte_size}, |
75 | substr( $rest, |
76 | $e->hash_size + $e->byte_size, |
77 | $e->byte_size, |
78 | ), |
79 | ); |
80 | $s = $e->_load_sector( $l ); $s->free if $s; |
81 | |
82 | foreach my $txn ( 0 .. $e->num_txns - 2 ) { |
83 | 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 | my $s = $e->_load_sector( $l ); $s->free if $s; |
90 | } |
91 | } |
92 | |
93 | $self->SUPER::free(); |
94 | } |
95 | |
96 | sub bucket_size { |
97 | my $self = shift; |
98 | unless ( $self->{bucket_size} ) { |
99 | my $e = $self->engine; |
100 | # Key + head (location) + transactions (location + staleness-counter) |
101 | my $location_size = $e->byte_size + $e->byte_size + ($e->num_txns - 1) * ($e->byte_size + $STALE_SIZE); |
102 | $self->{bucket_size} = $e->hash_size + $location_size; |
103 | } |
104 | 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 | my $self = shift; |
110 | |
111 | my $e = $self->engine; |
112 | |
113 | my @buckets; |
114 | foreach my $idx ( 0 .. $e->max_buckets - 1 ) { |
115 | my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size; |
116 | 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 | last if $md5 eq $e->blank_md5; |
120 | |
121 | my $rest = $e->storage->read_at( undef, $self->bucket_size - $e->hash_size ); |
122 | push @buckets, [ $spot, $md5 . $rest ]; |
123 | } |
124 | |
125 | return @buckets; |
126 | } |
127 | |
128 | sub write_at_next_open { |
129 | my $self = shift; |
130 | my ($entry) = @_; |
131 | |
132 | #XXX This is such a hack! |
133 | $self->{_next_open} = 0 unless exists $self->{_next_open}; |
134 | |
135 | my $spot = $self->offset + $self->base_size + $self->{_next_open}++ * $self->bucket_size; |
136 | $self->engine->storage->print_at( $spot, $entry ); |
137 | |
138 | return $spot; |
139 | } |
140 | |
141 | sub has_md5 { |
142 | my $self = shift; |
143 | unless ( exists $self->{found} ) { |
144 | $self->find_md5; |
145 | } |
146 | return $self->{found}; |
147 | } |
148 | |
149 | sub find_md5 { |
150 | my $self = shift; |
151 | |
152 | $self->{found} = undef; |
153 | $self->{idx} = -1; |
154 | |
155 | if ( @_ ) { |
156 | $self->{key_md5} = shift; |
157 | } |
158 | |
159 | # If we don't have an MD5, then what are we supposed to do? |
160 | unless ( exists $self->{key_md5} ) { |
161 | DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" ); |
162 | } |
163 | |
164 | my $e = $self->engine; |
165 | foreach my $idx ( 0 .. $e->max_buckets - 1 ) { |
166 | my $potential = $e->storage->read_at( |
167 | $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size, |
168 | ); |
169 | |
170 | if ( $potential eq $e->blank_md5 ) { |
171 | $self->{idx} = $idx; |
172 | return; |
173 | } |
174 | |
175 | if ( $potential eq $self->{key_md5} ) { |
176 | $self->{found} = 1; |
177 | $self->{idx} = $idx; |
178 | return; |
179 | } |
180 | } |
181 | |
182 | return; |
183 | } |
184 | |
185 | sub write_md5 { |
186 | my $self = shift; |
187 | my ($args) = @_; |
188 | |
189 | DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key}; |
190 | DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5}; |
191 | DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value}; |
192 | |
193 | my $engine = $self->engine; |
194 | |
195 | $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; |
196 | |
197 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
198 | $engine->add_entry( $args->{trans_id}, $spot ); |
199 | |
200 | unless ($self->{found}) { |
201 | my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({ |
202 | engine => $engine, |
203 | data => $args->{key}, |
204 | }); |
205 | |
206 | $engine->storage->print_at( $spot, |
207 | $args->{key_md5}, |
208 | pack( $StP{$engine->byte_size}, $key_sector->offset ), |
209 | ); |
210 | } |
211 | |
212 | my $loc = $spot |
213 | + $engine->hash_size |
214 | + $engine->byte_size; |
215 | |
216 | if ( $args->{trans_id} ) { |
217 | $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 | pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ), |
222 | ); |
223 | } |
224 | else { |
225 | $engine->storage->print_at( $loc, |
226 | pack( $StP{$engine->byte_size}, $args->{value}->offset ), |
227 | ); |
228 | } |
229 | } |
230 | |
231 | sub mark_deleted { |
232 | my $self = shift; |
233 | my ($args) = @_; |
234 | $args ||= {}; |
235 | |
236 | my $engine = $self->engine; |
237 | |
238 | $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; |
239 | |
240 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
241 | $engine->add_entry( $args->{trans_id}, $spot ); |
242 | |
243 | my $loc = $spot |
244 | + $engine->hash_size |
245 | + $engine->byte_size; |
246 | |
247 | if ( $args->{trans_id} ) { |
248 | $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 | pack( $StP{$STALE_SIZE}, $engine->get_txn_staleness_counter( $args->{trans_id} ) ), |
253 | ); |
254 | } |
255 | else { |
256 | $engine->storage->print_at( $loc, |
257 | pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted |
258 | ); |
259 | } |
260 | } |
261 | |
262 | sub delete_md5 { |
263 | my $self = shift; |
264 | my ($args) = @_; |
265 | |
266 | my $engine = $self->engine; |
267 | return undef unless $self->{found}; |
268 | |
269 | # Save the location so that we can free the data |
270 | my $location = $self->get_data_location_for({ |
271 | allow_head => 0, |
272 | }); |
273 | my $key_sector = $self->get_key_for; |
274 | |
275 | 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 | $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ), |
280 | ), |
281 | chr(0) x $self->bucket_size, |
282 | ); |
283 | |
284 | $key_sector->free; |
285 | |
286 | my $data_sector = $self->engine->_load_sector( $location ); |
287 | my $data = $data_sector->data({ export => 1 }); |
288 | $data_sector->free; |
289 | |
290 | return $data; |
291 | } |
292 | |
293 | sub get_data_location_for { |
294 | my $self = shift; |
295 | my ($args) = @_; |
296 | $args ||= {}; |
297 | |
298 | $args->{allow_head} = 0 unless exists $args->{allow_head}; |
299 | $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id}; |
300 | $args->{idx} = $self->{idx} unless exists $args->{idx}; |
301 | |
302 | my $e = $self->engine; |
303 | |
304 | my $spot = $self->offset + $self->base_size |
305 | + $args->{idx} * $self->bucket_size |
306 | + $e->hash_size |
307 | + $e->byte_size; |
308 | |
309 | if ( $args->{trans_id} ) { |
310 | $spot += $e->byte_size + ($args->{trans_id} - 1) * ( $e->byte_size + $STALE_SIZE ); |
311 | } |
312 | |
313 | my $buffer = $e->storage->read_at( |
314 | $spot, |
315 | $e->byte_size + $STALE_SIZE, |
316 | ); |
317 | my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, $buffer ); |
318 | |
319 | # XXX Merge the two if-clauses below |
320 | if ( $args->{trans_id} ) { |
321 | # We have found an entry that is old, so get rid of it |
322 | if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) { |
323 | $e->storage->print_at( |
324 | $spot, |
325 | pack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ), |
326 | ); |
327 | $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 | if ( $args->{trans_id} && !$loc && $args->{allow_head} ) { |
334 | return $self->get_data_location_for({ |
335 | trans_id => 0, |
336 | allow_head => 1, |
337 | idx => $args->{idx}, |
338 | }); |
339 | } |
340 | |
341 | return $loc <= 1 ? 0 : $loc; |
342 | } |
343 | |
344 | sub get_data_for { |
345 | my $self = shift; |
346 | my ($args) = @_; |
347 | $args ||= {}; |
348 | |
349 | return unless $self->{found}; |
350 | my $location = $self->get_data_location_for({ |
351 | allow_head => $args->{allow_head}, |
352 | }); |
353 | return $self->engine->_load_sector( $location ); |
354 | } |
355 | |
356 | sub get_key_for { |
357 | my $self = shift; |
358 | my ($idx) = @_; |
359 | $idx = $self->{idx} unless defined $idx; |
360 | |
361 | if ( $idx >= $self->engine->max_buckets ) { |
362 | DBM::Deep->_throw_error( "get_key_for(): Attempting to retrieve $idx" ); |
363 | } |
364 | |
365 | 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 | $location = unpack( $StP{$self->engine->byte_size}, $location ); |
370 | DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location; |
371 | |
372 | return $self->engine->_load_sector( $location ); |
373 | } |
374 | |
375 | 1; |
376 | __END__ |