Commit | Line | Data |
a20d9a3f |
1 | package DBM::Deep::Engine; |
2 | |
2120a181 |
3 | use 5.006_000; |
460b1067 |
4 | |
a20d9a3f |
5 | use strict; |
065b45be |
6 | use warnings FATAL => 'all'; |
a20d9a3f |
7 | |
75a6a379 |
8 | # Never import symbols into our namespace. We are a class, not a library. |
9 | # -RobK, 2008-05-27 |
10 | use Scalar::Util (); |
d6d8e27e |
11 | |
12 | #use Data::Dumper (); |
75a6a379 |
13 | |
21838116 |
14 | # File-wide notes: |
2120a181 |
15 | # * Every method in here assumes that the storage has been appropriately |
c3aafc14 |
16 | # safeguarded. This can be anything from flock() to some sort of manual |
17 | # mutex. But, it's the caller's responsability to make sure that this has |
18 | # been done. |
21838116 |
19 | |
8db25060 |
20 | # Setup file and tag signatures. These should never change. |
8db25060 |
21 | sub SIG_FILE () { 'DPDB' } |
460b1067 |
22 | sub SIG_HEADER () { 'h' } |
8db25060 |
23 | sub SIG_HASH () { 'H' } |
24 | sub SIG_ARRAY () { 'A' } |
8db25060 |
25 | sub SIG_NULL () { 'N' } |
26 | sub SIG_DATA () { 'D' } |
27 | sub SIG_INDEX () { 'I' } |
28 | sub SIG_BLIST () { 'B' } |
7b1e1aa1 |
29 | sub SIG_FREE () { 'F' } |
8db25060 |
30 | sub SIG_SIZE () { 1 } |
e9b0b5f0 |
31 | |
d426259c |
32 | use DBM::Deep::Storage::File (); |
5ae752e2 |
33 | use DBM::Deep::Iterator (); |
f0276afb |
34 | use DBM::Deep::Engine::Sector::Data (); |
35 | use DBM::Deep::Engine::Sector::BucketList (); |
36 | use DBM::Deep::Engine::Sector::Index (); |
37 | use DBM::Deep::Engine::Sector::Null (); |
38 | use DBM::Deep::Engine::Sector::Reference (); |
39 | use DBM::Deep::Engine::Sector::Scalar (); |
40 | use DBM::Deep::Null (); |
41 | |
9c87a079 |
42 | my $STALE_SIZE = 2; |
8db25060 |
43 | |
2120a181 |
44 | # Please refer to the pack() documentation for further information |
45 | my %StP = ( |
e9b0b5f0 |
46 | 1 => 'C', # Unsigned char value (no order needed as it's just one byte) |
2120a181 |
47 | 2 => 'n', # Unsigned short in "network" (big-endian) order |
48 | 4 => 'N', # Unsigned long in "network" (big-endian) order |
49 | 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) |
50 | ); |
00d9bd0b |
51 | |
ae6c15b8 |
52 | =head1 NAME |
53 | |
54 | DBM::Deep::Engine |
55 | |
56 | =head1 PURPOSE |
57 | |
58 | This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level |
59 | mapping between the L<DBM::Deep/> objects and the storage medium. |
60 | |
61 | The purpose of this documentation is to provide low-level documentation for |
62 | developers. It is B<not> intended to be used by the general public. This |
63 | documentation and what it documents can and will change without notice. |
64 | |
65 | =head1 OVERVIEW |
66 | |
67 | The engine exposes an API to the DBM::Deep objects (DBM::Deep, DBM::Deep::Array, |
68 | and DBM::Deep::Hash) for their use to access the actual stored values. This API |
69 | is the following: |
70 | |
71 | =over 4 |
72 | |
73 | =item * new |
74 | |
75 | =item * read_value |
76 | |
77 | =item * get_classname |
78 | |
79 | =item * make_reference |
80 | |
81 | =item * key_exists |
82 | |
83 | =item * delete_key |
84 | |
85 | =item * write_value |
86 | |
87 | =item * get_next_key |
88 | |
89 | =item * setup_fh |
90 | |
91 | =item * begin_work |
92 | |
93 | =item * commit |
94 | |
95 | =item * rollback |
96 | |
97 | =item * lock_exclusive |
98 | |
99 | =item * lock_shared |
100 | |
101 | =item * unlock |
102 | |
103 | =back |
104 | |
105 | They are explained in their own sections below. These methods, in turn, may |
106 | provide some bounds-checking, but primarily act to instantiate objects in the |
107 | Engine::Sector::* hierarchy and dispatch to them. |
108 | |
109 | =head1 TRANSACTIONS |
110 | |
111 | Transactions in DBM::Deep are implemented using a variant of MVCC. This attempts |
112 | to keep the amount of actual work done against the file low while stil providing |
113 | Atomicity, Consistency, and Isolation. Durability, unfortunately, cannot be done |
114 | with only one file. |
115 | |
116 | =head2 STALENESS |
117 | |
3b90cc56 |
118 | If another process uses a transaction slot and writes stuff to it, then |
119 | terminates, the data that process wrote it still within the file. In order to |
120 | address this, there is also a transaction staleness counter associated within |
121 | every write. Each time a transaction is started, that process increments that |
122 | transaction's staleness counter. If, when it reads a value, the staleness |
123 | counters aren't identical, DBM::Deep will consider the value on disk to be stale |
124 | and discard it. |
ae6c15b8 |
125 | |
126 | =head2 DURABILITY |
127 | |
128 | The fourth leg of ACID is Durability, the guarantee that when a commit returns, |
129 | the data will be there the next time you read from it. This should be regardless |
3b90cc56 |
130 | of any crashes or powerdowns in between the commit and subsequent read. |
131 | DBM::Deep does provide that guarantee; once the commit returns, all of the data |
132 | has been transferred from the transaction shadow to the HEAD. The issue arises |
133 | with partial commits - a commit that is interrupted in some fashion. In keeping |
134 | with DBM::Deep's "tradition" of very light error-checking and non-existent |
135 | error-handling, there is no way to recover from a partial commit. (This is |
136 | probably a failure in Consistency as well as Durability.) |
137 | |
138 | Other DBMSes use transaction logs (a separate file, generally) to achieve |
139 | Durability. As DBM::Deep is a single-file, we would have to do something |
140 | similar to what SQLite and BDB do in terms of committing using synchonized |
141 | writes. To do this, we would have to use a much higher RAM footprint and some |
142 | serious programming that make my head hurts just to think about it. |
ae6c15b8 |
143 | |
144 | =head1 EXTERNAL METHODS |
145 | |
ae6c15b8 |
146 | =head2 new() |
147 | |
148 | This takes a set of args. These args are described in the documentation for |
149 | L<DBM::Deep/new>. |
150 | |
151 | =cut |
152 | |
612969fb |
153 | sub new { |
154 | my $class = shift; |
155 | my ($args) = @_; |
156 | |
d426259c |
157 | $args->{storage} = DBM::Deep::Storage::File->new( $args ) |
f1879fdc |
158 | unless exists $args->{storage}; |
159 | |
612969fb |
160 | my $self = bless { |
2120a181 |
161 | byte_size => 4, |
162 | |
163 | digest => undef, |
164 | hash_size => 16, # In bytes |
165 | hash_chars => 256, # Number of chars the algorithm uses per byte |
612969fb |
166 | max_buckets => 16, |
e9b0b5f0 |
167 | num_txns => 1, # The HEAD |
2120a181 |
168 | trans_id => 0, # Default to the HEAD |
460b1067 |
169 | |
e9b0b5f0 |
170 | data_sector_size => 64, # Size in bytes of each data sector |
171 | |
2120a181 |
172 | entries => {}, # This is the list of entries for transactions |
83371fe3 |
173 | storage => undef, |
612969fb |
174 | }, $class; |
175 | |
e9b0b5f0 |
176 | # Never allow byte_size to be set directly. |
177 | delete $args->{byte_size}; |
e0098e7f |
178 | if ( defined $args->{pack_size} ) { |
179 | if ( lc $args->{pack_size} eq 'small' ) { |
2120a181 |
180 | $args->{byte_size} = 2; |
e0098e7f |
181 | } |
182 | elsif ( lc $args->{pack_size} eq 'medium' ) { |
2120a181 |
183 | $args->{byte_size} = 4; |
e0098e7f |
184 | } |
185 | elsif ( lc $args->{pack_size} eq 'large' ) { |
2120a181 |
186 | $args->{byte_size} = 8; |
e0098e7f |
187 | } |
188 | else { |
2120a181 |
189 | DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" ); |
e0098e7f |
190 | } |
191 | } |
192 | |
fde3db1a |
193 | # Grab the parameters we want to use |
194 | foreach my $param ( keys %$self ) { |
195 | next unless exists $args->{$param}; |
3e9498a1 |
196 | $self->{$param} = $args->{$param}; |
fde3db1a |
197 | } |
198 | |
e9b0b5f0 |
199 | my %validations = ( |
200 | max_buckets => { floor => 16, ceil => 256 }, |
201 | num_txns => { floor => 1, ceil => 255 }, |
202 | data_sector_size => { floor => 32, ceil => 256 }, |
203 | ); |
204 | |
205 | while ( my ($attr, $c) = each %validations ) { |
206 | if ( !defined $self->{$attr} |
207 | || !length $self->{$attr} |
208 | || $self->{$attr} =~ /\D/ |
209 | || $self->{$attr} < $c->{floor} |
210 | ) { |
211 | $self->{$attr} = '(undef)' if !defined $self->{$attr}; |
212 | warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n"; |
213 | $self->{$attr} = $c->{floor}; |
214 | } |
215 | elsif ( $self->{$attr} > $c->{ceil} ) { |
216 | warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n"; |
217 | $self->{$attr} = $c->{ceil}; |
218 | } |
e0098e7f |
219 | } |
220 | |
2120a181 |
221 | if ( !$self->{digest} ) { |
222 | require Digest::MD5; |
223 | $self->{digest} = \&Digest::MD5::md5; |
224 | } |
225 | |
260a80b4 |
226 | return $self; |
227 | } |
228 | |
ae6c15b8 |
229 | =head2 read_value( $obj, $key ) |
230 | |
231 | This takes an object that provides _base_offset() and a string. It returns the |
232 | value stored in the corresponding Sector::Value's data section. |
233 | |
234 | =cut |
235 | |
2120a181 |
236 | sub read_value { |
c3aafc14 |
237 | my $self = shift; |
2120a181 |
238 | my ($obj, $key) = @_; |
239 | |
240 | # This will be a Reference sector |
241 | my $sector = $self->_load_sector( $obj->_base_offset ) |
242 | or return; |
243 | |
244 | if ( $sector->staleness != $obj->_staleness ) { |
245 | return; |
246 | } |
247 | |
248 | my $key_md5 = $self->_apply_digest( $key ); |
249 | |
250 | my $value_sector = $sector->get_data_for({ |
251 | key_md5 => $key_md5, |
252 | allow_head => 1, |
253 | }); |
254 | |
255 | unless ( $value_sector ) { |
256 | $value_sector = DBM::Deep::Engine::Sector::Null->new({ |
257 | engine => $self, |
258 | data => undef, |
259 | }); |
260 | |
261 | $sector->write_data({ |
262 | key_md5 => $key_md5, |
263 | key => $key, |
264 | value => $value_sector, |
265 | }); |
266 | } |
267 | |
268 | return $value_sector->data; |
c3aafc14 |
269 | } |
270 | |
ae6c15b8 |
271 | =head2 get_classname( $obj ) |
272 | |
3b90cc56 |
273 | This takes an object that provides _base_offset() and returns the classname (if |
274 | any) associated with it. |
ae6c15b8 |
275 | |
276 | It delegates to Sector::Reference::get_classname() for the heavy lifting. |
277 | |
278 | It performs a staleness check. |
279 | |
280 | =cut |
281 | |
2120a181 |
282 | sub get_classname { |
260a80b4 |
283 | my $self = shift; |
2120a181 |
284 | my ($obj) = @_; |
260a80b4 |
285 | |
2120a181 |
286 | # This will be a Reference sector |
287 | my $sector = $self->_load_sector( $obj->_base_offset ) |
288 | or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" ); |
612969fb |
289 | |
2120a181 |
290 | if ( $sector->staleness != $obj->_staleness ) { |
291 | return; |
292 | } |
ea2f6d67 |
293 | |
2120a181 |
294 | return $sector->get_classname; |
1bf65be7 |
295 | } |
296 | |
ae6c15b8 |
297 | =head2 make_reference( $obj, $old_key, $new_key ) |
298 | |
299 | This takes an object that provides _base_offset() and two strings. The |
300 | strings correspond to the old key and new key, respectively. This operation |
3b90cc56 |
301 | is equivalent to (given C<< $db->{foo} = []; >>) C<< $db->{bar} = $db->{foo} >>. |
ae6c15b8 |
302 | |
303 | This returns nothing. |
304 | |
305 | =cut |
306 | |
1cff45d7 |
307 | sub make_reference { |
308 | my $self = shift; |
309 | my ($obj, $old_key, $new_key) = @_; |
310 | |
311 | # This will be a Reference sector |
312 | my $sector = $self->_load_sector( $obj->_base_offset ) |
ae6c15b8 |
313 | or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" ); |
1cff45d7 |
314 | |
315 | if ( $sector->staleness != $obj->_staleness ) { |
316 | return; |
317 | } |
318 | |
319 | my $old_md5 = $self->_apply_digest( $old_key ); |
320 | |
321 | my $value_sector = $sector->get_data_for({ |
322 | key_md5 => $old_md5, |
323 | allow_head => 1, |
324 | }); |
325 | |
326 | unless ( $value_sector ) { |
327 | $value_sector = DBM::Deep::Engine::Sector::Null->new({ |
328 | engine => $self, |
329 | data => undef, |
330 | }); |
331 | |
332 | $sector->write_data({ |
333 | key_md5 => $old_md5, |
334 | key => $old_key, |
335 | value => $value_sector, |
336 | }); |
337 | } |
338 | |
339 | if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) { |
340 | $sector->write_data({ |
341 | key => $new_key, |
342 | key_md5 => $self->_apply_digest( $new_key ), |
343 | value => $value_sector, |
344 | }); |
345 | $value_sector->increment_refcount; |
346 | } |
347 | else { |
348 | $sector->write_data({ |
349 | key => $new_key, |
350 | key_md5 => $self->_apply_digest( $new_key ), |
351 | value => $value_sector->clone, |
352 | }); |
353 | } |
ae6c15b8 |
354 | |
355 | return; |
1cff45d7 |
356 | } |
357 | |
ae6c15b8 |
358 | =head2 key_exists( $obj, $key ) |
359 | |
360 | This takes an object that provides _base_offset() and a string for |
361 | the key to be checked. This returns 1 for true and "" for false. |
362 | |
363 | =cut |
364 | |
2120a181 |
365 | sub key_exists { |
0d0f3d5d |
366 | my $self = shift; |
2120a181 |
367 | my ($obj, $key) = @_; |
0d0f3d5d |
368 | |
2120a181 |
369 | # This will be a Reference sector |
370 | my $sector = $self->_load_sector( $obj->_base_offset ) |
371 | or return ''; |
0d0f3d5d |
372 | |
2120a181 |
373 | if ( $sector->staleness != $obj->_staleness ) { |
374 | return ''; |
375 | } |
0d0f3d5d |
376 | |
2120a181 |
377 | my $data = $sector->get_data_for({ |
378 | key_md5 => $self->_apply_digest( $key ), |
379 | allow_head => 1, |
380 | }); |
20b7f047 |
381 | |
2120a181 |
382 | # exists() returns 1 or '' for true/false. |
383 | return $data ? 1 : ''; |
0d0f3d5d |
384 | } |
385 | |
ae6c15b8 |
386 | =head2 delete_key( $obj, $key ) |
387 | |
388 | This takes an object that provides _base_offset() and a string for |
389 | the key to be deleted. This returns the result of the Sector::Reference |
390 | delete_key() method. |
391 | |
392 | =cut |
393 | |
2120a181 |
394 | sub delete_key { |
e064ccd1 |
395 | my $self = shift; |
2120a181 |
396 | my ($obj, $key) = @_; |
e064ccd1 |
397 | |
2120a181 |
398 | my $sector = $self->_load_sector( $obj->_base_offset ) |
399 | or return; |
460b1067 |
400 | |
2120a181 |
401 | if ( $sector->staleness != $obj->_staleness ) { |
402 | return; |
403 | } |
404 | |
405 | return $sector->delete_key({ |
406 | key_md5 => $self->_apply_digest( $key ), |
407 | allow_head => 0, |
408 | }); |
409 | } |
410 | |
ae6c15b8 |
411 | =head2 write_value( $obj, $key, $value ) |
412 | |
413 | This takes an object that provides _base_offset(), a string for the |
414 | key, and a value. This value can be anything storable within L<DBM::Deep/>. |
415 | |
416 | This returns 1 upon success. |
417 | |
418 | =cut |
419 | |
2120a181 |
420 | sub write_value { |
421 | my $self = shift; |
422 | my ($obj, $key, $value) = @_; |
423 | |
424 | my $r = Scalar::Util::reftype( $value ) || ''; |
425 | { |
426 | last if $r eq ''; |
427 | last if $r eq 'HASH'; |
428 | last if $r eq 'ARRAY'; |
e064ccd1 |
429 | |
2120a181 |
430 | DBM::Deep->_throw_error( |
431 | "Storage of references of type '$r' is not supported." |
432 | ); |
460b1067 |
433 | } |
260a80b4 |
434 | |
1cff45d7 |
435 | # This will be a Reference sector |
436 | my $sector = $self->_load_sector( $obj->_base_offset ) |
9c87a079 |
437 | or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." ); |
1cff45d7 |
438 | |
439 | if ( $sector->staleness != $obj->_staleness ) { |
9c87a079 |
440 | DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." ); |
1cff45d7 |
441 | } |
442 | |
2120a181 |
443 | my ($class, $type); |
444 | if ( !defined $value ) { |
445 | $class = 'DBM::Deep::Engine::Sector::Null'; |
446 | } |
447 | elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) { |
75a6a379 |
448 | my $tmpvar; |
449 | if ( $r eq 'ARRAY' ) { |
450 | $tmpvar = tied @$value; |
451 | } elsif ( $r eq 'HASH' ) { |
452 | $tmpvar = tied %$value; |
453 | } |
5ef7542f |
454 | |
edd45134 |
455 | if ( $tmpvar ) { |
456 | my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); }; |
457 | |
458 | unless ( $is_dbm_deep ) { |
459 | DBM::Deep->_throw_error( "Cannot store something that is tied." ); |
460 | } |
461 | |
d6d8e27e |
462 | unless ( $tmpvar->_engine->storage == $self->storage ) { |
75a6a379 |
463 | DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." ); |
5ef7542f |
464 | } |
5ef7542f |
465 | |
d6d8e27e |
466 | # First, verify if we're storing the same thing to this spot. If we are, then |
467 | # this should be a no-op. -EJS, 2008-05-19 |
468 | my $loc = $sector->get_data_location_for({ |
469 | key_md5 => $self->_apply_digest( $key ), |
470 | allow_head => 1, |
471 | }); |
472 | |
473 | if ( defined($loc) && $loc == $tmpvar->_base_offset ) { |
1cff45d7 |
474 | return 1; |
475 | } |
476 | |
edd45134 |
477 | #XXX Can this use $loc? |
d6d8e27e |
478 | my $value_sector = $self->_load_sector( $tmpvar->_base_offset ); |
479 | $sector->write_data({ |
480 | key => $key, |
481 | key_md5 => $self->_apply_digest( $key ), |
482 | value => $value_sector, |
483 | }); |
484 | $value_sector->increment_refcount; |
485 | |
486 | return 1; |
1cff45d7 |
487 | } |
edd45134 |
488 | |
2120a181 |
489 | $class = 'DBM::Deep::Engine::Sector::Reference'; |
490 | $type = substr( $r, 0, 1 ); |
491 | } |
492 | else { |
1cff45d7 |
493 | if ( tied($value) ) { |
494 | DBM::Deep->_throw_error( "Cannot store something that is tied." ); |
495 | } |
2120a181 |
496 | $class = 'DBM::Deep::Engine::Sector::Scalar'; |
460b1067 |
497 | } |
9b2370e0 |
498 | |
2120a181 |
499 | # Create this after loading the reference sector in case something bad happens. |
500 | # This way, we won't allocate value sector(s) needlessly. |
501 | my $value_sector = $class->new({ |
502 | engine => $self, |
503 | data => $value, |
504 | type => $type, |
505 | }); |
75a6a379 |
506 | |
2120a181 |
507 | $sector->write_data({ |
508 | key => $key, |
509 | key_md5 => $self->_apply_digest( $key ), |
510 | value => $value_sector, |
511 | }); |
512 | |
513 | # This code is to make sure we write all the values in the $value to the disk |
514 | # and to make sure all changes to $value after the assignment are reflected |
515 | # on disk. This may be counter-intuitive at first, but it is correct dwimmery. |
516 | # NOTE - simply tying $value won't perform a STORE on each value. Hence, the |
517 | # copy to a temp value. |
518 | if ( $r eq 'ARRAY' ) { |
519 | my @temp = @$value; |
520 | tie @$value, 'DBM::Deep', { |
521 | base_offset => $value_sector->offset, |
522 | staleness => $value_sector->staleness, |
523 | storage => $self->storage, |
524 | engine => $self, |
525 | }; |
526 | @$value = @temp; |
527 | bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value ); |
e064ccd1 |
528 | } |
2120a181 |
529 | elsif ( $r eq 'HASH' ) { |
530 | my %temp = %$value; |
531 | tie %$value, 'DBM::Deep', { |
532 | base_offset => $value_sector->offset, |
533 | staleness => $value_sector->staleness, |
534 | storage => $self->storage, |
535 | engine => $self, |
536 | }; |
e064ccd1 |
537 | |
2120a181 |
538 | %$value = %temp; |
539 | bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value ); |
540 | } |
460b1067 |
541 | |
2120a181 |
542 | return 1; |
e064ccd1 |
543 | } |
544 | |
ae6c15b8 |
545 | =head2 get_next_key( $obj, $prev_key ) |
546 | |
547 | This takes an object that provides _base_offset() and an optional string |
548 | representing the prior key returned via a prior invocation of this method. |
549 | |
550 | This method delegates to C<< DBM::Deep::Iterator->get_next_key() >>. |
551 | |
552 | =cut |
553 | |
2120a181 |
554 | # XXX Add staleness here |
555 | sub get_next_key { |
460b1067 |
556 | my $self = shift; |
2120a181 |
557 | my ($obj, $prev_key) = @_; |
70b55428 |
558 | |
2120a181 |
559 | # XXX Need to add logic about resetting the iterator if any key in the reference has changed |
560 | unless ( $prev_key ) { |
561 | $obj->{iterator} = DBM::Deep::Iterator->new({ |
562 | base_offset => $obj->_base_offset, |
563 | engine => $self, |
564 | }); |
565 | } |
118ba343 |
566 | |
2120a181 |
567 | return $obj->{iterator}->get_next_key( $obj ); |
568 | } |
118ba343 |
569 | |
ae6c15b8 |
570 | =head2 setup_fh( $obj ) |
571 | |
572 | This takes an object that provides _base_offset(). It will do everything needed |
573 | in order to properly initialize all values for necessary functioning. If this is |
574 | called upon an already initialized object, this will also reset the inode. |
575 | |
576 | This returns 1. |
577 | |
578 | =cut |
579 | |
2120a181 |
580 | sub setup_fh { |
581 | my $self = shift; |
582 | my ($obj) = @_; |
359a01ac |
583 | |
9c87a079 |
584 | # We're opening the file. |
585 | unless ( $obj->_base_offset ) { |
586 | my $bytes_read = $self->_read_file_header; |
118ba343 |
587 | |
9c87a079 |
588 | # Creating a new file |
589 | unless ( $bytes_read ) { |
590 | $self->_write_file_header; |
118ba343 |
591 | |
9c87a079 |
592 | # 1) Create Array/Hash entry |
593 | my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({ |
594 | engine => $self, |
595 | type => $obj->_type, |
596 | }); |
597 | $obj->{base_offset} = $initial_reference->offset; |
598 | $obj->{staleness} = $initial_reference->staleness; |
118ba343 |
599 | |
9c87a079 |
600 | $self->storage->flush; |
118ba343 |
601 | } |
9c87a079 |
602 | # Reading from an existing file |
603 | else { |
604 | $obj->{base_offset} = $bytes_read; |
605 | my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({ |
606 | engine => $self, |
607 | offset => $obj->_base_offset, |
608 | }); |
609 | unless ( $initial_reference ) { |
610 | DBM::Deep->_throw_error("Corrupted file, no master index record"); |
611 | } |
2120a181 |
612 | |
9c87a079 |
613 | unless ($obj->_type eq $initial_reference->type) { |
614 | DBM::Deep->_throw_error("File type mismatch"); |
615 | } |
f1879fdc |
616 | |
9c87a079 |
617 | $obj->{staleness} = $initial_reference->staleness; |
618 | } |
118ba343 |
619 | } |
2120a181 |
620 | |
a5bdb1ac |
621 | $self->storage->set_inode; |
622 | |
2120a181 |
623 | return 1; |
624 | } |
625 | |
ae6c15b8 |
626 | =head2 begin_work( $obj ) |
627 | |
628 | This takes an object that provides _base_offset(). It will set up all necessary |
629 | bookkeeping in order to run all work within a transaction. |
630 | |
631 | If $obj is already within a transaction, an error wiill be thrown. If there are |
632 | no more available transactions, an error will be thrown. |
633 | |
634 | This returns undef. |
635 | |
636 | =cut |
637 | |
2120a181 |
638 | sub begin_work { |
639 | my $self = shift; |
640 | my ($obj) = @_; |
641 | |
642 | if ( $self->trans_id ) { |
643 | DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" ); |
644 | } |
645 | |
646 | my @slots = $self->read_txn_slots; |
e9b0b5f0 |
647 | my $found; |
648 | for my $i ( 0 .. $#slots ) { |
2120a181 |
649 | next if $slots[$i]; |
e9b0b5f0 |
650 | |
2120a181 |
651 | $slots[$i] = 1; |
e9b0b5f0 |
652 | $self->set_trans_id( $i + 1 ); |
653 | $found = 1; |
2120a181 |
654 | last; |
655 | } |
e9b0b5f0 |
656 | unless ( $found ) { |
657 | DBM::Deep->_throw_error( "Cannot allocate transaction ID" ); |
658 | } |
2120a181 |
659 | $self->write_txn_slots( @slots ); |
660 | |
661 | if ( !$self->trans_id ) { |
662 | DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" ); |
663 | } |
664 | |
665 | return; |
666 | } |
667 | |
ae6c15b8 |
668 | =head2 rollback( $obj ) |
669 | |
670 | This takes an object that provides _base_offset(). It will revert all |
671 | actions taken within the running transaction. |
672 | |
673 | If $obj is not within a transaction, an error will be thrown. |
674 | |
675 | This returns 1. |
676 | |
677 | =cut |
678 | |
2120a181 |
679 | sub rollback { |
680 | my $self = shift; |
681 | my ($obj) = @_; |
682 | |
683 | if ( !$self->trans_id ) { |
684 | DBM::Deep->_throw_error( "Cannot rollback without an active transaction" ); |
685 | } |
686 | |
9c87a079 |
687 | # Each entry is the file location for a bucket that has a modification for |
688 | # this transaction. The entries need to be expunged. |
689 | foreach my $entry (@{ $self->get_entries } ) { |
690 | # Remove the entry here |
691 | my $read_loc = $entry |
692 | + $self->hash_size |
693 | + $self->byte_size |
694 | + $self->byte_size |
695 | + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE ); |
696 | |
697 | my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size ); |
698 | $data_loc = unpack( $StP{$self->byte_size}, $data_loc ); |
699 | $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) ); |
700 | |
701 | if ( $data_loc > 1 ) { |
702 | $self->_load_sector( $data_loc )->free; |
703 | } |
db2eb673 |
704 | } |
705 | |
2120a181 |
706 | $self->clear_entries; |
70b55428 |
707 | |
2120a181 |
708 | my @slots = $self->read_txn_slots; |
e9b0b5f0 |
709 | $slots[$self->trans_id-1] = 0; |
2120a181 |
710 | $self->write_txn_slots( @slots ); |
711 | $self->inc_txn_staleness_counter( $self->trans_id ); |
712 | $self->set_trans_id( 0 ); |
6fde4ed2 |
713 | |
70b55428 |
714 | return 1; |
715 | } |
716 | |
ae6c15b8 |
717 | =head2 commit( $obj ) |
718 | |
719 | This takes an object that provides _base_offset(). It will apply all |
720 | actions taken within the transaction to the HEAD. |
721 | |
722 | If $obj is not within a transaction, an error will be thrown. |
723 | |
724 | This returns 1. |
725 | |
726 | =cut |
727 | |
2120a181 |
728 | sub commit { |
16d1ad9b |
729 | my $self = shift; |
2120a181 |
730 | my ($obj) = @_; |
731 | |
732 | if ( !$self->trans_id ) { |
733 | DBM::Deep->_throw_error( "Cannot commit without an active transaction" ); |
734 | } |
735 | |
9c87a079 |
736 | foreach my $entry (@{ $self->get_entries } ) { |
737 | # Overwrite the entry in head with the entry in trans_id |
738 | my $base = $entry |
739 | + $self->hash_size |
740 | + $self->byte_size; |
741 | |
742 | my $head_loc = $self->storage->read_at( $base, $self->byte_size ); |
743 | $head_loc = unpack( $StP{$self->byte_size}, $head_loc ); |
744 | |
745 | my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE ); |
746 | my $trans_loc = $self->storage->read_at( |
747 | $spot, $self->byte_size, |
748 | ); |
749 | |
750 | $self->storage->print_at( $base, $trans_loc ); |
751 | $self->storage->print_at( |
752 | $spot, |
753 | pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ), |
754 | ); |
755 | |
756 | if ( $head_loc > 1 ) { |
757 | $self->_load_sector( $head_loc )->free; |
758 | } |
db2eb673 |
759 | } |
760 | |
2120a181 |
761 | $self->clear_entries; |
762 | |
763 | my @slots = $self->read_txn_slots; |
e9b0b5f0 |
764 | $slots[$self->trans_id-1] = 0; |
2120a181 |
765 | $self->write_txn_slots( @slots ); |
766 | $self->inc_txn_staleness_counter( $self->trans_id ); |
767 | $self->set_trans_id( 0 ); |
768 | |
769 | return 1; |
16d1ad9b |
770 | } |
771 | |
ae6c15b8 |
772 | =head2 lock_exclusive() |
773 | |
774 | This takes an object that provides _base_offset(). It will guarantee that |
775 | the storage has taken precautions to be safe for a write. |
776 | |
777 | This returns nothing. |
778 | |
779 | =cut |
780 | |
781 | sub lock_exclusive { |
782 | my $self = shift; |
783 | my ($obj) = @_; |
784 | return $self->storage->lock_exclusive( $obj ); |
785 | } |
786 | |
787 | =head2 lock_shared() |
788 | |
789 | This takes an object that provides _base_offset(). It will guarantee that |
790 | the storage has taken precautions to be safe for a read. |
791 | |
792 | This returns nothing. |
793 | |
794 | =cut |
795 | |
796 | sub lock_shared { |
797 | my $self = shift; |
798 | my ($obj) = @_; |
799 | return $self->storage->lock_shared( $obj ); |
800 | } |
801 | |
802 | =head2 unlock() |
803 | |
804 | This takes an object that provides _base_offset(). It will guarantee that |
805 | the storage has released all locks taken. |
806 | |
807 | This returns nothing. |
808 | |
809 | =cut |
810 | |
811 | sub unlock { |
812 | my $self = shift; |
813 | my ($obj) = @_; |
814 | |
815 | my $rv = $self->storage->unlock( $obj ); |
816 | |
817 | $self->flush if $rv; |
818 | |
819 | return $rv; |
820 | } |
821 | |
ae6c15b8 |
822 | =head1 INTERNAL METHODS |
823 | |
824 | The following methods are internal-use-only to DBM::Deep::Engine. |
825 | |
826 | =cut |
827 | |
828 | =head2 read_txn_slots() |
829 | |
830 | This takes no arguments. |
831 | |
832 | This will return an array with a 1 or 0 in each slot. Each spot represents one |
833 | available transaction. If the slot is 1, that transaction is taken. If it is 0, |
834 | the transaction is available. |
835 | |
836 | =cut |
837 | |
2120a181 |
838 | sub read_txn_slots { |
d4b1166e |
839 | my $self = shift; |
9c87a079 |
840 | my $bl = $self->txn_bitfield_len; |
841 | my $num_bits = $bl * 8; |
842 | return split '', unpack( 'b'.$num_bits, |
843 | $self->storage->read_at( |
844 | $self->trans_loc, $bl, |
845 | ) |
846 | ); |
2120a181 |
847 | } |
20f7b20c |
848 | |
ae6c15b8 |
849 | =head2 write_txn_slots( @slots ) |
850 | |
851 | This takes an array of 1's and 0's. This array represents the transaction slots |
852 | returned by L</read_txn_slots()>. In other words, the following is true: |
853 | |
854 | @x = read_txn_slots( write_txn_slots( @x ) ); |
855 | |
856 | (With the obviously missing object referents added back in.) |
857 | |
858 | =cut |
859 | |
2120a181 |
860 | sub write_txn_slots { |
861 | my $self = shift; |
9c87a079 |
862 | my $num_bits = $self->txn_bitfield_len * 8; |
863 | $self->storage->print_at( $self->trans_loc, |
864 | pack( 'b'.$num_bits, join('', @_) ), |
865 | ); |
2120a181 |
866 | } |
867 | |
ae6c15b8 |
868 | =head2 get_running_txn_ids() |
869 | |
870 | This takes no arguments. |
871 | |
872 | This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>. |
873 | |
874 | =cut |
875 | |
2120a181 |
876 | sub get_running_txn_ids { |
877 | my $self = shift; |
878 | my @transactions = $self->read_txn_slots; |
ae6c15b8 |
879 | my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions; |
2120a181 |
880 | } |
881 | |
ae6c15b8 |
882 | =head2 get_txn_staleness_counter( $trans_id ) |
883 | |
884 | This will return the staleness counter for the given transaction ID. Please see |
885 | L</TRANSACTION STALENESS> for more information. |
886 | |
887 | =cut |
888 | |
2120a181 |
889 | sub get_txn_staleness_counter { |
890 | my $self = shift; |
9c87a079 |
891 | my ($trans_id) = @_; |
892 | |
893 | # Hardcode staleness of 0 for the HEAD |
894 | return 0 unless $trans_id; |
895 | |
896 | return unpack( $StP{$STALE_SIZE}, |
897 | $self->storage->read_at( |
898 | $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1), |
899 | $STALE_SIZE, |
900 | ) |
901 | ); |
d4b1166e |
902 | } |
903 | |
ae6c15b8 |
904 | =head2 inc_txn_staleness_counter( $trans_id ) |
905 | |
906 | This will increment the staleness counter for the given transaction ID. Please see |
907 | L</TRANSACTION STALENESS> for more information. |
908 | |
909 | =cut |
910 | |
2120a181 |
911 | sub inc_txn_staleness_counter { |
d4b1166e |
912 | my $self = shift; |
9c87a079 |
913 | my ($trans_id) = @_; |
914 | |
915 | # Hardcode staleness of 0 for the HEAD |
916 | return 0 unless $trans_id; |
917 | |
918 | $self->storage->print_at( |
919 | $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1), |
920 | pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ), |
921 | ); |
2120a181 |
922 | } |
20f7b20c |
923 | |
ae6c15b8 |
924 | =head2 get_entries() |
925 | |
926 | This takes no arguments. |
927 | |
928 | This returns a list of all the sectors that have been modified by this transaction. |
929 | |
930 | =cut |
931 | |
2120a181 |
932 | sub get_entries { |
933 | my $self = shift; |
934 | return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ]; |
d4b1166e |
935 | } |
936 | |
ae6c15b8 |
937 | =head2 add_entry( $trans_id, $location ) |
938 | |
3b90cc56 |
939 | This takes a transaction ID and a file location and marks the sector at that |
940 | location as having been modified by the transaction identified by $trans_id. |
ae6c15b8 |
941 | |
942 | This returns nothing. |
943 | |
944 | B<NOTE>: Unlike all the other _entries() methods, there are several cases where |
945 | C<< $trans_id != $self->trans_id >> for this method. |
946 | |
947 | =cut |
948 | |
2120a181 |
949 | sub add_entry { |
ea2f6d67 |
950 | my $self = shift; |
9c87a079 |
951 | my ($trans_id, $loc) = @_; |
97d40a0a |
952 | |
2120a181 |
953 | $self->{entries}{$trans_id} ||= {}; |
9c87a079 |
954 | $self->{entries}{$trans_id}{$loc} = undef; |
2120a181 |
955 | } |
ea2f6d67 |
956 | |
ae6c15b8 |
957 | =head2 reindex_entry( $old_loc, $new_loc ) |
958 | |
3b90cc56 |
959 | This takes two locations (old and new, respectively). If a location that has |
960 | been modified by this transaction is subsequently reindexed due to a bucketlist |
ae6c15b8 |
961 | overflowing, then the entries hash needs to be made aware of this change. |
962 | |
963 | This returns nothing. |
964 | |
965 | =cut |
966 | |
2120a181 |
967 | sub reindex_entry { |
968 | my $self = shift; |
9c87a079 |
969 | my ($old_loc, $new_loc) = @_; |
2120a181 |
970 | |
971 | TRANS: |
972 | while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) { |
9c87a079 |
973 | if ( exists $locs->{$old_loc} ) { |
974 | delete $locs->{$old_loc}; |
975 | $locs->{$new_loc} = undef; |
695c88b1 |
976 | next TRANS; |
2120a181 |
977 | } |
ea2f6d67 |
978 | } |
ea2f6d67 |
979 | } |
980 | |
ae6c15b8 |
981 | =head2 clear_entries() |
982 | |
3b90cc56 |
983 | This takes no arguments. It will clear the entries list for the running |
984 | transaction. |
ae6c15b8 |
985 | |
986 | This returns nothing. |
987 | |
988 | =cut |
989 | |
2120a181 |
990 | sub clear_entries { |
d4b1166e |
991 | my $self = shift; |
2120a181 |
992 | delete $self->{entries}{$self->trans_id}; |
993 | } |
eea0d863 |
994 | |
ae6c15b8 |
995 | =head2 _write_file_header() |
996 | |
997 | This writes the file header for a new file. This will write the various settings |
998 | that set how the file is interpreted. |
999 | |
1000 | =head2 _read_file_header() |
1001 | |
1002 | This reads the file header from an existing file. This will read the various |
1003 | settings that set how the file is interpreted. |
1004 | |
1005 | =cut |
1006 | |
9c87a079 |
1007 | { |
1008 | my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4; |
1009 | my $this_file_version = 3; |
16d1ad9b |
1010 | |
9c87a079 |
1011 | sub _write_file_header { |
1012 | my $self = shift; |
75be6413 |
1013 | |
9c87a079 |
1014 | my $nt = $self->num_txns; |
1015 | my $bl = $self->txn_bitfield_len; |
75be6413 |
1016 | |
9c87a079 |
1017 | my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size; |
75be6413 |
1018 | |
9c87a079 |
1019 | my $loc = $self->storage->request_space( $header_fixed + $header_var ); |
75be6413 |
1020 | |
9c87a079 |
1021 | $self->storage->print_at( $loc, |
1022 | SIG_FILE, |
1023 | SIG_HEADER, |
1024 | pack('N', $this_file_version), # At this point, we're at 9 bytes |
1025 | pack('N', $header_var), # header size |
1026 | # --- Above is $header_fixed. Below is $header_var |
1027 | pack('C', $self->byte_size), |
75be6413 |
1028 | |
9c87a079 |
1029 | # These shenanigans are to allow a 256 within a C |
1030 | pack('C', $self->max_buckets - 1), |
1031 | pack('C', $self->data_sector_size - 1), |
75be6413 |
1032 | |
9c87a079 |
1033 | pack('C', $nt), |
1034 | pack('C' . $bl, 0 ), # Transaction activeness bitfield |
1035 | pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters |
1036 | pack($StP{$self->byte_size}, 0), # Start of free chain (blist size) |
1037 | pack($StP{$self->byte_size}, 0), # Start of free chain (data size) |
1038 | pack($StP{$self->byte_size}, 0), # Start of free chain (index size) |
1039 | ); |
75be6413 |
1040 | |
9c87a079 |
1041 | #XXX Set these less fragilely |
1042 | $self->set_trans_loc( $header_fixed + 4 ); |
1043 | $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) ); |
75be6413 |
1044 | |
9c87a079 |
1045 | return; |
badf847c |
1046 | } |
7b1e1aa1 |
1047 | |
9c87a079 |
1048 | sub _read_file_header { |
badf847c |
1049 | my $self = shift; |
75be6413 |
1050 | |
9c87a079 |
1051 | my $buffer = $self->storage->read_at( 0, $header_fixed ); |
1052 | return unless length($buffer); |
2603d86e |
1053 | |
9c87a079 |
1054 | my ($file_signature, $sig_header, $file_version, $size) = unpack( |
1055 | 'A4 A N N', $buffer |
1056 | ); |
75be6413 |
1057 | |
9c87a079 |
1058 | unless ( $file_signature eq SIG_FILE ) { |
1059 | $self->storage->close; |
1060 | DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" ); |
1061 | } |
7b1e1aa1 |
1062 | |
9c87a079 |
1063 | unless ( $sig_header eq SIG_HEADER ) { |
1064 | $self->storage->close; |
1065 | DBM::Deep->_throw_error( "Pre-1.00 file version found" ); |
1066 | } |
1067 | |
1068 | unless ( $file_version == $this_file_version ) { |
1069 | $self->storage->close; |
1070 | DBM::Deep->_throw_error( |
1071 | "Wrong file version found - " . $file_version . |
1072 | " - expected " . $this_file_version |
1073 | ); |
1074 | } |
1075 | |
1076 | my $buffer2 = $self->storage->read_at( undef, $size ); |
1077 | my @values = unpack( 'C C C C', $buffer2 ); |
1078 | |
1079 | if ( @values != 4 || grep { !defined } @values ) { |
1080 | $self->storage->close; |
1081 | DBM::Deep->_throw_error("Corrupted file - bad header"); |
1082 | } |
1083 | |
1084 | #XXX Add warnings if values weren't set right |
1085 | @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values; |
1086 | |
1087 | # These shenangians are to allow a 256 within a C |
1088 | $self->{max_buckets} += 1; |
1089 | $self->{data_sector_size} += 1; |
1090 | |
1091 | my $bl = $self->txn_bitfield_len; |
1092 | |
1093 | my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size; |
1094 | unless ( $size == $header_var ) { |
1095 | $self->storage->close; |
1096 | DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." ); |
badf847c |
1097 | } |
7b1e1aa1 |
1098 | |
9c87a079 |
1099 | $self->set_trans_loc( $header_fixed + scalar(@values) ); |
1100 | $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) ); |
1101 | |
1102 | return length($buffer) + length($buffer2); |
7b1e1aa1 |
1103 | } |
75be6413 |
1104 | } |
1105 | |
ae6c15b8 |
1106 | =head2 _load_sector( $offset ) |
1107 | |
1108 | This will instantiate and return the sector object that represents the data found |
1109 | at $offset. |
1110 | |
1111 | =cut |
1112 | |
9c87a079 |
1113 | sub _load_sector { |
00d9bd0b |
1114 | my $self = shift; |
9c87a079 |
1115 | my ($offset) = @_; |
00d9bd0b |
1116 | |
9c87a079 |
1117 | # Add a catch for offset of 0 or 1 |
1118 | return if !$offset || $offset <= 1; |
1119 | |
1120 | my $type = $self->storage->read_at( $offset, 1 ); |
1121 | return if $type eq chr(0); |
1122 | |
1123 | if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) { |
1124 | return DBM::Deep::Engine::Sector::Reference->new({ |
1125 | engine => $self, |
1126 | type => $type, |
1127 | offset => $offset, |
1128 | }); |
1129 | } |
1130 | # XXX Don't we need key_md5 here? |
1131 | elsif ( $type eq $self->SIG_BLIST ) { |
1132 | return DBM::Deep::Engine::Sector::BucketList->new({ |
1133 | engine => $self, |
1134 | type => $type, |
1135 | offset => $offset, |
1136 | }); |
1137 | } |
1138 | elsif ( $type eq $self->SIG_INDEX ) { |
1139 | return DBM::Deep::Engine::Sector::Index->new({ |
1140 | engine => $self, |
1141 | type => $type, |
1142 | offset => $offset, |
1143 | }); |
1144 | } |
1145 | elsif ( $type eq $self->SIG_NULL ) { |
1146 | return DBM::Deep::Engine::Sector::Null->new({ |
1147 | engine => $self, |
1148 | type => $type, |
1149 | offset => $offset, |
1150 | }); |
1151 | } |
1152 | elsif ( $type eq $self->SIG_DATA ) { |
1153 | return DBM::Deep::Engine::Sector::Scalar->new({ |
1154 | engine => $self, |
1155 | type => $type, |
1156 | offset => $offset, |
1157 | }); |
1158 | } |
1159 | # This was deleted from under us, so just return and let the caller figure it out. |
1160 | elsif ( $type eq $self->SIG_FREE ) { |
1161 | return; |
1162 | } |
1163 | |
1164 | DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" ); |
00d9bd0b |
1165 | } |
1166 | |
ae6c15b8 |
1167 | =head2 _apply_digest( @stuff ) |
1168 | |
1169 | This will apply the digest methd (default to Digest::MD5::md5) to the arguments |
1170 | passed in and return the result. |
1171 | |
1172 | =cut |
1173 | |
9c87a079 |
1174 | sub _apply_digest { |
a8d2331c |
1175 | my $self = shift; |
9c87a079 |
1176 | return $self->{digest}->(@_); |
a8d2331c |
1177 | } |
1178 | |
ae6c15b8 |
1179 | =head2 _add_free_blist_sector( $offset, $size ) |
1180 | |
1181 | =head2 _add_free_data_sector( $offset, $size ) |
1182 | |
1183 | =head2 _add_free_index_sector( $offset, $size ) |
1184 | |
1185 | These methods are all wrappers around _add_free_sector(), providing the proper |
1186 | chain offset ($multiple) for the sector type. |
1187 | |
1188 | =cut |
1189 | |
9c87a079 |
1190 | sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) } |
1191 | sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) } |
1192 | sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) } |
1193 | |
ae6c15b8 |
1194 | =head2 _add_free_sector( $multiple, $offset, $size ) |
1195 | |
1196 | _add_free_sector() takes the offset into the chains location, the offset of the |
1197 | sector, and the size of that sector. It will mark the sector as a free sector |
1198 | and put it into the list of sectors that are free of this type for use later. |
1199 | |
1200 | This returns nothing. |
1201 | |
1202 | B<NOTE>: $size is unused? |
1203 | |
1204 | =cut |
1205 | |
9c87a079 |
1206 | sub _add_free_sector { |
00d9bd0b |
1207 | my $self = shift; |
9c87a079 |
1208 | my ($multiple, $offset, $size) = @_; |
1209 | |
1210 | my $chains_offset = $multiple * $self->byte_size; |
1211 | |
1212 | my $storage = $self->storage; |
1213 | |
1214 | # Increment staleness. |
1215 | # XXX Can this increment+modulo be done by "&= 0x1" ? |
1216 | my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + SIG_SIZE, $STALE_SIZE ) ); |
1217 | $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) ); |
1218 | $storage->print_at( $offset + SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) ); |
1219 | |
1220 | my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); |
1221 | |
1222 | $storage->print_at( $self->chains_loc + $chains_offset, |
1223 | pack( $StP{$self->byte_size}, $offset ), |
1224 | ); |
1225 | |
1226 | # Record the old head in the new sector after the signature and staleness counter |
1227 | $storage->print_at( $offset + SIG_SIZE + $STALE_SIZE, $old_head ); |
00d9bd0b |
1228 | } |
1229 | |
ae6c15b8 |
1230 | =head2 _request_blist_sector( $size ) |
1231 | |
1232 | =head2 _request_data_sector( $size ) |
1233 | |
1234 | =head2 _request_index_sector( $size ) |
1235 | |
1236 | These methods are all wrappers around _request_sector(), providing the proper |
1237 | chain offset ($multiple) for the sector type. |
1238 | |
1239 | =cut |
1240 | |
9c87a079 |
1241 | sub _request_blist_sector { shift->_request_sector( 0, @_ ) } |
1242 | sub _request_data_sector { shift->_request_sector( 1, @_ ) } |
1243 | sub _request_index_sector { shift->_request_sector( 2, @_ ) } |
1244 | |
ae6c15b8 |
1245 | =head2 _request_sector( $multiple $size ) |
1246 | |
1247 | This takes the offset into the chains location and the size of that sector. |
1248 | |
1249 | This returns the object with the sector. If there is an available free sector of |
1250 | that type, then it will be reused. If there isn't one, then a new one will be |
1251 | allocated. |
1252 | |
1253 | =cut |
1254 | |
9c87a079 |
1255 | sub _request_sector { |
a8d2331c |
1256 | my $self = shift; |
9c87a079 |
1257 | my ($multiple, $size) = @_; |
1258 | |
1259 | my $chains_offset = $multiple * $self->byte_size; |
1260 | |
1261 | my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size ); |
1262 | my $loc = unpack( $StP{$self->byte_size}, $old_head ); |
1263 | |
1264 | # We don't have any free sectors of the right size, so allocate a new one. |
1265 | unless ( $loc ) { |
1266 | my $offset = $self->storage->request_space( $size ); |
1267 | |
1268 | # Zero out the new sector. This also guarantees correct increases |
1269 | # in the filesize. |
1270 | $self->storage->print_at( $offset, chr(0) x $size ); |
a8d2331c |
1271 | |
9c87a079 |
1272 | return $offset; |
1273 | } |
1274 | |
1275 | # Read the new head after the signature and the staleness counter |
1276 | my $new_head = $self->storage->read_at( $loc + SIG_SIZE + $STALE_SIZE, $self->byte_size ); |
1277 | $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head ); |
1278 | $self->storage->print_at( |
1279 | $loc + SIG_SIZE + $STALE_SIZE, |
1280 | pack( $StP{$self->byte_size}, 0 ), |
1281 | ); |
1282 | |
1283 | return $loc; |
a8d2331c |
1284 | } |
1285 | |
ae6c15b8 |
1286 | =head2 flush() |
a8d2331c |
1287 | |
ae6c15b8 |
1288 | This takes no arguments. It will do everything necessary to flush all things to |
1289 | disk. This is usually called during unlock() and setup_fh(). |
a8d2331c |
1290 | |
ae6c15b8 |
1291 | This returns nothing. |
d451590f |
1292 | |
ae6c15b8 |
1293 | =cut |
f1879fdc |
1294 | |
ae6c15b8 |
1295 | sub flush { |
f1879fdc |
1296 | my $self = shift; |
a8d2331c |
1297 | |
ae6c15b8 |
1298 | # Why do we need to have the storage flush? Shouldn't autoflush take care of things? |
1299 | # -RobK, 2008-06-26 |
1300 | $self->storage->flush; |
f1879fdc |
1301 | } |
1302 | |
f0276afb |
1303 | =head2 ACCESSORS |
1304 | |
1305 | The following are readonly attributes. |
1306 | |
1307 | =over 4 |
1308 | |
1309 | =item * storage |
1310 | |
1311 | =item * byte_size |
1312 | |
1313 | =item * hash_size |
1314 | |
1315 | =item * hash_chars |
1316 | |
1317 | =item * num_txns |
1318 | |
1319 | =item * max_buckets |
1320 | |
1321 | =item * blank_md5 |
1322 | |
1323 | =item * data_sector_size |
1324 | |
1325 | =item * txn_bitfield_len |
1326 | |
1327 | =back |
1328 | |
1329 | =cut |
f1879fdc |
1330 | |
2120a181 |
1331 | sub storage { $_[0]{storage} } |
1332 | sub byte_size { $_[0]{byte_size} } |
1333 | sub hash_size { $_[0]{hash_size} } |
1334 | sub hash_chars { $_[0]{hash_chars} } |
1335 | sub num_txns { $_[0]{num_txns} } |
1336 | sub max_buckets { $_[0]{max_buckets} } |
1337 | sub blank_md5 { chr(0) x $_[0]->hash_size } |
e9b0b5f0 |
1338 | sub data_sector_size { $_[0]{data_sector_size} } |
1339 | |
1340 | # This is a calculated value |
1341 | sub txn_bitfield_len { |
1342 | my $self = shift; |
1343 | unless ( exists $self->{txn_bitfield_len} ) { |
1344 | my $temp = ($self->num_txns) / 8; |
1345 | if ( $temp > int( $temp ) ) { |
1346 | $temp = int( $temp ) + 1; |
1347 | } |
1348 | $self->{txn_bitfield_len} = $temp; |
1349 | } |
1350 | return $self->{txn_bitfield_len}; |
1351 | } |
8db25060 |
1352 | |
f0276afb |
1353 | =pod |
1354 | |
1355 | The following are read/write attributes. |
1356 | |
1357 | =over 4 |
1358 | |
1359 | =item * trans_id / set_trans_id( $new_id ) |
1360 | |
1361 | =item * trans_loc / set_trans_loc( $new_loc ) |
1362 | |
1363 | =item * chains_loc / set_chains_loc( $new_loc ) |
1364 | |
1365 | =back |
1366 | |
1367 | =cut |
1368 | |
2120a181 |
1369 | sub trans_id { $_[0]{trans_id} } |
1370 | sub set_trans_id { $_[0]{trans_id} = $_[1] } |
8db25060 |
1371 | |
2120a181 |
1372 | sub trans_loc { $_[0]{trans_loc} } |
1373 | sub set_trans_loc { $_[0]{trans_loc} = $_[1] } |
1374 | |
1375 | sub chains_loc { $_[0]{chains_loc} } |
1376 | sub set_chains_loc { $_[0]{chains_loc} = $_[1] } |
1377 | |
c57b19c6 |
1378 | sub cache { $_[0]{cache} ||= {} } |
1379 | sub clear_cache { %{$_[0]->cache} = () } |
1380 | |
f0276afb |
1381 | =head2 _dump_file() |
1382 | |
3b90cc56 |
1383 | This method takes no arguments. It's used to print out a textual representation |
1384 | of the DBM::Deep DB file. It assumes the file is not-corrupted. |
f0276afb |
1385 | |
1386 | =cut |
1387 | |
888453b9 |
1388 | sub _dump_file { |
1389 | my $self = shift; |
1390 | |
1391 | # Read the header |
9c87a079 |
1392 | my $spot = $self->_read_file_header(); |
888453b9 |
1393 | |
1394 | my %types = ( |
1395 | 0 => 'B', |
1396 | 1 => 'D', |
1397 | 2 => 'I', |
1398 | ); |
1399 | |
1400 | my %sizes = ( |
1401 | 'D' => $self->data_sector_size, |
1402 | 'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size, |
1403 | 'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size, |
1404 | ); |
1405 | |
1406 | my $return = ""; |
c57b19c6 |
1407 | |
1408 | # Header values |
1409 | $return .= "NumTxns: " . $self->num_txns . $/; |
1410 | |
888453b9 |
1411 | # Read the free sector chains |
1412 | my %sectors; |
1413 | foreach my $multiple ( 0 .. 2 ) { |
1414 | $return .= "Chains($types{$multiple}):"; |
1415 | my $old_loc = $self->chains_loc + $multiple * $self->byte_size; |
1416 | while ( 1 ) { |
1417 | my $loc = unpack( |
1418 | $StP{$self->byte_size}, |
1419 | $self->storage->read_at( $old_loc, $self->byte_size ), |
1420 | ); |
1421 | |
1422 | # We're now out of free sectors of this kind. |
1423 | unless ( $loc ) { |
1424 | last; |
1425 | } |
1426 | |
1427 | $sectors{ $types{$multiple} }{ $loc } = undef; |
1428 | $old_loc = $loc + SIG_SIZE + $STALE_SIZE; |
1429 | $return .= " $loc"; |
1430 | } |
1431 | $return .= $/; |
1432 | } |
1433 | |
1434 | SECTOR: |
1435 | while ( $spot < $self->storage->{end} ) { |
1436 | # Read each sector in order. |
1437 | my $sector = $self->_load_sector( $spot ); |
1438 | if ( !$sector ) { |
1439 | # Find it in the free-sectors that were found already |
1440 | foreach my $type ( keys %sectors ) { |
1441 | if ( exists $sectors{$type}{$spot} ) { |
1442 | my $size = $sizes{$type}; |
1443 | $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size; |
1444 | $spot += $size; |
1445 | next SECTOR; |
1446 | } |
1447 | } |
1448 | |
1449 | die "********\n$return\nDidn't find free sector for $spot in chains\n********\n"; |
1450 | } |
1451 | else { |
1452 | $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size; |
1453 | if ( $sector->type eq 'D' ) { |
1454 | $return .= ' ' . $sector->data; |
1455 | } |
1456 | elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) { |
1457 | $return .= ' REF: ' . $sector->get_refcount; |
1458 | } |
1459 | elsif ( $sector->type eq 'B' ) { |
1460 | foreach my $bucket ( $sector->chopped_up ) { |
1461 | $return .= "\n "; |
1462 | $return .= sprintf "%08d", unpack($StP{$self->byte_size}, |
1463 | substr( $bucket->[-1], $self->hash_size, $self->byte_size), |
1464 | ); |
c57b19c6 |
1465 | my $l = unpack( $StP{$self->byte_size}, |
1466 | substr( $bucket->[-1], |
1467 | $self->hash_size + $self->byte_size, |
1468 | $self->byte_size, |
1469 | ), |
1470 | ); |
1471 | $return .= sprintf " %08d", $l; |
1472 | foreach my $txn ( 0 .. $self->num_txns - 2 ) { |
888453b9 |
1473 | my $l = unpack( $StP{$self->byte_size}, |
1474 | substr( $bucket->[-1], |
c57b19c6 |
1475 | $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE), |
888453b9 |
1476 | $self->byte_size, |
1477 | ), |
1478 | ); |
1479 | $return .= sprintf " %08d", $l; |
1480 | } |
1481 | } |
1482 | } |
1483 | $return .= $/; |
1484 | |
1485 | $spot += $sector->size; |
1486 | } |
1487 | } |
1488 | |
1489 | return $return; |
1490 | } |
1491 | |
a20d9a3f |
1492 | 1; |
1493 | __END__ |