File Coverage

blib/lib/Number/Phone/UK/DBM/Deep.pm
Criterion Covered Total %
statement 161 658 24.4
branch 46 266 17.2
condition 11 78 14.1
subroutine 26 56 46.4
pod 18 18 100.0
total 262 1076 24.3


line stmt bran cond sub pod time code
1             package Number::Phone::UK::DBM::Deep;
2              
3             ##
4             # Number::Phone::UK::DBM::Deep
5             #
6             # Description:
7             # Multi-level database module for storing hash trees, arrays and simple
8             # key/value pairs into FTP-able, cross-platform binary database files.
9             #
10             # Type `perldoc Number::Phone::UK::DBM::Deep` for complete documentation.
11             #
12             # Usage Examples:
13             # my %db;
14             # tie %db, 'Number::Phone::UK::DBM::Deep', 'my_database.db'; # standard tie() method
15             #
16             # my $db = new Number::Phone::UK::DBM::Deep( 'my_database.db' ); # preferred OO method
17             #
18             # $db->{my_scalar} = 'hello world';
19             # $db->{my_hash} = { larry => 'genius', hashes => 'fast' };
20             # $db->{my_array} = [ 1, 2, 3, time() ];
21             # $db->{my_complex} = [ 'hello', { perl => 'rules' }, 42, 99 ];
22             # push @{$db->{my_array}}, 'another value';
23             # my @key_list = keys %{$db->{my_hash}};
24             # print "This module " . $db->{my_complex}->[1]->{perl} . "!\n";
25             #
26             # Copyright:
27             # (c) 2002-2006 Joseph Huckaby. All Rights Reserved.
28             # This program is free software; you can redistribute it and/or
29             # modify it under the same terms as Perl itself.
30             ##
31              
32 1     1   4 use strict;
  1         1  
  1         32  
33              
34 1     1   2 use Fcntl qw( :DEFAULT :flock :seek );
  1         2  
  1         393  
35 1     1   3 use Digest::MD5 ();
  1         2  
  1         14  
36 1     1   3 use Scalar::Util ();
  1         1  
  1         14  
37              
38 1     1   3 use vars qw( $VERSION );
  1         1  
  1         5034  
39             $VERSION = q(0.983);
40              
41             ##
42             # Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file.
43             # (Perl must be compiled with largefile support for files > 2 GB)
44             #
45             # Set to 8 and 'Q' for 64-bit offsets. Theoretical limit of 16 XB per file.
46             # (Perl must be compiled with largefile and 64-bit long support)
47             ##
48             #my $LONG_SIZE = 4;
49             #my $LONG_PACK = 'N';
50              
51             ##
52             # Set to 4 and 'N' for 32-bit data length prefixes. Limit of 4 GB for each key/value.
53             # Upgrading this is possible (see above) but probably not necessary. If you need
54             # more than 4 GB for a single key or value, this module is really not for you :-)
55             ##
56             #my $DATA_LENGTH_SIZE = 4;
57             #my $DATA_LENGTH_PACK = 'N';
58             our ($LONG_SIZE, $LONG_PACK, $DATA_LENGTH_SIZE, $DATA_LENGTH_PACK);
59              
60             ##
61             # Maximum number of buckets per list before another level of indexing is done.
62             # Increase this value for slightly greater speed, but larger database files.
63             # DO NOT decrease this value below 16, due to risk of recursive reindex overrun.
64             ##
65             my $MAX_BUCKETS = 16;
66              
67             ##
68             # Better not adjust anything below here, unless you're me :-)
69             ##
70              
71             ##
72             # Setup digest function for keys
73             ##
74             our ($DIGEST_FUNC, $HASH_SIZE);
75             #my $DIGEST_FUNC = \&Digest::MD5::md5;
76              
77             ##
78             # Precalculate index and bucket sizes based on values above.
79             ##
80             #my $HASH_SIZE = 16;
81             my ($INDEX_SIZE, $BUCKET_SIZE, $BUCKET_LIST_SIZE);
82              
83             set_digest();
84             #set_pack();
85             #_precalc_sizes();
86              
87             ##
88             # Setup file and tag signatures. These should never change.
89             ##
90             sub SIG_FILE () { 'DPDB' }
91             sub SIG_HASH () { 'H' }
92             sub SIG_ARRAY () { 'A' }
93             sub SIG_NULL () { 'N' }
94             sub SIG_DATA () { 'D' }
95             sub SIG_INDEX () { 'I' }
96             sub SIG_BLIST () { 'B' }
97             sub SIG_SIZE () { 1 }
98              
99             ##
100             # Setup constants for users to pass to new()
101             ##
102             sub TYPE_HASH () { SIG_HASH }
103             sub TYPE_ARRAY () { SIG_ARRAY }
104              
105             sub _get_args {
106 24     24   17 my $proto = shift;
107              
108 24         21 my $args;
109 24 50       27 if (scalar(@_) > 1) {
    0          
110 24 50       37 if ( @_ % 2 ) {
111 0         0 $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] );
112             }
113 24         35 $args = {@_};
114             }
115             elsif ( ref $_[0] ) {
116 0 0       0 unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) {
  0 0       0  
  0         0  
  0         0  
117 0         0 $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] );
118             }
119 0         0 $args = $_[0];
120             }
121             else {
122 0         0 $args = { file => shift };
123             }
124              
125 24         35 return $args;
126             }
127              
128             sub new {
129             ##
130             # Class constructor method for Perl OO interface.
131             # Calls tie() and returns blessed reference to tied hash or array,
132             # providing a hybrid OO/tie interface.
133             ##
134 12     12 1 11 my $class = shift;
135 12         20 my $args = $class->_get_args( @_ );
136            
137             ##
138             # Check if we want a tied hash or array.
139             ##
140 12         10 my $self;
141 12 50 66     38 if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
142 0         0 $class = 'Number::Phone::UK::DBM::Deep::Array';
143 0         0 require Number::Phone::UK::DBM::Deep::Array;
144 0         0 tie @$self, $class, %$args;
145             }
146             else {
147 12         11 $class = 'Number::Phone::UK::DBM::Deep::Hash';
148 12         472 require Number::Phone::UK::DBM::Deep::Hash;
149 12         49 tie %$self, $class, %$args;
150             }
151              
152 12         22 return bless $self, $class;
153             }
154              
155             sub _init {
156             ##
157             # Setup $self and bless into this class.
158             ##
159 12     12   11 my $class = shift;
160 12         7 my $args = shift;
161              
162             # These are the defaults to be optionally overridden below
163 12         20 my $self = bless {
164             type => TYPE_HASH,
165             base_offset => length(SIG_FILE),
166             }, $class;
167              
168 12         24 foreach my $param ( keys %$self ) {
169 24 100       30 next unless exists $args->{$param};
170 23         25 $self->{$param} = delete $args->{$param}
171             }
172            
173             # locking implicitly enables autoflush
174 12 50       20 if ($args->{locking}) { $args->{autoflush} = 1; }
  0         0  
175            
176             $self->{root} = exists $args->{root}
177             ? $args->{root}
178 12 100       23 : Number::Phone::UK::DBM::Deep::_::Root->new( $args );
179              
180 12 50       15 if (!defined($self->_fh)) { $self->_open(); }
  0         0  
181              
182 12         21 return $self;
183             }
184              
185             sub TIEHASH {
186 0     0   0 shift;
187 0         0 require Number::Phone::UK::DBM::Deep::Hash;
188 0         0 return Number::Phone::UK::DBM::Deep::Hash->TIEHASH( @_ );
189             }
190              
191             sub TIEARRAY {
192 0     0   0 shift;
193 0         0 require Number::Phone::UK::DBM::Deep::Array;
194 0         0 return Number::Phone::UK::DBM::Deep::Array->TIEARRAY( @_ );
195             }
196              
197             #XXX Unneeded now ...
198             #sub DESTROY {
199             #}
200              
201             sub _open {
202             ##
203             # Open a fh to the database, create if nonexistent.
204             # Make sure file signature matches Number::Phone::UK::DBM::Deep spec.
205             ##
206 0     0   0 my $self = $_[0]->_get_self;
207              
208 0         0 local($/,$\);
209              
210 0 0       0 if (defined($self->_fh)) { $self->_close(); }
  0         0  
211            
212 0         0 my $flags = O_RDWR | O_CREAT | O_BINARY;
213              
214 0         0 my $fh;
215             sysopen( $fh, $self->_root->{file}, $flags )
216 0 0       0 or $self->_throw_error( "Cannot sysopen file: " . $self->_root->{file} . ": $!" );
217              
218 0         0 $self->_root->{fh} = $fh;
219              
220 0 0       0 if ($self->_root->{autoflush}) {
221 0         0 my $old = select $fh;
222 0         0 $|=1;
223 0         0 select $old;
224             }
225            
226 0         0 seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET);
227              
228 0         0 my $signature;
229 0         0 my $bytes_read = read( $fh, $signature, length(SIG_FILE));
230            
231             ##
232             # File is empty -- write signature and master index
233             ##
234 0 0       0 if (!$bytes_read) {
235 0         0 seek($fh, 0 + $self->_root->{file_offset}, SEEK_SET);
236 0         0 print( $fh SIG_FILE);
237 0         0 $self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE);
238              
239 0         0 my $plain_key = "[base]";
240 0         0 print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
241              
242             # Flush the filehandle
243 0         0 my $old_fh = select $fh;
244 0         0 my $old_af = $|; $| = 1; $| = $old_af;
  0         0  
  0         0  
