Commit | Line | Data |
696cadb7 |
1 | package DBM::Deep::Engine3; |
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 } |
30 | |
696cadb7 |
31 | ################################################################################ |
32 | |
8fbac729 |
33 | # Please refer to the pack() documentation for further information |
34 | my %StP = ( |
b4e17919 |
35 | 1 => 'C', # Unsigned char value (no order specified, presumably ASCII) |
8fbac729 |
36 | 2 => 'n', # Unsigned short in "network" (big-endian) order |
37 | 4 => 'N', # Unsigned long in "network" (big-endian) order |
38 | 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) |
c83524c6 |
39 | ); |
40 | |
696cadb7 |
41 | sub new { |
42 | my $class = shift; |
43 | my ($args) = @_; |
44 | |
45 | my $self = bless { |
c83524c6 |
46 | byte_size => 4, |
696cadb7 |
47 | |
c83524c6 |
48 | digest => undef, |
696cadb7 |
49 | hash_size => 16, # In bytes |
50 | max_buckets => 16, |
3976d8c9 |
51 | num_txns => 16, # HEAD plus 15 running txns |
8cb9205a |
52 | trans_id => 0, # Default to the HEAD |
696cadb7 |
53 | |
6f999f6e |
54 | entries => {}, # This is the list of entries for transactions |
696cadb7 |
55 | storage => undef, |
696cadb7 |
56 | }, $class; |
57 | |
58 | if ( defined $args->{pack_size} ) { |
59 | if ( lc $args->{pack_size} eq 'small' ) { |
c83524c6 |
60 | $args->{byte_size} = 2; |
696cadb7 |
61 | } |
62 | elsif ( lc $args->{pack_size} eq 'medium' ) { |
c83524c6 |
63 | $args->{byte_size} = 4; |
696cadb7 |
64 | } |
65 | elsif ( lc $args->{pack_size} eq 'large' ) { |
c83524c6 |
66 | $args->{byte_size} = 8; |
696cadb7 |
67 | } |
68 | else { |
69 | die "Unknown pack_size value: '$args->{pack_size}'\n"; |
70 | } |
71 | } |
72 | |
73 | # Grab the parameters we want to use |
74 | foreach my $param ( keys %$self ) { |
75 | next unless exists $args->{$param}; |
76 | $self->{$param} = $args->{$param}; |
77 | } |
696cadb7 |
78 | |
8fbac729 |
79 | $self->{byte_pack} = $StP{ $self->byte_size }; |
c83524c6 |
80 | |
696cadb7 |
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 | |
110 | my $key_md5 = $self->_apply_digest( $key ); |
111 | |
2432d6cc |
112 | my $value_sector = $sector->get_data_for({ |
113 | key_md5 => $key_md5, |
114 | allow_head => 1, |
115 | }); |
3976d8c9 |
116 | |
2432d6cc |
117 | unless ( $value_sector ) { |
4056dff7 |
118 | $value_sector = DBM::Deep::Engine::Sector::Null->new({ |
119 | engine => $self, |
120 | data => undef, |
121 | }); |
122 | |
2432d6cc |
123 | $sector->write_data({ |
124 | key_md5 => $key_md5, |
125 | key => $key, |
126 | value => $value_sector, |
127 | }); |
4056dff7 |
128 | } |
3976d8c9 |
129 | |
130 | return $value_sector->data; |
696cadb7 |
131 | } |
132 | |
84467b9f |
133 | sub get_classname { |
134 | my $self = shift; |
c9f02899 |
135 | my ($obj) = @_; |
84467b9f |
136 | |
137 | # This will be a Reference sector |
c9f02899 |
138 | my $sector = $self->_load_sector( $obj->_base_offset ) |
76c68c87 |
139 | or die "How did get_classname fail (no sector for '$obj')?!\n"; |
84467b9f |
140 | |
141 | return $sector->get_classname; |
142 | } |
143 | |
696cadb7 |
144 | sub key_exists { |
145 | my $self = shift; |
c9f02899 |
146 | my ($obj, $key) = @_; |
c000ae6e |
147 | |
148 | # This will be a Reference sector |
c9f02899 |
149 | my $sector = $self->_load_sector( $obj->_base_offset ) |
76c68c87 |
150 | or return ''; |
c000ae6e |
151 | |
2432d6cc |
152 | my $data = $sector->get_data_for({ |
153 | key_md5 => $self->_apply_digest( $key ), |
154 | allow_head => 1, |
155 | }); |
c000ae6e |
156 | |
e86cef36 |
157 | # exists() returns 1 or '' for true/false. |
2432d6cc |
158 | return $data ? 1 : ''; |
696cadb7 |
159 | } |
160 | |
161 | sub delete_key { |
162 | my $self = shift; |
c9f02899 |
163 | my ($obj, $key) = @_; |
e86cef36 |
164 | |
c9f02899 |
165 | my $sector = $self->_load_sector( $obj->_base_offset ) |
76c68c87 |
166 | or return; |
e86cef36 |
167 | |
2432d6cc |
168 | return $sector->delete_key({ |
169 | key_md5 => $self->_apply_digest( $key ), |
170 | allow_head => 0, |
171 | }); |
696cadb7 |
172 | } |
173 | |
174 | sub write_value { |
175 | my $self = shift; |
c9f02899 |
176 | my ($obj, $key, $value) = @_; |
3976d8c9 |
177 | |
764e6cb9 |
178 | my $r = Scalar::Util::reftype( $value ) || ''; |
d49782fe |
179 | { |
180 | last if $r eq ''; |
181 | last if $r eq 'HASH'; |
182 | last if $r eq 'ARRAY'; |
183 | |
184 | DBM::Deep->_throw_error( |
185 | "Storage of references of type '$r' is not supported." |
186 | ); |
187 | } |
188 | |
764e6cb9 |
189 | my ($class, $type); |
68369f26 |
190 | if ( !defined $value ) { |
4eee718c |
191 | $class = 'DBM::Deep::Engine::Sector::Null'; |
68369f26 |
192 | } |
764e6cb9 |
193 | elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) { |
d49782fe |
194 | if ( $r eq 'ARRAY' && tied(@$value) ) { |
25eb38b8 |
195 | DBM::Deep->_throw_error( "Cannot store something that is tied." ); |
d49782fe |
196 | } |
197 | if ( $r eq 'HASH' && tied(%$value) ) { |
25eb38b8 |
198 | DBM::Deep->_throw_error( "Cannot store something that is tied." ); |
d49782fe |
199 | } |
764e6cb9 |
200 | $class = 'DBM::Deep::Engine::Sector::Reference'; |
ed38e772 |
201 | $type = substr( $r, 0, 1 ); |
764e6cb9 |
202 | } |
68369f26 |
203 | else { |
4eee718c |
204 | $class = 'DBM::Deep::Engine::Sector::Scalar'; |
68369f26 |
205 | } |
3976d8c9 |
206 | |
2432d6cc |
207 | # This will be a Reference sector |
208 | my $sector = $self->_load_sector( $obj->_base_offset ) |
76c68c87 |
209 | or die "Cannot write to a deleted spot in DBM::Deep.\n"; |
ed38e772 |
210 | |
2432d6cc |
211 | # Create this after loading the reference sector in case something bad happens. |
212 | # This way, we won't allocate value sector(s) needlessly. |
4eee718c |
213 | my $value_sector = $class->new({ |
214 | engine => $self, |
215 | data => $value, |
764e6cb9 |
216 | type => $type, |
4eee718c |
217 | }); |
218 | |
2432d6cc |
219 | $sector->write_data({ |
220 | key => $key, |
221 | key_md5 => $self->_apply_digest( $key ), |
222 | value => $value_sector, |
223 | }); |
764e6cb9 |
224 | |
225 | # This code is to make sure we write all the values in the $value to the disk |
ed38e772 |
226 | # and to make sure all changes to $value after the assignment are reflected |
227 | # on disk. This may be counter-intuitive at first, but it is correct dwimmery. |
228 | # NOTE - simply tying $value won't perform a STORE on each value. Hence, the |
229 | # copy to a temp value. |
764e6cb9 |
230 | if ( $r eq 'ARRAY' ) { |
ed38e772 |
231 | my @temp = @$value; |
764e6cb9 |
232 | tie @$value, 'DBM::Deep', { |
233 | base_offset => $value_sector->offset, |
234 | storage => $self->storage, |
c9f02899 |
235 | engine => $self, |
764e6cb9 |
236 | }; |
ed38e772 |
237 | @$value = @temp; |
764e6cb9 |
238 | bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value ); |
239 | } |
240 | elsif ( $r eq 'HASH' ) { |
ed38e772 |
241 | my %temp = %$value; |
764e6cb9 |
242 | tie %$value, 'DBM::Deep', { |
243 | base_offset => $value_sector->offset, |
244 | storage => $self->storage, |
c9f02899 |
245 | engine => $self, |
764e6cb9 |
246 | }; |
ed38e772 |
247 | |
248 | %$value = %temp; |
764e6cb9 |
249 | bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value ); |
250 | } |
251 | |
252 | return 1; |
696cadb7 |
253 | } |
254 | |
255 | sub get_next_key { |
256 | my $self = shift; |
c9f02899 |
257 | my ($obj, $prev_key) = @_; |
ed38e772 |
258 | |
259 | # XXX Need to add logic about resetting the iterator if any key in the reference has changed |
260 | unless ( $prev_key ) { |
c9f02899 |
261 | $obj->{iterator} = DBM::Deep::Engine::Iterator->new({ |
262 | base_offset => $obj->_base_offset, |
ed38e772 |
263 | engine => $self, |
264 | }); |
4eee718c |
265 | } |
266 | |
c9f02899 |
267 | return $obj->{iterator}->get_next_key; |
696cadb7 |
268 | } |
269 | |
270 | ################################################################################ |
271 | |
272 | sub setup_fh { |
273 | my $self = shift; |
274 | my ($obj) = @_; |
275 | |
276 | # We're opening the file. |
277 | unless ( $obj->_base_offset ) { |
696cadb7 |
278 | my $bytes_read = $self->_read_file_header; |
696cadb7 |
279 | |
280 | # Creating a new file |
281 | unless ( $bytes_read ) { |
282 | $self->_write_file_header; |
c83524c6 |
283 | |
284 | # 1) Create Array/Hash entry |
8fbac729 |
285 | my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({ |
286 | engine => $self, |
287 | type => $obj->_type, |
288 | }); |
289 | $obj->{base_offset} = $initial_reference->offset; |
c83524c6 |
290 | |
8fbac729 |
291 | $self->storage->flush; |
696cadb7 |
292 | } |
293 | # Reading from an existing file |
294 | else { |
295 | $obj->{base_offset} = $bytes_read; |
764e6cb9 |
296 | my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({ |
297 | engine => $self, |
298 | offset => $obj->_base_offset, |
299 | }); |
300 | unless ( $initial_reference ) { |
696cadb7 |
301 | DBM::Deep->_throw_error("Corrupted file, no master index record"); |
302 | } |
303 | |
764e6cb9 |
304 | unless ($obj->_type eq $initial_reference->type) { |
696cadb7 |
305 | DBM::Deep->_throw_error("File type mismatch"); |
306 | } |
307 | } |
308 | } |
696cadb7 |
309 | |
696cadb7 |
310 | return 1; |
311 | } |
312 | |
8cb9205a |
313 | sub begin_work { |
c9f02899 |
314 | my $self = shift; |
8cb9205a |
315 | my ($obj) = @_; |
316 | |
317 | if ( $self->trans_id ) { |
6f999f6e |
318 | DBM::Deep->_throw_error( "Cannot begin_work within a transaction" ); |
8cb9205a |
319 | } |
320 | |
cf03415a |
321 | my @slots = $self->read_txn_slots; |
8cb9205a |
322 | for my $i ( 1 .. @slots ) { |
323 | next if $slots[$i]; |
324 | $slots[$i] = 1; |
325 | $self->set_trans_id( $i ); |
326 | last; |
327 | } |
cf03415a |
328 | $self->write_txn_slots( @slots ); |
8cb9205a |
329 | |
330 | if ( !$self->trans_id ) { |
6f999f6e |
331 | DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" ); |
8cb9205a |
332 | } |
333 | |
334 | return; |
c9f02899 |
335 | } |
696cadb7 |
336 | |
8cb9205a |
337 | sub rollback { |
696cadb7 |
338 | my $self = shift; |
8cb9205a |
339 | my ($obj) = @_; |
340 | |
341 | if ( !$self->trans_id ) { |
6f999f6e |
342 | DBM::Deep->_throw_error( "Cannot rollback without a transaction" ); |
343 | } |
344 | |
345 | # Each entry is the file location for a bucket that has a modification for |
346 | # this transaction. The entries need to be expunged. |
347 | foreach my $entry (@{ $self->get_entries } ) { |
348 | # Remove the entry here |
349 | my $read_loc = $entry |
350 | + $self->hash_size |
351 | + $self->byte_size |
17164f8a |
352 | + $self->trans_id * ( $self->byte_size + 4 ); |
6f999f6e |
353 | |
354 | my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size ); |
355 | $data_loc = unpack( $StP{$self->byte_size}, $data_loc ); |
356 | $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) ); |
357 | |
358 | if ( $data_loc > 1 ) { |
359 | $self->_load_sector( $data_loc )->free; |
360 | } |
8cb9205a |
361 | } |
6f999f6e |
362 | |
363 | $self->clear_entries; |
364 | |
cf03415a |
365 | my @slots = $self->read_txn_slots; |
6f999f6e |
366 | $slots[$self->trans_id] = 0; |
cf03415a |
367 | $self->write_txn_slots( @slots ); |
6de4e4e9 |
368 | $self->inc_txn_staleness_counter( $self->trans_id ); |
6f999f6e |
369 | $self->set_trans_id( 0 ); |
370 | |
371 | return 1; |
c9f02899 |
372 | } |
696cadb7 |
373 | |
8cb9205a |
374 | sub commit { |
c9f02899 |
375 | my $self = shift; |
8cb9205a |
376 | my ($obj) = @_; |
377 | |
378 | if ( !$self->trans_id ) { |
6f999f6e |
379 | DBM::Deep->_throw_error( "Cannot commit without a transaction" ); |
380 | } |
381 | |
6f999f6e |
382 | foreach my $entry (@{ $self->get_entries } ) { |
6f999f6e |
383 | # Overwrite the entry in head with the entry in trans_id |
384 | my $base = $entry |
385 | + $self->hash_size |
386 | + $self->byte_size; |
387 | |
388 | my $head_loc = $self->storage->read_at( $base, $self->byte_size ); |
389 | $head_loc = unpack( $StP{$self->byte_size}, $head_loc ); |
390 | my $trans_loc = $self->storage->read_at( |
17164f8a |
391 | $base + $self->trans_id * ( $self->byte_size + 4 ), $self->byte_size, |
6f999f6e |
392 | ); |
393 | |
394 | $self->storage->print_at( $base, $trans_loc ); |
395 | $self->storage->print_at( |
17164f8a |
396 | $base + $self->trans_id * ( $self->byte_size + 4 ), |
6de4e4e9 |
397 | pack( $StP{$self->byte_size} . ' N', (0) x 2 ), |
6f999f6e |
398 | ); |
399 | |
400 | if ( $head_loc > 1 ) { |
401 | $self->_load_sector( $head_loc )->free; |
402 | } |
8cb9205a |
403 | } |
6f999f6e |
404 | |
405 | $self->clear_entries; |
406 | |
cf03415a |
407 | my @slots = $self->read_txn_slots; |
6f999f6e |
408 | $slots[$self->trans_id] = 0; |
cf03415a |
409 | $self->write_txn_slots( @slots ); |
6de4e4e9 |
410 | $self->inc_txn_staleness_counter( $self->trans_id ); |
6f999f6e |
411 | $self->set_trans_id( 0 ); |
412 | |
413 | return 1; |
8cb9205a |
414 | } |
415 | |
cf03415a |
416 | sub read_txn_slots { |
8cb9205a |
417 | my $self = shift; |
cf03415a |
418 | return split '', unpack( 'b32', |
419 | $self->storage->read_at( |
420 | $self->trans_loc, 4, |
421 | ) |
422 | ); |
8cb9205a |
423 | } |
424 | |
cf03415a |
425 | sub write_txn_slots { |
8cb9205a |
426 | my $self = shift; |
427 | $self->storage->print_at( $self->trans_loc, |
cf03415a |
428 | pack( 'b32', join('', @_) ), |
8cb9205a |
429 | ); |
c9f02899 |
430 | } |
696cadb7 |
431 | |
cf03415a |
432 | sub get_running_txn_ids { |
433 | my $self = shift; |
434 | my @transactions = $self->read_txn_slots; |
435 | my @trans_ids = grep { $transactions[$_] } 0 .. $#transactions; |
436 | } |
437 | |
6de4e4e9 |
438 | sub get_txn_staleness_counter { |
439 | my $self = shift; |
440 | my ($trans_id) = @_; |
b4e17919 |
441 | |
442 | # Hardcode staleness of 0 for the HEAD |
443 | return 0 unless $trans_id; |
444 | |
41e27db3 |
445 | my $x = unpack( 'N', |
6de4e4e9 |
446 | $self->storage->read_at( |
b4e17919 |
447 | $self->trans_loc + 4 * $trans_id, |
41e27db3 |
448 | 4, |
6de4e4e9 |
449 | ) |
450 | ); |
41e27db3 |
451 | return $x; |
6de4e4e9 |
452 | } |
453 | |
454 | sub inc_txn_staleness_counter { |
455 | my $self = shift; |
456 | my ($trans_id) = @_; |
b4e17919 |
457 | |
458 | # Hardcode staleness of 0 for the HEAD |
459 | return unless $trans_id; |
460 | |
6de4e4e9 |
461 | $self->storage->print_at( |
b4e17919 |
462 | $self->trans_loc + 4 * $trans_id, |
6de4e4e9 |
463 | pack( 'N', $self->get_txn_staleness_counter( $trans_id ) + 1 ), |
464 | ); |
465 | } |
466 | |
6f999f6e |
467 | sub get_entries { |
468 | my $self = shift; |
469 | return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ]; |
470 | } |
471 | |
472 | sub add_entry { |
473 | my $self = shift; |
474 | my ($trans_id, $loc) = @_; |
475 | |
6f999f6e |
476 | $self->{entries}{$trans_id} ||= {}; |
477 | $self->{entries}{$trans_id}{$loc} = undef; |
6f999f6e |
478 | } |
479 | |
480 | sub clear_entries { |
481 | my $self = shift; |
6f999f6e |
482 | delete $self->{entries}{$self->trans_id}; |
483 | } |
484 | |
c9f02899 |
485 | ################################################################################ |
b9ec359f |
486 | |
c9f02899 |
487 | { |
488 | my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4; |
696cadb7 |
489 | |
c9f02899 |
490 | sub _write_file_header { |
491 | my $self = shift; |
696cadb7 |
492 | |
cf03415a |
493 | my $header_var = 1 + 1 + 4 + 4 * $self->num_txns + 2 * $self->byte_size; |
696cadb7 |
494 | |
c9f02899 |
495 | my $loc = $self->storage->request_space( $header_fixed + $header_var ); |
c83524c6 |
496 | |
c9f02899 |
497 | $self->storage->print_at( $loc, |
498 | SIG_FILE, |
499 | SIG_HEADER, |
500 | pack('N', 1), # header version - at this point, we're at 9 bytes |
501 | pack('N', $header_var), # header size |
502 | # --- Above is $header_fixed. Below is $header_var |
503 | pack('C', $self->byte_size), |
504 | pack('C', $self->max_buckets), |
b4e17919 |
505 | pack('N', 0 ), # Transaction activeness bitfield |
506 | pack('N' . $self->num_txns, 0 x $self->num_txns ), # Transaction staleness counters |
c9f02899 |
507 | pack($StP{$self->byte_size}, 0), # Start of free chain (blist size) |
508 | pack($StP{$self->byte_size}, 0), # Start of free chain (data size) |
509 | ); |
696cadb7 |
510 | |
c9f02899 |
511 | $self->set_trans_loc( $header_fixed + 2 ); |
cf03415a |
512 | $self->set_chains_loc( $header_fixed + 2 + 4 + 4 * $self->num_txns ); |
696cadb7 |
513 | |
c9f02899 |
514 | return; |
696cadb7 |
515 | } |
516 | |
c9f02899 |
517 | sub _read_file_header { |
518 | my $self = shift; |
696cadb7 |
519 | |
c9f02899 |
520 | my $buffer = $self->storage->read_at( 0, $header_fixed ); |
521 | return unless length($buffer); |
696cadb7 |
522 | |
c9f02899 |
523 | my ($file_signature, $sig_header, $header_version, $size) = unpack( |
524 | 'A4 A N N', $buffer |
525 | ); |
b9ec359f |
526 | |
c9f02899 |
527 | unless ( $file_signature eq SIG_FILE ) { |
528 | $self->storage->close; |
529 | DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" ); |
530 | } |
696cadb7 |
531 | |
c9f02899 |
532 | unless ( $sig_header eq SIG_HEADER ) { |
533 | $self->storage->close; |
534 | DBM::Deep->_throw_error( "Old file version found." ); |
535 | } |
696cadb7 |
536 | |
c9f02899 |
537 | my $buffer2 = $self->storage->read_at( undef, $size ); |
538 | my @values = unpack( 'C C', $buffer2 ); |
696cadb7 |
539 | |
c9f02899 |
540 | $self->set_trans_loc( $header_fixed + 2 ); |
cf03415a |
541 | $self->set_chains_loc( $header_fixed + 2 + 4 + 4 * $self->num_txns ); |
c9f02899 |
542 | |
543 | if ( @values < 2 || grep { !defined } @values ) { |
544 | $self->storage->close; |
545 | DBM::Deep->_throw_error("Corrupted file - bad header"); |
546 | } |
547 | |
548 | #XXX Add warnings if values weren't set right |
549 | @{$self}{qw(byte_size max_buckets)} = @values; |
b9ec359f |
550 | |
cf03415a |
551 | my $header_var = 1 + 1 + 4 + 4 * $self->num_txns + 2 * $self->byte_size; |
c9f02899 |
552 | unless ( $size eq $header_var ) { |
553 | $self->storage->close; |
554 | DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." ); |
555 | } |
556 | |
557 | return length($buffer) + length($buffer2); |
558 | } |
696cadb7 |
559 | } |
560 | |
3976d8c9 |
561 | sub _load_sector { |
562 | my $self = shift; |
563 | my ($offset) = @_; |
564 | |
565 | my $type = $self->storage->read_at( $offset, 1 ); |
b9ec359f |
566 | return if $type eq chr(0); |
567 | |
3976d8c9 |
568 | if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) { |
569 | return DBM::Deep::Engine::Sector::Reference->new({ |
570 | engine => $self, |
571 | type => $type, |
572 | offset => $offset, |
573 | }); |
574 | } |
2432d6cc |
575 | # XXX Don't we need key_md5 here? |
3976d8c9 |
576 | elsif ( $type eq $self->SIG_BLIST ) { |
577 | return DBM::Deep::Engine::Sector::BucketList->new({ |
578 | engine => $self, |
579 | type => $type, |
580 | offset => $offset, |
581 | }); |
582 | } |
68369f26 |
583 | elsif ( $type eq $self->SIG_NULL ) { |
584 | return DBM::Deep::Engine::Sector::Null->new({ |
585 | engine => $self, |
586 | type => $type, |
587 | offset => $offset, |
588 | }); |
589 | } |
590 | elsif ( $type eq $self->SIG_DATA ) { |
591 | return DBM::Deep::Engine::Sector::Scalar->new({ |
592 | engine => $self, |
593 | type => $type, |
594 | offset => $offset, |
595 | }); |
596 | } |
b9ec359f |
597 | # This was deleted from under us, so just return and let the caller figure it out. |
598 | elsif ( $type eq $self->SIG_FREE ) { |
599 | return; |
600 | } |
3976d8c9 |
601 | |
ed38e772 |
602 | die "'$offset': Don't know what to do with type '$type'\n"; |
3976d8c9 |
603 | } |
604 | |
605 | sub _apply_digest { |
606 | my $self = shift; |
607 | return $self->{digest}->(@_); |
608 | } |
609 | |
ed38e772 |
610 | sub _add_free_sector { |
611 | my $self = shift; |
612 | my ($offset, $size) = @_; |
b9ec359f |
613 | |
614 | my $chains_offset; |
615 | # Data sector |
616 | if ( $size == 256 ) { |
617 | $chains_offset = $self->byte_size; |
618 | } |
619 | # Blist sector |
620 | else { |
621 | $chains_offset = 0; |
622 | } |
623 | |
624 | my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); |
625 | |
3ed26433 |
626 | $self->storage->print_at( $self->chains_loc + $chains_offset, |
b9ec359f |
627 | pack( $StP{$self->byte_size}, $offset ), |
628 | ); |
629 | |
630 | # Record the old head in the new sector after the signature |
631 | $self->storage->print_at( $offset + 1, $old_head ); |
632 | } |
633 | |
634 | sub _request_sector { |
635 | my $self = shift; |
636 | my ($size) = @_; |
637 | |
638 | my $chains_offset; |
639 | # Data sector |
640 | if ( $size == 256 ) { |
641 | $chains_offset = $self->byte_size; |
642 | } |
643 | # Blist sector |
644 | else { |
645 | $chains_offset = 0; |
646 | } |
647 | |
648 | my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); |
649 | my $loc = unpack( $StP{$self->byte_size}, $old_head ); |
650 | |
651 | # We don't have any free sectors of the right size, so allocate a new one. |
652 | unless ( $loc ) { |
653 | return $self->storage->request_space( $size ); |
654 | } |
655 | |
656 | my $new_head = $self->storage->read_at( $loc + 1, $self->byte_size ); |
657 | $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head ); |
658 | |
659 | return $loc; |
ed38e772 |
660 | } |
661 | |
696cadb7 |
662 | ################################################################################ |
663 | |
3976d8c9 |
664 | sub storage { $_[0]{storage} } |
665 | sub byte_size { $_[0]{byte_size} } |
666 | sub hash_size { $_[0]{hash_size} } |
667 | sub num_txns { $_[0]{num_txns} } |
668 | sub max_buckets { $_[0]{max_buckets} } |
c000ae6e |
669 | sub blank_md5 { chr(0) x $_[0]->hash_size } |
8fbac729 |
670 | |
8cb9205a |
671 | sub trans_id { $_[0]{trans_id} } |
672 | sub set_trans_id { $_[0]{trans_id} = $_[1] } |
673 | |
c9f02899 |
674 | sub trans_loc { $_[0]{trans_loc} } |
675 | sub set_trans_loc { $_[0]{trans_loc} = $_[1] } |
676 | |
b9ec359f |
677 | sub chains_loc { $_[0]{chains_loc} } |
678 | sub set_chains_loc { $_[0]{chains_loc} = $_[1] } |
679 | |
8fbac729 |
680 | ################################################################################ |
681 | |
ed38e772 |
682 | package DBM::Deep::Engine::Iterator; |
683 | |
684 | sub new { |
685 | my $class = shift; |
686 | my ($args) = @_; |
687 | |
688 | my $self = bless { |
689 | breadcrumbs => [], |
690 | engine => $args->{engine}, |
691 | base_offset => $args->{base_offset}, |
ed38e772 |
692 | }, $class; |
693 | |
694 | Scalar::Util::weaken( $self->{engine} ); |
695 | |
696 | return $self; |
697 | } |
698 | |
699 | sub reset { |
700 | my $self = shift; |
701 | $self->{breadcrumbs} = []; |
702 | } |
703 | |
704 | sub get_next_key { |
705 | my $self = shift; |
706 | |
707 | my $crumbs = $self->{breadcrumbs}; |
708 | |
709 | unless ( @$crumbs ) { |
710 | # This will be a Reference sector |
711 | my $sector = $self->{engine}->_load_sector( $self->{base_offset} ) |
b9ec359f |
712 | # or die "Iterator: How did this fail (no ref sector for '$self->{base_offset}')?!\n"; |
713 | # If no sector is found, thist must have been deleted from under us. |
714 | or return; |
ed38e772 |
715 | push @$crumbs, [ $sector->get_blist_loc, 0 ]; |
716 | } |
717 | |
718 | my $key; |
719 | while ( 1 ) { |
720 | my ($offset, $idx) = @{ $crumbs->[-1] }; |
721 | unless ( $offset ) { |
722 | $self->reset; |
723 | last; |
724 | } |
725 | |
2432d6cc |
726 | if ( $idx >= $self->{engine}->max_buckets ) { |
727 | $self->reset; |
728 | last; |
729 | } |
730 | |
ed38e772 |
731 | my $sector = $self->{engine}->_load_sector( $offset ) |
b9ec359f |
732 | or die "Iterator: How did this fail (no blist sector for '$offset')?!\n"; |
ed38e772 |
733 | |
2432d6cc |
734 | #XXX Think this through! |
735 | my $loc = $sector->get_data_location_for({ |
736 | idx => $idx, |
17164f8a |
737 | allow_head => 1, |
2432d6cc |
738 | }); |
739 | unless ( $loc ) { |
740 | $crumbs->[-1][1]++; |
741 | next; |
742 | } |
743 | |
ed38e772 |
744 | my $key_sector = $sector->get_key_for( $idx ); |
745 | unless ( $key_sector ) { |
746 | $self->reset; |
747 | last; |
748 | } |
749 | |
750 | $crumbs->[-1][1]++; |
751 | $key = $key_sector->data; |
752 | last; |
753 | } |
754 | |
755 | return $key; |
756 | } |
757 | |
3976d8c9 |
758 | package DBM::Deep::Engine::Sector; |
759 | |
760 | sub new { |
761 | my $self = bless $_[1], $_[0]; |
762 | Scalar::Util::weaken( $self->{engine} ); |
763 | $self->_init; |
764 | return $self; |
765 | } |
766 | sub _init {} |
2432d6cc |
767 | sub clone { die "Must be implemented in the child class" } |
3976d8c9 |
768 | |
769 | sub engine { $_[0]{engine} } |
770 | sub offset { $_[0]{offset} } |
771 | sub type { $_[0]{type} } |
772 | |
ed38e772 |
773 | sub free { |
774 | my $self = shift; |
775 | |
b9ec359f |
776 | $self->engine->storage->print_at( $self->offset, |
777 | $self->engine->SIG_FREE, |
778 | chr(0) x ($self->size - 1), |
779 | ); |
780 | |
ed38e772 |
781 | $self->engine->_add_free_sector( |
782 | $self->offset, $self->size, |
783 | ); |
784 | |
b9ec359f |
785 | return; |
ed38e772 |
786 | } |
3976d8c9 |
787 | |
788 | package DBM::Deep::Engine::Sector::Data; |
8fbac729 |
789 | |
790 | our @ISA = qw( DBM::Deep::Engine::Sector ); |
791 | |
3976d8c9 |
792 | # This is in bytes |
793 | sub size { return 256 } |
794 | |
2432d6cc |
795 | sub clone { |
796 | my $self = shift; |
797 | return ref($self)->new({ |
798 | engine => $self->engine, |
799 | data => $self->data, |
800 | type => $self->type, |
801 | }); |
802 | } |
803 | |
3976d8c9 |
804 | package DBM::Deep::Engine::Sector::Scalar; |
805 | |
806 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
807 | |
ad4ae302 |
808 | sub free { |
809 | my $self = shift; |
810 | |
811 | my $chain_loc = $self->chain_loc; |
812 | |
813 | $self->SUPER::free(); |
814 | |
815 | if ( $chain_loc ) { |
816 | $self->engine->_load_sector( $chain_loc )->free; |
817 | } |
818 | |
819 | return; |
820 | } |
821 | |
3976d8c9 |
822 | sub type { $_[0]{engine}->SIG_DATA } |
8fbac729 |
823 | sub _init { |
824 | my $self = shift; |
825 | |
826 | my $engine = $self->engine; |
827 | |
3976d8c9 |
828 | unless ( $self->offset ) { |
ad4ae302 |
829 | my $data_section = $self->size - 3 - 1 * $engine->byte_size; |
3976d8c9 |
830 | |
b9ec359f |
831 | $self->{offset} = $engine->_request_sector( $self->size ); |
ad4ae302 |
832 | |
2432d6cc |
833 | my $data = delete $self->{data}; |
ad4ae302 |
834 | my $dlen = length $data; |
835 | my $continue = 1; |
836 | my $curr_offset = $self->offset; |
837 | while ( $continue ) { |
838 | |
839 | my $next_offset = 0; |
840 | |
841 | my ($leftover, $this_len, $chunk); |
842 | if ( $dlen > $data_section ) { |
843 | $leftover = 0; |
844 | $this_len = $data_section; |
845 | $chunk = substr( $data, 0, $this_len ); |
846 | |
847 | $dlen -= $data_section; |
848 | $next_offset = $engine->_request_sector( $self->size ); |
849 | $data = substr( $data, $this_len ); |
850 | } |
851 | else { |
852 | $leftover = $data_section - $dlen; |
853 | $this_len = $dlen; |
854 | $chunk = $data; |
855 | |
856 | $continue = 0; |
857 | } |
858 | |
859 | $engine->storage->print_at( $curr_offset, |
860 | $self->type, # Sector type |
861 | pack( $StP{1}, 0 ), # Recycled counter |
862 | pack( $StP{$engine->byte_size}, $next_offset ), # Chain loc |
863 | pack( $StP{1}, $this_len ), # Data length |
864 | $chunk, # Data to be stored in this sector |
865 | chr(0) x $leftover, # Zero-fill the rest |
866 | ); |
867 | |
868 | $curr_offset = $next_offset; |
869 | } |
3976d8c9 |
870 | |
871 | return; |
872 | } |
873 | } |
874 | |
875 | sub data_length { |
876 | my $self = shift; |
877 | |
ad4ae302 |
878 | my $buffer = $self->engine->storage->read_at( |
3976d8c9 |
879 | $self->offset + 2 + $self->engine->byte_size, 1 |
8fbac729 |
880 | ); |
ad4ae302 |
881 | |
882 | return unpack( $StP{1}, $buffer ); |
883 | } |
884 | |
885 | sub chain_loc { |
886 | my $self = shift; |
887 | my $chain_loc = $self->engine->storage->read_at( |
888 | $self->offset + 2, $self->engine->byte_size, |
889 | ); |
890 | return unpack( $StP{$self->engine->byte_size}, $chain_loc ); |
3976d8c9 |
891 | } |
892 | |
893 | sub data { |
894 | my $self = shift; |
8fbac729 |
895 | |
378b4748 |
896 | my $data; |
897 | while ( 1 ) { |
898 | my $chain_loc = $self->chain_loc; |
ad4ae302 |
899 | |
378b4748 |
900 | $data .= $self->engine->storage->read_at( |
901 | $self->offset + 2 + $self->engine->byte_size + 1, $self->data_length, |
902 | ); |
ad4ae302 |
903 | |
378b4748 |
904 | last unless $chain_loc; |
905 | |
906 | $self = $self->engine->_load_sector( $chain_loc ); |
ad4ae302 |
907 | } |
908 | |
909 | return $data; |
8fbac729 |
910 | } |
911 | |
68369f26 |
912 | package DBM::Deep::Engine::Sector::Null; |
913 | |
914 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
915 | |
916 | sub type { $_[0]{engine}->SIG_NULL } |
917 | sub data_length { 0 } |
918 | sub data { return } |
919 | |
920 | sub _init { |
921 | my $self = shift; |
922 | |
923 | my $engine = $self->engine; |
924 | |
925 | unless ( $self->offset ) { |
926 | my $leftover = $self->size - 3 - 1 * $engine->byte_size; |
927 | |
b9ec359f |
928 | $self->{offset} = $engine->_request_sector( $self->size ); |
68369f26 |
929 | $engine->storage->print_at( $self->offset, |
930 | $self->type, # Sector type |
931 | pack( $StP{1}, 0 ), # Recycled counter |
932 | pack( $StP{$engine->byte_size}, 0 ), # Chain loc |
933 | pack( $StP{1}, $self->data_length ), # Data length |
934 | chr(0) x $leftover, # Zero-fill the rest |
935 | ); |
936 | |
937 | return; |
938 | } |
939 | } |
940 | |
3976d8c9 |
941 | package DBM::Deep::Engine::Sector::Reference; |
8fbac729 |
942 | |
3976d8c9 |
943 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
944 | |
945 | sub _init { |
946 | my $self = shift; |
947 | |
948 | my $engine = $self->engine; |
949 | |
950 | unless ( $self->offset ) { |
ba075714 |
951 | my $classname = Scalar::Util::blessed( delete $self->{data} ); |
060c7e54 |
952 | my $leftover = $self->size - 2 - 2 * $engine->byte_size; |
d4f34951 |
953 | |
954 | my $class_offset = 0; |
955 | if ( defined $classname ) { |
956 | my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({ |
957 | engine => $self->engine, |
958 | data => $classname, |
959 | }); |
960 | $class_offset = $class_sector->offset; |
961 | } |
3976d8c9 |
962 | |
b9ec359f |
963 | $self->{offset} = $engine->_request_sector( $self->size ); |
3976d8c9 |
964 | $engine->storage->print_at( $self->offset, |
d4f34951 |
965 | $self->type, # Sector type |
966 | pack( $StP{1}, 0 ), # Recycled counter |
967 | pack( $StP{$engine->byte_size}, 0 ), # Index/BList loc |
968 | pack( $StP{$engine->byte_size}, $class_offset ), # Classname loc |
969 | chr(0) x $leftover, # Zero-fill the rest |
3976d8c9 |
970 | ); |
971 | |
972 | return; |
973 | } |
764e6cb9 |
974 | |
975 | $self->{type} = $engine->storage->read_at( $self->offset, 1 ); |
976 | |
977 | return; |
3976d8c9 |
978 | } |
979 | |
2432d6cc |
980 | sub get_data_for { |
981 | my $self = shift; |
982 | my ($args) = @_; |
983 | |
984 | # Assume that the head is not allowed unless otherwise specified. |
985 | $args->{allow_head} = 0 unless exists $args->{allow_head}; |
986 | |
987 | # Assume we don't create a new blist location unless otherwise specified. |
988 | $args->{create} = 0 unless exists $args->{create}; |
989 | |
990 | my $blist = $self->get_bucket_list({ |
991 | key_md5 => $args->{key_md5}, |
992 | create => $args->{create}, |
993 | }); |
994 | return unless $blist && $blist->{found}; |
995 | |
996 | # At this point, $blist knows where the md5 is. What it -doesn't- know yet |
997 | # is whether or not this transaction has this key. That's part of the next |
998 | # function call. |
999 | my $location = $blist->get_data_location_for({ |
1000 | allow_head => $args->{allow_head}, |
1001 | }) or return; |
1002 | |
1003 | return $self->engine->_load_sector( $location ); |
1004 | } |
1005 | |
1006 | sub write_data { |
1007 | my $self = shift; |
1008 | my ($args) = @_; |
1009 | |
1010 | my $blist = $self->get_bucket_list({ |
1011 | key_md5 => $args->{key_md5}, |
1012 | create => 1, |
6f999f6e |
1013 | }) or die "How did write_data fail (no blist)?!\n"; |
2432d6cc |
1014 | |
1015 | # Handle any transactional bookkeeping. |
1016 | if ( $self->engine->trans_id ) { |
1017 | if ( ! $blist->{found} ) { |
1018 | $blist->mark_deleted({ |
1019 | trans_id => 0, |
1020 | }); |
1021 | } |
1022 | } |
1023 | else { |
cf03415a |
1024 | my @trans_ids = $self->engine->get_running_txn_ids; |
2432d6cc |
1025 | if ( $blist->{found} ) { |
1026 | if ( @trans_ids ) { |
1027 | my $old_value = $blist->get_data_for; |
1028 | foreach my $other_trans_id ( @trans_ids ) { |
b4e17919 |
1029 | next if $blist->get_data_location_for({ |
1030 | trans_id => $other_trans_id, |
1031 | allow_head => 0, |
1032 | }); |
2432d6cc |
1033 | $blist->write_md5({ |
1034 | trans_id => $other_trans_id, |
1035 | key => $args->{key}, |
1036 | key_md5 => $args->{key_md5}, |
1037 | value => $old_value->clone, |
1038 | }); |
1039 | } |
1040 | } |
1041 | } |
1042 | else { |
1043 | if ( @trans_ids ) { |
1044 | foreach my $other_trans_id ( @trans_ids ) { |
1045 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
1046 | $blist->mark_deleted({ |
1047 | trans_id => $other_trans_id, |
1048 | }); |
1049 | } |
1050 | } |
1051 | } |
1052 | } |
1053 | |
6f999f6e |
1054 | #XXX Is this safe to do transactionally? |
2432d6cc |
1055 | # Free the place we're about to write to. |
1056 | if ( $blist->get_data_location_for({ allow_head => 0 }) ) { |
1057 | $blist->get_data_for({ allow_head => 0 })->free; |
1058 | } |
1059 | |
1060 | $blist->write_md5({ |
1061 | key => $args->{key}, |
1062 | key_md5 => $args->{key_md5}, |
1063 | value => $args->{value}, |
1064 | }); |
1065 | } |
1066 | |
1067 | sub delete_key { |
1068 | my $self = shift; |
1069 | my ($args) = @_; |
1070 | |
1071 | # XXX What should happen if this fails? |
1072 | my $blist = $self->get_bucket_list({ |
1073 | key_md5 => $args->{key_md5}, |
1074 | }) or die "How did delete_key fail (no blist)?!\n"; |
1075 | |
6f999f6e |
1076 | # Save the location so that we can free the data |
1077 | my $location = $blist->get_data_location_for({ |
1078 | allow_head => 0, |
1079 | }); |
26897a1c |
1080 | my $old_value = $location && $self->engine->_load_sector( $location ); |
6f999f6e |
1081 | |
1082 | if ( $self->engine->trans_id == 0 ) { |
cf03415a |
1083 | my @trans_ids = $self->engine->get_running_txn_ids; |
6f999f6e |
1084 | if ( @trans_ids ) { |
1085 | foreach my $other_trans_id ( @trans_ids ) { |
1086 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
1087 | $blist->write_md5({ |
1088 | trans_id => $other_trans_id, |
1089 | key => $args->{key}, |
1090 | key_md5 => $args->{key_md5}, |
1091 | value => $old_value->clone, |
1092 | }); |
1093 | } |
1094 | } |
1095 | } |
1096 | |
1097 | $blist->mark_deleted( $args ); |
1098 | |
26897a1c |
1099 | my $data; |
1100 | if ( $old_value ) { |
1101 | $data = $old_value->data; |
1102 | $old_value->free; |
1103 | } |
6f999f6e |
1104 | |
1105 | return $data; |
2432d6cc |
1106 | } |
1107 | |
3976d8c9 |
1108 | sub get_blist_loc { |
1109 | my $self = shift; |
1110 | |
2432d6cc |
1111 | my $e = $self->engine; |
1112 | my $blist_loc = $e->storage->read_at( $self->offset + 2, $e->byte_size ); |
1113 | return unpack( $StP{$e->byte_size}, $blist_loc ); |
3976d8c9 |
1114 | } |
1115 | |
1116 | sub get_bucket_list { |
1117 | my $self = shift; |
1118 | my ($args) = @_; |
4eee718c |
1119 | $args ||= {}; |
3976d8c9 |
1120 | |
1121 | # XXX Add in check here for recycling? |
1122 | |
1123 | my $engine = $self->engine; |
1124 | |
1125 | my $blist_loc = $self->get_blist_loc; |
1126 | |
1127 | # There's no index or blist yet |
1128 | unless ( $blist_loc ) { |
1129 | return unless $args->{create}; |
1130 | |
1131 | my $blist = DBM::Deep::Engine::Sector::BucketList->new({ |
2432d6cc |
1132 | engine => $engine, |
1133 | key_md5 => $args->{key_md5}, |
3976d8c9 |
1134 | }); |
2432d6cc |
1135 | |
d4f34951 |
1136 | $engine->storage->print_at( $self->offset + 2, |
3976d8c9 |
1137 | pack( $StP{$engine->byte_size}, $blist->offset ), |
1138 | ); |
2432d6cc |
1139 | |
3976d8c9 |
1140 | return $blist; |
1141 | } |
1142 | |
1143 | return DBM::Deep::Engine::Sector::BucketList->new({ |
2432d6cc |
1144 | engine => $engine, |
1145 | offset => $blist_loc, |
1146 | key_md5 => $args->{key_md5}, |
3976d8c9 |
1147 | }); |
1148 | } |
1149 | |
ba075714 |
1150 | sub get_classname { |
1151 | my $self = shift; |
1152 | |
d4f34951 |
1153 | my $class_offset = $self->engine->storage->read_at( |
1154 | $self->offset + 2 + 1 * $self->engine->byte_size, $self->engine->byte_size, |
ba075714 |
1155 | ); |
d4f34951 |
1156 | $class_offset = unpack ( $StP{$self->engine->byte_size}, $class_offset ); |
ba075714 |
1157 | |
d4f34951 |
1158 | return unless $class_offset; |
ba075714 |
1159 | |
d4f34951 |
1160 | return $self->engine->_load_sector( $class_offset )->data; |
ba075714 |
1161 | } |
1162 | |
764e6cb9 |
1163 | sub data { |
1164 | my $self = shift; |
1165 | |
1166 | my $new_obj = DBM::Deep->new({ |
1167 | type => $self->type, |
1168 | base_offset => $self->offset, |
1169 | storage => $self->engine->storage, |
c9f02899 |
1170 | engine => $self->engine, |
764e6cb9 |
1171 | }); |
1172 | |
ba075714 |
1173 | if ( $self->engine->storage->{autobless} ) { |
1174 | my $classname = $self->get_classname; |
1175 | if ( defined $classname ) { |
1176 | bless $new_obj, $classname; |
1177 | } |
1178 | } |
1179 | |
764e6cb9 |
1180 | return $new_obj; |
1181 | } |
1182 | |
3976d8c9 |
1183 | package DBM::Deep::Engine::Sector::BucketList; |
1184 | |
1185 | our @ISA = qw( DBM::Deep::Engine::Sector ); |
1186 | |
1187 | sub _init { |
1188 | my $self = shift; |
1189 | |
1190 | my $engine = $self->engine; |
1191 | |
1192 | unless ( $self->offset ) { |
c000ae6e |
1193 | my $leftover = $self->size - $self->base_size; |
3976d8c9 |
1194 | |
b9ec359f |
1195 | $self->{offset} = $engine->_request_sector( $self->size ); |
3976d8c9 |
1196 | $engine->storage->print_at( $self->offset, |
1197 | $engine->SIG_BLIST, # Sector type |
1198 | pack( $StP{1}, 0 ), # Recycled counter |
1199 | chr(0) x $leftover, # Zero-fill the data |
1200 | ); |
1201 | } |
8fbac729 |
1202 | |
2432d6cc |
1203 | if ( $self->{key_md5} ) { |
1204 | $self->find_md5; |
1205 | } |
1206 | |
8fbac729 |
1207 | return $self; |
1208 | } |
8fbac729 |
1209 | |
6de4e4e9 |
1210 | sub base_size { 1 + 1 } # Sig + recycled counter |
c000ae6e |
1211 | |
3976d8c9 |
1212 | sub size { |
1213 | my $self = shift; |
2432d6cc |
1214 | unless ( $self->{size} ) { |
1215 | my $e = $self->engine; |
1216 | $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; # Base + numbuckets * bucketsize |
1217 | } |
1218 | return $self->{size}; |
c000ae6e |
1219 | } |
1220 | |
1221 | sub bucket_size { |
1222 | my $self = shift; |
2432d6cc |
1223 | unless ( $self->{bucket_size} ) { |
1224 | my $e = $self->engine; |
6de4e4e9 |
1225 | # Key + head (location) + transactions (location + staleness-counter) |
17164f8a |
1226 | my $location_size = $e->byte_size + $e->num_txns * ( $e->byte_size + 4 ); |
6de4e4e9 |
1227 | $self->{bucket_size} = $e->hash_size + $location_size; |
2432d6cc |
1228 | } |
1229 | return $self->{bucket_size}; |
3976d8c9 |
1230 | } |
8fbac729 |
1231 | |
3976d8c9 |
1232 | sub has_md5 { |
c000ae6e |
1233 | my $self = shift; |
2432d6cc |
1234 | unless ( exists $self->{found} ) { |
1235 | $self->find_md5; |
1236 | } |
1237 | return $self->{found}; |
c000ae6e |
1238 | } |
1239 | |
1240 | sub find_md5 { |
1241 | my $self = shift; |
c000ae6e |
1242 | |
2432d6cc |
1243 | $self->{found} = undef; |
1244 | $self->{idx} = -1; |
c000ae6e |
1245 | |
2432d6cc |
1246 | # If we don't have an MD5, then what are we supposed to do? |
1247 | unless ( exists $self->{key_md5} ) { |
6f999f6e |
1248 | DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" ); |
2432d6cc |
1249 | } |
8cb9205a |
1250 | |
2432d6cc |
1251 | my $e = $self->engine; |
1252 | foreach my $idx ( 0 .. $e->max_buckets - 1 ) { |
1253 | my $potential = $e->storage->read_at( |
1254 | $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size, |
1255 | ); |
1256 | |
1257 | if ( $potential eq $e->blank_md5 ) { |
1258 | $self->{idx} = $idx; |
1259 | return; |
1260 | } |
8cb9205a |
1261 | |
2432d6cc |
1262 | if ( $potential eq $self->{key_md5} ) { |
1263 | $self->{found} = 1; |
1264 | $self->{idx} = $idx; |
1265 | return; |
8cb9205a |
1266 | } |
c000ae6e |
1267 | } |
1268 | |
1269 | return; |
3976d8c9 |
1270 | } |
1271 | |
1272 | sub write_md5 { |
1273 | my $self = shift; |
2432d6cc |
1274 | my ($args) = @_; |
2432d6cc |
1275 | |
6f999f6e |
1276 | DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key}; |
1277 | DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5}; |
1278 | DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value}; |
3976d8c9 |
1279 | |
1280 | my $engine = $self->engine; |
6f999f6e |
1281 | |
1282 | $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; |
1283 | |
2432d6cc |
1284 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
6f999f6e |
1285 | $engine->add_entry( $args->{trans_id}, $spot ); |
4eee718c |
1286 | |
2432d6cc |
1287 | unless ($self->{found}) { |
4eee718c |
1288 | my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({ |
6f999f6e |
1289 | engine => $engine, |
2432d6cc |
1290 | data => $args->{key}, |
4eee718c |
1291 | }); |
1292 | |
1293 | $engine->storage->print_at( $spot, |
2432d6cc |
1294 | $args->{key_md5}, |
6f999f6e |
1295 | pack( $StP{$engine->byte_size}, $key_sector->offset ), |
4eee718c |
1296 | ); |
1297 | } |
1298 | |
6f999f6e |
1299 | my $loc = $spot |
2432d6cc |
1300 | + $engine->hash_size |
1301 | + $engine->byte_size |
17164f8a |
1302 | + $args->{trans_id} * ( $engine->byte_size + 4 ); |
6f999f6e |
1303 | |
1304 | $engine->storage->print_at( $loc, |
2432d6cc |
1305 | pack( $StP{$engine->byte_size}, $args->{value}->offset ), |
6de4e4e9 |
1306 | pack( 'N', $engine->get_txn_staleness_counter( $args->{trans_id} ) ), |
2432d6cc |
1307 | ); |
1308 | } |
1309 | |
1310 | sub mark_deleted { |
1311 | my $self = shift; |
1312 | my ($args) = @_; |
6f999f6e |
1313 | $args ||= {}; |
1314 | |
1315 | my $engine = $self->engine; |
1316 | |
1317 | $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; |
2432d6cc |
1318 | |
1319 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
6f999f6e |
1320 | $engine->add_entry( $args->{trans_id}, $spot ); |
1321 | |
1322 | my $loc = $spot |
1323 | + $engine->hash_size |
1324 | + $engine->byte_size |
17164f8a |
1325 | + $args->{trans_id} * ( $engine->byte_size + 4 ); |
6f999f6e |
1326 | |
1327 | $engine->storage->print_at( $loc, |
1328 | pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted |
6de4e4e9 |
1329 | pack( 'N', $engine->get_txn_staleness_counter( $args->{trans_id} ) ), |
3976d8c9 |
1330 | ); |
1331 | } |
1332 | |
e86cef36 |
1333 | sub delete_md5 { |
3976d8c9 |
1334 | my $self = shift; |
2432d6cc |
1335 | my ($args) = @_; |
3976d8c9 |
1336 | |
e86cef36 |
1337 | my $engine = $self->engine; |
2432d6cc |
1338 | return undef unless $self->{found}; |
4eee718c |
1339 | |
1340 | # Save the location so that we can free the data |
2432d6cc |
1341 | my $location = $self->get_data_location_for({ |
1342 | allow_head => 0, |
1343 | }); |
1344 | my $key_sector = $self->get_key_for; |
4eee718c |
1345 | |
6f999f6e |
1346 | #XXX This isn't going to work right and you know it! This eradicates data |
1347 | # that we're not ready to eradicate just yet. |
2432d6cc |
1348 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
4eee718c |
1349 | $engine->storage->print_at( $spot, |
1350 | $engine->storage->read_at( |
1351 | $spot + $self->bucket_size, |
2432d6cc |
1352 | $self->bucket_size * ( $engine->num_txns - $self->{idx} - 1 ), |
4eee718c |
1353 | ), |
1354 | chr(0) x $self->bucket_size, |
e86cef36 |
1355 | ); |
1356 | |
3ed26433 |
1357 | $key_sector->free; |
1358 | |
ed38e772 |
1359 | my $data_sector = $self->engine->_load_sector( $location ); |
1360 | my $data = $data_sector->data; |
ed38e772 |
1361 | $data_sector->free; |
5c0f86e1 |
1362 | |
1363 | return $data; |
e86cef36 |
1364 | } |
1365 | |
ed38e772 |
1366 | sub get_data_location_for { |
e86cef36 |
1367 | my $self = shift; |
2432d6cc |
1368 | my ($args) = @_; |
1369 | $args ||= {}; |
1370 | |
1371 | $args->{allow_head} = 0 unless exists $args->{allow_head}; |
1372 | $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id}; |
1373 | $args->{idx} = $self->{idx} unless exists $args->{idx}; |
e86cef36 |
1374 | |
6de4e4e9 |
1375 | my $e = $self->engine; |
1376 | |
1377 | my $spot = $self->offset + $self->base_size |
2432d6cc |
1378 | + $args->{idx} * $self->bucket_size |
6de4e4e9 |
1379 | + $e->hash_size |
1380 | + $e->byte_size |
17164f8a |
1381 | + $args->{trans_id} * ( $e->byte_size + 4 ); |
6de4e4e9 |
1382 | |
1383 | my $buffer = $e->storage->read_at( |
1384 | $spot, |
17164f8a |
1385 | $e->byte_size + 4, |
3976d8c9 |
1386 | ); |
6de4e4e9 |
1387 | my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' N', $buffer ); |
1388 | |
1389 | # We have found an entry that is old, so get rid of it |
41e27db3 |
1390 | if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) { |
6de4e4e9 |
1391 | $e->storage->print_at( |
1392 | $spot, |
1393 | pack( $StP{$e->byte_size} . ' N', (0) x 2 ), |
1394 | ); |
1395 | $loc = 0; |
1396 | } |
8cb9205a |
1397 | |
1398 | # If we're in a transaction and we never wrote to this location, try the |
1399 | # HEAD instead. |
2432d6cc |
1400 | if ( $args->{trans_id} && !$loc && $args->{allow_head} ) { |
1401 | return $self->get_data_location_for({ |
1402 | trans_id => 0, |
1403 | allow_head => 1, |
17164f8a |
1404 | idx => $args->{idx}, |
2432d6cc |
1405 | }); |
8cb9205a |
1406 | } |
2432d6cc |
1407 | return $loc <= 1 ? 0 : $loc; |
e86cef36 |
1408 | } |
1409 | |
1410 | sub get_data_for { |
1411 | my $self = shift; |
2432d6cc |
1412 | my ($args) = @_; |
1413 | $args ||= {}; |
e86cef36 |
1414 | |
2432d6cc |
1415 | return unless $self->{found}; |
1416 | my $location = $self->get_data_location_for({ |
1417 | allow_head => $args->{allow_head}, |
1418 | }); |
ed38e772 |
1419 | return $self->engine->_load_sector( $location ); |
1420 | } |
1421 | |
1422 | sub get_key_for { |
1423 | my $self = shift; |
1424 | my ($idx) = @_; |
2432d6cc |
1425 | $idx = $self->{idx} unless defined $idx; |
ed38e772 |
1426 | |
1427 | my $location = $self->engine->storage->read_at( |
1428 | $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size, |
1429 | $self->engine->byte_size, |
1430 | ); |
1431 | $location = unpack( $StP{$self->engine->byte_size}, $location ); |
1432 | return unless $location; |
68369f26 |
1433 | return $self->engine->_load_sector( $location ); |
3976d8c9 |
1434 | } |
696cadb7 |
1435 | |
1436 | 1; |
1437 | __END__ |
76c68c87 |
1438 | |
1439 | package DBM::Deep::Engine::Sector::BucketList; |
1440 | |
1441 | our @ISA = qw( DBM::Deep::Engine::Sector ); |
1442 | |
1443 | sub _init { |
1444 | my $self = shift; |
1445 | |
1446 | my $engine = $self->engine; |
1447 | |
1448 | unless ( $self->offset ) { |
1449 | my $leftover = $self->size - $self->base_size; |
1450 | |
1451 | $self->{offset} = $engine->_request_sector( $self->size ); |
1452 | $engine->storage->print_at( $self->offset, |
1453 | $engine->SIG_BLIST, # Sector type |
1454 | pack( $StP{1}, 0 ), # Recycled counter |
1455 | chr(0) x $leftover, # Zero-fill the data |
1456 | ); |
1457 | } |
1458 | |
1459 | if ( $self->{key_md5} ) { |
1460 | $self->find_md5; |
1461 | } |
1462 | |
1463 | return $self; |
1464 | } |
1465 | |
1466 | sub base_size { 1 + 1 } # Sig + recycled counter |
1467 | |
1468 | sub size { |
1469 | my $self = shift; |
1470 | unless ( $self->{size} ) { |
1471 | my $e = $self->engine; |
1472 | $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; # Base + numbuckets * bucketsize |
1473 | } |
1474 | return $self->{size}; |
1475 | } |
1476 | |
1477 | sub bucket_size { |
1478 | my $self = shift; |
1479 | unless ( $self->{bucket_size} ) { |
1480 | my $e = $self->engine; |
1481 | # Key + head (location) + transactions (location + staleness-counter) |
1482 | my $location_size = $e->byte_size + $e->num_txns * ( $e->byte_size + 4 ); |
1483 | $self->{bucket_size} = $e->hash_size + $location_size; |
1484 | } |
1485 | return $self->{bucket_size}; |
1486 | } |
1487 | |
1488 | 1; |
1489 | __END__ |