Commit | Line | Data |
662db255 |
1 | package DBM::Deep::Engine; |
696cadb7 |
2 | |
3 | use 5.6.0; |
4 | |
5 | use strict; |
6 | |
7 | our $VERSION = q(0.99_03); |
8 | |
696cadb7 |
9 | use Scalar::Util (); |
10 | |
11 | # File-wide notes: |
8fbac729 |
12 | # * Every method in here assumes that the storage has been appropriately |
696cadb7 |
13 | # safeguarded. This can be anything from flock() to some sort of manual |
14 | # mutex. But, it's the caller's responsability to make sure that this has |
15 | # been done. |
16 | |
17 | # Setup file and tag signatures. These should never change. |
18 | sub SIG_FILE () { 'DPDB' } |
19 | sub SIG_HEADER () { 'h' } |
20 | sub SIG_INTERNAL () { 'i' } |
21 | sub SIG_HASH () { 'H' } |
22 | sub SIG_ARRAY () { 'A' } |
23 | sub SIG_NULL () { 'N' } |
24 | sub SIG_DATA () { 'D' } |
25 | sub SIG_INDEX () { 'I' } |
26 | sub SIG_BLIST () { 'B' } |
27 | sub SIG_FREE () { 'F' } |
28 | sub SIG_KEYS () { 'K' } |
29 | sub SIG_SIZE () { 1 } |
d58fd793 |
30 | sub STALE_SIZE () { 1 } |
696cadb7 |
31 | |
8fbac729 |
32 | # Please refer to the pack() documentation for further information |
33 | my %StP = ( |
b4e17919 |
34 | 1 => 'C', # Unsigned char value (no order specified, presumably ASCII) |
8fbac729 |
35 | 2 => 'n', # Unsigned short in "network" (big-endian) order |
36 | 4 => 'N', # Unsigned long in "network" (big-endian) order |
37 | 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) |
c83524c6 |
38 | ); |
39 | |
7645a22a |
40 | ################################################################################ |
41 | |
696cadb7 |
42 | sub new { |
43 | my $class = shift; |
44 | my ($args) = @_; |
45 | |
46 | my $self = bless { |
c83524c6 |
47 | byte_size => 4, |
696cadb7 |
48 | |
c83524c6 |
49 | digest => undef, |
6a4f323c |
50 | hash_size => 16, # In bytes |
51 | hash_chars => 256, # Number of chars the algorithm uses per byte |
696cadb7 |
52 | max_buckets => 16, |
36d630c6 |
53 | num_txns => 2, # HEAD plus 1 additional transaction for importing |
54 | trans_id => 0, # Default to the HEAD |
696cadb7 |
55 | |
6f999f6e |
56 | entries => {}, # This is the list of entries for transactions |
696cadb7 |
57 | storage => undef, |
696cadb7 |
58 | }, $class; |
59 | |
60 | if ( defined $args->{pack_size} ) { |
61 | if ( lc $args->{pack_size} eq 'small' ) { |
c83524c6 |
62 | $args->{byte_size} = 2; |
696cadb7 |
63 | } |
64 | elsif ( lc $args->{pack_size} eq 'medium' ) { |
c83524c6 |
65 | $args->{byte_size} = 4; |
696cadb7 |
66 | } |
67 | elsif ( lc $args->{pack_size} eq 'large' ) { |
c83524c6 |
68 | $args->{byte_size} = 8; |
696cadb7 |
69 | } |
70 | else { |
a67c4bbf |
71 | DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" ); |
696cadb7 |
72 | } |
73 | } |
74 | |
75 | # Grab the parameters we want to use |
76 | foreach my $param ( keys %$self ) { |
77 | next unless exists $args->{$param}; |
78 | $self->{$param} = $args->{$param}; |
79 | } |
696cadb7 |
80 | |
81 | ## |
82 | # Number of buckets per blist before another level of indexing is |
83 | # done. Increase this value for slightly greater speed, but larger database |
84 | # files. DO NOT decrease this value below 16, due to risk of recursive |
85 | # reindex overrun. |
86 | ## |
87 | if ( $self->{max_buckets} < 16 ) { |
88 | warn "Floor of max_buckets is 16. Setting it to 16 from '$self->{max_buckets}'\n"; |
89 | $self->{max_buckets} = 16; |
90 | } |
91 | |
c83524c6 |
92 | if ( !$self->{digest} ) { |
93 | require Digest::MD5; |
94 | $self->{digest} = \&Digest::MD5::md5; |
95 | } |
96 | |
696cadb7 |
97 | return $self; |
98 | } |
99 | |
100 | ################################################################################ |
101 | |
102 | sub read_value { |
103 | my $self = shift; |
c9f02899 |
104 | my ($obj, $key) = @_; |
3976d8c9 |
105 | |
106 | # This will be a Reference sector |
c9f02899 |
107 | my $sector = $self->_load_sector( $obj->_base_offset ) |
76c68c87 |
108 | or return; |
3976d8c9 |
109 | |
8af340bf |
110 | if ( $sector->staleness != $obj->_staleness ) { |
111 | return; |
112 | } |
113 | |
3976d8c9 |
114 | my $key_md5 = $self->_apply_digest( $key ); |
115 | |
2432d6cc |
116 | my $value_sector = $sector->get_data_for({ |
117 | key_md5 => $key_md5, |
118 | allow_head => 1, |
119 | }); |
3976d8c9 |
120 | |
2432d6cc |
121 | unless ( $value_sector ) { |
4056dff7 |
122 | $value_sector = DBM::Deep::Engine::Sector::Null->new({ |
123 | engine => $self, |
124 | data => undef, |
125 | }); |
126 | |
2432d6cc |
127 | $sector->write_data({ |
128 | key_md5 => $key_md5, |
129 | key => $key, |
130 | value => $value_sector, |
131 | }); |
4056dff7 |
132 | } |
3976d8c9 |
133 | |
134 | return $value_sector->data; |
696cadb7 |
135 | } |
136 | |
84467b9f |
137 | sub get_classname { |
138 | my $self = shift; |
c9f02899 |
139 | my ($obj) = @_; |
84467b9f |
140 | |
141 | # This will be a Reference sector |
c9f02899 |
142 | my $sector = $self->_load_sector( $obj->_base_offset ) |
a67c4bbf |
143 | or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" ); |
84467b9f |
144 | |
8af340bf |
145 | if ( $sector->staleness != $obj->_staleness ) { |
146 | return; |
147 | } |
148 | |
84467b9f |
149 | return $sector->get_classname; |
150 | } |
151 | |
696cadb7 |
152 | sub key_exists { |
153 | my $self = shift; |
c9f02899 |
154 | my ($obj, $key) = @_; |
c000ae6e |
155 | |
156 | # This will be a Reference sector |
c9f02899 |
157 | my $sector = $self->_load_sector( $obj->_base_offset ) |
76c68c87 |
158 | or return ''; |
c000ae6e |
159 | |
8af340bf |
160 | if ( $sector->staleness != $obj->_staleness ) { |
161 | return ''; |
162 | } |
163 | |
2432d6cc |
164 | my $data = $sector->get_data_for({ |
165 | key_md5 => $self->_apply_digest( $key ), |
166 | allow_head => 1, |
167 | }); |
c000ae6e |
168 | |
e86cef36 |
169 | # exists() returns 1 or '' for true/false. |
2432d6cc |
170 | return $data ? 1 : ''; |
696cadb7 |
171 | } |
172 | |
173 | sub delete_key { |
174 | my $self = shift; |
c9f02899 |
175 | my ($obj, $key) = @_; |
e86cef36 |
176 | |
c9f02899 |
177 | my $sector = $self->_load_sector( $obj->_base_offset ) |
76c68c87 |
178 | or return; |
e86cef36 |
179 | |
8af340bf |
180 | if ( $sector->staleness != $obj->_staleness ) { |
181 | return; |
182 | } |
183 | |
2432d6cc |
184 | return $sector->delete_key({ |
185 | key_md5 => $self->_apply_digest( $key ), |
186 | allow_head => 0, |
187 | }); |
696cadb7 |
188 | } |
189 | |
190 | sub write_value { |
191 | my $self = shift; |
c9f02899 |
192 | my ($obj, $key, $value) = @_; |
3976d8c9 |
193 | |
764e6cb9 |
194 | my $r = Scalar::Util::reftype( $value ) || ''; |
d49782fe |
195 | { |
196 | last if $r eq ''; |
197 | last if $r eq 'HASH'; |
198 | last if $r eq 'ARRAY'; |
199 | |
200 | DBM::Deep->_throw_error( |
201 | "Storage of references of type '$r' is not supported." |
202 | ); |
203 | } |
204 | |
764e6cb9 |
205 | my ($class, $type); |
68369f26 |
206 | if ( !defined $value ) { |
4eee718c |
207 | $class = 'DBM::Deep::Engine::Sector::Null'; |
68369f26 |
208 | } |
764e6cb9 |
209 | elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) { |
d49782fe |
210 | if ( $r eq 'ARRAY' && tied(@$value) ) { |
25eb38b8 |
211 | DBM::Deep->_throw_error( "Cannot store something that is tied." ); |
d49782fe |
212 | } |
213 | if ( $r eq 'HASH' && tied(%$value) ) { |
25eb38b8 |
214 | DBM::Deep->_throw_error( "Cannot store something that is tied." ); |
d49782fe |
215 | } |
764e6cb9 |
216 | $class = 'DBM::Deep::Engine::Sector::Reference'; |
ed38e772 |
217 | $type = substr( $r, 0, 1 ); |
764e6cb9 |
218 | } |
68369f26 |
219 | else { |
4eee718c |
220 | $class = 'DBM::Deep::Engine::Sector::Scalar'; |
68369f26 |
221 | } |
3976d8c9 |
222 | |
2432d6cc |
223 | # This will be a Reference sector |
224 | my $sector = $self->_load_sector( $obj->_base_offset ) |
a67c4bbf |
225 | or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." ); |
ed38e772 |
226 | |
8af340bf |
227 | if ( $sector->staleness != $obj->_staleness ) { |
a67c4bbf |
228 | DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep.n" ); |
8af340bf |
229 | } |
230 | |
2432d6cc |
231 | # Create this after loading the reference sector in case something bad happens. |
232 | # This way, we won't allocate value sector(s) needlessly. |
4eee718c |
233 | my $value_sector = $class->new({ |
234 | engine => $self, |
235 | data => $value, |
764e6cb9 |
236 | type => $type, |
4eee718c |
237 | }); |
238 | |
2432d6cc |
239 | $sector->write_data({ |
240 | key => $key, |
241 | key_md5 => $self->_apply_digest( $key ), |
242 | value => $value_sector, |
243 | }); |
764e6cb9 |
244 | |
245 | # This code is to make sure we write all the values in the $value to the disk |
ed38e772 |
246 | # and to make sure all changes to $value after the assignment are reflected |
247 | # on disk. This may be counter-intuitive at first, but it is correct dwimmery. |
248 | # NOTE - simply tying $value won't perform a STORE on each value. Hence, the |
249 | # copy to a temp value. |
764e6cb9 |
250 | if ( $r eq 'ARRAY' ) { |
ed38e772 |
251 | my @temp = @$value; |
764e6cb9 |
252 | tie @$value, 'DBM::Deep', { |
253 | base_offset => $value_sector->offset, |
8af340bf |
254 | staleness => $value_sector->staleness, |
764e6cb9 |
255 | storage => $self->storage, |
c9f02899 |
256 | engine => $self, |
764e6cb9 |
257 | }; |
ed38e772 |
258 | @$value = @temp; |
764e6cb9 |
259 | bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value ); |
260 | } |
261 | elsif ( $r eq 'HASH' ) { |
ed38e772 |
262 | my %temp = %$value; |
764e6cb9 |
263 | tie %$value, 'DBM::Deep', { |
264 | base_offset => $value_sector->offset, |
8af340bf |
265 | staleness => $value_sector->staleness, |
764e6cb9 |
266 | storage => $self->storage, |
c9f02899 |
267 | engine => $self, |
764e6cb9 |
268 | }; |
ed38e772 |
269 | |
270 | %$value = %temp; |
764e6cb9 |
271 | bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value ); |
272 | } |
273 | |
274 | return 1; |
696cadb7 |
275 | } |
276 | |
8af340bf |
277 | # XXX Add staleness here |
696cadb7 |
278 | sub get_next_key { |
279 | my $self = shift; |
c9f02899 |
280 | my ($obj, $prev_key) = @_; |
ed38e772 |
281 | |
282 | # XXX Need to add logic about resetting the iterator if any key in the reference has changed |
283 | unless ( $prev_key ) { |
0f4ed906 |
284 | $obj->{iterator} = DBM::Deep::Iterator->new({ |
c9f02899 |
285 | base_offset => $obj->_base_offset, |
ed38e772 |
286 | engine => $self, |
287 | }); |
4eee718c |
288 | } |
289 | |
8af340bf |
290 | return $obj->{iterator}->get_next_key( $obj ); |
696cadb7 |
291 | } |
292 | |
293 | ################################################################################ |
294 | |
295 | sub setup_fh { |
296 | my $self = shift; |
297 | my ($obj) = @_; |
298 | |
299 | # We're opening the file. |
300 | unless ( $obj->_base_offset ) { |
696cadb7 |
301 | my $bytes_read = $self->_read_file_header; |
696cadb7 |
302 | |
303 | # Creating a new file |
304 | unless ( $bytes_read ) { |
305 | $self->_write_file_header; |
c83524c6 |
306 | |
307 | # 1) Create Array/Hash entry |
8fbac729 |
308 | my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({ |
309 | engine => $self, |
310 | type => $obj->_type, |
311 | }); |
312 | $obj->{base_offset} = $initial_reference->offset; |
8af340bf |
313 | $obj->{staleness} = $initial_reference->staleness; |
c83524c6 |
314 | |
8fbac729 |
315 | $self->storage->flush; |
696cadb7 |
316 | } |
317 | # Reading from an existing file |
318 | else { |
319 | $obj->{base_offset} = $bytes_read; |
764e6cb9 |
320 | my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({ |
321 | engine => $self, |
322 | offset => $obj->_base_offset, |
323 | }); |
324 | unless ( $initial_reference ) { |
696cadb7 |
325 | DBM::Deep->_throw_error("Corrupted file, no master index record"); |
326 | } |
327 | |
764e6cb9 |
328 | unless ($obj->_type eq $initial_reference->type) { |
696cadb7 |
329 | DBM::Deep->_throw_error("File type mismatch"); |
330 | } |
8af340bf |
331 | |
332 | $obj->{staleness} = $initial_reference->staleness; |
696cadb7 |
333 | } |
334 | } |
696cadb7 |
335 | |
696cadb7 |
336 | return 1; |
337 | } |
338 | |
8cb9205a |
339 | sub begin_work { |
c9f02899 |
340 | my $self = shift; |
8cb9205a |
341 | my ($obj) = @_; |
342 | |
343 | if ( $self->trans_id ) { |
de82ff48 |
344 | DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" ); |
8cb9205a |
345 | } |
346 | |
cf03415a |
347 | my @slots = $self->read_txn_slots; |
8cb9205a |
348 | for my $i ( 1 .. @slots ) { |
349 | next if $slots[$i]; |
350 | $slots[$i] = 1; |
351 | $self->set_trans_id( $i ); |
352 | last; |
353 | } |
cf03415a |
354 | $self->write_txn_slots( @slots ); |
8cb9205a |
355 | |
356 | if ( !$self->trans_id ) { |
6f999f6e |
357 | DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" ); |
8cb9205a |
358 | } |
359 | |
360 | return; |
c9f02899 |
361 | } |
696cadb7 |
362 | |
8cb9205a |
363 | sub rollback { |
696cadb7 |
364 | my $self = shift; |
8cb9205a |
365 | my ($obj) = @_; |
366 | |
367 | if ( !$self->trans_id ) { |
de82ff48 |
368 | DBM::Deep->_throw_error( "Cannot rollback without an active transaction" ); |
6f999f6e |
369 | } |
370 | |
371 | # Each entry is the file location for a bucket that has a modification for |
372 | # this transaction. The entries need to be expunged. |
373 | foreach my $entry (@{ $self->get_entries } ) { |
374 | # Remove the entry here |
375 | my $read_loc = $entry |
376 | + $self->hash_size |
377 | + $self->byte_size |
17164f8a |
378 | + $self->trans_id * ( $self->byte_size + 4 ); |
6f999f6e |
379 | |
380 | my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size ); |
381 | $data_loc = unpack( $StP{$self->byte_size}, $data_loc ); |
382 | $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) ); |
383 | |
384 | if ( $data_loc > 1 ) { |
385 | $self->_load_sector( $data_loc )->free; |
386 | } |
8cb9205a |
387 | } |
6f999f6e |
388 | |
389 | $self->clear_entries; |
390 | |
cf03415a |
391 | my @slots = $self->read_txn_slots; |
6f999f6e |
392 | $slots[$self->trans_id] = 0; |
cf03415a |
393 | $self->write_txn_slots( @slots ); |
6de4e4e9 |
394 | $self->inc_txn_staleness_counter( $self->trans_id ); |
6f999f6e |
395 | $self->set_trans_id( 0 ); |
396 | |
397 | return 1; |
c9f02899 |
398 | } |
696cadb7 |
399 | |
8cb9205a |
400 | sub commit { |
c9f02899 |
401 | my $self = shift; |
8cb9205a |
402 | my ($obj) = @_; |
403 | |
404 | if ( !$self->trans_id ) { |
de82ff48 |
405 | DBM::Deep->_throw_error( "Cannot commit without an active transaction" ); |
6f999f6e |
406 | } |
407 | |
6f999f6e |
408 | foreach my $entry (@{ $self->get_entries } ) { |
6f999f6e |
409 | # Overwrite the entry in head with the entry in trans_id |
410 | my $base = $entry |
411 | + $self->hash_size |
412 | + $self->byte_size; |
413 | |
414 | my $head_loc = $self->storage->read_at( $base, $self->byte_size ); |
415 | $head_loc = unpack( $StP{$self->byte_size}, $head_loc ); |
416 | my $trans_loc = $self->storage->read_at( |
17164f8a |
417 | $base + $self->trans_id * ( $self->byte_size + 4 ), $self->byte_size, |
6f999f6e |
418 | ); |
419 | |
420 | $self->storage->print_at( $base, $trans_loc ); |
421 | $self->storage->print_at( |
17164f8a |
422 | $base + $self->trans_id * ( $self->byte_size + 4 ), |
6de4e4e9 |
423 | pack( $StP{$self->byte_size} . ' N', (0) x 2 ), |
6f999f6e |
424 | ); |
425 | |
426 | if ( $head_loc > 1 ) { |
427 | $self->_load_sector( $head_loc )->free; |
428 | } |
8cb9205a |
429 | } |
6f999f6e |
430 | |
431 | $self->clear_entries; |
432 | |
cf03415a |
433 | my @slots = $self->read_txn_slots; |
6f999f6e |
434 | $slots[$self->trans_id] = 0; |
cf03415a |
435 | $self->write_txn_slots( @slots ); |
6de4e4e9 |
436 | $self->inc_txn_staleness_counter( $self->trans_id ); |
6f999f6e |
437 | $self->set_trans_id( 0 ); |
438 | |
439 | return 1; |
8cb9205a |
440 | } |
441 | |
cf03415a |
442 | sub read_txn_slots { |
8cb9205a |
443 | my $self = shift; |
cf03415a |
444 | return split '', unpack( 'b32', |
445 | $self->storage->read_at( |
446 | $self->trans_loc, 4, |
447 | ) |
448 | ); |
8cb9205a |
449 | } |
450 | |
cf03415a |
451 | sub write_txn_slots { |
8cb9205a |
452 | my $self = shift; |
453 | $self->storage->print_at( $self->trans_loc, |
cf03415a |
454 | pack( 'b32', join('', @_) ), |
8cb9205a |
455 | ); |
c9f02899 |
456 | } |
696cadb7 |
457 | |
cf03415a |
458 | sub get_running_txn_ids { |
459 | my $self = shift; |
460 | my @transactions = $self->read_txn_slots; |
461 | my @trans_ids = grep { $transactions[$_] } 0 .. $#transactions; |
462 | } |
463 | |
6de4e4e9 |
464 | sub get_txn_staleness_counter { |
465 | my $self = shift; |
466 | my ($trans_id) = @_; |
b4e17919 |
467 | |
468 | # Hardcode staleness of 0 for the HEAD |
469 | return 0 unless $trans_id; |
470 | |
41e27db3 |
471 | my $x = unpack( 'N', |
6de4e4e9 |
472 | $self->storage->read_at( |
b4e17919 |
473 | $self->trans_loc + 4 * $trans_id, |
41e27db3 |
474 | 4, |
6de4e4e9 |
475 | ) |
476 | ); |
41e27db3 |
477 | return $x; |
6de4e4e9 |
478 | } |
479 | |
480 | sub inc_txn_staleness_counter { |
481 | my $self = shift; |
482 | my ($trans_id) = @_; |
b4e17919 |
483 | |
484 | # Hardcode staleness of 0 for the HEAD |
485 | return unless $trans_id; |
486 | |
6de4e4e9 |
487 | $self->storage->print_at( |
b4e17919 |
488 | $self->trans_loc + 4 * $trans_id, |
6de4e4e9 |
489 | pack( 'N', $self->get_txn_staleness_counter( $trans_id ) + 1 ), |
490 | ); |
491 | } |
492 | |
6f999f6e |
493 | sub get_entries { |
494 | my $self = shift; |
495 | return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ]; |
496 | } |
497 | |
498 | sub add_entry { |
499 | my $self = shift; |
500 | my ($trans_id, $loc) = @_; |
501 | |
6f999f6e |
502 | $self->{entries}{$trans_id} ||= {}; |
503 | $self->{entries}{$trans_id}{$loc} = undef; |
6f999f6e |
504 | } |
505 | |
65bd261b |
506 | # If the buckets are being relocated because of a reindexing, the entries |
507 | # mechanism needs to be made aware of it. |
508 | sub reindex_entry { |
509 | my $self = shift; |
510 | my ($old_loc, $new_loc) = @_; |
511 | |
512 | TRANS: |
513 | while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) { |
514 | foreach my $orig_loc ( keys %{ $locs } ) { |
515 | if ( $orig_loc == $old_loc ) { |
516 | delete $locs->{orig_loc}; |
517 | $locs->{$new_loc} = undef; |
518 | next TRANS; |
519 | } |
520 | } |
521 | } |
522 | } |
523 | |
6f999f6e |
524 | sub clear_entries { |
525 | my $self = shift; |
6f999f6e |
526 | delete $self->{entries}{$self->trans_id}; |
527 | } |
528 | |
c9f02899 |
529 | ################################################################################ |
b9ec359f |
530 | |
c9f02899 |
531 | { |
532 | my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4; |
696cadb7 |
533 | |
c9f02899 |
534 | sub _write_file_header { |
535 | my $self = shift; |
696cadb7 |
536 | |
36d630c6 |
537 | my $header_var = 1 + 1 + 1 + 4 + 4 * $self->num_txns + 3 * $self->byte_size; |
696cadb7 |
538 | |
c9f02899 |
539 | my $loc = $self->storage->request_space( $header_fixed + $header_var ); |
c83524c6 |
540 | |
c9f02899 |
541 | $self->storage->print_at( $loc, |
542 | SIG_FILE, |
543 | SIG_HEADER, |
544 | pack('N', 1), # header version - at this point, we're at 9 bytes |
545 | pack('N', $header_var), # header size |
546 | # --- Above is $header_fixed. Below is $header_var |
547 | pack('C', $self->byte_size), |
548 | pack('C', $self->max_buckets), |
36d630c6 |
549 | pack('C', $self->num_txns), |
b4e17919 |
550 | pack('N', 0 ), # Transaction activeness bitfield |
551 | pack('N' . $self->num_txns, 0 x $self->num_txns ), # Transaction staleness counters |
c9f02899 |
552 | pack($StP{$self->byte_size}, 0), # Start of free chain (blist size) |
553 | pack($StP{$self->byte_size}, 0), # Start of free chain (data size) |
d58fd793 |
554 | pack($StP{$self->byte_size}, 0), # Start of free chain (index size) |
c9f02899 |
555 | ); |
696cadb7 |
556 | |
36d630c6 |
557 | $self->set_trans_loc( $header_fixed + 3 ); |
558 | $self->set_chains_loc( $header_fixed + 3 + 4 + 4 * $self->num_txns ); |
696cadb7 |
559 | |
c9f02899 |
560 | return; |
696cadb7 |
561 | } |
562 | |
c9f02899 |
563 | sub _read_file_header { |
564 | my $self = shift; |
696cadb7 |
565 | |
c9f02899 |
566 | my $buffer = $self->storage->read_at( 0, $header_fixed ); |
567 | return unless length($buffer); |
696cadb7 |
568 | |
c9f02899 |
569 | my ($file_signature, $sig_header, $header_version, $size) = unpack( |
570 | 'A4 A N N', $buffer |
571 | ); |
b9ec359f |
572 | |
c9f02899 |
573 | unless ( $file_signature eq SIG_FILE ) { |
574 | $self->storage->close; |
575 | DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" ); |
576 | } |
696cadb7 |
577 | |
c9f02899 |
578 | unless ( $sig_header eq SIG_HEADER ) { |
579 | $self->storage->close; |
580 | DBM::Deep->_throw_error( "Old file version found." ); |
581 | } |
696cadb7 |
582 | |
c9f02899 |
583 | my $buffer2 = $self->storage->read_at( undef, $size ); |
36d630c6 |
584 | my @values = unpack( 'C C C', $buffer2 ); |
696cadb7 |
585 | |
36d630c6 |
586 | if ( @values != 3 || grep { !defined } @values ) { |
c9f02899 |
587 | $self->storage->close; |
588 | DBM::Deep->_throw_error("Corrupted file - bad header"); |
589 | } |
590 | |
36d630c6 |
591 | $self->set_trans_loc( $header_fixed + scalar(@values) ); |
592 | $self->set_chains_loc( $header_fixed + scalar(@values) + 4 + 4 * $self->num_txns ); |
593 | |
c9f02899 |
594 | #XXX Add warnings if values weren't set right |
36d630c6 |
595 | @{$self}{qw(byte_size max_buckets num_txns)} = @values; |
b9ec359f |
596 | |
36d630c6 |
597 | my $header_var = scalar(@values) + 4 + 4 * $self->num_txns + 3 * $self->byte_size; |
a67c4bbf |
598 | unless ( $size == $header_var ) { |
c9f02899 |
599 | $self->storage->close; |
600 | DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." ); |
601 | } |
602 | |
603 | return length($buffer) + length($buffer2); |
604 | } |
696cadb7 |
605 | } |
606 | |
3976d8c9 |
607 | sub _load_sector { |
608 | my $self = shift; |
609 | my ($offset) = @_; |
610 | |
0f4ed906 |
611 | # Add a catch for offset of 0 or 1 |
612 | return if $offset <= 1; |
613 | |
3976d8c9 |
614 | my $type = $self->storage->read_at( $offset, 1 ); |
b9ec359f |
615 | return if $type eq chr(0); |
616 | |
3976d8c9 |
617 | if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) { |
618 | return DBM::Deep::Engine::Sector::Reference->new({ |
619 | engine => $self, |
620 | type => $type, |
621 | offset => $offset, |
622 | }); |
623 | } |
2432d6cc |
624 | # XXX Don't we need key_md5 here? |
3976d8c9 |
625 | elsif ( $type eq $self->SIG_BLIST ) { |
626 | return DBM::Deep::Engine::Sector::BucketList->new({ |
627 | engine => $self, |
628 | type => $type, |
629 | offset => $offset, |
630 | }); |
631 | } |
d58fd793 |
632 | elsif ( $type eq $self->SIG_INDEX ) { |
633 | return DBM::Deep::Engine::Sector::Index->new({ |
634 | engine => $self, |
635 | type => $type, |
636 | offset => $offset, |
637 | }); |
638 | } |
68369f26 |
639 | elsif ( $type eq $self->SIG_NULL ) { |
640 | return DBM::Deep::Engine::Sector::Null->new({ |
641 | engine => $self, |
642 | type => $type, |
643 | offset => $offset, |
644 | }); |
645 | } |
646 | elsif ( $type eq $self->SIG_DATA ) { |
647 | return DBM::Deep::Engine::Sector::Scalar->new({ |
648 | engine => $self, |
649 | type => $type, |
650 | offset => $offset, |
651 | }); |
652 | } |
b9ec359f |
653 | # This was deleted from under us, so just return and let the caller figure it out. |
654 | elsif ( $type eq $self->SIG_FREE ) { |
655 | return; |
656 | } |
3976d8c9 |
657 | |
a67c4bbf |
658 | DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" ); |
3976d8c9 |
659 | } |
660 | |
661 | sub _apply_digest { |
662 | my $self = shift; |
663 | return $self->{digest}->(@_); |
664 | } |
665 | |
c0507636 |
666 | sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) } |
667 | sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) } |
668 | sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) } |
669 | |
ed38e772 |
670 | sub _add_free_sector { |
671 | my $self = shift; |
c0507636 |
672 | my ($multiple, $offset, $size) = @_; |
b9ec359f |
673 | |
c0507636 |
674 | my $chains_offset = $multiple * $self->byte_size; |
b9ec359f |
675 | |
8af340bf |
676 | my $storage = $self->storage; |
677 | |
678 | # Increment staleness. |
c0507636 |
679 | # XXX Can this increment+modulo be done by "&= 0x1" ? |
d58fd793 |
680 | my $staleness = unpack( $StP{STALE_SIZE()}, $storage->read_at( $offset + SIG_SIZE, STALE_SIZE ) ); |
681 | $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * STALE_SIZE ) ); |
682 | $storage->print_at( $offset + SIG_SIZE, pack( $StP{STALE_SIZE()}, $staleness ) ); |
b9ec359f |
683 | |
8af340bf |
684 | my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); |
685 | |
686 | $storage->print_at( $self->chains_loc + $chains_offset, |
b9ec359f |
687 | pack( $StP{$self->byte_size}, $offset ), |
688 | ); |
689 | |
8af340bf |
690 | # Record the old head in the new sector after the signature and staleness counter |
d58fd793 |
691 | $storage->print_at( $offset + SIG_SIZE + STALE_SIZE, $old_head ); |
b9ec359f |
692 | } |
693 | |
c0507636 |
694 | sub _request_blist_sector { shift->_request_sector( 0, @_ ) } |
695 | sub _request_data_sector { shift->_request_sector( 1, @_ ) } |
696 | sub _request_index_sector { shift->_request_sector( 2, @_ ) } |
697 | |
b9ec359f |
698 | sub _request_sector { |
699 | my $self = shift; |
c0507636 |
700 | my ($multiple, $size) = @_; |
b9ec359f |
701 | |
c0507636 |
702 | my $chains_offset = $multiple * $self->byte_size; |
b9ec359f |
703 | |
704 | my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); |
705 | my $loc = unpack( $StP{$self->byte_size}, $old_head ); |
706 | |
707 | # We don't have any free sectors of the right size, so allocate a new one. |
708 | unless ( $loc ) { |
8af340bf |
709 | my $offset = $self->storage->request_space( $size ); |
710 | |
711 | # Zero out the new sector. This also guarantees correct increases |
712 | # in the filesize. |
713 | $self->storage->print_at( $offset, chr(0) x $size ); |
714 | |
715 | return $offset; |
b9ec359f |
716 | } |
717 | |
8af340bf |
718 | # Read the new head after the signature and the staleness counter |
d58fd793 |
719 | my $new_head = $self->storage->read_at( $loc + SIG_SIZE + STALE_SIZE, $self->byte_size ); |
b9ec359f |
720 | $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head ); |
3a917474 |
721 | $self->storage->print_at( |
722 | $loc + SIG_SIZE + STALE_SIZE, |
723 | pack( $StP{$self->byte_size}, 0 ), |
724 | ); |
b9ec359f |
725 | |
726 | return $loc; |
ed38e772 |
727 | } |
728 | |
696cadb7 |
729 | ################################################################################ |
730 | |
3976d8c9 |
731 | sub storage { $_[0]{storage} } |
732 | sub byte_size { $_[0]{byte_size} } |
733 | sub hash_size { $_[0]{hash_size} } |
6a4f323c |
734 | sub hash_chars { $_[0]{hash_chars} } |
3976d8c9 |
735 | sub num_txns { $_[0]{num_txns} } |
736 | sub max_buckets { $_[0]{max_buckets} } |
c000ae6e |
737 | sub blank_md5 { chr(0) x $_[0]->hash_size } |
8fbac729 |
738 | |
8cb9205a |
739 | sub trans_id { $_[0]{trans_id} } |
740 | sub set_trans_id { $_[0]{trans_id} = $_[1] } |
741 | |
c9f02899 |
742 | sub trans_loc { $_[0]{trans_loc} } |
743 | sub set_trans_loc { $_[0]{trans_loc} = $_[1] } |
744 | |
b9ec359f |
745 | sub chains_loc { $_[0]{chains_loc} } |
746 | sub set_chains_loc { $_[0]{chains_loc} = $_[1] } |
747 | |
8fbac729 |
748 | ################################################################################ |
749 | |
0f4ed906 |
750 | package DBM::Deep::Iterator; |
ed38e772 |
751 | |
752 | sub new { |
753 | my $class = shift; |
754 | my ($args) = @_; |
755 | |
756 | my $self = bless { |
757 | breadcrumbs => [], |
758 | engine => $args->{engine}, |
759 | base_offset => $args->{base_offset}, |
ed38e772 |
760 | }, $class; |
761 | |
762 | Scalar::Util::weaken( $self->{engine} ); |
763 | |
764 | return $self; |
765 | } |
766 | |
0f4ed906 |
767 | sub reset { $_[0]{breadcrumbs} = [] } |
768 | |
769 | sub get_sector_iterator { |
ed38e772 |
770 | my $self = shift; |
0f4ed906 |
771 | my ($loc) = @_; |
772 | |
773 | my $sector = $self->{engine}->_load_sector( $loc ) |
774 | or return; |
775 | |
776 | if ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) { |
777 | return DBM::Deep::Iterator::Index->new({ |
778 | iterator => $self, |
779 | sector => $sector, |
780 | }); |
781 | } |
782 | elsif ( $sector->isa( 'DBM::Deep::Engine::Sector::BucketList' ) ) { |
783 | return DBM::Deep::Iterator::BucketList->new({ |
784 | iterator => $self, |
785 | sector => $sector, |
786 | }); |
787 | } |
a67c4bbf |
788 | |
789 | DBM::Deep->_throw_error( "get_sector_iterator(): Why did $loc make a $sector?" ); |
ed38e772 |
790 | } |
791 | |
792 | sub get_next_key { |
793 | my $self = shift; |
8af340bf |
794 | my ($obj) = @_; |
ed38e772 |
795 | |
796 | my $crumbs = $self->{breadcrumbs}; |
0f4ed906 |
797 | my $e = $self->{engine}; |
ed38e772 |
798 | |
799 | unless ( @$crumbs ) { |
800 | # This will be a Reference sector |
0f4ed906 |
801 | my $sector = $e->_load_sector( $self->{base_offset} ) |
b9ec359f |
802 | # If no sector is found, thist must have been deleted from under us. |
803 | or return; |
8af340bf |
804 | |
805 | if ( $sector->staleness != $obj->_staleness ) { |
806 | return; |
807 | } |
808 | |
0f4ed906 |
809 | my $loc = $sector->get_blist_loc |
810 | or return; |
811 | |
812 | push @$crumbs, $self->get_sector_iterator( $loc ); |
ed38e772 |
813 | } |
814 | |
0f4ed906 |
815 | FIND_NEXT_KEY: { |
816 | # We're at the end. |
817 | unless ( @$crumbs ) { |
ed38e772 |
818 | $self->reset; |
0f4ed906 |
819 | return; |
ed38e772 |
820 | } |
821 | |
0f4ed906 |
822 | my $iterator = $crumbs->[-1]; |
823 | |
824 | # This level is done. |
825 | if ( $iterator->at_end ) { |
826 | pop @$crumbs; |
827 | redo FIND_NEXT_KEY; |
2432d6cc |
828 | } |
829 | |
0f4ed906 |
830 | if ( $iterator->isa( 'DBM::Deep::Iterator::Index' ) ) { |
831 | # If we don't have any more, it will be caught at the |
832 | # prior check. |
833 | if ( my $next = $iterator->get_next_iterator ) { |
834 | push @$crumbs, $next; |
835 | } |
836 | redo FIND_NEXT_KEY; |
837 | } |
ed38e772 |
838 | |
0f4ed906 |
839 | unless ( $iterator->isa( 'DBM::Deep::Iterator::BucketList' ) ) { |
840 | DBM::Deep->_throw_error( |
841 | "Should have a bucketlist iterator here - instead have $iterator" |
842 | ); |
2432d6cc |
843 | } |
844 | |
0f4ed906 |
845 | # At this point, we have a BucketList iterator |
846 | my $key = $iterator->get_next_key; |
847 | if ( defined $key ) { |
848 | return $key; |
ed38e772 |
849 | } |
a67c4bbf |
850 | #XXX else { $iterator->set_to_end() } ? |
ed38e772 |
851 | |
0f4ed906 |
852 | # We hit the end of the bucketlist iterator, so redo |
853 | redo FIND_NEXT_KEY; |
854 | } |
855 | |
856 | DBM::Deep->_throw_error( "get_next_key(): How did we get here?" ); |
857 | } |
858 | |
859 | package DBM::Deep::Iterator::Index; |
860 | |
861 | sub new { |
862 | my $self = bless $_[1] => $_[0]; |
863 | $self->{curr_index} = 0; |
864 | return $self; |
865 | } |
866 | |
867 | sub at_end { |
868 | my $self = shift; |
869 | return $self->{curr_index} >= $self->{iterator}{engine}->hash_chars; |
870 | } |
871 | |
872 | sub get_next_iterator { |
873 | my $self = shift; |
874 | |
875 | my $loc; |
876 | while ( !$loc ) { |
877 | return if $self->at_end; |
878 | $loc = $self->{sector}->get_entry( $self->{curr_index}++ ); |
ed38e772 |
879 | } |
880 | |
0f4ed906 |
881 | return $self->{iterator}->get_sector_iterator( $loc ); |
882 | } |
883 | |
884 | package DBM::Deep::Iterator::BucketList; |
885 | |
886 | sub new { |
887 | my $self = bless $_[1] => $_[0]; |
888 | $self->{curr_index} = 0; |
889 | return $self; |
890 | } |
891 | |
892 | sub at_end { |
893 | my $self = shift; |
894 | return $self->{curr_index} >= $self->{iterator}{engine}->max_buckets; |
895 | } |
896 | |
897 | sub get_next_key { |
898 | my $self = shift; |
899 | |
900 | return if $self->at_end; |
901 | |
a67c4bbf |
902 | my $idx = $self->{curr_index}++; |
903 | |
9ce79856 |
904 | my $data_loc = $self->{sector}->get_data_location_for({ |
905 | allow_head => 1, |
a67c4bbf |
906 | idx => $idx, |
9ce79856 |
907 | }) or return; |
908 | |
a67c4bbf |
909 | #XXX Do we want to add corruption checks here? |
910 | return $self->{sector}->get_key_for( $idx )->data; |
ed38e772 |
911 | } |
912 | |
3976d8c9 |
913 | package DBM::Deep::Engine::Sector; |
914 | |
915 | sub new { |
916 | my $self = bless $_[1], $_[0]; |
917 | Scalar::Util::weaken( $self->{engine} ); |
918 | $self->_init; |
919 | return $self; |
920 | } |
a67c4bbf |
921 | |
7701c066 |
922 | #sub _init {} |
a67c4bbf |
923 | #sub clone { DBM::Deep->_throw_error( "Must be implemented in the child class" ); } |
3976d8c9 |
924 | |
925 | sub engine { $_[0]{engine} } |
926 | sub offset { $_[0]{offset} } |
927 | sub type { $_[0]{type} } |
928 | |
d58fd793 |
929 | sub base_size { |
930 | my $self = shift; |
931 | return $self->engine->SIG_SIZE + $self->engine->STALE_SIZE; |
932 | } |
b6fc126b |
933 | |
ed38e772 |
934 | sub free { |
935 | my $self = shift; |
936 | |
b6fc126b |
937 | my $e = $self->engine; |
938 | |
939 | $e->storage->print_at( $self->offset, $e->SIG_FREE ); |
8af340bf |
940 | # Skip staleness counter |
b6fc126b |
941 | $e->storage->print_at( $self->offset + $self->base_size, |
942 | chr(0) x ($self->size - $self->base_size), |
b9ec359f |
943 | ); |
944 | |
c0507636 |
945 | my $free_meth = $self->free_meth; |
946 | $e->$free_meth( $self->offset, $self->size ); |
ed38e772 |
947 | |
b9ec359f |
948 | return; |
ed38e772 |
949 | } |
3976d8c9 |
950 | |
951 | package DBM::Deep::Engine::Sector::Data; |
8fbac729 |
952 | |
953 | our @ISA = qw( DBM::Deep::Engine::Sector ); |
954 | |
3976d8c9 |
955 | # This is in bytes |
956 | sub size { return 256 } |
c0507636 |
957 | sub free_meth { return '_add_free_data_sector' } |
3976d8c9 |
958 | |
2432d6cc |
959 | sub clone { |
960 | my $self = shift; |
961 | return ref($self)->new({ |
962 | engine => $self->engine, |
963 | data => $self->data, |
964 | type => $self->type, |
965 | }); |
966 | } |
967 | |
3976d8c9 |
968 | package DBM::Deep::Engine::Sector::Scalar; |
969 | |
970 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
971 | |
ad4ae302 |
972 | sub free { |
973 | my $self = shift; |
974 | |
975 | my $chain_loc = $self->chain_loc; |
976 | |
977 | $self->SUPER::free(); |
978 | |
979 | if ( $chain_loc ) { |
980 | $self->engine->_load_sector( $chain_loc )->free; |
981 | } |
982 | |
983 | return; |
984 | } |
985 | |
3976d8c9 |
986 | sub type { $_[0]{engine}->SIG_DATA } |
8fbac729 |
987 | sub _init { |
988 | my $self = shift; |
989 | |
990 | my $engine = $self->engine; |
991 | |
3976d8c9 |
992 | unless ( $self->offset ) { |
b6fc126b |
993 | my $data_section = $self->size - $self->base_size - 1 * $engine->byte_size - 1; |
3976d8c9 |
994 | |
c0507636 |
995 | $self->{offset} = $engine->_request_data_sector( $self->size ); |
ad4ae302 |
996 | |
2432d6cc |
997 | my $data = delete $self->{data}; |
ad4ae302 |
998 | my $dlen = length $data; |
999 | my $continue = 1; |
1000 | my $curr_offset = $self->offset; |
1001 | while ( $continue ) { |
1002 | |
1003 | my $next_offset = 0; |
1004 | |
1005 | my ($leftover, $this_len, $chunk); |
1006 | if ( $dlen > $data_section ) { |
1007 | $leftover = 0; |
1008 | $this_len = $data_section; |
1009 | $chunk = substr( $data, 0, $this_len ); |
1010 | |
1011 | $dlen -= $data_section; |
c0507636 |
1012 | $next_offset = $engine->_request_data_sector( $self->size ); |
ad4ae302 |
1013 | $data = substr( $data, $this_len ); |
1014 | } |
1015 | else { |
1016 | $leftover = $data_section - $dlen; |
1017 | $this_len = $dlen; |
1018 | $chunk = $data; |
1019 | |
1020 | $continue = 0; |
1021 | } |
1022 | |
8af340bf |
1023 | $engine->storage->print_at( $curr_offset, $self->type ); # Sector type |
1024 | # Skip staleness |
d58fd793 |
1025 | $engine->storage->print_at( $curr_offset + $self->base_size, |
ad4ae302 |
1026 | pack( $StP{$engine->byte_size}, $next_offset ), # Chain loc |
1027 | pack( $StP{1}, $this_len ), # Data length |
1028 | $chunk, # Data to be stored in this sector |
1029 | chr(0) x $leftover, # Zero-fill the rest |
1030 | ); |
1031 | |
1032 | $curr_offset = $next_offset; |
1033 | } |
3976d8c9 |
1034 | |
1035 | return; |
1036 | } |
1037 | } |
1038 | |
1039 | sub data_length { |
1040 | my $self = shift; |
1041 | |
ad4ae302 |
1042 | my $buffer = $self->engine->storage->read_at( |
b6fc126b |
1043 | $self->offset + $self->base_size + $self->engine->byte_size, 1 |
8fbac729 |
1044 | ); |
ad4ae302 |
1045 | |
1046 | return unpack( $StP{1}, $buffer ); |
1047 | } |
1048 | |
1049 | sub chain_loc { |
1050 | my $self = shift; |
3a917474 |
1051 | return unpack( |
1052 | $StP{$self->engine->byte_size}, |
1053 | $self->engine->storage->read_at( |
1054 | $self->offset + $self->base_size, |
1055 | $self->engine->byte_size, |
1056 | ), |
ad4ae302 |
1057 | ); |
3976d8c9 |
1058 | } |
1059 | |
1060 | sub data { |
1061 | my $self = shift; |
8fbac729 |
1062 | |
378b4748 |
1063 | my $data; |
1064 | while ( 1 ) { |
1065 | my $chain_loc = $self->chain_loc; |
ad4ae302 |
1066 | |
378b4748 |
1067 | $data .= $self->engine->storage->read_at( |
b6fc126b |
1068 | $self->offset + $self->base_size + $self->engine->byte_size + 1, $self->data_length, |
378b4748 |
1069 | ); |
ad4ae302 |
1070 | |
378b4748 |
1071 | last unless $chain_loc; |
1072 | |
1073 | $self = $self->engine->_load_sector( $chain_loc ); |
ad4ae302 |
1074 | } |
1075 | |
1076 | return $data; |
8fbac729 |
1077 | } |
1078 | |
68369f26 |
1079 | package DBM::Deep::Engine::Sector::Null; |
1080 | |
1081 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
1082 | |
1083 | sub type { $_[0]{engine}->SIG_NULL } |
1084 | sub data_length { 0 } |
1085 | sub data { return } |
1086 | |
1087 | sub _init { |
1088 | my $self = shift; |
1089 | |
1090 | my $engine = $self->engine; |
1091 | |
1092 | unless ( $self->offset ) { |
b6fc126b |
1093 | my $leftover = $self->size - $self->base_size - 1 * $engine->byte_size - 1; |
68369f26 |
1094 | |
c0507636 |
1095 | $self->{offset} = $engine->_request_data_sector( $self->size ); |
8af340bf |
1096 | $engine->storage->print_at( $self->offset, $self->type ); # Sector type |
1097 | # Skip staleness counter |
b6fc126b |
1098 | $engine->storage->print_at( $self->offset + $self->base_size, |
68369f26 |
1099 | pack( $StP{$engine->byte_size}, 0 ), # Chain loc |
1100 | pack( $StP{1}, $self->data_length ), # Data length |
1101 | chr(0) x $leftover, # Zero-fill the rest |
1102 | ); |
1103 | |
1104 | return; |
1105 | } |
1106 | } |
1107 | |
3976d8c9 |
1108 | package DBM::Deep::Engine::Sector::Reference; |
8fbac729 |
1109 | |
3976d8c9 |
1110 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
1111 | |
1112 | sub _init { |
1113 | my $self = shift; |
1114 | |
d58fd793 |
1115 | my $e = $self->engine; |
3976d8c9 |
1116 | |
1117 | unless ( $self->offset ) { |
ba075714 |
1118 | my $classname = Scalar::Util::blessed( delete $self->{data} ); |
d58fd793 |
1119 | my $leftover = $self->size - $self->base_size - 2 * $e->byte_size; |
d4f34951 |
1120 | |
1121 | my $class_offset = 0; |
1122 | if ( defined $classname ) { |
1123 | my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({ |
d58fd793 |
1124 | engine => $e, |
d4f34951 |
1125 | data => $classname, |
1126 | }); |
1127 | $class_offset = $class_sector->offset; |
1128 | } |
3976d8c9 |
1129 | |
c0507636 |
1130 | $self->{offset} = $e->_request_data_sector( $self->size ); |
d58fd793 |
1131 | $e->storage->print_at( $self->offset, $self->type ); # Sector type |
8af340bf |
1132 | # Skip staleness counter |
d58fd793 |
1133 | $e->storage->print_at( $self->offset + $self->base_size, |
1134 | pack( $StP{$e->byte_size}, 0 ), # Index/BList loc |
1135 | pack( $StP{$e->byte_size}, $class_offset ), # Classname loc |
c0507636 |
1136 | chr(0) x $leftover, # Zero-fill the rest |
3976d8c9 |
1137 | ); |
8af340bf |
1138 | } |
1139 | else { |
d58fd793 |
1140 | $self->{type} = $e->storage->read_at( $self->offset, 1 ); |
3976d8c9 |
1141 | } |
764e6cb9 |
1142 | |
8af340bf |
1143 | $self->{staleness} = unpack( |
d58fd793 |
1144 | $StP{$e->STALE_SIZE}, |
1145 | $e->storage->read_at( $self->offset + $e->SIG_SIZE, $e->STALE_SIZE ), |
8af340bf |
1146 | ); |
764e6cb9 |
1147 | |
1148 | return; |
3976d8c9 |
1149 | } |
1150 | |
d938be6a |
1151 | sub free { |
1152 | my $self = shift; |
1153 | |
1154 | my $blist_loc = $self->get_blist_loc; |
1155 | $self->engine->_load_sector( $blist_loc )->free if $blist_loc; |
1156 | |
1157 | my $class_loc = $self->get_class_offset; |
1158 | $self->engine->_load_sector( $class_loc )->free if $class_loc; |
1159 | |
1160 | $self->SUPER::free(); |
1161 | } |
1162 | |
8af340bf |
1163 | sub staleness { $_[0]{staleness} } |
1164 | |
2432d6cc |
1165 | sub get_data_for { |
1166 | my $self = shift; |
1167 | my ($args) = @_; |
1168 | |
1169 | # Assume that the head is not allowed unless otherwise specified. |
1170 | $args->{allow_head} = 0 unless exists $args->{allow_head}; |
1171 | |
1172 | # Assume we don't create a new blist location unless otherwise specified. |
1173 | $args->{create} = 0 unless exists $args->{create}; |
1174 | |
1175 | my $blist = $self->get_bucket_list({ |
1176 | key_md5 => $args->{key_md5}, |
0f4ed906 |
1177 | key => $args->{key}, |
2432d6cc |
1178 | create => $args->{create}, |
1179 | }); |
1180 | return unless $blist && $blist->{found}; |
1181 | |
1182 | # At this point, $blist knows where the md5 is. What it -doesn't- know yet |
1183 | # is whether or not this transaction has this key. That's part of the next |
1184 | # function call. |
1185 | my $location = $blist->get_data_location_for({ |
1186 | allow_head => $args->{allow_head}, |
1187 | }) or return; |
1188 | |
1189 | return $self->engine->_load_sector( $location ); |
1190 | } |
1191 | |
1192 | sub write_data { |
1193 | my $self = shift; |
1194 | my ($args) = @_; |
1195 | |
1196 | my $blist = $self->get_bucket_list({ |
1197 | key_md5 => $args->{key_md5}, |
0f4ed906 |
1198 | key => $args->{key}, |
2432d6cc |
1199 | create => 1, |
a67c4bbf |
1200 | }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" ); |
2432d6cc |
1201 | |
1202 | # Handle any transactional bookkeeping. |
1203 | if ( $self->engine->trans_id ) { |
d938be6a |
1204 | if ( ! $blist->has_md5 ) { |
2432d6cc |
1205 | $blist->mark_deleted({ |
1206 | trans_id => 0, |
1207 | }); |
1208 | } |
1209 | } |
1210 | else { |
cf03415a |
1211 | my @trans_ids = $self->engine->get_running_txn_ids; |
d938be6a |
1212 | if ( $blist->has_md5 ) { |
2432d6cc |
1213 | if ( @trans_ids ) { |
1214 | my $old_value = $blist->get_data_for; |
1215 | foreach my $other_trans_id ( @trans_ids ) { |
b4e17919 |
1216 | next if $blist->get_data_location_for({ |
1217 | trans_id => $other_trans_id, |
1218 | allow_head => 0, |
1219 | }); |
2432d6cc |
1220 | $blist->write_md5({ |
1221 | trans_id => $other_trans_id, |
1222 | key => $args->{key}, |
1223 | key_md5 => $args->{key_md5}, |
1224 | value => $old_value->clone, |
1225 | }); |
1226 | } |
1227 | } |
1228 | } |
1229 | else { |
1230 | if ( @trans_ids ) { |
1231 | foreach my $other_trans_id ( @trans_ids ) { |
a67c4bbf |
1232 | #XXX This doesn't seem to possible to ever happen . . . |
2432d6cc |
1233 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
1234 | $blist->mark_deleted({ |
1235 | trans_id => $other_trans_id, |
1236 | }); |
1237 | } |
1238 | } |
1239 | } |
1240 | } |
1241 | |
6f999f6e |
1242 | #XXX Is this safe to do transactionally? |
2432d6cc |
1243 | # Free the place we're about to write to. |
1244 | if ( $blist->get_data_location_for({ allow_head => 0 }) ) { |
1245 | $blist->get_data_for({ allow_head => 0 })->free; |
1246 | } |
1247 | |
1248 | $blist->write_md5({ |
1249 | key => $args->{key}, |
1250 | key_md5 => $args->{key_md5}, |
1251 | value => $args->{value}, |
1252 | }); |
1253 | } |
1254 | |
1255 | sub delete_key { |
1256 | my $self = shift; |
1257 | my ($args) = @_; |
1258 | |
1259 | # XXX What should happen if this fails? |
1260 | my $blist = $self->get_bucket_list({ |
1261 | key_md5 => $args->{key_md5}, |
a67c4bbf |
1262 | }) or DBM::Deep->_throw_error( "How did delete_key fail (no blist)?!" ); |
2432d6cc |
1263 | |
6f999f6e |
1264 | # Save the location so that we can free the data |
1265 | my $location = $blist->get_data_location_for({ |
1266 | allow_head => 0, |
1267 | }); |
26897a1c |
1268 | my $old_value = $location && $self->engine->_load_sector( $location ); |
6f999f6e |
1269 | |
3a917474 |
1270 | my @trans_ids = $self->engine->get_running_txn_ids; |
1271 | |
6f999f6e |
1272 | if ( $self->engine->trans_id == 0 ) { |
6f999f6e |
1273 | if ( @trans_ids ) { |
1274 | foreach my $other_trans_id ( @trans_ids ) { |
1275 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
1276 | $blist->write_md5({ |
1277 | trans_id => $other_trans_id, |
1278 | key => $args->{key}, |
1279 | key_md5 => $args->{key_md5}, |
1280 | value => $old_value->clone, |
1281 | }); |
1282 | } |
1283 | } |
1284 | } |
1285 | |
26897a1c |
1286 | my $data; |
3a917474 |
1287 | if ( @trans_ids ) { |
1288 | $blist->mark_deleted( $args ); |
1289 | |
1290 | if ( $old_value ) { |
1291 | $data = $old_value->data; |
1292 | $old_value->free; |
1293 | } |
1294 | } |
1295 | else { |
1296 | $data = $blist->delete_md5( $args ); |
26897a1c |
1297 | } |
6f999f6e |
1298 | |
1299 | return $data; |
2432d6cc |
1300 | } |
1301 | |
3976d8c9 |
1302 | sub get_blist_loc { |
1303 | my $self = shift; |
1304 | |
2432d6cc |
1305 | my $e = $self->engine; |
b6fc126b |
1306 | my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size ); |
2432d6cc |
1307 | return unpack( $StP{$e->byte_size}, $blist_loc ); |
3976d8c9 |
1308 | } |
1309 | |
1310 | sub get_bucket_list { |
1311 | my $self = shift; |
1312 | my ($args) = @_; |
4eee718c |
1313 | $args ||= {}; |
3976d8c9 |
1314 | |
1315 | # XXX Add in check here for recycling? |
1316 | |
1317 | my $engine = $self->engine; |
1318 | |
1319 | my $blist_loc = $self->get_blist_loc; |
1320 | |
1321 | # There's no index or blist yet |
1322 | unless ( $blist_loc ) { |
1323 | return unless $args->{create}; |
1324 | |
1325 | my $blist = DBM::Deep::Engine::Sector::BucketList->new({ |
2432d6cc |
1326 | engine => $engine, |
1327 | key_md5 => $args->{key_md5}, |
3976d8c9 |
1328 | }); |
2432d6cc |
1329 | |
b6fc126b |
1330 | $engine->storage->print_at( $self->offset + $self->base_size, |
3976d8c9 |
1331 | pack( $StP{$engine->byte_size}, $blist->offset ), |
1332 | ); |
2432d6cc |
1333 | |
3976d8c9 |
1334 | return $blist; |
1335 | } |
1336 | |
d938be6a |
1337 | my $sector = $engine->_load_sector( $blist_loc ) |
a67c4bbf |
1338 | or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); |
d938be6a |
1339 | my $i = 0; |
1340 | my $last_sector = undef; |
1341 | while ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) { |
6a4f323c |
1342 | $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) ); |
d938be6a |
1343 | $last_sector = $sector; |
625a24b4 |
1344 | if ( $blist_loc ) { |
1345 | $sector = $engine->_load_sector( $blist_loc ) |
a67c4bbf |
1346 | or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" ); |
625a24b4 |
1347 | } |
1348 | else { |
1349 | $sector = undef; |
1350 | last; |
1351 | } |
1352 | } |
1353 | |
1354 | # This means we went through the Index sector(s) and found an empty slot |
1355 | unless ( $sector ) { |
1356 | return unless $args->{create}; |
1357 | |
a67c4bbf |
1358 | DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" ) |
625a24b4 |
1359 | unless $last_sector; |
1360 | |
1361 | my $blist = DBM::Deep::Engine::Sector::BucketList->new({ |
1362 | engine => $engine, |
1363 | key_md5 => $args->{key_md5}, |
1364 | }); |
1365 | |
1366 | $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset ); |
1367 | |
1368 | return $blist; |
d938be6a |
1369 | } |
1370 | |
1371 | $sector->find_md5( $args->{key_md5} ); |
1372 | |
1373 | # See whether or not we need to reindex the bucketlist |
6a4f323c |
1374 | if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) { |
6a4f323c |
1375 | my $new_index = DBM::Deep::Engine::Sector::Index->new({ |
1376 | engine => $engine, |
1377 | }); |
1378 | |
1379 | my %blist_cache; |
65bd261b |
1380 | #XXX q.v. the comments for this function. |
1381 | foreach my $entry ( $sector->chopped_up ) { |
1382 | my ($spot, $md5) = @{$entry}; |
6a4f323c |
1383 | my $idx = ord( substr( $md5, $i, 1 ) ); |
1384 | |
0f4ed906 |
1385 | # XXX This is inefficient |
6a4f323c |
1386 | my $blist = $blist_cache{$idx} |
1387 | ||= DBM::Deep::Engine::Sector::BucketList->new({ |
1388 | engine => $engine, |
1389 | }); |
1390 | |
1391 | $new_index->set_entry( $idx => $blist->offset ); |
1392 | |
65bd261b |
1393 | my $new_spot = $blist->write_at_next_open( $md5 ); |
1394 | $engine->reindex_entry( $spot => $new_spot ); |
6a4f323c |
1395 | } |
1396 | |
0f4ed906 |
1397 | # Handle the new item separately. |
1398 | { |
1399 | my $idx = ord( substr( $args->{key_md5}, $i, 1 ) ); |
1400 | my $blist = $blist_cache{$idx} |
1401 | ||= DBM::Deep::Engine::Sector::BucketList->new({ |
1402 | engine => $engine, |
1403 | }); |
1404 | |
1405 | $new_index->set_entry( $idx => $blist->offset ); |
1406 | |
1407 | #XXX THIS IS HACKY! |
1408 | $blist->find_md5( $args->{key_md5} ); |
1409 | $blist->write_md5({ |
1410 | key => $args->{key}, |
1411 | key_md5 => $args->{key_md5}, |
1412 | value => DBM::Deep::Engine::Sector::Null->new({ |
1413 | engine => $engine, |
1414 | data => undef, |
1415 | }), |
1416 | }); |
1417 | } |
1418 | |
6a4f323c |
1419 | if ( $last_sector ) { |
1420 | $last_sector->set_entry( |
1421 | ord( substr( $args->{key_md5}, $i - 1, 1 ) ), |
1422 | $new_index->offset, |
1423 | ); |
1424 | } else { |
1425 | $engine->storage->print_at( $self->offset + $self->base_size, |
1426 | pack( $StP{$engine->byte_size}, $new_index->offset ), |
1427 | ); |
1428 | } |
1429 | |
1430 | $sector->free; |
1431 | |
1432 | $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) }; |
1433 | $sector->find_md5( $args->{key_md5} ); |
d938be6a |
1434 | } |
1435 | |
1436 | return $sector; |
3976d8c9 |
1437 | } |
1438 | |
d938be6a |
1439 | sub get_class_offset { |
ba075714 |
1440 | my $self = shift; |
1441 | |
d938be6a |
1442 | my $e = $self->engine; |
1443 | return unpack( |
1444 | $StP{$e->byte_size}, |
1445 | $e->storage->read_at( |
1446 | $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size, |
1447 | ), |
ba075714 |
1448 | ); |
d938be6a |
1449 | } |
1450 | |
1451 | sub get_classname { |
1452 | my $self = shift; |
1453 | |
1454 | my $class_offset = $self->get_class_offset; |
ba075714 |
1455 | |
d4f34951 |
1456 | return unless $class_offset; |
ba075714 |
1457 | |
d4f34951 |
1458 | return $self->engine->_load_sector( $class_offset )->data; |
ba075714 |
1459 | } |
1460 | |
a67c4bbf |
1461 | #XXX Add singleton handling here |
764e6cb9 |
1462 | sub data { |
1463 | my $self = shift; |
1464 | |
1465 | my $new_obj = DBM::Deep->new({ |
1466 | type => $self->type, |
1467 | base_offset => $self->offset, |
8af340bf |
1468 | staleness => $self->staleness, |
764e6cb9 |
1469 | storage => $self->engine->storage, |
c9f02899 |
1470 | engine => $self->engine, |
764e6cb9 |
1471 | }); |
1472 | |
ba075714 |
1473 | if ( $self->engine->storage->{autobless} ) { |
1474 | my $classname = $self->get_classname; |
1475 | if ( defined $classname ) { |
1476 | bless $new_obj, $classname; |
1477 | } |
1478 | } |
1479 | |
764e6cb9 |
1480 | return $new_obj; |
1481 | } |
1482 | |
3976d8c9 |
1483 | package DBM::Deep::Engine::Sector::BucketList; |
1484 | |
1485 | our @ISA = qw( DBM::Deep::Engine::Sector ); |
1486 | |
1487 | sub _init { |
1488 | my $self = shift; |
1489 | |
1490 | my $engine = $self->engine; |
1491 | |
1492 | unless ( $self->offset ) { |
c000ae6e |
1493 | my $leftover = $self->size - $self->base_size; |
3976d8c9 |
1494 | |
c0507636 |
1495 | $self->{offset} = $engine->_request_blist_sector( $self->size ); |
8af340bf |
1496 | $engine->storage->print_at( $self->offset, $engine->SIG_BLIST ); # Sector type |
1497 | # Skip staleness counter |
b6fc126b |
1498 | $engine->storage->print_at( $self->offset + $self->base_size, |
3976d8c9 |
1499 | chr(0) x $leftover, # Zero-fill the data |
1500 | ); |
1501 | } |
8fbac729 |
1502 | |
2432d6cc |
1503 | if ( $self->{key_md5} ) { |
1504 | $self->find_md5; |
1505 | } |
1506 | |
8fbac729 |
1507 | return $self; |
1508 | } |
8fbac729 |
1509 | |
3976d8c9 |
1510 | sub size { |
1511 | my $self = shift; |
2432d6cc |
1512 | unless ( $self->{size} ) { |
1513 | my $e = $self->engine; |
d938be6a |
1514 | # Base + numbuckets * bucketsize |
1515 | $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; |
2432d6cc |
1516 | } |
1517 | return $self->{size}; |
c000ae6e |
1518 | } |
1519 | |
c0507636 |
1520 | sub free_meth { return '_add_free_blist_sector' } |
1521 | |
c000ae6e |
1522 | sub bucket_size { |
1523 | my $self = shift; |
2432d6cc |
1524 | unless ( $self->{bucket_size} ) { |
1525 | my $e = $self->engine; |
6de4e4e9 |
1526 | # Key + head (location) + transactions (location + staleness-counter) |
17164f8a |
1527 | my $location_size = $e->byte_size + $e->num_txns * ( $e->byte_size + 4 ); |
6de4e4e9 |
1528 | $self->{bucket_size} = $e->hash_size + $location_size; |
2432d6cc |
1529 | } |
1530 | return $self->{bucket_size}; |
3976d8c9 |
1531 | } |
8fbac729 |
1532 | |
65bd261b |
1533 | # XXX This is such a poor hack. I need to rethink this code. |
6a4f323c |
1534 | sub chopped_up { |
1535 | my $self = shift; |
1536 | |
1537 | my $e = $self->engine; |
1538 | |
625a24b4 |
1539 | my @buckets; |
6a4f323c |
1540 | foreach my $idx ( 0 .. $e->max_buckets - 1 ) { |
65bd261b |
1541 | my $spot = $self->offset + $self->base_size + $idx * $self->bucket_size; |
1542 | my $md5 = $e->storage->read_at( $spot, $e->hash_size ); |
6a4f323c |
1543 | |
a67c4bbf |
1544 | #XXX If we're chopping, why would we ever have the blank_md5? |
6a4f323c |
1545 | last if $md5 eq $e->blank_md5; |
1546 | |
1547 | my $rest = $e->storage->read_at( undef, $self->bucket_size - $e->hash_size ); |
65bd261b |
1548 | push @buckets, [ $spot, $md5 . $rest ]; |
6a4f323c |
1549 | } |
1550 | |
625a24b4 |
1551 | return @buckets; |
6a4f323c |
1552 | } |
1553 | |
1554 | sub write_at_next_open { |
1555 | my $self = shift; |
65bd261b |
1556 | my ($entry) = @_; |
6a4f323c |
1557 | |
1558 | #XXX This is such a hack! |
625a24b4 |
1559 | $self->{_next_open} = 0 unless exists $self->{_next_open}; |
6a4f323c |
1560 | |
65bd261b |
1561 | my $spot = $self->offset + $self->base_size + $self->{_next_open}++ * $self->bucket_size; |
1562 | $self->engine->storage->print_at( $spot, $entry ); |
1563 | |
1564 | return $spot; |
6a4f323c |
1565 | } |
1566 | |
3976d8c9 |
1567 | sub has_md5 { |
c000ae6e |
1568 | my $self = shift; |
2432d6cc |
1569 | unless ( exists $self->{found} ) { |
1570 | $self->find_md5; |
1571 | } |
1572 | return $self->{found}; |
c000ae6e |
1573 | } |
1574 | |
1575 | sub find_md5 { |
1576 | my $self = shift; |
c000ae6e |
1577 | |
2432d6cc |
1578 | $self->{found} = undef; |
1579 | $self->{idx} = -1; |
c000ae6e |
1580 | |
d938be6a |
1581 | if ( @_ ) { |
1582 | $self->{key_md5} = shift; |
1583 | } |
1584 | |
2432d6cc |
1585 | # If we don't have an MD5, then what are we supposed to do? |
1586 | unless ( exists $self->{key_md5} ) { |
6f999f6e |
1587 | DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" ); |
2432d6cc |
1588 | } |
8cb9205a |
1589 | |
2432d6cc |
1590 | my $e = $self->engine; |
1591 | foreach my $idx ( 0 .. $e->max_buckets - 1 ) { |
1592 | my $potential = $e->storage->read_at( |
1593 | $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size, |
1594 | ); |
1595 | |
1596 | if ( $potential eq $e->blank_md5 ) { |
1597 | $self->{idx} = $idx; |
1598 | return; |
1599 | } |
8cb9205a |
1600 | |
2432d6cc |
1601 | if ( $potential eq $self->{key_md5} ) { |
1602 | $self->{found} = 1; |
1603 | $self->{idx} = $idx; |
1604 | return; |
8cb9205a |
1605 | } |
c000ae6e |
1606 | } |
1607 | |
1608 | return; |
3976d8c9 |
1609 | } |
1610 | |
1611 | sub write_md5 { |
1612 | my $self = shift; |
2432d6cc |
1613 | my ($args) = @_; |
2432d6cc |
1614 | |
6f999f6e |
1615 | DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key}; |
1616 | DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5}; |
1617 | DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value}; |
3976d8c9 |
1618 | |
1619 | my $engine = $self->engine; |
6f999f6e |
1620 | |
1621 | $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; |
1622 | |
2432d6cc |
1623 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
6f999f6e |
1624 | $engine->add_entry( $args->{trans_id}, $spot ); |
4eee718c |
1625 | |
2432d6cc |
1626 | unless ($self->{found}) { |
4eee718c |
1627 | my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({ |
6f999f6e |
1628 | engine => $engine, |
2432d6cc |
1629 | data => $args->{key}, |
4eee718c |
1630 | }); |
1631 | |
1632 | $engine->storage->print_at( $spot, |
2432d6cc |
1633 | $args->{key_md5}, |
6f999f6e |
1634 | pack( $StP{$engine->byte_size}, $key_sector->offset ), |
4eee718c |
1635 | ); |
1636 | } |
1637 | |
6f999f6e |
1638 | my $loc = $spot |
2432d6cc |
1639 | + $engine->hash_size |
1640 | + $engine->byte_size |
17164f8a |
1641 | + $args->{trans_id} * ( $engine->byte_size + 4 ); |
6f999f6e |
1642 | |
1643 | $engine->storage->print_at( $loc, |
2432d6cc |
1644 | pack( $StP{$engine->byte_size}, $args->{value}->offset ), |
6de4e4e9 |
1645 | pack( 'N', $engine->get_txn_staleness_counter( $args->{trans_id} ) ), |
2432d6cc |
1646 | ); |
1647 | } |
1648 | |
1649 | sub mark_deleted { |
1650 | my $self = shift; |
1651 | my ($args) = @_; |
6f999f6e |
1652 | $args ||= {}; |
1653 | |
1654 | my $engine = $self->engine; |
1655 | |
1656 | $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; |
2432d6cc |
1657 | |
1658 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
6f999f6e |
1659 | $engine->add_entry( $args->{trans_id}, $spot ); |
1660 | |
1661 | my $loc = $spot |
1662 | + $engine->hash_size |
1663 | + $engine->byte_size |
17164f8a |
1664 | + $args->{trans_id} * ( $engine->byte_size + 4 ); |
6f999f6e |
1665 | |
1666 | $engine->storage->print_at( $loc, |
1667 | pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted |
6de4e4e9 |
1668 | pack( 'N', $engine->get_txn_staleness_counter( $args->{trans_id} ) ), |
3976d8c9 |
1669 | ); |
1670 | } |
1671 | |
e86cef36 |
1672 | sub delete_md5 { |
3976d8c9 |
1673 | my $self = shift; |
2432d6cc |
1674 | my ($args) = @_; |
3976d8c9 |
1675 | |
e86cef36 |
1676 | my $engine = $self->engine; |
2432d6cc |
1677 | return undef unless $self->{found}; |
4eee718c |
1678 | |
1679 | # Save the location so that we can free the data |
2432d6cc |
1680 | my $location = $self->get_data_location_for({ |
1681 | allow_head => 0, |
1682 | }); |
1683 | my $key_sector = $self->get_key_for; |
4eee718c |
1684 | |
2432d6cc |
1685 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
4eee718c |
1686 | $engine->storage->print_at( $spot, |
1687 | $engine->storage->read_at( |
1688 | $spot + $self->bucket_size, |
3a917474 |
1689 | $self->bucket_size * ( $engine->max_buckets - $self->{idx} - 1 ), |
4eee718c |
1690 | ), |
1691 | chr(0) x $self->bucket_size, |
e86cef36 |
1692 | ); |
1693 | |
3ed26433 |
1694 | $key_sector->free; |
1695 | |
ed38e772 |
1696 | my $data_sector = $self->engine->_load_sector( $location ); |
1697 | my $data = $data_sector->data; |
ed38e772 |
1698 | $data_sector->free; |
5c0f86e1 |
1699 | |
1700 | return $data; |
e86cef36 |
1701 | } |
1702 | |
ed38e772 |
1703 | sub get_data_location_for { |
e86cef36 |
1704 | my $self = shift; |
2432d6cc |
1705 | my ($args) = @_; |
1706 | $args ||= {}; |
1707 | |
1708 | $args->{allow_head} = 0 unless exists $args->{allow_head}; |
1709 | $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id}; |
1710 | $args->{idx} = $self->{idx} unless exists $args->{idx}; |
e86cef36 |
1711 | |
6de4e4e9 |
1712 | my $e = $self->engine; |
1713 | |
1714 | my $spot = $self->offset + $self->base_size |
2432d6cc |
1715 | + $args->{idx} * $self->bucket_size |
6de4e4e9 |
1716 | + $e->hash_size |
1717 | + $e->byte_size |
17164f8a |
1718 | + $args->{trans_id} * ( $e->byte_size + 4 ); |
6de4e4e9 |
1719 | |
1720 | my $buffer = $e->storage->read_at( |
1721 | $spot, |
17164f8a |
1722 | $e->byte_size + 4, |
3976d8c9 |
1723 | ); |
6de4e4e9 |
1724 | my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' N', $buffer ); |
1725 | |
1726 | # We have found an entry that is old, so get rid of it |
41e27db3 |
1727 | if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) { |
6de4e4e9 |
1728 | $e->storage->print_at( |
1729 | $spot, |
1730 | pack( $StP{$e->byte_size} . ' N', (0) x 2 ), |
1731 | ); |
1732 | $loc = 0; |
1733 | } |
8cb9205a |
1734 | |
1735 | # If we're in a transaction and we never wrote to this location, try the |
1736 | # HEAD instead. |
2432d6cc |
1737 | if ( $args->{trans_id} && !$loc && $args->{allow_head} ) { |
1738 | return $self->get_data_location_for({ |
1739 | trans_id => 0, |
1740 | allow_head => 1, |
17164f8a |
1741 | idx => $args->{idx}, |
2432d6cc |
1742 | }); |
8cb9205a |
1743 | } |
2432d6cc |
1744 | return $loc <= 1 ? 0 : $loc; |
e86cef36 |
1745 | } |
1746 | |
1747 | sub get_data_for { |
1748 | my $self = shift; |
2432d6cc |
1749 | my ($args) = @_; |
1750 | $args ||= {}; |
e86cef36 |
1751 | |
2432d6cc |
1752 | return unless $self->{found}; |
1753 | my $location = $self->get_data_location_for({ |
1754 | allow_head => $args->{allow_head}, |
1755 | }); |
ed38e772 |
1756 | return $self->engine->_load_sector( $location ); |
1757 | } |
1758 | |
1759 | sub get_key_for { |
1760 | my $self = shift; |
1761 | my ($idx) = @_; |
2432d6cc |
1762 | $idx = $self->{idx} unless defined $idx; |
ed38e772 |
1763 | |
0f4ed906 |
1764 | if ( $idx >= $self->engine->max_buckets ) { |
1765 | DBM::Deep->_throw_error( "get_key_for(): Attempting to retrieve $idx" ); |
1766 | } |
1767 | |
ed38e772 |
1768 | my $location = $self->engine->storage->read_at( |
1769 | $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size, |
1770 | $self->engine->byte_size, |
1771 | ); |
1772 | $location = unpack( $StP{$self->engine->byte_size}, $location ); |
a67c4bbf |
1773 | DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location; |
1774 | |
68369f26 |
1775 | return $self->engine->_load_sector( $location ); |
3976d8c9 |
1776 | } |
696cadb7 |
1777 | |
8af340bf |
1778 | package DBM::Deep::Engine::Sector::Index; |
76c68c87 |
1779 | |
1780 | our @ISA = qw( DBM::Deep::Engine::Sector ); |
1781 | |
1782 | sub _init { |
1783 | my $self = shift; |
1784 | |
1785 | my $engine = $self->engine; |
1786 | |
1787 | unless ( $self->offset ) { |
1788 | my $leftover = $self->size - $self->base_size; |
1789 | |
c0507636 |
1790 | $self->{offset} = $engine->_request_index_sector( $self->size ); |
6a4f323c |
1791 | $engine->storage->print_at( $self->offset, $engine->SIG_INDEX ); # Sector type |
8af340bf |
1792 | # Skip staleness counter |
b6fc126b |
1793 | $engine->storage->print_at( $self->offset + $self->base_size, |
d58fd793 |
1794 | chr(0) x $leftover, # Zero-fill the rest |
76c68c87 |
1795 | ); |
1796 | } |
1797 | |
76c68c87 |
1798 | return $self; |
1799 | } |
1800 | |
76c68c87 |
1801 | sub size { |
1802 | my $self = shift; |
1803 | unless ( $self->{size} ) { |
1804 | my $e = $self->engine; |
d58fd793 |
1805 | $self->{size} = $self->base_size + $e->byte_size * $e->hash_chars; |
76c68c87 |
1806 | } |
1807 | return $self->{size}; |
1808 | } |
1809 | |
c0507636 |
1810 | sub free_meth { return '_add_free_index_sector' } |
1811 | |
d938be6a |
1812 | sub free { |
1813 | my $self = shift; |
1814 | my $e = $self->engine; |
1815 | |
1816 | for my $i ( 0 .. $e->hash_chars - 1 ) { |
7701c066 |
1817 | my $l = $self->get_entry( $i ) or next; |
d938be6a |
1818 | $e->_load_sector( $l )->free; |
1819 | } |
1820 | |
1821 | $self->SUPER::free(); |
1822 | } |
1823 | |
6a4f323c |
1824 | sub _loc_for { |
1825 | my $self = shift; |
1826 | my ($idx) = @_; |
1827 | return $self->offset + $self->base_size + $idx * $self->engine->byte_size; |
1828 | } |
1829 | |
1830 | sub get_entry { |
d938be6a |
1831 | my $self = shift; |
1832 | my ($idx) = @_; |
1833 | |
1834 | my $e = $self->engine; |
1835 | |
a67c4bbf |
1836 | DBM::Deep->_throw_error( "get_entry: Out of range ($idx)" ) |
0f4ed906 |
1837 | if $idx < 0 || $idx >= $e->hash_chars; |
1838 | |
d938be6a |
1839 | return unpack( |
1840 | $StP{$e->byte_size}, |
6a4f323c |
1841 | $e->storage->read_at( $self->_loc_for( $idx ), $e->byte_size ), |
1842 | ); |
1843 | } |
1844 | |
1845 | sub set_entry { |
1846 | my $self = shift; |
1847 | my ($idx, $loc) = @_; |
1848 | |
0f4ed906 |
1849 | my $e = $self->engine; |
1850 | |
a67c4bbf |
1851 | DBM::Deep->_throw_error( "set_entry: Out of range ($idx)" ) |
0f4ed906 |
1852 | if $idx < 0 || $idx >= $e->hash_chars; |
1853 | |
6a4f323c |
1854 | $self->engine->storage->print_at( |
1855 | $self->_loc_for( $idx ), |
0f4ed906 |
1856 | pack( $StP{$e->byte_size}, $loc ), |
d938be6a |
1857 | ); |
1858 | } |
1859 | |
76c68c87 |
1860 | 1; |
1861 | __END__ |