245 0         0 select $old_fh;
246              
247 0         0 my @stats = stat($fh);
248 0         0 $self->_root->{inode} = $stats[1];
249 0         0 $self->_root->{end} = $stats[7];
250              
251 0         0 return 1;
252             }
253            
254             ##
255             # Check signature was valid
256             ##
257 0 0       0 unless ($signature eq SIG_FILE) {
258 0         0 $self->_close();
259 0         0 return $self->_throw_error("Signature not found -- file is not a Deep DB");
260             }
261              
262 0         0 my @stats = stat($fh);
263 0         0 $self->_root->{inode} = $stats[1];
264 0         0 $self->_root->{end} = $stats[7];
265            
266             ##
267             # Get our type from master index signature
268             ##
269 0         0 my $tag = $self->_load_tag($self->_base_offset);
270              
271             #XXX We probably also want to store the hash algorithm name and not assume anything
272             #XXX The cool thing would be to allow a different hashing algorithm at every level
273              
274 0 0       0 if (!$tag) {
275 0         0 return $self->_throw_error("Corrupted file, no master index record");
276             }
277 0 0       0 if ($self->{type} ne $tag->{signature}) {
278 0         0 return $self->_throw_error("File type mismatch");
279             }
280            
281 0         0 return 1;
282             }
283              
284             sub _close {
285             ##
286             # Close database fh
287             ##
288 0     0   0 my $self = $_[0]->_get_self;
289 0 0       0 close $self->_root->{fh} if $self->_root->{fh};
290 0         0 $self->_root->{fh} = undef;
291             }
292              
293             sub _create_tag {
294             ##
295             # Given offset, signature and content, create tag and write to disk
296             ##
297 0     0   0 my ($self, $offset, $sig, $content) = @_;
298 0         0 my $size = length($content);
299              
300 0         0 local($/,$\);
301            
302 0         0 my $fh = $self->_fh;
303              
304 0         0 seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET);
305 0         0 print( $fh $sig . pack($DATA_LENGTH_PACK, $size) . $content );
306            
307 0 0       0 if ($offset == $self->_root->{end}) {
308 0         0 $self->_root->{end} += SIG_SIZE + $DATA_LENGTH_SIZE + $size;
309             }
310            
311             return {
312 0         0 signature => $sig,
313             size => $size,
314             offset => $offset + SIG_SIZE + $DATA_LENGTH_SIZE,
315             content => $content
316             };
317             }
318              
319             sub _load_tag {
320             ##
321             # Given offset, load single tag and return signature, size and data
322             ##
323 47     47   34 my $self = shift;
324 47         23 my $offset = shift;
325              
326 47         87 local($/,$\);
327            
328 47         47 my $fh = $self->_fh;
329              
330 47         56 seek($fh, $offset + $self->_root->{file_offset}, SEEK_SET);
331 47 50       228 if (eof $fh) { return undef; }
  0         0  
332            
333 47         39 my $b;
334 47         77 read( $fh, $b, SIG_SIZE + $DATA_LENGTH_SIZE );
335 47         123 my ($sig, $size) = unpack( "A $DATA_LENGTH_PACK", $b );
336            
337 47         28 my $buffer;
338 47         91 read( $fh, $buffer, $size);
339            
340             return {
341 47         177 signature => $sig,
342             size => $size,
343             offset => $offset + SIG_SIZE + $DATA_LENGTH_SIZE,
344             content => $buffer
345             };
346             }
347              
348             sub _index_lookup {
349             ##
350             # Given index tag, lookup single entry in index and return .
351             ##
352 27     27   18 my $self = shift;
353 27         22 my ($tag, $index) = @_;
354              
355 27         43 my $location = unpack($LONG_PACK, substr($tag->{content}, $index * $LONG_SIZE, $LONG_SIZE) );
356 27 50       33 if (!$location) { return; }
  0         0  
357            
358 27         33 return $self->_load_tag( $location );
359             }
360              
361             sub _add_bucket {
362             ##
363             # Adds one key/value pair to bucket list, given offset, MD5 digest of key,
364             # plain (undigested) key and value.
365             ##
366 0     0   0 my $self = shift;
367 0         0 my ($tag, $md5, $plain_key, $value) = @_;
368 0         0 my $keys = $tag->{content};
369 0         0 my $location = 0;
370 0         0 my $result = 2;
371              
372 0         0 local($/,$\);
373              
374             # This verifies that only supported values will be stored.
375             {
376 0         0 my $r = Scalar::Util::reftype( $value );
  0         0  
377 0 0       0 last if !defined $r;
378              
379 0 0       0 last if $r eq 'HASH';
380 0 0       0 last if $r eq 'ARRAY';
381              
382 0         0 $self->_throw_error(
383             "Storage of variables of type '$r' is not supported."
384             );
385             }
386              
387 0         0 my $root = $self->_root;
388              
389 0         0 my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'Number::Phone::UK::DBM::Deep' ) };
  0         0  
  0         0  
