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 = ( |
ad4ae302 |
35 | 1 => 'C', # Unsigned char value |
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 ) |
108 | or die "How did read_value fail (no sector for '$obj')?!\n"; |
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 ) |
139 | or die "How did read_value 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 ) |
150 | or die "How did key_exists fail (no sector for '$obj')?!\n"; |
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 ) |
166 | or die "How did delete_key fail (no sector for '$obj')?!\n"; |
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 ) |
209 | or die "How did write_value fail (no sector for '$obj')?!\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 | |
6de4e4e9 |
334 | $self->set_trans_ctr( |
335 | $self->get_txn_staleness_counter( $self->trans_id ), |
336 | ); |
337 | |
8cb9205a |
338 | return; |
c9f02899 |
339 | } |
696cadb7 |
340 | |
8cb9205a |
341 | sub rollback { |
696cadb7 |
342 | my $self = shift; |
8cb9205a |
343 | my ($obj) = @_; |
344 | |
345 | if ( !$self->trans_id ) { |
6f999f6e |
346 | DBM::Deep->_throw_error( "Cannot rollback without a transaction" ); |
347 | } |
348 | |
349 | # Each entry is the file location for a bucket that has a modification for |
350 | # this transaction. The entries need to be expunged. |
351 | foreach my $entry (@{ $self->get_entries } ) { |
352 | # Remove the entry here |
353 | my $read_loc = $entry |
354 | + $self->hash_size |
355 | + $self->byte_size |
6de4e4e9 |
356 | + $self->trans_id * ( 2 * $self->byte_size ); |
6f999f6e |
357 | |
358 | my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size ); |
359 | $data_loc = unpack( $StP{$self->byte_size}, $data_loc ); |
360 | $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) ); |
361 | |
362 | if ( $data_loc > 1 ) { |
363 | $self->_load_sector( $data_loc )->free; |
364 | } |
8cb9205a |
365 | } |
6f999f6e |
366 | |
367 | $self->clear_entries; |
368 | |
cf03415a |
369 | my @slots = $self->read_txn_slots; |
6f999f6e |
370 | $slots[$self->trans_id] = 0; |
cf03415a |
371 | $self->write_txn_slots( @slots ); |
6de4e4e9 |
372 | $self->inc_txn_staleness_counter( $self->trans_id ); |
373 | $self->set_trans_ctr( 0 ); |
6f999f6e |
374 | $self->set_trans_id( 0 ); |
375 | |
376 | return 1; |
c9f02899 |
377 | } |
696cadb7 |
378 | |
8cb9205a |
379 | sub commit { |
c9f02899 |
380 | my $self = shift; |
8cb9205a |
381 | my ($obj) = @_; |
382 | |
383 | if ( !$self->trans_id ) { |
6f999f6e |
384 | DBM::Deep->_throw_error( "Cannot commit without a transaction" ); |
385 | } |
386 | |
6de4e4e9 |
387 | #print "TID: " . $self->trans_id, $/; |
6f999f6e |
388 | foreach my $entry (@{ $self->get_entries } ) { |
6de4e4e9 |
389 | #print "$entry\n"; |
6f999f6e |
390 | # Overwrite the entry in head with the entry in trans_id |
391 | my $base = $entry |
392 | + $self->hash_size |
393 | + $self->byte_size; |
394 | |
395 | my $head_loc = $self->storage->read_at( $base, $self->byte_size ); |
396 | $head_loc = unpack( $StP{$self->byte_size}, $head_loc ); |
397 | my $trans_loc = $self->storage->read_at( |
6de4e4e9 |
398 | $base + $self->trans_id * ( 2 * $self->byte_size ), $self->byte_size, |
6f999f6e |
399 | ); |
400 | |
401 | $self->storage->print_at( $base, $trans_loc ); |
402 | $self->storage->print_at( |
6de4e4e9 |
403 | $base + $self->trans_id * ( 2 * $self->byte_size ), |
404 | pack( $StP{$self->byte_size} . ' N', (0) x 2 ), |
6f999f6e |
405 | ); |
406 | |
407 | if ( $head_loc > 1 ) { |
408 | $self->_load_sector( $head_loc )->free; |
409 | } |
8cb9205a |
410 | } |
6f999f6e |
411 | |
412 | $self->clear_entries; |
413 | |
cf03415a |
414 | my @slots = $self->read_txn_slots; |
6f999f6e |
415 | $slots[$self->trans_id] = 0; |
cf03415a |
416 | $self->write_txn_slots( @slots ); |
6de4e4e9 |
417 | $self->inc_txn_staleness_counter( $self->trans_id ); |
418 | $self->set_trans_ctr( 0 ); |
6f999f6e |
419 | $self->set_trans_id( 0 ); |
420 | |
421 | return 1; |
8cb9205a |
422 | } |
423 | |
cf03415a |
424 | sub read_txn_slots { |
8cb9205a |
425 | my $self = shift; |
cf03415a |
426 | return split '', unpack( 'b32', |
427 | $self->storage->read_at( |
428 | $self->trans_loc, 4, |
429 | ) |
430 | ); |
8cb9205a |
431 | } |
432 | |
cf03415a |
433 | sub write_txn_slots { |
8cb9205a |
434 | my $self = shift; |
435 | $self->storage->print_at( $self->trans_loc, |
cf03415a |
436 | pack( 'b32', join('', @_) ), |
8cb9205a |
437 | ); |
c9f02899 |
438 | } |
696cadb7 |
439 | |
cf03415a |
440 | sub get_running_txn_ids { |
441 | my $self = shift; |
442 | my @transactions = $self->read_txn_slots; |
443 | my @trans_ids = grep { $transactions[$_] } 0 .. $#transactions; |
444 | } |
445 | |
6de4e4e9 |
446 | sub get_txn_staleness_counter { |
447 | my $self = shift; |
448 | my ($trans_id) = @_; |
449 | return unpack( 'N', |
450 | $self->storage->read_at( |
451 | $self->trans_loc + 4 * ($trans_id - 1), 4, |
452 | ) |
453 | ); |
454 | } |
455 | |
456 | sub inc_txn_staleness_counter { |
457 | my $self = shift; |
458 | my ($trans_id) = @_; |
459 | $self->storage->print_at( |
460 | $self->trans_loc, |
461 | pack( 'N', $self->get_txn_staleness_counter( $trans_id ) + 1 ), |
462 | ); |
463 | } |
464 | |
6f999f6e |
465 | sub get_entries { |
466 | my $self = shift; |
467 | return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ]; |
468 | } |
469 | |
470 | sub add_entry { |
471 | my $self = shift; |
472 | my ($trans_id, $loc) = @_; |
473 | |
6de4e4e9 |
474 | #print "$trans_id => $loc\n"; |
6f999f6e |
475 | $self->{entries}{$trans_id} ||= {}; |
476 | $self->{entries}{$trans_id}{$loc} = undef; |
6de4e4e9 |
477 | #use Data::Dumper;print "$self: " . Dumper $self->{entries}; |
6f999f6e |
478 | } |
479 | |
480 | sub clear_entries { |
481 | my $self = shift; |
6de4e4e9 |
482 | #print "Clearing\n"; |
6f999f6e |
483 | delete $self->{entries}{$self->trans_id}; |
484 | } |
485 | |
c9f02899 |
486 | ################################################################################ |
b9ec359f |
487 | |
c9f02899 |
488 | { |
489 | my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4; |
696cadb7 |
490 | |
c9f02899 |
491 | sub _write_file_header { |
492 | my $self = shift; |
696cadb7 |
493 | |
cf03415a |
494 | my $header_var = 1 + 1 + 4 + 4 * $self->num_txns + 2 * $self->byte_size; |
696cadb7 |
495 | |
c9f02899 |
496 | my $loc = $self->storage->request_space( $header_fixed + $header_var ); |
c83524c6 |
497 | |
c9f02899 |
498 | $self->storage->print_at( $loc, |
499 | SIG_FILE, |
500 | SIG_HEADER, |
501 | pack('N', 1), # header version - at this point, we're at 9 bytes |
502 | pack('N', $header_var), # header size |
503 | # --- Above is $header_fixed. Below is $header_var |
504 | pack('C', $self->byte_size), |
505 | pack('C', $self->max_buckets), |
cf03415a |
506 | pack('N', 0 ), # Transaction cctiveness bitfield |
507 | pack('N' . $self->num_txns, 0 ), # Transaction staleness counters |
c9f02899 |
508 | pack($StP{$self->byte_size}, 0), # Start of free chain (blist size) |
509 | pack($StP{$self->byte_size}, 0), # Start of free chain (data size) |
510 | ); |
696cadb7 |
511 | |
c9f02899 |
512 | $self->set_trans_loc( $header_fixed + 2 ); |
cf03415a |
513 | $self->set_chains_loc( $header_fixed + 2 + 4 + 4 * $self->num_txns ); |
6de4e4e9 |
514 | $self->set_trans_ctr( 0 ); |
696cadb7 |
515 | |
c9f02899 |
516 | return; |
696cadb7 |
517 | } |
518 | |
c9f02899 |
519 | sub _read_file_header { |
520 | my $self = shift; |
696cadb7 |
521 | |
c9f02899 |
522 | my $buffer = $self->storage->read_at( 0, $header_fixed ); |
523 | return unless length($buffer); |
696cadb7 |
524 | |
c9f02899 |
525 | my ($file_signature, $sig_header, $header_version, $size) = unpack( |
526 | 'A4 A N N', $buffer |
527 | ); |
b9ec359f |
528 | |
c9f02899 |
529 | unless ( $file_signature eq SIG_FILE ) { |
530 | $self->storage->close; |
531 | DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" ); |
532 | } |
696cadb7 |
533 | |
c9f02899 |
534 | unless ( $sig_header eq SIG_HEADER ) { |
535 | $self->storage->close; |
536 | DBM::Deep->_throw_error( "Old file version found." ); |
537 | } |
696cadb7 |
538 | |
c9f02899 |
539 | my $buffer2 = $self->storage->read_at( undef, $size ); |
540 | my @values = unpack( 'C C', $buffer2 ); |
696cadb7 |
541 | |
c9f02899 |
542 | $self->set_trans_loc( $header_fixed + 2 ); |
cf03415a |
543 | $self->set_chains_loc( $header_fixed + 2 + 4 + 4 * $self->num_txns ); |
6de4e4e9 |
544 | $self->set_trans_ctr( 0 ); |
c9f02899 |
545 | |
546 | if ( @values < 2 || grep { !defined } @values ) { |
547 | $self->storage->close; |
548 | DBM::Deep->_throw_error("Corrupted file - bad header"); |
549 | } |
550 | |
551 | #XXX Add warnings if values weren't set right |
552 | @{$self}{qw(byte_size max_buckets)} = @values; |
b9ec359f |
553 | |
cf03415a |
554 | my $header_var = 1 + 1 + 4 + 4 * $self->num_txns + 2 * $self->byte_size; |
c9f02899 |
555 | unless ( $size eq $header_var ) { |
556 | $self->storage->close; |
557 | DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." ); |
558 | } |
559 | |
560 | return length($buffer) + length($buffer2); |
561 | } |
696cadb7 |
562 | } |
563 | |
3976d8c9 |
564 | sub _load_sector { |
565 | my $self = shift; |
566 | my ($offset) = @_; |
567 | |
568 | my $type = $self->storage->read_at( $offset, 1 ); |
b9ec359f |
569 | return if $type eq chr(0); |
570 | |
3976d8c9 |
571 | if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) { |
572 | return DBM::Deep::Engine::Sector::Reference->new({ |
573 | engine => $self, |
574 | type => $type, |
575 | offset => $offset, |
576 | }); |
577 | } |
2432d6cc |
578 | # XXX Don't we need key_md5 here? |
3976d8c9 |
579 | elsif ( $type eq $self->SIG_BLIST ) { |
580 | return DBM::Deep::Engine::Sector::BucketList->new({ |
581 | engine => $self, |
582 | type => $type, |
583 | offset => $offset, |
584 | }); |
585 | } |
68369f26 |
586 | elsif ( $type eq $self->SIG_NULL ) { |
587 | return DBM::Deep::Engine::Sector::Null->new({ |
588 | engine => $self, |
589 | type => $type, |
590 | offset => $offset, |
591 | }); |
592 | } |
593 | elsif ( $type eq $self->SIG_DATA ) { |
594 | return DBM::Deep::Engine::Sector::Scalar->new({ |
595 | engine => $self, |
596 | type => $type, |
597 | offset => $offset, |
598 | }); |
599 | } |
b9ec359f |
600 | # This was deleted from under us, so just return and let the caller figure it out. |
601 | elsif ( $type eq $self->SIG_FREE ) { |
602 | return; |
603 | } |
3976d8c9 |
604 | |
ed38e772 |
605 | die "'$offset': Don't know what to do with type '$type'\n"; |
3976d8c9 |
606 | } |
607 | |
608 | sub _apply_digest { |
609 | my $self = shift; |
610 | return $self->{digest}->(@_); |
611 | } |
612 | |
ed38e772 |
613 | sub _add_free_sector { |
614 | my $self = shift; |
615 | my ($offset, $size) = @_; |
b9ec359f |
616 | |
617 | my $chains_offset; |
618 | # Data sector |
619 | if ( $size == 256 ) { |
620 | $chains_offset = $self->byte_size; |
621 | } |
622 | # Blist sector |
623 | else { |
624 | $chains_offset = 0; |
625 | } |
626 | |
627 | my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); |
628 | |
3ed26433 |
629 | $self->storage->print_at( $self->chains_loc + $chains_offset, |
b9ec359f |
630 | pack( $StP{$self->byte_size}, $offset ), |
631 | ); |
632 | |
633 | # Record the old head in the new sector after the signature |
634 | $self->storage->print_at( $offset + 1, $old_head ); |
635 | } |
636 | |
637 | sub _request_sector { |
638 | my $self = shift; |
639 | my ($size) = @_; |
640 | |
641 | my $chains_offset; |
642 | # Data sector |
643 | if ( $size == 256 ) { |
644 | $chains_offset = $self->byte_size; |
645 | } |
646 | # Blist sector |
647 | else { |
648 | $chains_offset = 0; |
649 | } |
650 | |
651 | my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); |
652 | my $loc = unpack( $StP{$self->byte_size}, $old_head ); |
653 | |
654 | # We don't have any free sectors of the right size, so allocate a new one. |
655 | unless ( $loc ) { |
656 | return $self->storage->request_space( $size ); |
657 | } |
658 | |
659 | my $new_head = $self->storage->read_at( $loc + 1, $self->byte_size ); |
660 | $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head ); |
661 | |
662 | return $loc; |
ed38e772 |
663 | } |
664 | |
696cadb7 |
665 | ################################################################################ |
666 | |
3976d8c9 |
667 | sub storage { $_[0]{storage} } |
668 | sub byte_size { $_[0]{byte_size} } |
669 | sub hash_size { $_[0]{hash_size} } |
670 | sub num_txns { $_[0]{num_txns} } |
671 | sub max_buckets { $_[0]{max_buckets} } |
c000ae6e |
672 | sub blank_md5 { chr(0) x $_[0]->hash_size } |
8fbac729 |
673 | |
8cb9205a |
674 | sub trans_id { $_[0]{trans_id} } |
675 | sub set_trans_id { $_[0]{trans_id} = $_[1] } |
676 | |
6de4e4e9 |
677 | sub trans_ctr { $_[0]{trans_ctr} } |
678 | sub set_trans_ctr { $_[0]{trans_ctr} = $_[1] } |
679 | |
c9f02899 |
680 | sub trans_loc { $_[0]{trans_loc} } |
681 | sub set_trans_loc { $_[0]{trans_loc} = $_[1] } |
682 | |
b9ec359f |
683 | sub chains_loc { $_[0]{chains_loc} } |
684 | sub set_chains_loc { $_[0]{chains_loc} = $_[1] } |
685 | |
8fbac729 |
686 | ################################################################################ |
687 | |
ed38e772 |
688 | package DBM::Deep::Engine::Iterator; |
689 | |
690 | sub new { |
691 | my $class = shift; |
692 | my ($args) = @_; |
693 | |
694 | my $self = bless { |
695 | breadcrumbs => [], |
696 | engine => $args->{engine}, |
697 | base_offset => $args->{base_offset}, |
ed38e772 |
698 | }, $class; |
699 | |
700 | Scalar::Util::weaken( $self->{engine} ); |
701 | |
702 | return $self; |
703 | } |
704 | |
705 | sub reset { |
706 | my $self = shift; |
707 | $self->{breadcrumbs} = []; |
708 | } |
709 | |
710 | sub get_next_key { |
711 | my $self = shift; |
712 | |
713 | my $crumbs = $self->{breadcrumbs}; |
714 | |
715 | unless ( @$crumbs ) { |
716 | # This will be a Reference sector |
717 | my $sector = $self->{engine}->_load_sector( $self->{base_offset} ) |
b9ec359f |
718 | # or die "Iterator: How did this fail (no ref sector for '$self->{base_offset}')?!\n"; |
719 | # If no sector is found, thist must have been deleted from under us. |
720 | or return; |
ed38e772 |
721 | push @$crumbs, [ $sector->get_blist_loc, 0 ]; |
722 | } |
723 | |
724 | my $key; |
725 | while ( 1 ) { |
726 | my ($offset, $idx) = @{ $crumbs->[-1] }; |
727 | unless ( $offset ) { |
728 | $self->reset; |
729 | last; |
730 | } |
731 | |
2432d6cc |
732 | if ( $idx >= $self->{engine}->max_buckets ) { |
733 | $self->reset; |
734 | last; |
735 | } |
736 | |
ed38e772 |
737 | my $sector = $self->{engine}->_load_sector( $offset ) |
b9ec359f |
738 | or die "Iterator: How did this fail (no blist sector for '$offset')?!\n"; |
ed38e772 |
739 | |
2432d6cc |
740 | #XXX Think this through! |
741 | my $loc = $sector->get_data_location_for({ |
742 | idx => $idx, |
743 | }); |
744 | unless ( $loc ) { |
745 | $crumbs->[-1][1]++; |
746 | next; |
747 | } |
748 | |
ed38e772 |
749 | my $key_sector = $sector->get_key_for( $idx ); |
750 | unless ( $key_sector ) { |
751 | $self->reset; |
752 | last; |
753 | } |
754 | |
755 | $crumbs->[-1][1]++; |
756 | $key = $key_sector->data; |
757 | last; |
758 | } |
759 | |
760 | return $key; |
761 | } |
762 | |
3976d8c9 |
763 | package DBM::Deep::Engine::Sector; |
764 | |
765 | sub new { |
766 | my $self = bless $_[1], $_[0]; |
767 | Scalar::Util::weaken( $self->{engine} ); |
768 | $self->_init; |
769 | return $self; |
770 | } |
771 | sub _init {} |
2432d6cc |
772 | sub clone { die "Must be implemented in the child class" } |
3976d8c9 |
773 | |
774 | sub engine { $_[0]{engine} } |
775 | sub offset { $_[0]{offset} } |
776 | sub type { $_[0]{type} } |
777 | |
ed38e772 |
778 | sub free { |
779 | my $self = shift; |
780 | |
b9ec359f |
781 | $self->engine->storage->print_at( $self->offset, |
782 | $self->engine->SIG_FREE, |
783 | chr(0) x ($self->size - 1), |
784 | ); |
785 | |
ed38e772 |
786 | $self->engine->_add_free_sector( |
787 | $self->offset, $self->size, |
788 | ); |
789 | |
b9ec359f |
790 | return; |
ed38e772 |
791 | } |
3976d8c9 |
792 | |
793 | package DBM::Deep::Engine::Sector::Data; |
8fbac729 |
794 | |
795 | our @ISA = qw( DBM::Deep::Engine::Sector ); |
796 | |
3976d8c9 |
797 | # This is in bytes |
798 | sub size { return 256 } |
799 | |
2432d6cc |
800 | sub clone { |
801 | my $self = shift; |
802 | return ref($self)->new({ |
803 | engine => $self->engine, |
804 | data => $self->data, |
805 | type => $self->type, |
806 | }); |
807 | } |
808 | |
3976d8c9 |
809 | package DBM::Deep::Engine::Sector::Scalar; |
810 | |
811 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
812 | |
ad4ae302 |
813 | sub free { |
814 | my $self = shift; |
815 | |
816 | my $chain_loc = $self->chain_loc; |
817 | |
818 | $self->SUPER::free(); |
819 | |
820 | if ( $chain_loc ) { |
821 | $self->engine->_load_sector( $chain_loc )->free; |
822 | } |
823 | |
824 | return; |
825 | } |
826 | |
3976d8c9 |
827 | sub type { $_[0]{engine}->SIG_DATA } |
8fbac729 |
828 | sub _init { |
829 | my $self = shift; |
830 | |
831 | my $engine = $self->engine; |
832 | |
3976d8c9 |
833 | unless ( $self->offset ) { |
ad4ae302 |
834 | my $data_section = $self->size - 3 - 1 * $engine->byte_size; |
3976d8c9 |
835 | |
b9ec359f |
836 | $self->{offset} = $engine->_request_sector( $self->size ); |
ad4ae302 |
837 | |
2432d6cc |
838 | my $data = delete $self->{data}; |
ad4ae302 |
839 | my $dlen = length $data; |
840 | my $continue = 1; |
841 | my $curr_offset = $self->offset; |
842 | while ( $continue ) { |
843 | |
844 | my $next_offset = 0; |
845 | |
846 | my ($leftover, $this_len, $chunk); |
847 | if ( $dlen > $data_section ) { |
848 | $leftover = 0; |
849 | $this_len = $data_section; |
850 | $chunk = substr( $data, 0, $this_len ); |
851 | |
852 | $dlen -= $data_section; |
853 | $next_offset = $engine->_request_sector( $self->size ); |
854 | $data = substr( $data, $this_len ); |
855 | } |
856 | else { |
857 | $leftover = $data_section - $dlen; |
858 | $this_len = $dlen; |
859 | $chunk = $data; |
860 | |
861 | $continue = 0; |
862 | } |
863 | |
864 | $engine->storage->print_at( $curr_offset, |
865 | $self->type, # Sector type |
866 | pack( $StP{1}, 0 ), # Recycled counter |
867 | pack( $StP{$engine->byte_size}, $next_offset ), # Chain loc |
868 | pack( $StP{1}, $this_len ), # Data length |
869 | $chunk, # Data to be stored in this sector |
870 | chr(0) x $leftover, # Zero-fill the rest |
871 | ); |
872 | |
873 | $curr_offset = $next_offset; |
874 | } |
3976d8c9 |
875 | |
876 | return; |
877 | } |
878 | } |
879 | |
880 | sub data_length { |
881 | my $self = shift; |
882 | |
ad4ae302 |
883 | my $buffer = $self->engine->storage->read_at( |
3976d8c9 |
884 | $self->offset + 2 + $self->engine->byte_size, 1 |
8fbac729 |
885 | ); |
ad4ae302 |
886 | |
887 | return unpack( $StP{1}, $buffer ); |
888 | } |
889 | |
890 | sub chain_loc { |
891 | my $self = shift; |
892 | my $chain_loc = $self->engine->storage->read_at( |
893 | $self->offset + 2, $self->engine->byte_size, |
894 | ); |
895 | return unpack( $StP{$self->engine->byte_size}, $chain_loc ); |
3976d8c9 |
896 | } |
897 | |
898 | sub data { |
899 | my $self = shift; |
8fbac729 |
900 | |
378b4748 |
901 | my $data; |
902 | while ( 1 ) { |
903 | my $chain_loc = $self->chain_loc; |
ad4ae302 |
904 | |
378b4748 |
905 | $data .= $self->engine->storage->read_at( |
906 | $self->offset + 2 + $self->engine->byte_size + 1, $self->data_length, |
907 | ); |
ad4ae302 |
908 | |
378b4748 |
909 | last unless $chain_loc; |
910 | |
911 | $self = $self->engine->_load_sector( $chain_loc ); |
ad4ae302 |
912 | } |
913 | |
914 | return $data; |
8fbac729 |
915 | } |
916 | |
68369f26 |
917 | package DBM::Deep::Engine::Sector::Null; |
918 | |
919 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
920 | |
921 | sub type { $_[0]{engine}->SIG_NULL } |
922 | sub data_length { 0 } |
923 | sub data { return } |
924 | |
925 | sub _init { |
926 | my $self = shift; |
927 | |
928 | my $engine = $self->engine; |
929 | |
930 | unless ( $self->offset ) { |
931 | my $leftover = $self->size - 3 - 1 * $engine->byte_size; |
932 | |
b9ec359f |
933 | $self->{offset} = $engine->_request_sector( $self->size ); |
68369f26 |
934 | $engine->storage->print_at( $self->offset, |
935 | $self->type, # Sector type |
936 | pack( $StP{1}, 0 ), # Recycled counter |
937 | pack( $StP{$engine->byte_size}, 0 ), # Chain loc |
938 | pack( $StP{1}, $self->data_length ), # Data length |
939 | chr(0) x $leftover, # Zero-fill the rest |
940 | ); |
941 | |
942 | return; |
943 | } |
944 | } |
945 | |
3976d8c9 |
946 | package DBM::Deep::Engine::Sector::Reference; |
8fbac729 |
947 | |
3976d8c9 |
948 | our @ISA = qw( DBM::Deep::Engine::Sector::Data ); |
949 | |
950 | sub _init { |
951 | my $self = shift; |
952 | |
953 | my $engine = $self->engine; |
954 | |
955 | unless ( $self->offset ) { |
ba075714 |
956 | my $classname = Scalar::Util::blessed( delete $self->{data} ); |
d4f34951 |
957 | my $leftover = $self->size - 4 - 2 * $engine->byte_size; |
958 | |
959 | my $class_offset = 0; |
960 | if ( defined $classname ) { |
961 | my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({ |
962 | engine => $self->engine, |
963 | data => $classname, |
964 | }); |
965 | $class_offset = $class_sector->offset; |
966 | } |
3976d8c9 |
967 | |
b9ec359f |
968 | $self->{offset} = $engine->_request_sector( $self->size ); |
3976d8c9 |
969 | $engine->storage->print_at( $self->offset, |
d4f34951 |
970 | $self->type, # Sector type |
971 | pack( $StP{1}, 0 ), # Recycled counter |
972 | pack( $StP{$engine->byte_size}, 0 ), # Index/BList loc |
973 | pack( $StP{$engine->byte_size}, $class_offset ), # Classname loc |
974 | chr(0) x $leftover, # Zero-fill the rest |
3976d8c9 |
975 | ); |
976 | |
977 | return; |
978 | } |
764e6cb9 |
979 | |
980 | $self->{type} = $engine->storage->read_at( $self->offset, 1 ); |
981 | |
982 | return; |
3976d8c9 |
983 | } |
984 | |
2432d6cc |
985 | sub get_data_for { |
986 | my $self = shift; |
987 | my ($args) = @_; |
988 | |
989 | # Assume that the head is not allowed unless otherwise specified. |
990 | $args->{allow_head} = 0 unless exists $args->{allow_head}; |
991 | |
992 | # Assume we don't create a new blist location unless otherwise specified. |
993 | $args->{create} = 0 unless exists $args->{create}; |
994 | |
995 | my $blist = $self->get_bucket_list({ |
996 | key_md5 => $args->{key_md5}, |
997 | create => $args->{create}, |
998 | }); |
999 | return unless $blist && $blist->{found}; |
1000 | |
1001 | # At this point, $blist knows where the md5 is. What it -doesn't- know yet |
1002 | # is whether or not this transaction has this key. That's part of the next |
1003 | # function call. |
1004 | my $location = $blist->get_data_location_for({ |
1005 | allow_head => $args->{allow_head}, |
1006 | }) or return; |
1007 | |
1008 | return $self->engine->_load_sector( $location ); |
1009 | } |
1010 | |
1011 | sub write_data { |
1012 | my $self = shift; |
1013 | my ($args) = @_; |
1014 | |
1015 | my $blist = $self->get_bucket_list({ |
1016 | key_md5 => $args->{key_md5}, |
1017 | create => 1, |
6f999f6e |
1018 | }) or die "How did write_data fail (no blist)?!\n"; |
2432d6cc |
1019 | |
1020 | # Handle any transactional bookkeeping. |
1021 | if ( $self->engine->trans_id ) { |
1022 | if ( ! $blist->{found} ) { |
1023 | $blist->mark_deleted({ |
1024 | trans_id => 0, |
1025 | }); |
1026 | } |
1027 | } |
1028 | else { |
cf03415a |
1029 | my @trans_ids = $self->engine->get_running_txn_ids; |
2432d6cc |
1030 | if ( $blist->{found} ) { |
1031 | if ( @trans_ids ) { |
1032 | my $old_value = $blist->get_data_for; |
1033 | foreach my $other_trans_id ( @trans_ids ) { |
1034 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
6de4e4e9 |
1035 | #print "write_md5 to save a value\n"; |
2432d6cc |
1036 | $blist->write_md5({ |
1037 | trans_id => $other_trans_id, |
1038 | key => $args->{key}, |
1039 | key_md5 => $args->{key_md5}, |
1040 | value => $old_value->clone, |
1041 | }); |
1042 | } |
1043 | } |
1044 | } |
1045 | else { |
1046 | if ( @trans_ids ) { |
1047 | foreach my $other_trans_id ( @trans_ids ) { |
1048 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
1049 | $blist->mark_deleted({ |
1050 | trans_id => $other_trans_id, |
1051 | }); |
1052 | } |
1053 | } |
1054 | } |
1055 | } |
1056 | |
6f999f6e |
1057 | #XXX Is this safe to do transactionally? |
2432d6cc |
1058 | # Free the place we're about to write to. |
1059 | if ( $blist->get_data_location_for({ allow_head => 0 }) ) { |
1060 | $blist->get_data_for({ allow_head => 0 })->free; |
1061 | } |
1062 | |
1063 | $blist->write_md5({ |
1064 | key => $args->{key}, |
1065 | key_md5 => $args->{key_md5}, |
1066 | value => $args->{value}, |
1067 | }); |
1068 | } |
1069 | |
1070 | sub delete_key { |
1071 | my $self = shift; |
1072 | my ($args) = @_; |
1073 | |
1074 | # XXX What should happen if this fails? |
1075 | my $blist = $self->get_bucket_list({ |
1076 | key_md5 => $args->{key_md5}, |
1077 | }) or die "How did delete_key fail (no blist)?!\n"; |
1078 | |
6f999f6e |
1079 | # Save the location so that we can free the data |
1080 | my $location = $blist->get_data_location_for({ |
1081 | allow_head => 0, |
1082 | }); |
26897a1c |
1083 | my $old_value = $location && $self->engine->_load_sector( $location ); |
6f999f6e |
1084 | |
1085 | if ( $self->engine->trans_id == 0 ) { |
cf03415a |
1086 | my @trans_ids = $self->engine->get_running_txn_ids; |
6f999f6e |
1087 | if ( @trans_ids ) { |
1088 | foreach my $other_trans_id ( @trans_ids ) { |
1089 | next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 }); |
1090 | $blist->write_md5({ |
1091 | trans_id => $other_trans_id, |
1092 | key => $args->{key}, |
1093 | key_md5 => $args->{key_md5}, |
1094 | value => $old_value->clone, |
1095 | }); |
1096 | } |
1097 | } |
1098 | } |
1099 | |
1100 | $blist->mark_deleted( $args ); |
1101 | |
26897a1c |
1102 | my $data; |
1103 | if ( $old_value ) { |
1104 | $data = $old_value->data; |
1105 | $old_value->free; |
1106 | } |
6f999f6e |
1107 | |
1108 | return $data; |
2432d6cc |
1109 | } |
1110 | |
3976d8c9 |
1111 | sub get_blist_loc { |
1112 | my $self = shift; |
1113 | |
2432d6cc |
1114 | my $e = $self->engine; |
1115 | my $blist_loc = $e->storage->read_at( $self->offset + 2, $e->byte_size ); |
1116 | return unpack( $StP{$e->byte_size}, $blist_loc ); |
3976d8c9 |
1117 | } |
1118 | |
1119 | sub get_bucket_list { |
1120 | my $self = shift; |
1121 | my ($args) = @_; |
4eee718c |
1122 | $args ||= {}; |
3976d8c9 |
1123 | |
1124 | # XXX Add in check here for recycling? |
1125 | |
1126 | my $engine = $self->engine; |
1127 | |
1128 | my $blist_loc = $self->get_blist_loc; |
1129 | |
1130 | # There's no index or blist yet |
1131 | unless ( $blist_loc ) { |
1132 | return unless $args->{create}; |
1133 | |
1134 | my $blist = DBM::Deep::Engine::Sector::BucketList->new({ |
2432d6cc |
1135 | engine => $engine, |
1136 | key_md5 => $args->{key_md5}, |
3976d8c9 |
1137 | }); |
2432d6cc |
1138 | |
d4f34951 |
1139 | $engine->storage->print_at( $self->offset + 2, |
3976d8c9 |
1140 | pack( $StP{$engine->byte_size}, $blist->offset ), |
1141 | ); |
2432d6cc |
1142 | |
3976d8c9 |
1143 | return $blist; |
1144 | } |
1145 | |
1146 | return DBM::Deep::Engine::Sector::BucketList->new({ |
2432d6cc |
1147 | engine => $engine, |
1148 | offset => $blist_loc, |
1149 | key_md5 => $args->{key_md5}, |
3976d8c9 |
1150 | }); |
1151 | } |
1152 | |
ba075714 |
1153 | sub get_classname { |
1154 | my $self = shift; |
1155 | |
d4f34951 |
1156 | my $class_offset = $self->engine->storage->read_at( |
1157 | $self->offset + 2 + 1 * $self->engine->byte_size, $self->engine->byte_size, |
ba075714 |
1158 | ); |
d4f34951 |
1159 | $class_offset = unpack ( $StP{$self->engine->byte_size}, $class_offset ); |
ba075714 |
1160 | |
d4f34951 |
1161 | return unless $class_offset; |
ba075714 |
1162 | |
d4f34951 |
1163 | return $self->engine->_load_sector( $class_offset )->data; |
ba075714 |
1164 | } |
1165 | |
764e6cb9 |
1166 | sub data { |
1167 | my $self = shift; |
1168 | |
1169 | my $new_obj = DBM::Deep->new({ |
1170 | type => $self->type, |
1171 | base_offset => $self->offset, |
1172 | storage => $self->engine->storage, |
c9f02899 |
1173 | engine => $self->engine, |
764e6cb9 |
1174 | }); |
1175 | |
ba075714 |
1176 | if ( $self->engine->storage->{autobless} ) { |
1177 | my $classname = $self->get_classname; |
1178 | if ( defined $classname ) { |
1179 | bless $new_obj, $classname; |
1180 | } |
1181 | } |
1182 | |
764e6cb9 |
1183 | return $new_obj; |
1184 | } |
1185 | |
3976d8c9 |
1186 | package DBM::Deep::Engine::Sector::BucketList; |
1187 | |
1188 | our @ISA = qw( DBM::Deep::Engine::Sector ); |
1189 | |
1190 | sub _init { |
1191 | my $self = shift; |
1192 | |
1193 | my $engine = $self->engine; |
1194 | |
1195 | unless ( $self->offset ) { |
c000ae6e |
1196 | my $leftover = $self->size - $self->base_size; |
3976d8c9 |
1197 | |
b9ec359f |
1198 | $self->{offset} = $engine->_request_sector( $self->size ); |
3976d8c9 |
1199 | $engine->storage->print_at( $self->offset, |
1200 | $engine->SIG_BLIST, # Sector type |
1201 | pack( $StP{1}, 0 ), # Recycled counter |
1202 | chr(0) x $leftover, # Zero-fill the data |
1203 | ); |
1204 | } |
8fbac729 |
1205 | |
2432d6cc |
1206 | if ( $self->{key_md5} ) { |
1207 | $self->find_md5; |
1208 | } |
1209 | |
8fbac729 |
1210 | return $self; |
1211 | } |
8fbac729 |
1212 | |
6de4e4e9 |
1213 | sub base_size { 1 + 1 } # Sig + recycled counter |
c000ae6e |
1214 | |
3976d8c9 |
1215 | sub size { |
1216 | my $self = shift; |
2432d6cc |
1217 | unless ( $self->{size} ) { |
1218 | my $e = $self->engine; |
1219 | $self->{size} = $self->base_size + $e->max_buckets * $self->bucket_size; # Base + numbuckets * bucketsize |
1220 | } |
1221 | return $self->{size}; |
c000ae6e |
1222 | } |
1223 | |
1224 | sub bucket_size { |
1225 | my $self = shift; |
2432d6cc |
1226 | unless ( $self->{bucket_size} ) { |
1227 | my $e = $self->engine; |
6de4e4e9 |
1228 | # Key + head (location) + transactions (location + staleness-counter) |
1229 | my $location_size = $e->byte_size + $e->num_txns * ( 2 * $e->byte_size ); |
1230 | $self->{bucket_size} = $e->hash_size + $location_size; |
2432d6cc |
1231 | } |
1232 | return $self->{bucket_size}; |
3976d8c9 |
1233 | } |
8fbac729 |
1234 | |
3976d8c9 |
1235 | sub has_md5 { |
c000ae6e |
1236 | my $self = shift; |
2432d6cc |
1237 | unless ( exists $self->{found} ) { |
1238 | $self->find_md5; |
1239 | } |
1240 | return $self->{found}; |
c000ae6e |
1241 | } |
1242 | |
1243 | sub find_md5 { |
1244 | my $self = shift; |
c000ae6e |
1245 | |
2432d6cc |
1246 | $self->{found} = undef; |
1247 | $self->{idx} = -1; |
c000ae6e |
1248 | |
2432d6cc |
1249 | # If we don't have an MD5, then what are we supposed to do? |
1250 | unless ( exists $self->{key_md5} ) { |
6f999f6e |
1251 | DBM::Deep->_throw_error( "Cannot find_md5 without a key_md5 set" ); |
2432d6cc |
1252 | } |
8cb9205a |
1253 | |
2432d6cc |
1254 | my $e = $self->engine; |
1255 | foreach my $idx ( 0 .. $e->max_buckets - 1 ) { |
1256 | my $potential = $e->storage->read_at( |
1257 | $self->offset + $self->base_size + $idx * $self->bucket_size, $e->hash_size, |
1258 | ); |
1259 | |
1260 | if ( $potential eq $e->blank_md5 ) { |
1261 | $self->{idx} = $idx; |
1262 | return; |
1263 | } |
8cb9205a |
1264 | |
2432d6cc |
1265 | if ( $potential eq $self->{key_md5} ) { |
1266 | $self->{found} = 1; |
1267 | $self->{idx} = $idx; |
1268 | return; |
8cb9205a |
1269 | } |
c000ae6e |
1270 | } |
1271 | |
1272 | return; |
3976d8c9 |
1273 | } |
1274 | |
1275 | sub write_md5 { |
1276 | my $self = shift; |
2432d6cc |
1277 | my ($args) = @_; |
2432d6cc |
1278 | |
6f999f6e |
1279 | DBM::Deep->_throw_error( "write_md5: no key" ) unless exists $args->{key}; |
1280 | DBM::Deep->_throw_error( "write_md5: no key_md5" ) unless exists $args->{key_md5}; |
1281 | DBM::Deep->_throw_error( "write_md5: no value" ) unless exists $args->{value}; |
3976d8c9 |
1282 | |
1283 | my $engine = $self->engine; |
6f999f6e |
1284 | |
1285 | $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; |
1286 | |
2432d6cc |
1287 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
6de4e4e9 |
1288 | #print "Adding $args->{trans_id} -> $spot\n"; |
6f999f6e |
1289 | $engine->add_entry( $args->{trans_id}, $spot ); |
4eee718c |
1290 | |
2432d6cc |
1291 | unless ($self->{found}) { |
4eee718c |
1292 | my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({ |
6f999f6e |
1293 | engine => $engine, |
2432d6cc |
1294 | data => $args->{key}, |
4eee718c |
1295 | }); |
1296 | |
1297 | $engine->storage->print_at( $spot, |
2432d6cc |
1298 | $args->{key_md5}, |
6f999f6e |
1299 | pack( $StP{$engine->byte_size}, $key_sector->offset ), |
4eee718c |
1300 | ); |
1301 | } |
1302 | |
6f999f6e |
1303 | my $loc = $spot |
2432d6cc |
1304 | + $engine->hash_size |
1305 | + $engine->byte_size |
6de4e4e9 |
1306 | + $args->{trans_id} * ( 2 * $engine->byte_size ); |
6f999f6e |
1307 | |
1308 | $engine->storage->print_at( $loc, |
2432d6cc |
1309 | pack( $StP{$engine->byte_size}, $args->{value}->offset ), |
6de4e4e9 |
1310 | pack( 'N', $engine->get_txn_staleness_counter( $args->{trans_id} ) ), |
2432d6cc |
1311 | ); |
1312 | } |
1313 | |
1314 | sub mark_deleted { |
1315 | my $self = shift; |
1316 | my ($args) = @_; |
6f999f6e |
1317 | $args ||= {}; |
1318 | |
1319 | my $engine = $self->engine; |
1320 | |
1321 | $args->{trans_id} = $engine->trans_id unless exists $args->{trans_id}; |
2432d6cc |
1322 | |
1323 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
6f999f6e |
1324 | $engine->add_entry( $args->{trans_id}, $spot ); |
1325 | |
1326 | my $loc = $spot |
1327 | + $engine->hash_size |
1328 | + $engine->byte_size |
6de4e4e9 |
1329 | + $args->{trans_id} * ( 2 * $engine->byte_size ); |
6f999f6e |
1330 | |
1331 | $engine->storage->print_at( $loc, |
1332 | pack( $StP{$engine->byte_size}, 1 ), # 1 is the marker for deleted |
6de4e4e9 |
1333 | pack( 'N', $engine->get_txn_staleness_counter( $args->{trans_id} ) ), |
3976d8c9 |
1334 | ); |
1335 | } |
1336 | |
e86cef36 |
1337 | sub delete_md5 { |
3976d8c9 |
1338 | my $self = shift; |
2432d6cc |
1339 | my ($args) = @_; |
3976d8c9 |
1340 | |
e86cef36 |
1341 | my $engine = $self->engine; |
2432d6cc |
1342 | return undef unless $self->{found}; |
4eee718c |
1343 | |
1344 | # Save the location so that we can free the data |
2432d6cc |
1345 | my $location = $self->get_data_location_for({ |
1346 | allow_head => 0, |
1347 | }); |
1348 | my $key_sector = $self->get_key_for; |
4eee718c |
1349 | |
6f999f6e |
1350 | #XXX This isn't going to work right and you know it! This eradicates data |
1351 | # that we're not ready to eradicate just yet. |
2432d6cc |
1352 | my $spot = $self->offset + $self->base_size + $self->{idx} * $self->bucket_size; |
4eee718c |
1353 | $engine->storage->print_at( $spot, |
1354 | $engine->storage->read_at( |
1355 | $spot + $self->bucket_size, |
2432d6cc |
1356 | $self->bucket_size * ( $engine->num_txns - $self->{idx} - 1 ), |
4eee718c |
1357 | ), |
1358 | chr(0) x $self->bucket_size, |
e86cef36 |
1359 | ); |
1360 | |
3ed26433 |
1361 | $key_sector->free; |
1362 | |
ed38e772 |
1363 | my $data_sector = $self->engine->_load_sector( $location ); |
1364 | my $data = $data_sector->data; |
ed38e772 |
1365 | $data_sector->free; |
5c0f86e1 |
1366 | |
1367 | return $data; |
e86cef36 |
1368 | } |
1369 | |
ed38e772 |
1370 | sub get_data_location_for { |
e86cef36 |
1371 | my $self = shift; |
2432d6cc |
1372 | my ($args) = @_; |
1373 | $args ||= {}; |
1374 | |
1375 | $args->{allow_head} = 0 unless exists $args->{allow_head}; |
1376 | $args->{trans_id} = $self->engine->trans_id unless exists $args->{trans_id}; |
1377 | $args->{idx} = $self->{idx} unless exists $args->{idx}; |
e86cef36 |
1378 | |
6de4e4e9 |
1379 | my $e = $self->engine; |
1380 | |
1381 | my $spot = $self->offset + $self->base_size |
2432d6cc |
1382 | + $args->{idx} * $self->bucket_size |
6de4e4e9 |
1383 | + $e->hash_size |
1384 | + $e->byte_size |
1385 | + $args->{trans_id} * ( 2 * $e->byte_size ); |
1386 | |
1387 | my $buffer = $e->storage->read_at( |
1388 | $spot, |
1389 | 2 * $e->byte_size, |
3976d8c9 |
1390 | ); |
6de4e4e9 |
1391 | my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' N', $buffer ); |
1392 | |
1393 | # We have found an entry that is old, so get rid of it |
1394 | if ( $staleness != $e->get_txn_staleness_counter( $args->{trans_id} ) ) { |
1395 | $e->storage->print_at( |
1396 | $spot, |
1397 | pack( $StP{$e->byte_size} . ' N', (0) x 2 ), |
1398 | ); |
1399 | $loc = 0; |
1400 | } |
8cb9205a |
1401 | |
1402 | # If we're in a transaction and we never wrote to this location, try the |
1403 | # HEAD instead. |
2432d6cc |
1404 | if ( $args->{trans_id} && !$loc && $args->{allow_head} ) { |
1405 | return $self->get_data_location_for({ |
1406 | trans_id => 0, |
1407 | allow_head => 1, |
1408 | }); |
8cb9205a |
1409 | } |
2432d6cc |
1410 | return $loc <= 1 ? 0 : $loc; |
e86cef36 |
1411 | } |
1412 | |
1413 | sub get_data_for { |
1414 | my $self = shift; |
2432d6cc |
1415 | my ($args) = @_; |
1416 | $args ||= {}; |
e86cef36 |
1417 | |
2432d6cc |
1418 | return unless $self->{found}; |
1419 | my $location = $self->get_data_location_for({ |
1420 | allow_head => $args->{allow_head}, |
1421 | }); |
ed38e772 |
1422 | return $self->engine->_load_sector( $location ); |
1423 | } |
1424 | |
1425 | sub get_key_for { |
1426 | my $self = shift; |
1427 | my ($idx) = @_; |
2432d6cc |
1428 | $idx = $self->{idx} unless defined $idx; |
ed38e772 |
1429 | |
1430 | my $location = $self->engine->storage->read_at( |
1431 | $self->offset + $self->base_size + $idx * $self->bucket_size + $self->engine->hash_size, |
1432 | $self->engine->byte_size, |
1433 | ); |
1434 | $location = unpack( $StP{$self->engine->byte_size}, $location ); |
1435 | return unless $location; |
68369f26 |
1436 | return $self->engine->_load_sector( $location ); |
3976d8c9 |
1437 | } |
696cadb7 |
1438 | |
1439 | 1; |
1440 | __END__ |