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