Commit | Line | Data |
a20d9a3f |
1 | package DBM::Deep::Engine; |
2 | |
3 | use strict; |
4 | |
5 | use Fcntl qw( :DEFAULT :flock :seek ); |
6 | |
7 | sub open { |
20f7b20c |
8 | ## |
9 | # Open a fh to the database, create if nonexistent. |
10 | # Make sure file signature matches DBM::Deep spec. |
11 | ## |
a20d9a3f |
12 | my $self = shift; |
cd59cad8 |
13 | my $obj = shift; |
a20d9a3f |
14 | |
20f7b20c |
15 | if (defined($obj->_fh)) { $self->close( $obj ); } |
16 | |
a20d9a3f |
17 | eval { |
18 | local $SIG{'__DIE__'}; |
19 | # Theoretically, adding O_BINARY should remove the need for the binmode |
20 | # Of course, testing it is going to be ... interesting. |
21 | my $flags = O_RDWR | O_CREAT | O_BINARY; |
22 | |
23 | my $fh; |
cd59cad8 |
24 | sysopen( $fh, $obj->_root->{file}, $flags ) |
a20d9a3f |
25 | or $fh = undef; |
cd59cad8 |
26 | $obj->_root->{fh} = $fh; |
27 | }; if ($@ ) { $obj->_throw_error( "Received error: $@\n" ); } |
20f7b20c |
28 | if (! defined($obj->_fh)) { |
29 | return $obj->_throw_error("Cannot sysopen file: " . $obj->_root->{file} . ": $!"); |
30 | } |
a20d9a3f |
31 | |
cd59cad8 |
32 | my $fh = $obj->_fh; |
a20d9a3f |
33 | |
34 | #XXX Can we remove this by using the right sysopen() flags? |
35 | # Maybe ... q.v. above |
36 | binmode $fh; # for win32 |
37 | |
cd59cad8 |
38 | if ($obj->_root->{autoflush}) { |
a20d9a3f |
39 | my $old = select $fh; |
40 | $|=1; |
41 | select $old; |
42 | } |
20f7b20c |
43 | |
cd59cad8 |
44 | seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET); |
a20d9a3f |
45 | |
46 | my $signature; |
47 | my $bytes_read = read( $fh, $signature, length(DBM::Deep->SIG_FILE)); |
20f7b20c |
48 | |
a20d9a3f |
49 | ## |
50 | # File is empty -- write signature and master index |
51 | ## |
52 | if (!$bytes_read) { |
cd59cad8 |
53 | seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET); |
a20d9a3f |
54 | print( $fh DBM::Deep->SIG_FILE); |
d4b1166e |
55 | $self->create_tag($obj, $obj->_base_offset, $obj->_type, chr(0) x $DBM::Deep::INDEX_SIZE); |
a20d9a3f |
56 | |
57 | my $plain_key = "[base]"; |
58 | print( $fh pack($DBM::Deep::DATA_LENGTH_PACK, length($plain_key)) . $plain_key ); |
59 | |
60 | # Flush the filehandle |
61 | my $old_fh = select $fh; |
62 | my $old_af = $|; $| = 1; $| = $old_af; |
63 | select $old_fh; |
64 | |
65 | my @stats = stat($fh); |
cd59cad8 |
66 | $obj->_root->{inode} = $stats[1]; |
67 | $obj->_root->{end} = $stats[7]; |
a20d9a3f |
68 | |
69 | return 1; |
70 | } |
20f7b20c |
71 | |
a20d9a3f |
72 | ## |
73 | # Check signature was valid |
74 | ## |
75 | unless ($signature eq DBM::Deep->SIG_FILE) { |
cd59cad8 |
76 | $self->close( $obj ); |
77 | return $obj->_throw_error("Signature not found -- file is not a Deep DB"); |
a20d9a3f |
78 | } |
79 | |
20f7b20c |
80 | my @stats = stat($fh); |
81 | $obj->_root->{inode} = $stats[1]; |
cd59cad8 |
82 | $obj->_root->{end} = $stats[7]; |
20f7b20c |
83 | |
a20d9a3f |
84 | ## |
85 | # Get our type from master index signature |
86 | ## |
d4b1166e |
87 | my $tag = $self->load_tag($obj, $obj->_base_offset); |
a20d9a3f |
88 | |
89 | #XXX We probably also want to store the hash algorithm name and not assume anything |
90 | #XXX The cool thing would be to allow a different hashing algorithm at every level |
91 | |
92 | if (!$tag) { |
20f7b20c |
93 | return $obj->_throw_error("Corrupted file, no master index record"); |
a20d9a3f |
94 | } |
cd59cad8 |
95 | if ($obj->{type} ne $tag->{signature}) { |
20f7b20c |
96 | return $obj->_throw_error("File type mismatch"); |
a20d9a3f |
97 | } |
20f7b20c |
98 | |
a20d9a3f |
99 | return 1; |
100 | } |
101 | |
cd59cad8 |
102 | sub close { |
103 | my $self = shift; |
104 | my $obj = shift; |
105 | |
106 | if ( my $fh = $obj->_root->{fh} ) { |
107 | close $fh; |
108 | } |
109 | $obj->_root->{fh} = undef; |
110 | |
111 | return 1; |
112 | } |
113 | |
d4b1166e |
114 | sub create_tag { |
20f7b20c |
115 | ## |
116 | # Given offset, signature and content, create tag and write to disk |
117 | ## |
d4b1166e |
118 | my $self = shift; |
20f7b20c |
119 | my ($obj, $offset, $sig, $content) = @_; |
120 | my $size = length($content); |
121 | |
d4b1166e |
122 | my $fh = $obj->_fh; |
123 | |
20f7b20c |
124 | seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET); |
125 | print( $fh $sig . pack($DBM::Deep::DATA_LENGTH_PACK, $size) . $content ); |
126 | |
127 | if ($offset == $obj->_root->{end}) { |
128 | $obj->_root->{end} += DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE + $size; |
129 | } |
130 | |
131 | return { |
132 | signature => $sig, |
133 | size => $size, |
134 | offset => $offset + DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE, |
135 | content => $content |
136 | }; |
d4b1166e |
137 | } |
138 | |
139 | sub load_tag { |
20f7b20c |
140 | ## |
141 | # Given offset, load single tag and return signature, size and data |
142 | ## |
d4b1166e |
143 | my $self = shift; |
20f7b20c |
144 | my ($obj, $offset) = @_; |
145 | |
d4b1166e |
146 | my $fh = $obj->_fh; |
147 | |
20f7b20c |
148 | seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET); |
149 | if (eof $fh) { return undef; } |
150 | |
d4b1166e |
151 | my $b; |
152 | read( $fh, $b, DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE ); |
153 | my ($sig, $size) = unpack( "A $DBM::Deep::DATA_LENGTH_PACK", $b ); |
20f7b20c |
154 | |
155 | my $buffer; |
156 | read( $fh, $buffer, $size); |
157 | |
158 | return { |
159 | signature => $sig, |
160 | size => $size, |
161 | offset => $offset + DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE, |
162 | content => $buffer |
163 | }; |
d4b1166e |
164 | } |
165 | |
166 | sub index_lookup { |
20f7b20c |
167 | ## |
168 | # Given index tag, lookup single entry in index and return . |
169 | ## |
170 | my $self = shift; |
171 | my ($obj, $tag, $index) = @_; |
172 | |
173 | my $location = unpack($DBM::Deep::LONG_PACK, substr($tag->{content}, $index * $DBM::Deep::LONG_SIZE, $DBM::Deep::LONG_SIZE) ); |
174 | if (!$location) { return; } |
175 | |
176 | return $self->load_tag( $obj, $location ); |
177 | } |
178 | |
179 | sub add_bucket { |
180 | ## |
181 | # Adds one key/value pair to bucket list, given offset, MD5 digest of key, |
182 | # plain (undigested) key and value. |
183 | ## |
d4b1166e |
184 | my $self = shift; |
20f7b20c |
185 | my ($obj, $tag, $md5, $plain_key, $value) = @_; |
186 | my $keys = $tag->{content}; |
187 | my $location = 0; |
188 | my $result = 2; |
189 | |
190 | my $root = $obj->_root; |
191 | |
192 | my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep' ) }; |
193 | my $internal_ref = $is_dbm_deep && ($value->_root eq $root); |
194 | |
195 | my $fh = $obj->_fh; |
196 | |
197 | ## |
198 | # Iterate through buckets, seeing if this is a new entry or a replace. |
199 | ## |
200 | for (my $i=0; $i<$DBM::Deep::MAX_BUCKETS; $i++) { |
201 | my $subloc = unpack($DBM::Deep::LONG_PACK, substr($keys, ($i * $DBM::Deep::BUCKET_SIZE) + $DBM::Deep::HASH_SIZE, $DBM::Deep::LONG_SIZE)); |
202 | if (!$subloc) { |
203 | ## |
204 | # Found empty bucket (end of list). Populate and exit loop. |
205 | ## |
206 | $result = 2; |
207 | |
208 | $location = $internal_ref |
209 | ? $value->_base_offset |
210 | : $root->{end}; |
211 | |
212 | seek($fh, $tag->{offset} + ($i * $DBM::Deep::BUCKET_SIZE) + $root->{file_offset}, SEEK_SET); |
213 | print( $fh $md5 . pack($DBM::Deep::LONG_PACK, $location) ); |
214 | last; |
215 | } |
216 | |
217 | my $key = substr($keys, $i * $DBM::Deep::BUCKET_SIZE, $DBM::Deep::HASH_SIZE); |
218 | if ($md5 eq $key) { |
219 | ## |
220 | # Found existing bucket with same key. Replace with new value. |
221 | ## |
222 | $result = 1; |
223 | |
224 | if ($internal_ref) { |
225 | $location = $value->_base_offset; |
226 | seek($fh, $tag->{offset} + ($i * $DBM::Deep::BUCKET_SIZE) + $root->{file_offset}, SEEK_SET); |
227 | print( $fh $md5 . pack($DBM::Deep::LONG_PACK, $location) ); |
228 | return $result; |
229 | } |
230 | |
231 | seek($fh, $subloc + DBM::Deep->SIG_SIZE + $root->{file_offset}, SEEK_SET); |
232 | my $size; |
233 | read( $fh, $size, $DBM::Deep::DATA_LENGTH_SIZE); $size = unpack($DBM::Deep::DATA_LENGTH_PACK, $size); |
234 | |
235 | ## |
236 | # If value is a hash, array, or raw value with equal or less size, we can |
237 | # reuse the same content area of the database. Otherwise, we have to create |
238 | # a new content area at the EOF. |
239 | ## |
240 | my $actual_length; |
241 | my $r = Scalar::Util::reftype( $value ) || ''; |
242 | if ( $r eq 'HASH' || $r eq 'ARRAY' ) { |
243 | $actual_length = $DBM::Deep::INDEX_SIZE; |
244 | |
245 | # if autobless is enabled, must also take into consideration |
246 | # the class name, as it is stored along with key/value. |
247 | if ( $root->{autobless} ) { |
248 | my $value_class = Scalar::Util::blessed($value); |
249 | if ( defined $value_class && !$value->isa('DBM::Deep') ) { |
250 | $actual_length += length($value_class); |
251 | } |
252 | } |
253 | } |
254 | else { $actual_length = length($value); } |
255 | |
256 | if ($actual_length <= $size) { |
257 | $location = $subloc; |
258 | } |
259 | else { |
260 | $location = $root->{end}; |
261 | seek($fh, $tag->{offset} + ($i * $DBM::Deep::BUCKET_SIZE) + $DBM::Deep::HASH_SIZE + $root->{file_offset}, SEEK_SET); |
262 | print( $fh pack($DBM::Deep::LONG_PACK, $location) ); |
263 | } |
264 | |
265 | last; |
266 | } |
267 | } |
268 | |
269 | ## |
270 | # If this is an internal reference, return now. |
271 | # No need to write value or plain key |
272 | ## |
273 | if ($internal_ref) { |
274 | return $result; |
275 | } |
276 | |
277 | ## |
278 | # If bucket didn't fit into list, split into a new index level |
279 | ## |
280 | if (!$location) { |
281 | seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET); |
282 | print( $fh pack($DBM::Deep::LONG_PACK, $root->{end}) ); |
283 | |
284 | my $index_tag = $self->create_tag($obj, $root->{end}, DBM::Deep->SIG_INDEX, chr(0) x $DBM::Deep::INDEX_SIZE); |
285 | my @offsets = (); |
286 | |
287 | $keys .= $md5 . pack($DBM::Deep::LONG_PACK, 0); |
288 | |
289 | for (my $i=0; $i<=$DBM::Deep::MAX_BUCKETS; $i++) { |
290 | my $key = substr($keys, $i * $DBM::Deep::BUCKET_SIZE, $DBM::Deep::HASH_SIZE); |
291 | if ($key) { |
292 | my $old_subloc = unpack($DBM::Deep::LONG_PACK, substr($keys, ($i * $DBM::Deep::BUCKET_SIZE) + |
293 | $DBM::Deep::HASH_SIZE, $DBM::Deep::LONG_SIZE)); |
294 | my $num = ord(substr($key, $tag->{ch} + 1, 1)); |
295 | |
296 | if ($offsets[$num]) { |
297 | my $offset = $offsets[$num] + DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE; |
298 | seek($fh, $offset + $root->{file_offset}, SEEK_SET); |
299 | my $subkeys; |
300 | read( $fh, $subkeys, $DBM::Deep::BUCKET_LIST_SIZE); |
301 | |
302 | for (my $k=0; $k<$DBM::Deep::MAX_BUCKETS; $k++) { |
303 | my $subloc = unpack($DBM::Deep::LONG_PACK, substr($subkeys, ($k * $DBM::Deep::BUCKET_SIZE) + |
304 | $DBM::Deep::HASH_SIZE, $DBM::Deep::LONG_SIZE)); |
305 | if (!$subloc) { |
306 | seek($fh, $offset + ($k * $DBM::Deep::BUCKET_SIZE) + $root->{file_offset}, SEEK_SET); |
307 | print( $fh $key . pack($DBM::Deep::LONG_PACK, $old_subloc || $root->{end}) ); |
308 | last; |
309 | } |
310 | } # k loop |
311 | } |
312 | else { |
313 | $offsets[$num] = $root->{end}; |
314 | seek($fh, $index_tag->{offset} + ($num * $DBM::Deep::LONG_SIZE) + $root->{file_offset}, SEEK_SET); |
315 | print( $fh pack($DBM::Deep::LONG_PACK, $root->{end}) ); |
316 | |
317 | my $blist_tag = $self->create_tag($obj, $root->{end}, DBM::Deep->SIG_BLIST, chr(0) x $DBM::Deep::BUCKET_LIST_SIZE); |
318 | |
319 | seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET); |
320 | print( $fh $key . pack($DBM::Deep::LONG_PACK, $old_subloc || $root->{end}) ); |
321 | } |
322 | } # key is real |
323 | } # i loop |
324 | |
325 | $location ||= $root->{end}; |
326 | } # re-index bucket list |
327 | |
328 | ## |
329 | # Seek to content area and store signature, value and plaintext key |
330 | ## |
331 | if ($location) { |
332 | my $content_length; |
333 | seek($fh, $location + $root->{file_offset}, SEEK_SET); |
334 | |
335 | ## |
336 | # Write signature based on content type, set content length and write actual value. |
337 | ## |
338 | my $r = Scalar::Util::reftype($value) || ''; |
339 | if ($r eq 'HASH') { |
340 | print( $fh DBM::Deep->TYPE_HASH ); |
341 | print( $fh pack($DBM::Deep::DATA_LENGTH_PACK, $DBM::Deep::INDEX_SIZE) . chr(0) x $DBM::Deep::INDEX_SIZE ); |
342 | $content_length = $DBM::Deep::INDEX_SIZE; |
343 | } |
344 | elsif ($r eq 'ARRAY') { |
345 | print( $fh DBM::Deep->TYPE_ARRAY ); |
346 | print( $fh pack($DBM::Deep::DATA_LENGTH_PACK, $DBM::Deep::INDEX_SIZE) . chr(0) x $DBM::Deep::INDEX_SIZE ); |
347 | $content_length = $DBM::Deep::INDEX_SIZE; |
348 | } |
349 | elsif (!defined($value)) { |
350 | print( $fh DBM::Deep->SIG_NULL ); |
351 | print( $fh pack($DBM::Deep::DATA_LENGTH_PACK, 0) ); |
352 | $content_length = 0; |
353 | } |
354 | else { |
355 | print( $fh DBM::Deep->SIG_DATA ); |
356 | print( $fh pack($DBM::Deep::DATA_LENGTH_PACK, length($value)) . $value ); |
357 | $content_length = length($value); |
358 | } |
359 | |
360 | ## |
361 | # Plain key is stored AFTER value, as keys are typically fetched less often. |
362 | ## |
363 | print( $fh pack($DBM::Deep::DATA_LENGTH_PACK, length($plain_key)) . $plain_key ); |
364 | |
365 | ## |
366 | # If value is blessed, preserve class name |
367 | ## |
368 | if ( $root->{autobless} ) { |
369 | my $value_class = Scalar::Util::blessed($value); |
370 | if ( defined $value_class && $value_class ne 'DBM::Deep' ) { |
371 | ## |
372 | # Blessed ref -- will restore later |
373 | ## |
374 | print( $fh chr(1) ); |
375 | print( $fh pack($DBM::Deep::DATA_LENGTH_PACK, length($value_class)) . $value_class ); |
376 | $content_length += 1; |
377 | $content_length += $DBM::Deep::DATA_LENGTH_SIZE + length($value_class); |
378 | } |
379 | else { |
380 | print( $fh chr(0) ); |
381 | $content_length += 1; |
382 | } |
383 | } |
384 | |
385 | ## |
386 | # If this is a new content area, advance EOF counter |
387 | ## |
388 | if ($location == $root->{end}) { |
389 | $root->{end} += DBM::Deep->SIG_SIZE; |
390 | $root->{end} += $DBM::Deep::DATA_LENGTH_SIZE + $content_length; |
391 | $root->{end} += $DBM::Deep::DATA_LENGTH_SIZE + length($plain_key); |
392 | } |
393 | |
394 | ## |
395 | # If content is a hash or array, create new child DBM::Deep object and |
396 | # pass each key or element to it. |
397 | ## |
398 | if ($r eq 'HASH') { |
399 | my $branch = DBM::Deep->new( |
400 | type => DBM::Deep->TYPE_HASH, |
401 | base_offset => $location, |
402 | root => $root, |
403 | ); |
404 | foreach my $key (keys %{$value}) { |
405 | $branch->STORE( $key, $value->{$key} ); |
406 | } |
407 | } |
408 | elsif ($r eq 'ARRAY') { |
409 | my $branch = DBM::Deep->new( |
410 | type => DBM::Deep->TYPE_ARRAY, |
411 | base_offset => $location, |
412 | root => $root, |
413 | ); |
414 | my $index = 0; |
415 | foreach my $element (@{$value}) { |
416 | $branch->STORE( $index, $element ); |
417 | $index++; |
418 | } |
419 | } |
420 | |
421 | return $result; |
422 | } |
d4b1166e |
423 | |
20f7b20c |
424 | return $obj->_throw_error("Fatal error: indexing failed -- possibly due to corruption in file"); |
d4b1166e |
425 | } |
426 | |
9020ee8c |
427 | sub get_bucket_value { |
428 | ## |
429 | # Fetch single value given tag and MD5 digested key. |
430 | ## |
431 | my $self = shift; |
432 | my ($obj, $tag, $md5) = @_; |
433 | my $keys = $tag->{content}; |
434 | |
435 | my $fh = $obj->_fh; |
436 | |
437 | ## |
438 | # Iterate through buckets, looking for a key match |
439 | ## |
440 | BUCKET: |
441 | for (my $i=0; $i<$DBM::Deep::MAX_BUCKETS; $i++) { |
442 | my $key = substr($keys, $i * $DBM::Deep::BUCKET_SIZE, $DBM::Deep::HASH_SIZE); |
443 | my $subloc = unpack($DBM::Deep::LONG_PACK, substr($keys, ($i * $DBM::Deep::BUCKET_SIZE) + $DBM::Deep::HASH_SIZE, $DBM::Deep::LONG_SIZE)); |
444 | |
445 | if (!$subloc) { |
446 | ## |
447 | # Hit end of list, no match |
448 | ## |
449 | return; |
450 | } |
451 | |
452 | if ( $md5 ne $key ) { |
453 | next BUCKET; |
454 | } |
455 | |
456 | ## |
457 | # Found match -- seek to offset and read signature |
458 | ## |
459 | my $signature; |
460 | seek($fh, $subloc + $obj->_root->{file_offset}, SEEK_SET); |
461 | read( $fh, $signature, DBM::Deep->SIG_SIZE); |
462 | |
463 | ## |
464 | # If value is a hash or array, return new DBM::Deep object with correct offset |
465 | ## |
466 | if (($signature eq DBM::Deep->TYPE_HASH) || ($signature eq DBM::Deep->TYPE_ARRAY)) { |
467 | my $obj = DBM::Deep->new( |
468 | type => $signature, |
469 | base_offset => $subloc, |
470 | root => $obj->_root, |
471 | ); |
472 | |
473 | if ($obj->_root->{autobless}) { |
474 | ## |
475 | # Skip over value and plain key to see if object needs |
476 | # to be re-blessed |
477 | ## |
478 | seek($fh, $DBM::Deep::DATA_LENGTH_SIZE + $DBM::Deep::INDEX_SIZE, SEEK_CUR); |
479 | |
480 | my $size; |
481 | read( $fh, $size, $DBM::Deep::DATA_LENGTH_SIZE); $size = unpack($DBM::Deep::DATA_LENGTH_PACK, $size); |
482 | if ($size) { seek($fh, $size, SEEK_CUR); } |
483 | |
484 | my $bless_bit; |
485 | read( $fh, $bless_bit, 1); |
486 | if (ord($bless_bit)) { |
487 | ## |
488 | # Yes, object needs to be re-blessed |
489 | ## |
490 | my $class_name; |
491 | read( $fh, $size, $DBM::Deep::DATA_LENGTH_SIZE); $size = unpack($DBM::Deep::DATA_LENGTH_PACK, $size); |
492 | if ($size) { read( $fh, $class_name, $size); } |
493 | if ($class_name) { $obj = bless( $obj, $class_name ); } |
494 | } |
495 | } |
496 | |
497 | return $obj; |
498 | } |
499 | |
500 | ## |
501 | # Otherwise return actual value |
502 | ## |
503 | elsif ($signature eq DBM::Deep->SIG_DATA) { |
504 | my $size; |
505 | my $value = ''; |
506 | read( $fh, $size, $DBM::Deep::DATA_LENGTH_SIZE); $size = unpack($DBM::Deep::DATA_LENGTH_PACK, $size); |
507 | if ($size) { read( $fh, $value, $size); } |
508 | return $value; |
509 | } |
510 | |
511 | ## |
512 | # Key exists, but content is null |
513 | ## |
514 | else { return; } |
515 | } # i loop |
516 | |
517 | return; |
518 | } |
ab0e4957 |
519 | |
520 | sub delete_bucket { |
521 | ## |
522 | # Delete single key/value pair given tag and MD5 digested key. |
523 | ## |
524 | my $self = shift; |
525 | my ($obj, $tag, $md5) = @_; |
526 | my $keys = $tag->{content}; |
527 | |
528 | my $fh = $obj->_fh; |
529 | |
530 | ## |
531 | # Iterate through buckets, looking for a key match |
532 | ## |
533 | BUCKET: |
534 | for (my $i=0; $i<$DBM::Deep::MAX_BUCKETS; $i++) { |
535 | my $key = substr($keys, $i * $DBM::Deep::BUCKET_SIZE, $DBM::Deep::HASH_SIZE); |
536 | my $subloc = unpack($DBM::Deep::LONG_PACK, substr($keys, ($i * $DBM::Deep::BUCKET_SIZE) + $DBM::Deep::HASH_SIZE, $DBM::Deep::LONG_SIZE)); |
537 | |
538 | if (!$subloc) { |
539 | ## |
540 | # Hit end of list, no match |
541 | ## |
542 | return; |
543 | } |
544 | |
545 | if ( $md5 ne $key ) { |
546 | next BUCKET; |
547 | } |
548 | |
549 | ## |
550 | # Matched key -- delete bucket and return |
551 | ## |
552 | seek($fh, $tag->{offset} + ($i * $DBM::Deep::BUCKET_SIZE) + $obj->_root->{file_offset}, SEEK_SET); |
553 | print( $fh substr($keys, ($i+1) * $DBM::Deep::BUCKET_SIZE ) ); |
554 | print( $fh chr(0) x $DBM::Deep::BUCKET_SIZE ); |
555 | |
556 | return 1; |
557 | } # i loop |
558 | |
559 | return; |
560 | } |
561 | |
912d50b1 |
562 | sub bucket_exists { |
563 | ## |
564 | # Check existence of single key given tag and MD5 digested key. |
565 | ## |
566 | my $self = shift; |
567 | my ($obj, $tag, $md5) = @_; |
568 | my $keys = $tag->{content}; |
569 | |
570 | ## |
571 | # Iterate through buckets, looking for a key match |
572 | ## |
573 | BUCKET: |
574 | for (my $i=0; $i<$DBM::Deep::MAX_BUCKETS; $i++) { |
575 | my $key = substr($keys, $i * $DBM::Deep::BUCKET_SIZE, $DBM::Deep::HASH_SIZE); |
576 | my $subloc = unpack($DBM::Deep::LONG_PACK, substr($keys, ($i * $DBM::Deep::BUCKET_SIZE) + $DBM::Deep::HASH_SIZE, $DBM::Deep::LONG_SIZE)); |
577 | |
578 | if (!$subloc) { |
579 | ## |
580 | # Hit end of list, no match |
581 | ## |
582 | return; |
583 | } |
584 | |
585 | if ( $md5 ne $key ) { |
586 | next BUCKET; |
587 | } |
588 | |
589 | ## |
590 | # Matched key -- return true |
591 | ## |
592 | return 1; |
593 | } # i loop |
594 | |
595 | return; |
596 | } |
597 | |
a20d9a3f |
598 | 1; |
599 | __END__ |