390 0   0     0 my $internal_ref = $is_dbm_deep && ($value->_root eq $root);
391              
392 0         0 my $fh = $self->_fh;
393              
394             ##
395             # Iterate through buckets, seeing if this is a new entry or a replace.
396             ##
397 0         0 for (my $i=0; $i<$MAX_BUCKETS; $i++) {
398 0         0 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
399 0 0       0 if (!$subloc) {
400             ##
401             # Found empty bucket (end of list). Populate and exit loop.
402             ##
403 0         0 $result = 2;
404            
405             $location = $internal_ref
406             ? $value->_base_offset
407 0 0       0 : $root->{end};
408            
409 0         0 seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
410 0         0 print( $fh $md5 . pack($LONG_PACK, $location) );
411 0         0 last;
412             }
413              
414 0         0 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
415 0 0       0 if ($md5 eq $key) {
416             ##
417             # Found existing bucket with same key. Replace with new value.
418             ##
419 0         0 $result = 1;
420            
421 0 0       0 if ($internal_ref) {
422 0         0 $location = $value->_base_offset;
423 0         0 seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
424 0         0 print( $fh $md5 . pack($LONG_PACK, $location) );
425 0         0 return $result;
426             }
427              
428 0         0 seek($fh, $subloc + SIG_SIZE + $root->{file_offset}, SEEK_SET);
429 0         0 my $size;
430 0         0 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
  0         0  
431            
432             ##
433             # If value is a hash, array, or raw value with equal or less size, we can
434             # reuse the same content area of the database. Otherwise, we have to create
435             # a new content area at the EOF.
436             ##
437 0         0 my $actual_length;
438 0   0     0 my $r = Scalar::Util::reftype( $value ) || '';
439 0 0 0     0 if ( $r eq 'HASH' || $r eq 'ARRAY' ) {
440 0         0 $actual_length = $INDEX_SIZE;
441            
442             # if autobless is enabled, must also take into consideration
443             # the class name, as it is stored along with key/value.
444 0 0       0 if ( $root->{autobless} ) {
445 0         0 my $value_class = Scalar::Util::blessed($value);
446 0 0 0     0 if ( defined $value_class && !$value->isa('Number::Phone::UK::DBM::Deep') ) {
447 0         0 $actual_length += length($value_class);
448             }
449             }
450             }
451 0         0 else { $actual_length = length($value); }
452            
453 0 0 0     0 if ($actual_length <= ($size || 0)) {
454 0         0 $location = $subloc;
455             }
456             else {
457 0         0 $location = $root->{end};
458 0         0 seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $HASH_SIZE + $root->{file_offset}, SEEK_SET);
459 0         0 print( $fh pack($LONG_PACK, $location) );
460             }
461              
462 0         0 last;
463             }
464             }
465            
466             ##
467             # If this is an internal reference, return now.
468             # No need to write value or plain key
469             ##
470 0 0       0 if ($internal_ref) {
471 0         0 return $result;
472             }
473            
474             ##
475             # If bucket didn't fit into list, split into a new index level
476             ##
477 0 0       0 if (!$location) {
478 0         0 seek($fh, $tag->{ref_loc} + $root->{file_offset}, SEEK_SET);
479 0         0 print( $fh pack($LONG_PACK, $root->{end}) );
480            
481 0         0 my $index_tag = $self->_create_tag($root->{end}, SIG_INDEX, chr(0) x $INDEX_SIZE);
482 0         0 my @offsets = ();
483            
484 0         0 $keys .= $md5 . pack($LONG_PACK, 0);
485            
486 0         0 for (my $i=0; $i<=$MAX_BUCKETS; $i++) {
487 0         0 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
488 0 0       0 if ($key) {
489 0         0 my $old_subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
490 0         0 my $num = ord(substr($key, $tag->{ch} + 1, 1));
491            
492 0 0       0 if ($offsets[$num]) {
493 0         0 my $offset = $offsets[$num] + SIG_SIZE + $DATA_LENGTH_SIZE;
494 0         0 seek($fh, $offset + $root->{file_offset}, SEEK_SET);
495 0         0 my $subkeys;
496 0         0 read( $fh, $subkeys, $BUCKET_LIST_SIZE);
497            
498 0         0 for (my $k=0; $k<$MAX_BUCKETS; $k++) {
499 0         0 my $subloc = unpack($LONG_PACK, substr($subkeys, ($k * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
500 0 0       0 if (!$subloc) {
501 0         0 seek($fh, $offset + ($k * $BUCKET_SIZE) + $root->{file_offset}, SEEK_SET);
502 0   0     0 print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) );
503 0         0 last;
504             }
505             } # k loop
506             }
507             else {
508 0         0 $offsets[$num] = $root->{end};
509 0         0 seek($fh, $index_tag->{offset} + ($num * $LONG_SIZE) + $root->{file_offset}, SEEK_SET);
510 0         0 print( $fh pack($LONG_PACK, $root->{end}) );
511            
512 0         0 my $blist_tag = $self->_create_tag($root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
513            
514 0         0 seek($fh, $blist_tag->{offset} + $root->{file_offset}, SEEK_SET);
515 0   0     0 print( $fh $key . pack($LONG_PACK, $old_subloc || $root->{end}) );
516             }
517             } # key is real
518             } # i loop
519            
520 0   0     0 $location ||= $root->{end};
521             } # re-index bucket list
522            
523             ##
524             # Seek to content area and store signature, value and plaintext key
525             ##
526 0 0       0 if ($location) {
527 0         0 my $content_length;
528 0         0 seek($fh, $location + $root->{file_offset}, SEEK_SET);
529            
530             ##
531             # Write signature based on content type, set content length and write actual value.
532             ##
533 0   0     0 my $r = Scalar::Util::reftype($value) || '';
534 0 0       0 if ($r eq 'HASH') {
    0          
    0          
535 0 0 0     0 if ( !$internal_ref && tied %{$value} ) {
  0         0  
536 0         0 return $self->_throw_error("Cannot store a tied value");
537             }
538 0         0 print( $fh TYPE_HASH );
539 0         0 print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
540 0         0 $content_length = $INDEX_SIZE;
541             }
542             elsif ($r eq 'ARRAY') {
543 0 0 0     0 if ( !$internal_ref && tied @{$value} ) {
  0         0  
544 0         0 return $self->_throw_error("Cannot store a tied value");
545             }
546 0         0 print( $fh TYPE_ARRAY );
547 0         0 print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
548 0         0 $content_length = $INDEX_SIZE;
549             }
550             elsif (!defined($value)) {
551 0         0 print( $fh SIG_NULL );
552 0         0 print( $fh pack($DATA_LENGTH_PACK, 0) );
553 0         0 $content_length = 0;
554             }
555             else {
556 0         0 print( $fh SIG_DATA );
557 0         0 print( $fh pack($DATA_LENGTH_PACK, length($value)) . $value );
558 0         0 $content_length = length($value);
559             }
560            
561             ##
562             # Plain key is stored AFTER value, as keys are typically fetched less often.
563             ##
564 0         0 print( $fh pack($DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
565            
566             ##
567             # If value is blessed, preserve class name
568             ##
569 0 0       0 if ( $root->{autobless} ) {
570 0         0 my $value_class = Scalar::Util::blessed($value);
571 0 0 0     0 if ( defined $value_class && $value_class ne 'Number::Phone::UK::DBM::Deep' ) {
572             ##
573             # Blessed ref -- will restore later
574             ##
575 0         0 print( $fh chr(1) );
576 0         0 print( $fh pack($DATA_LENGTH_PACK, length($value_class)) . $value_class );
577 0         0 $content_length += 1;
578 0         0 $content_length += $DATA_LENGTH_SIZE + length($value_class);
579             }
580             else {
581 0         0 print( $fh chr(0) );
582 0         0 $content_length += 1;
583             }
584             }
585            
586             ##
587             # If this is a new content area, advance EOF counter
588             ##
589 0 0       0 if ($location == $root->{end}) {
590 0         0 $root->{end} += SIG_SIZE;
591 0         0 $root->{end} += $DATA_LENGTH_SIZE + $content_length;
592 0         0 $root->{end} += $DATA_LENGTH_SIZE + length($plain_key);
593             }
594            
595             ##
596             # If content is a hash or array, create new child Number::Phone::UK::DBM::Deep object and
597             # pass each key or element to it.
598             ##
599 0 0       0 if ($r eq 'HASH') {
    0          
600 0         0 my %x = %$value;
601 0         0 tie %$value, 'Number::Phone::UK::DBM::Deep', {
602             type => TYPE_HASH,
603             base_offset => $location,
604             root => $root,
605             };
606 0         0 %$value = %x;
607             }
608             elsif ($r eq 'ARRAY') {
609 0         0 my @x = @$value;
610 0         0 tie @$value, 'Number::Phone::UK::DBM::Deep', {
611             type => TYPE_ARRAY,
612             base_offset => $location,
613             root => $root,
614             };
615 0         0 @$value = @x;
616             }
617            
618 0         0 return $result;
619             }
620            
621 0         0 return $self->_throw_error("Fatal error: indexing failed -- possibly due to corruption in file");
622             }
623              
624             sub _get_bucket_value {
625             ##
626             # Fetch single value given tag and MD5 digested key.
627             ##
628 15     15   12 my $self = shift;
629 15         14 my ($tag, $md5) = @_;
630 15         10 my $keys = $tag->{content};
631              
632 15         26 local($/,$\);
633              
634 15         16 my $fh = $self->_fh;
635              
636             ##
637             # Iterate through buckets, looking for a key match
638             ##
639             BUCKET:
640 15         28 for (my $i=0; $i<$MAX_BUCKETS; $i++) {
641 21         25 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
642 21         31 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
643              
644 21 50       29 if (!$subloc) {
645             ##
646             # Hit end of list, no match
647             ##
648 0         0 return;
649             }
650              
651 21 100       24 if ( $md5 ne $key ) {
652 6         9 next BUCKET;
653             }
654              
655             ##
656             # Found match -- seek to offset and read signature
657             ##
658 15         14 my $signature;
659 15         15 seek($fh, $subloc + $self->_root->{file_offset}, SEEK_SET);
660 15         65 read( $fh, $signature, SIG_SIZE);
661            
662             ##
663             # If value is a hash or array, return new Number::Phone::UK::DBM::Deep object with correct offset
664             ##
665 15 100 66     44 if (($signature eq TYPE_HASH) || ($signature eq TYPE_ARRAY)) {
    50          
666 11         16 my $obj = Number::Phone::UK::DBM::Deep->new(
667             type => $signature,
668             base_offset => $subloc,
669             root => $self->_root
670             );
671            
672 11 50       12 if ($self->_root->{autobless}) {
673             ##
674             # Skip over value and plain key to see if object needs
675             # to be re-blessed
676             ##
677 0         0 seek($fh, $DATA_LENGTH_SIZE + $INDEX_SIZE, SEEK_CUR);
678            
679 0         0 my $size;
680 0         0 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
  0         0  
681 0 0       0 if ($size) { seek($fh, $size, SEEK_CUR); }
  0         0  
682            
683 0         0 my $bless_bit;
684 0         0 read( $fh, $bless_bit, 1);
685 0 0       0 if (ord($bless_bit)) {
686             ##
687             # Yes, object needs to be re-blessed
688             ##
689 0         0 my $class_name;
690 0         0 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
  0         0  
691 0 0       0 if ($size) { read( $fh, $class_name, $size); }
  0         0  
692 0 0       0 if ($class_name) { $obj = bless( $obj, $class_name ); }
  0         0  
693             }
694             }
695            
696 11         31 return $obj;
697             }
698            
699             ##
700             # Otherwise return actual value
701             ##
702             elsif ($signature eq SIG_DATA) {
703 4         1 my $size;
704 4         4 my $value = '';
705 4         5 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
  4         5  
706 4 50       6 if ($size) { read( $fh, $value, $size); }
  4         27  
707 4         11 return $value;
708             }
709            
710             ##
711             # Key exists, but content is null
712             ##
713 0         0 else { return; }
714             } # i loop
715              
716 0         0 return;
717             }
718              
719             sub _delete_bucket {
720             ##
721             # Delete single key/value pair given tag and MD5 digested key.
722             ##
723 0     0   0 my $self = shift;
724 0         0 my ($tag, $md5) = @_;
725 0         0 my $keys = $tag->{content};
726              
727 0         0 local($/,$\);
728              
729 0         0 my $fh = $self->_fh;
730            
731             ##
732             # Iterate through buckets, looking for a key match
733             ##
734             BUCKET:
735 0         0 for (my $i=0; $i<$MAX_BUCKETS; $i++) {
736 0         0 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
737 0         0 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
738              
739 0 0       0 if (!$subloc) {
740             ##
741             # Hit end of list, no match
742             ##
743 0         0 return;
744             }
745              
746 0 0       0 if ( $md5 ne $key ) {
747 0         0 next BUCKET;
748             }
749              
750             ##
751             # Matched key -- delete bucket and return
752             ##
753 0         0 seek($fh, $tag->{offset} + ($i * $BUCKET_SIZE) + $self->_root->{file_offset}, SEEK_SET);
754 0         0 print( $fh substr($keys, ($i+1) * $BUCKET_SIZE ) );
755 0         0 print( $fh chr(0) x $BUCKET_SIZE );
756            
757 0         0 return 1;
758             } # i loop
759              
760 0         0 return;
761             }
762              
763             sub _bucket_exists {
764             ##
765             # Check existence of single key given tag and MD5 digested key.
766             ##
767 5     5   2 my $self = shift;
768 5         6 my ($tag, $md5) = @_;
769 5         4 my $keys = $tag->{content};
770            
771             ##
772             # Iterate through buckets, looking for a key match
773             ##
774             BUCKET:
775 5         10 for (my $i=0; $i<$MAX_BUCKETS; $i++) {
776 16         16 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
777 16         15 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
778              
779 16 100       19 if (!$subloc) {
780             ##
781             # Hit end of list, no match
782             ##
783 4         18 return;
784             }
785              
786 12 100       15 if ( $md5 ne $key ) {
787 11         17 next BUCKET;
788             }
789              
790             ##
791             # Matched key -- return true
792             ##
793 1         3 return 1;
794             } # i loop
795              
796 0         0 return;
797             }
798              
799             sub _find_bucket_list {
800             ##
801             # Locate offset for bucket list, given digested key
802             ##
803 20     20   11 my $self = shift;
804 20         15 my $md5 = shift;
805            
806             ##
807             # Locate offset for bucket list using digest index system
808             ##
809 20         16 my $ch = 0;
810 20         23 my $tag = $self->_load_tag($self->_base_offset);
811 20 50       33 if (!$tag) { return; }
  0         0  
812            
813 20         38 while ($tag->{signature} ne SIG_BLIST) {
814 27         52 $tag = $self->_index_lookup($tag, ord(substr($md5, $ch, 1)));
815 27 50       58 if (!$tag) { return; }
  0         0  
816 27         38 $ch++;
817             }
818            
819 20         23 return $tag;
820             }
821              
822             sub _traverse_index {
823             ##
824             # Scan index and recursively step into deeper levels, looking for next key.
825             ##
826 0     0   0 my ($self, $offset, $ch, $force_return_next) = @_;
827 0 0       0 $force_return_next = undef unless $force_return_next;
828              
829 0         0 local($/,$\);
830            
831 0         0 my $tag = $self->_load_tag( $offset );
832              
833 0         0 my $fh = $self->_fh;
834            
835 0 0       0 if ($tag->{signature} ne SIG_BLIST) {
    0          
836 0         0 my $content = $tag->{content};
837 0         0 my $start;
838 0 0       0 if ($self->{return_next}) { $start = 0; }
  0         0  
839 0         0 else { $start = ord(substr($self->{prev_md5}, $ch, 1)); }
840            
841 0         0 for (my $index = $start; $index < 256; $index++) {
842 0         0 my $subloc = unpack($LONG_PACK, substr($content, $index * $LONG_SIZE, $LONG_SIZE) );
843 0 0       0 if ($subloc) {
844 0         0 my $result = $self->_traverse_index( $subloc, $ch + 1, $force_return_next );
845 0 0       0 if (defined($result)) { return $result; }
  0         0  
846             }
847             } # index loop
848            
849 0         0 $self->{return_next} = 1;
850             } # tag is an index
851            
852             elsif ($tag->{signature} eq SIG_BLIST) {
853 0         0 my $keys = $tag->{content};
854 0 0       0 if ($force_return_next) { $self->{return_next} = 1; }
  0         0  
855            
856             ##
857             # Iterate through buckets, looking for a key match
858             ##
859 0         0 for (my $i=0; $i<$MAX_BUCKETS; $i++) {
860 0         0 my $key = substr($keys, $i * $BUCKET_SIZE, $HASH_SIZE);
861 0         0 my $subloc = unpack($LONG_PACK, substr($keys, ($i * $BUCKET_SIZE) + $HASH_SIZE, $LONG_SIZE));
862            
863 0 0       0 if (!$subloc) {
    0          
    0          
864             ##
865             # End of bucket list -- return to outer loop
866             ##
867 0         0 $self->{return_next} = 1;
868 0         0 last;
869             }
870             elsif ($key eq $self->{prev_md5}) {
871             ##
872             # Located previous key -- return next one found
873             ##
874 0         0 $self->{return_next} = 1;
875 0         0 next;
876             }
877             elsif ($self->{return_next}) {
878             ##
879             # Seek to bucket location and skip over signature
880             ##
881 0         0 seek($fh, $subloc + SIG_SIZE + $self->_root->{file_offset}, SEEK_SET);
882            
883             ##
884             # Skip over value to get to plain key
885             ##
886 0         0 my $size;
887 0         0 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
  0         0  
888 0 0       0 if ($size) { seek($fh, $size, SEEK_CUR); }
  0         0  
889            
890             ##
891             # Read in plain key and return as scalar
892             ##
893 0         0 my $plain_key;
894 0         0 read( $fh, $size, $DATA_LENGTH_SIZE); $size = unpack($DATA_LENGTH_PACK, $size);
  0         0  
895 0 0       0 if ($size) { read( $fh, $plain_key, $size); }
  0         0  
896            
897 0         0 return $plain_key;
898             }
899             } # bucket loop
900            
901 0         0 $self->{return_next} = 1;
902             } # tag is a bucket list
903            
904 0         0 return;
905             }
906              
907             sub _get_next_key {
908             ##
909             # Locate next key, given digested previous one
910             ##
911 0     0   0 my $self = $_[0]->_get_self;
912            
913 0 0       0 $self->{prev_md5} = $_[1] ? $_[1] : undef;
914 0         0 $self->{return_next} = 0;
915            
916             ##
917             # If the previous key was not specifed, start at the top and
918             # return the first one found.
919             ##
920 0 0       0 if (!$self->{prev_md5}) {
921 0         0 $self->{prev_md5} = chr(0) x $HASH_SIZE;
922 0         0 $self->{return_next} = 1;
923             }
924            
925 0         0 return $self->_traverse_index( $self->_base_offset, 0 );
926             }
927              
928             sub lock {
929             ##
930             # If db locking is set, flock() the db file. If called multiple
931             # times before unlock(), then the same number of unlocks() must
932             # be called before the lock is released.
933             ##
934 20     20 1 30 my $self = $_[0]->_get_self;
935 20         18 my $type = $_[1];
936 20 50       26 $type = LOCK_EX unless defined $type;
937            
938 20 50       22 if (!defined($self->_fh)) { return; }
  0         0  
939              
940 20 50       46 if ($self->_root->{locking}) {
941 0 0       0 if (!$self->_root->{locked}) {
942 0         0 flock($self->_fh, $type);
943            
944             # refresh end counter in case file has changed size
945 0         0 my @stats = stat($self->_root->{file});
946 0         0 $self->_root->{end} = $stats[7];
947            
948             # double-check file inode, in case another process
949             # has optimize()d our file while we were waiting.
950 0 0       0 if ($stats[1] != $self->_root->{inode}) {
951 0         0 $self->_open(); # re-open
952 0         0 flock($self->_fh, $type); # re-lock
953 0         0 $self->_root->{end} = (stat($self->_fh))[7]; # re-end
954             }
955             }
956 0         0 $self->_root->{locked}++;
957              
958 0         0 return 1;
959             }
960              
961 20         18 return;
962             }
963              
964             sub unlock {
965             ##
966             # If db locking is set, unlock the db file. See note in lock()
967             # regarding calling lock() multiple times.
968             ##
969 20     20 1 37 my $self = $_[0]->_get_self;
970              
971 20 50       23 if (!defined($self->_fh)) { return; }
  0         0  
972            
973 20 50 33     26 if ($self->_root->{locking} && $self->_root->{locked} > 0) {
974 0         0 $self->_root->{locked}--;
975 0 0       0 if (!$self->_root->{locked}) { flock($self->_fh, LOCK_UN); }
  0         0  
976              
977 0         0 return 1;
978             }
979              
980 20         17 return;
981             }
982              
983             sub _copy_value {
984 0     0   0 my $self = shift->_get_self;
985 0         0 my ($spot, $value) = @_;
986              
987 0 0       0 if ( !ref $value ) {
    0          
988 0         0 ${$spot} = $value;
  0         0  
989             }
990 0         0 elsif ( eval { local $SIG{__DIE__}; $value->isa( 'Number::Phone::UK::DBM::Deep' ) } ) {
  0         0  
991 0         0 my $type = $value->_type;
992 0 0       0 ${$spot} = $type eq TYPE_HASH ? {} : [];
  0         0  
993 0         0 $value->_copy_node( ${$spot} );
  0         0  
994             }
995             else {
996 0         0 my $r = Scalar::Util::reftype( $value );
997 0         0 my $c = Scalar::Util::blessed( $value );
998 0 0       0 if ( $r eq 'ARRAY' ) {
999 0         0 ${$spot} = [ @{$value} ];
  0         0  
  0         0  
1000             }
1001             else {
1002 0         0 ${$spot} = { %{$value} };
  0         0  
  0         0  
1003             }
1004 0 0       0 ${$spot} = bless ${$spot}, $c
  0         0  
  0         0  
1005             if defined $c;
1006             }
1007              
1008 0         0 return 1;
1009             }
1010              
1011             sub _copy_node {
1012             ##
1013             # Copy single level of keys or elements to new DB handle.
1014             # Recurse for nested structures
1015             ##
1016 0     0   0 my $self = shift->_get_self;
1017 0         0 my ($db_temp) = @_;
1018              
1019 0 0       0 if ($self->_type eq TYPE_HASH) {
1020 0         0 my $key = $self->first_key();
1021 0         0 while ($key) {
1022 0         0 my $value = $self->get($key);
1023 0         0 $self->_copy_value( \$db_temp->{$key}, $value );
1024 0         0 $key = $self->next_key($key);
1025             }
1026             }
1027             else {
1028 0         0 my $length = $self->length();
1029 0         0 for (my $index = 0; $index < $length; $index++) {
1030 0         0 my $value = $self->get($index);
1031 0         0 $self->_copy_value( \$db_temp->[$index], $value );
1032             }
1033             }
1034              
1035 0         0 return 1;
1036             }
1037              
1038             sub export {
1039             ##
1040             # Recursively export into standard Perl hashes and arrays.
1041             ##
1042 0     0 1 0 my $self = $_[0]->_get_self;
1043            
1044 0         0 my $temp;
1045 0 0       0 if ($self->_type eq TYPE_HASH) { $temp = {}; }
  0 0       0  
1046 0         0 elsif ($self->_type eq TYPE_ARRAY) { $temp = []; }
1047            
1048 0         0 $self->lock();
1049 0         0 $self->_copy_node( $temp );
1050 0         0 $self->unlock();
1051            
1052 0         0 return $temp;
1053             }
1054              
1055             sub import {
1056             ##
1057             # Recursively import Perl hash/array structure
1058             ##
1059             #XXX This use of ref() seems to be ok
1060 1 50   1   3 if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
  1         52  
1061            
1062 0         0 my $self = $_[0]->_get_self;
1063 0         0 my $struct = $_[1];
1064            
1065             #XXX This use of ref() seems to be ok
1066 0 0       0 if (!ref($struct)) {
1067             ##
1068             # struct is not a reference, so just import based on our type
1069             ##
1070 0         0 shift @_;
1071            
1072 0 0       0 if ($self->_type eq TYPE_HASH) { $struct = {@_}; }
  0 0       0  
1073 0         0 elsif ($self->_type eq TYPE_ARRAY) { $struct = [@_]; }
1074             }
1075            
1076 0   0     0 my $r = Scalar::Util::reftype($struct) || '';
1077 0 0 0     0 if ($r eq "HASH" && $self->_type eq TYPE_HASH) {
    0 0        
1078 0         0 foreach my $key (keys %$struct) { $self->put($key, $struct->{$key}); }
  0         0  
1079             }
1080             elsif ($r eq "ARRAY" && $self->_type eq TYPE_ARRAY) {
1081 0         0 $self->push( @$struct );
1082             }
1083             else {
1084 0         0 return $self->_throw_error("Cannot import: type mismatch");
1085             }
1086            
1087 0         0 return 1;
1088             }
1089              
1090             sub optimize {
1091             ##
1092             # Rebuild entire database into new file, then move
1093             # it back on top of original.
1094             ##
1095 0     0 1 0 my $self = $_[0]->_get_self;
1096              
1097             #XXX Need to create a new test for this
1098             # if ($self->_root->{links} > 1) {
1099             # return $self->_throw_error("Cannot optimize: reference count is greater than 1");
1100             # }
1101            
1102             my $db_temp = Number::Phone::UK::DBM::Deep->new(
1103 0         0 file => $self->_root->{file} . '.tmp',
1104             type => $self->_type
1105             );
1106 0 0       0 if (!$db_temp) {
1107 0         0 return $self->_throw_error("Cannot optimize: failed to open temp file: $!");
1108             }
1109            
1110 0         0 $self->lock();
1111 0         0 $self->_copy_node( $db_temp );
1112 0         0 undef $db_temp;
1113            
1114             ##
1115             # Attempt to copy user, group and permissions over to new file
1116             ##
1117 0         0 my @stats = stat($self->_fh);
1118 0         0 my $perms = $stats[2] & 07777;
1119 0         0 my $uid = $stats[4];
1120 0         0 my $gid = $stats[5];
1121 0         0 chown( $uid, $gid, $self->_root->{file} . '.tmp' );
1122 0         0 chmod( $perms, $self->_root->{file} . '.tmp' );
1123            
1124             # q.v. perlport for more information on this variable
1125 0 0 0     0 if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
1126             ##
1127             # Potential race condition when optmizing on Win32 with locking.
1128             # The Windows filesystem requires that the filehandle be closed
1129             # before it is overwritten with rename(). This could be redone
1130             # with a soft copy.
1131             ##
1132 0         0 $self->unlock();
1133 0         0 $self->_close();
1134             }
1135            
1136 0 0       0 if (!rename $self->_root->{file} . '.tmp', $self->_root->{file}) {
1137 0         0 unlink $self->_root->{file} . '.tmp';
1138 0         0 $self->unlock();
1139 0         0 return $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
1140             }
1141            
1142 0         0 $self->unlock();
1143 0         0 $self->_close();
1144 0         0 $self->_open();
1145            
1146 0         0 return 1;
1147             }
1148              
1149             sub clone {
1150             ##
1151             # Make copy of object and return
1152             ##
1153 0     0 1 0 my $self = $_[0]->_get_self;
1154            
1155 0         0 return Number::Phone::UK::DBM::Deep->new(
1156             type => $self->_type,
1157             base_offset => $self->_base_offset,
1158             root => $self->_root
1159             );
1160             }
1161              
1162             {
1163             my %is_legal_filter = map {
1164             $_ => ~~1,
1165             } qw(
1166             store_key store_value
1167             fetch_key fetch_value
1168             );
1169              
1170             sub set_filter {
1171             ##
1172             # Setup filter function for storing or fetching the key or value
1173             ##
1174 0     0 1 0 my $self = $_[0]->_get_self;
1175 0         0 my $type = lc $_[1];
1176 0 0       0 my $func = $_[2] ? $_[2] : undef;
1177            
1178 0 0       0 if ( $is_legal_filter{$type} ) {
1179 0         0 $self->_root->{"filter_$type"} = $func;
1180 0         0 return 1;
1181             }
1182              
1183 0         0 return;
1184             }
1185             }
1186              
1187             ##
1188             # Accessor methods
1189             ##
1190              
1191             sub _root {
1192             ##
1193             # Get access to the root structure
1194             ##
1195 282     282   385 my $self = $_[0]->_get_self;
1196 282         550 return $self->{root};
1197             }
1198              
1199             sub _fh {
1200             ##
1201             # Get access to the raw fh
1202             ##
1203             #XXX It will be useful, though, when we split out HASH and ARRAY
1204 134     134   191 my $self = $_[0]->_get_self;
1205 134         147 return $self->_root->{fh};
1206             }
1207              
1208             sub _type {
1209             ##
1210             # Get type of current node (TYPE_HASH or TYPE_ARRAY)
1211             ##
1212 0     0   0 my $self = $_[0]->_get_self;
1213 0         0 return $self->{type};
1214             }
1215              
1216             sub _base_offset {
1217             ##
1218             # Get base_offset of current node (TYPE_HASH or TYPE_ARRAY)
1219             ##
1220 20     20   26 my $self = $_[0]->_get_self;
1221 20         29 return $self->{base_offset};
1222             }
1223              
1224             sub error {
1225             ##
1226             # Get last error string, or undef if no error
1227             ##
1228             return $_[0]
1229             ? ( $_[0]->_get_self->{root}->{error} or undef )
1230 1 50 50 1 1 3 : $@;
1231             }
1232              
1233             ##
1234             # Utility methods
1235             ##
1236              
1237             sub _throw_error {
1238             ##
1239             # Store error string in self
1240             ##
1241 0     0   0 my $error_text = $_[1];
1242            
1243 0 0       0 if ( Scalar::Util::blessed $_[0] ) {
1244 0         0 my $self = $_[0]->_get_self;
1245 0         0 $self->_root->{error} = $error_text;
1246            
1247 0 0       0 unless ($self->_root->{debug}) {
1248 0         0 die "Number::Phone::UK::DBM::Deep: $error_text\n";
1249             }
1250              
1251 0         0 warn "Number::Phone::UK::DBM::Deep: $error_text\n";
1252 0         0 return;
1253             }
1254             else {
1255 0         0 die "Number::Phone::UK::DBM::Deep: $error_text\n";
1256             }
1257             }
1258              
1259             sub clear_error {
1260             ##
1261             # Clear error state
1262             ##
1263 0     0 1 0 my $self = $_[0]->_get_self;
1264            
1265 0         0 undef $self->_root->{error};
1266             }
1267              
1268             sub _precalc_sizes {
1269             ##
1270             # Precalculate index, bucket and bucket list sizes
1271             ##
1272              
1273             #XXX I don't like this ...
1274 2 100   2   6 set_pack() unless defined $LONG_SIZE;
1275              
1276 2         2 $INDEX_SIZE = 256 * $LONG_SIZE;
1277 2         2 $BUCKET_SIZE = $HASH_SIZE + $LONG_SIZE;
1278 2         2 $BUCKET_LIST_SIZE = $MAX_BUCKETS * $BUCKET_SIZE;
1279             }
1280              
1281             sub set_pack {
1282             ##
1283             # Set pack/unpack modes (see file header for more)
1284             ##
1285 1     1 1 1 my ($long_s, $long_p, $data_s, $data_p) = @_;
1286              
1287 1 50       2 $LONG_SIZE = $long_s ? $long_s : 4;
1288 1 50       2 $LONG_PACK = $long_p ? $long_p : 'N';
1289              
1290 1 50       2 $DATA_LENGTH_SIZE = $data_s ? $data_s : 4;
1291 1 50       1 $DATA_LENGTH_PACK = $data_p ? $data_p : 'N';
1292              
1293 1         3 _precalc_sizes();
1294             }
1295              
1296             sub set_digest {
1297             ##
1298             # Set key digest function (default is MD5)
1299             ##
1300 1     1 1 2 my ($digest_func, $hash_size) = @_;
1301              
1302 1 50       4 $DIGEST_FUNC = $digest_func ? $digest_func : \&Digest::MD5::md5;
1303 1 50       3 $HASH_SIZE = $hash_size ? $hash_size : 16;
1304              
1305 1         4 _precalc_sizes();
1306             }
1307              
1308             sub _is_writable {
1309 0     0   0 my $fh = shift;
1310 0         0 (O_WRONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
1311             }
1312              
1313             #sub _is_readable {
1314             # my $fh = shift;
1315             # (O_RDONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0);
1316             #}
1317              
1318             ##
1319             # tie() methods (hashes and arrays)
1320             ##
1321              
1322             sub STORE {
1323             ##
1324             # Store single hash key/value or array element in database.
1325             ##
1326 0     0   0 my $self = $_[0]->_get_self;
1327 0         0 my $key = $_[1];
1328              
1329 0         0 local($/,$\);
1330              
1331             # User may be storing a hash, in which case we do not want it run
1332             # through the filtering system
1333             my $value = ($self->_root->{filter_store_value} && !ref($_[2]))
1334 0 0 0     0 ? $self->_root->{filter_store_value}->($_[2])
1335             : $_[2];
1336            
1337 0         0 my $md5 = $DIGEST_FUNC->($key);
1338            
1339             ##
1340             # Make sure file is open
1341             ##
1342 0 0 0     0 if (!defined($self->_fh) && !$self->_open()) {
1343 0         0 return;
1344             }
1345              
1346 0 0 0     0 if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) {
1347 0         0 $self->_throw_error( 'Cannot write to a readonly filehandle' );
1348             }
1349            
1350             ##
1351             # Request exclusive lock for writing
1352             ##
1353 0         0 $self->lock( LOCK_EX );
1354            
1355 0         0 my $fh = $self->_fh;
1356            
1357             ##
1358             # Locate offset for bucket list using digest index system
1359             ##
1360 0         0 my $tag = $self->_load_tag($self->_base_offset);
1361 0 0       0 if (!$tag) {
1362 0         0 $tag = $self->_create_tag($self->_base_offset, SIG_INDEX, chr(0) x $INDEX_SIZE);
1363             }
1364            
1365 0         0 my $ch = 0;
1366 0         0 while ($tag->{signature} ne SIG_BLIST) {
1367 0         0 my $num = ord(substr($md5, $ch, 1));
1368              
1369 0         0 my $ref_loc = $tag->{offset} + ($num * $LONG_SIZE);
1370 0         0 my $new_tag = $self->_index_lookup($tag, $num);
1371              
1372 0 0       0 if (!$new_tag) {
1373 0         0 seek($fh, $ref_loc + $self->_root->{file_offset}, SEEK_SET);
1374 0         0 print( $fh pack($LONG_PACK, $self->_root->{end}) );
1375            
1376 0         0 $tag = $self->_create_tag($self->_root->{end}, SIG_BLIST, chr(0) x $BUCKET_LIST_SIZE);
1377              
1378 0         0 $tag->{ref_loc} = $ref_loc;
1379 0         0 $tag->{ch} = $ch;
1380              
1381 0         0 last;
1382             }
1383             else {
1384 0         0 $tag = $new_tag;
1385              
1386 0         0 $tag->{ref_loc} = $ref_loc;
1387 0         0 $tag->{ch} = $ch;
1388             }
1389 0         0 $ch++;
1390             }
1391            
1392             ##
1393             # Add key/value to bucket list
1394             ##
1395 0         0 my $result = $self->_add_bucket( $tag, $md5, $key, $value );
1396            
1397 0         0 $self->unlock();
1398              
1399 0         0 return $result;
1400             }
1401              
1402             sub FETCH {
1403             ##
1404             # Fetch single value or element given plain key or array index
1405             ##
1406 15     15   22 my $self = shift->_get_self;
1407 15         10 my $key = shift;
1408              
1409             ##
1410             # Make sure file is open
1411             ##
1412 15 50       15 if (!defined($self->_fh)) { $self->_open(); }
  0         0  
1413            
1414 15         36 my $md5 = $DIGEST_FUNC->($key);
1415              
1416             ##
1417             # Request shared lock for reading
1418             ##
1419 15         23 $self->lock( LOCK_SH );
1420            
1421 15         18 my $tag = $self->_find_bucket_list( $md5 );
1422 15 50       20 if (!$tag) {
1423 0         0 $self->unlock();
1424 0         0 return;
1425             }
1426            
1427             ##
1428             # Get value from bucket list
1429             ##
1430 15         24 my $result = $self->_get_bucket_value( $tag, $md5 );
1431            
1432 15         22 $self->unlock();
1433            
1434             #XXX What is ref() checking here?
1435             #YYY Filters only apply on scalar values, so the ref check is making
1436             #YYY sure the fetched bucket is a scalar, not a child hash or array.
1437             return ($result && !ref($result) && $self->_root->{filter_fetch_value})
1438 15 50 66     93 ? $self->_root->{filter_fetch_value}->($result)
1439             : $result;
1440             }
1441              
1442             sub DELETE {
1443             ##
1444             # Delete single key/value pair or element given plain key or array index
1445             ##
1446 0     0   0 my $self = $_[0]->_get_self;
1447 0         0 my $key = $_[1];
1448            
1449 0         0 my $md5 = $DIGEST_FUNC->($key);
1450              
1451             ##
1452             # Make sure file is open
1453             ##
1454 0 0       0 if (!defined($self->_fh)) { $self->_open(); }
  0         0  
1455            
1456             ##
1457             # Request exclusive lock for writing
1458             ##
1459 0         0 $self->lock( LOCK_EX );
1460            
1461 0         0 my $tag = $self->_find_bucket_list( $md5 );
1462 0 0       0 if (!$tag) {
1463 0         0 $self->unlock();
1464 0         0 return;
1465             }
1466            
1467             ##
1468             # Delete bucket
1469             ##
1470 0         0 my $value = $self->_get_bucket_value( $tag, $md5 );
1471 0 0 0     0 if ($value && !ref($value) && $self->_root->{filter_fetch_value}) {
      0        
1472 0         0 $value = $self->_root->{filter_fetch_value}->($value);
1473             }
1474              
1475 0         0 my $result = $self->_delete_bucket( $tag, $md5 );
1476            
1477             ##
1478             # If this object is an array and the key deleted was on the end of the stack,
1479             # decrement the length variable.
1480             ##
1481            
1482 0         0 $self->unlock();
1483            
1484 0         0 return $value;
1485             }
1486              
1487             sub EXISTS {
1488             ##
1489             # Check if a single key or element exists given plain key or array index
1490             ##
1491 5     5   8 my $self = $_[0]->_get_self;
1492 5         3 my $key = $_[1];
1493            
1494 5         14 my $md5 = $DIGEST_FUNC->($key);
1495              
1496             ##
1497             # Make sure file is open
1498             ##
1499 5 50       6 if (!defined($self->_fh)) { $self->_open(); }
  0         0  
1500            
1501             ##
1502             # Request shared lock for reading
1503             ##
1504 5         5 $self->lock( LOCK_SH );
1505            
1506 5         6 my $tag = $self->_find_bucket_list( $md5 );
1507            
1508             ##
1509             # For some reason, the built-in exists() function returns '' for false
1510             ##
1511 5 50       7 if (!$tag) {
1512 0         0 $self->unlock();
1513 0         0 return '';
1514             }
1515            
1516             ##
1517             # Check if bucket exists and return 1 or ''
1518             ##
1519 5   100     11 my $result = $self->_bucket_exists( $tag, $md5 ) || '';
1520            
1521 5         8 $self->unlock();
1522            
1523 5         12 return $result;
1524             }
1525              
1526             sub CLEAR {
1527             ##
1528             # Clear all keys from hash, or all elements from array.
1529             ##
1530 0     0   0 my $self = $_[0]->_get_self;
1531              
1532             ##
1533             # Make sure file is open
1534             ##
1535 0 0       0 if (!defined($self->_fh)) { $self->_open(); }
  0         0  
1536            
1537             ##
1538             # Request exclusive lock for writing
1539             ##
1540 0         0 $self->lock( LOCK_EX );
1541            
1542 0         0 my $fh = $self->_fh;
1543              
1544 0         0 seek($fh, $self->_base_offset + $self->_root->{file_offset}, SEEK_SET);
1545 0 0       0 if (eof $fh) {
1546 0         0 $self->unlock();
1547 0         0 return;
1548             }
1549            
1550 0         0 $self->_create_tag($self->_base_offset, $self->_type, chr(0) x $INDEX_SIZE);
1551            
1552 0         0 $self->unlock();
1553            
1554 0         0 return 1;
1555             }
1556              
1557             ##
1558             # Public method aliases
1559             ##
1560 0     0 1 0 sub put { (shift)->STORE( @_ ) }
1561 0     0 1 0 sub store { (shift)->STORE( @_ ) }
1562 0     0 1 0 sub get { (shift)->FETCH( @_ ) }
1563 0     0 1 0 sub fetch { (shift)->FETCH( @_ ) }
1564 0     0 1 0 sub delete { (shift)->DELETE( @_ ) }
1565 0     0 1 0 sub exists { (shift)->EXISTS( @_ ) }
1566 0     0 1 0 sub clear { (shift)->CLEAR( @_ ) }
1567              
1568             package Number::Phone::UK::DBM::Deep::_::Root;
1569              
1570             sub new {
1571 1     1   1 my $class = shift;
1572 1         1 my ($args) = @_;
1573              
1574 1         6 my $self = bless {
1575             file => undef,
1576             fh => undef,
1577             file_offset => 0,
1578             end => 0,
1579             autoflush => undef,
1580             locking => undef,
1581             debug => undef,
1582             filter_store_key => undef,
1583             filter_store_value => undef,
1584             filter_fetch_key => undef,
1585             filter_fetch_value => undef,
1586             autobless => undef,
1587             locked => 0,
1588             %$args,
1589             }, $class;
1590              
1591 1 50 33     10 if ( $self->{fh} && !$self->{file_offset} ) {
1592 1         2 $self->{file_offset} = tell( $self->{fh} );
1593             }
1594              
1595 1         2 return $self;
1596             }
1597              
1598             sub DESTROY {
1599 0     0     my $self = shift;
1600 0 0         return unless $self;
1601              
1602 0 0         close $self->{fh} if $self->{fh};
1603              
1604 0           return;
1605             }
1606              
1607             1;
1608              
1609             __END__