X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBM%2FDeep.pm;h=aa231793e928a6ea26c822958fd3482813ecfbdb;hb=fb451ba69d35e7acbd996e3de8c073f6ce76d7ea;hp=c66df2b6933abab05390bc6cbe992b573e6eafc1;hpb=1990c72d30c0a748a3eedbd903baaf78d94c2d34;p=dbsrgits%2FDBM-Deep.git diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index c66df2b..aa23179 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -37,7 +37,10 @@ use warnings; our $VERSION = q(0.99_03); use Fcntl qw( :DEFAULT :flock :seek ); + +use Clone::Any '_clone_data'; use Digest::MD5 (); +use FileHandle::Fmode (); use Scalar::Util (); use DBM::Deep::Engine; @@ -105,8 +108,8 @@ sub _init { my $class = shift; my ($args) = @_; - $args->{fileobj} = DBM::Deep::File->new( $args ) - unless exists $args->{fileobj}; + $args->{storage} = DBM::Deep::File->new( $args ) + unless exists $args->{storage}; # locking implicitly enables autoflush if ($args->{locking}) { $args->{autoflush} = 1; } @@ -119,7 +122,7 @@ sub _init { parent => undef, parent_key => undef, - fileobj => undef, + storage => undef, }, $class; $self->{engine} = DBM::Deep::Engine->new( { %{$args}, obj => $self } ); @@ -131,7 +134,7 @@ sub _init { $self->_engine->setup_fh( $self ); - $self->{fileobj}->set_db( $self ); + $self->_storage->set_db( $self ); return $self; } @@ -150,12 +153,12 @@ sub TIEARRAY { sub lock { my $self = shift->_get_self; - return $self->_fileobj->lock( $self, @_ ); + return $self->_storage->lock( $self, @_ ); } sub unlock { my $self = shift->_get_self; - return $self->_fileobj->unlock( $self, @_ ); + return $self->_storage->unlock( $self, @_ ); } sub _copy_value { @@ -232,9 +235,22 @@ sub import { $struct = $self->_repr( @_ ); } - return $self->_import( $struct ); + #XXX This isn't the best solution. Better would be to use Data::Walker, + #XXX but that's a lot more thinking than I want to do right now. + eval { + $self->begin_work; + $self->_import( _clone_data( $struct ) ); + $self->commit; + }; if ( $@ ) { + $self->rollback; + die $@; + } + + return 1; } +#XXX Need to keep track of who has a fh to this file in order to +#XXX close them all prior to optimize on Win32/cygwin sub optimize { ## # Rebuild entire database into new file, then move @@ -243,12 +259,14 @@ sub optimize { my $self = shift->_get_self; #XXX Need to create a new test for this -# if ($self->_fileobj->{links} > 1) { +# if ($self->_storage->{links} > 1) { # $self->_throw_error("Cannot optimize: reference count is greater than 1"); # } + #XXX Do we have to lock the tempfile? + my $db_temp = DBM::Deep->new( - file => $self->_fileobj->{file} . '.tmp', + file => $self->_storage->{file} . '.tmp', type => $self->_type ); @@ -263,8 +281,8 @@ sub optimize { my $perms = $stats[2] & 07777; my $uid = $stats[4]; my $gid = $stats[5]; - chown( $uid, $gid, $self->_fileobj->{file} . '.tmp' ); - chmod( $perms, $self->_fileobj->{file} . '.tmp' ); + chown( $uid, $gid, $self->_storage->{file} . '.tmp' ); + chmod( $perms, $self->_storage->{file} . '.tmp' ); # q.v. perlport for more information on this variable if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { @@ -275,18 +293,18 @@ sub optimize { # with a soft copy. ## $self->unlock(); - $self->_fileobj->close; + $self->_storage->close; } - if (!rename $self->_fileobj->{file} . '.tmp', $self->_fileobj->{file}) { - unlink $self->_fileobj->{file} . '.tmp'; + if (!rename $self->_storage->{file} . '.tmp', $self->_storage->{file}) { + unlink $self->_storage->{file} . '.tmp'; $self->unlock(); $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!"); } $self->unlock(); - $self->_fileobj->close; - $self->_fileobj->open; + $self->_storage->close; + $self->_storage->open; $self->_engine->setup_fh( $self ); return 1; @@ -299,9 +317,11 @@ sub clone { my $self = shift->_get_self; return DBM::Deep->new( - type => $self->_type, + type => $self->_type, base_offset => $self->_base_offset, - fileobj => $self->_fileobj, + storage => $self->_storage, + parent => $self->{parent}, + parent_key => $self->{parent_key}, ); } @@ -322,7 +342,7 @@ sub clone { my $func = shift; if ( $is_legal_filter{$type} ) { - $self->_fileobj->{"filter_$type"} = $func; + $self->_storage->{"filter_$type"} = $func; return 1; } @@ -332,20 +352,17 @@ sub clone { sub begin_work { my $self = shift->_get_self; - $self->_fileobj->begin_transaction; - return 1; + return $self->_storage->begin_transaction; } sub rollback { my $self = shift->_get_self; - $self->_fileobj->end_transaction; - return 1; + return $self->_storage->end_transaction; } sub commit { my $self = shift->_get_self; - $self->_fileobj->commit_transaction; - return 1; + return $self->_storage->commit_transaction; } ## @@ -357,9 +374,9 @@ sub _engine { return $self->{engine}; } -sub _fileobj { +sub _storage { my $self = $_[0]->_get_self; - return $self->{fileobj}; + return $self->{storage}; } sub _type { @@ -374,7 +391,7 @@ sub _base_offset { sub _fh { my $self = $_[0]->_get_self; - return $self->_fileobj->{fh}; + return $self->_storage->{fh}; } ## @@ -385,16 +402,6 @@ sub _throw_error { die "DBM::Deep: $_[1]\n"; } -sub _is_writable { - my $fh = shift; - (O_WRONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0); -} - -#sub _is_readable { -# my $fh = shift; -# (O_RDONLY | O_RDWR) & fcntl( $fh, F_GETFL, my $slush = 0); -#} - sub _find_parent { my $self = shift; @@ -428,14 +435,14 @@ sub STORE { ## my $self = shift->_get_self; my ($key, $value, $orig_key) = @_; + $orig_key = $key unless defined $orig_key; - - if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) { + if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } #XXX The second condition needs to disappear - if ( defined $orig_key && !( $self->_type eq TYPE_ARRAY && $orig_key eq 'length') ) { + if ( !( $self->_type eq TYPE_ARRAY && $orig_key eq 'length') ) { my $rhs; my $r = Scalar::Util::reftype( $value ) || ''; @@ -471,7 +478,7 @@ sub STORE { $lhs = "\$db->put(q{$orig_key},$rhs);"; } - $self->_fileobj->audit($lhs); + $self->_storage->audit($lhs); } ## @@ -479,20 +486,13 @@ sub STORE { ## $self->lock( LOCK_EX ); - my $md5 = $self->_engine->{digest}->($key); - - my $tag = $self->_engine->find_blist( $self->_base_offset, $md5, { create => 1 } ); - - # User may be storing a hash, in which case we do not want it run - # through the filtering system - if ( !ref($value) && $self->_fileobj->{filter_store_value} ) { - $value = $self->_fileobj->{filter_store_value}->( $value ); + # User may be storing a complex value, in which case we do not want it run + # through the filtering system. + if ( !ref($value) && $self->_storage->{filter_store_value} ) { + $value = $self->_storage->{filter_store_value}->( $value ); } - ## - # Add key/value to bucket list - ## - $self->_engine->add_bucket( $tag, $md5, $key, $value, undef, $orig_key ); + $self->_engine->write_value( $self->_base_offset, $key, $value, $orig_key ); $self->unlock(); @@ -505,32 +505,21 @@ sub FETCH { ## my $self = shift->_get_self; my ($key, $orig_key) = @_; - - my $md5 = $self->_engine->{digest}->($key); + $orig_key = $key unless defined $orig_key; ## # Request shared lock for reading ## $self->lock( LOCK_SH ); - my $tag = $self->_engine->find_blist( $self->_base_offset, $md5 );#, { create => 1 } ); - #XXX This needs to autovivify - if (!$tag) { - $self->unlock(); - return; - } - - ## - # Get value from bucket list - ## - my $result = $self->_engine->get_bucket_value( $tag, $md5, $orig_key ); + my $result = $self->_engine->read_value( $self->_base_offset, $key, $orig_key ); $self->unlock(); # Filters only apply to scalar values, so the ref check is making # sure the fetched bucket is a scalar, not a child hash or array. - return ($result && !ref($result) && $self->_fileobj->{filter_fetch_value}) - ? $self->_fileobj->{filter_fetch_value}->($result) + return ($result && !ref($result) && $self->_storage->{filter_fetch_value}) + ? $self->_storage->{filter_fetch_value}->($result) : $result; } @@ -540,18 +529,19 @@ sub DELETE { ## my $self = shift->_get_self; my ($key, $orig_key) = @_; + $orig_key = $key unless defined $orig_key; - if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) { + if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } if ( defined $orig_key ) { my $lhs = $self->_find_parent; if ( $lhs ) { - $self->_fileobj->audit( "delete $lhs;" ); + $self->_storage->audit( "delete $lhs;" ); } else { - $self->_fileobj->audit( "\$db->delete('$orig_key');" ); + $self->_storage->audit( "\$db->delete('$orig_key');" ); } } @@ -560,30 +550,15 @@ sub DELETE { ## $self->lock( LOCK_EX ); - my $md5 = $self->_engine->{digest}->($key); - - my $tag = $self->_engine->find_blist( $self->_base_offset, $md5 ); - if (!$tag) { - $self->unlock(); - return; - } - ## # Delete bucket ## - my $value = $self->_engine->get_bucket_value( $tag, $md5 ); + my $value = $self->_engine->delete_key( $self->_base_offset, $key, $orig_key ); - if (defined $value && !ref($value) && $self->_fileobj->{filter_fetch_value}) { - $value = $self->_fileobj->{filter_fetch_value}->($value); + if (defined $value && !ref($value) && $self->_storage->{filter_fetch_value}) { + $value = $self->_storage->{filter_fetch_value}->($value); } - my $result = $self->_engine->delete_bucket( $tag, $md5, $orig_key ); - - ## - # If this object is an array and the key deleted was on the end of the stack, - # decrement the length variable. - ## - $self->unlock(); return $value; @@ -596,27 +571,12 @@ sub EXISTS { my $self = shift->_get_self; my ($key) = @_; - my $md5 = $self->_engine->{digest}->($key); - ## # Request shared lock for reading ## $self->lock( LOCK_SH ); - my $tag = $self->_engine->find_blist( $self->_base_offset, $md5 ); - if (!$tag) { - $self->unlock(); - - ## - # For some reason, the built-in exists() function returns '' for false - ## - return ''; - } - - ## - # Check if bucket exists and return 1 or '' - ## - my $result = $self->_engine->bucket_exists( $tag, $md5 ) || ''; + my $result = $self->_engine->key_exists( $self->_base_offset, $key ); $self->unlock(); @@ -629,7 +589,7 @@ sub CLEAR { ## my $self = shift->_get_self; - if ( $^O ne 'MSWin32' && !_is_writable( $self->_fh ) ) { + if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } @@ -643,7 +603,7 @@ sub CLEAR { $lhs = '@{' . $lhs . '}'; } - $self->_fileobj->audit( "$lhs = ();" ); + $self->_storage->audit( "$lhs = ();" ); } ## @@ -654,19 +614,16 @@ sub CLEAR { if ( $self->_type eq TYPE_HASH ) { my $key = $self->first_key; while ( $key ) { + # Retrieve the key before deleting because we depend on next_key my $next_key = $self->next_key( $key ); - my $md5 = $self->_engine->{digest}->($key); - my $tag = $self->_engine->find_blist( $self->_base_offset, $md5 ); - $self->_engine->delete_bucket( $tag, $md5, $key ); + $self->_engine->delete_key( $self->_base_offset, $key, $key ); $key = $next_key; } } else { my $size = $self->FETCHSIZE; - for my $key ( map { pack ( $self->_engine->{long_pack}, $_ ) } 0 .. $size - 1 ) { - my $md5 = $self->_engine->{digest}->($key); - my $tag = $self->_engine->find_blist( $self->_base_offset, $md5 ); - $self->_engine->delete_bucket( $tag, $md5, $key ); + for my $key ( 0 .. $size - 1 ) { + $self->_engine->delete_key( $self->_base_offset, $key, $key ); } $self->STORESIZE( 0 ); } @@ -750,7 +707,7 @@ Perl's tie() function. Both are examined here. The recommended way to construct a DBM::Deep object is to use the new() method, which gets you a blessed I tied hash (or array) reference. - my $db = DBM::Deep->new( "foo.db" ); + my $db = DBM::Deep->new( "foo.db" ); This opens a new database handle, mapped to the file "foo.db". If this file does not exist, it will automatically be created. DB files are @@ -760,11 +717,11 @@ hash, unless otherwise specified (see L below). You can pass a number of options to the constructor to specify things like locking, autoflush, etc. This is done by passing an inline hash (or hashref): - my $db = DBM::Deep->new( - file => "foo.db", - locking => 1, - autoflush => 1 - ); + my $db = DBM::Deep->new( + file => "foo.db", + locking => 1, + autoflush => 1 + ); Notice that the filename is now specified I the hash with the "file" parameter, as opposed to being the sole argument to the @@ -774,10 +731,10 @@ See L below for the complete list. You can also start with an array instead of a hash. For this, you must specify the C parameter: - my $db = DBM::Deep->new( - file => "foo.db", - type => DBM::Deep->TYPE_ARRAY - ); + my $db = DBM::Deep->new( + file => "foo.db", + type => DBM::Deep->TYPE_ARRAY + ); B Specifing the C parameter only takes effect when beginning a new DB file. If you create a DBM::Deep object with an existing file, the @@ -791,21 +748,21 @@ tie() function. The object returned from tie() can be used to call methods, such as lock() and unlock(). (That object can be retrieved from the tied variable at any time using tied() - please see L for more info. - my %hash; - my $db = tie %hash, "DBM::Deep", "foo.db"; + my %hash; + my $db = tie %hash, "DBM::Deep", "foo.db"; - my @array; - my $db = tie @array, "DBM::Deep", "bar.db"; + my @array; + my $db = tie @array, "DBM::Deep", "bar.db"; As with the OO constructor, you can replace the DB filename parameter with a hash containing one or more options (see L just below for the complete list). - tie %hash, "DBM::Deep", { - file => "foo.db", - locking => 1, - autoflush => 1 - }; + tie %hash, "DBM::Deep", { + file => "foo.db", + locking => 1, + autoflush => 1 + }; =head2 OPTIONS @@ -907,19 +864,19 @@ to access your databases. You can treat any DBM::Deep object like a normal Perl hash reference. Add keys, or even nested hashes (or arrays) using standard Perl syntax: - my $db = DBM::Deep->new( "foo.db" ); + my $db = DBM::Deep->new( "foo.db" ); - $db->{mykey} = "myvalue"; - $db->{myhash} = {}; - $db->{myhash}->{subkey} = "subvalue"; + $db->{mykey} = "myvalue"; + $db->{myhash} = {}; + $db->{myhash}->{subkey} = "subvalue"; - print $db->{myhash}->{subkey} . "\n"; + print $db->{myhash}->{subkey} . "\n"; You can even step through hash keys using the normal Perl C function: - foreach my $key (keys %$db) { - print "$key: " . $db->{$key} . "\n"; - } + foreach my $key (keys %$db) { + print "$key: " . $db->{$key} . "\n"; + } Remember that Perl's C function extracts I key from the hash and pushes them onto an array, all before the loop even begins. If you have an @@ -927,15 +884,15 @@ extremely large hash, this may exhaust Perl's memory. Instead, consider using Perl's C function, which pulls keys/values one at a time, using very little memory: - while (my ($key, $value) = each %$db) { - print "$key: $value\n"; - } + while (my ($key, $value) = each %$db) { + print "$key: $value\n"; + } Please note that when using C, you should always pass a direct hash reference, not a lookup. Meaning, you should B do this: - # NEVER DO THIS - while (my ($key, $value) = each %{$db->{foo}}) { # BAD + # NEVER DO THIS + while (my ($key, $value) = each %{$db->{foo}}) { # BAD This causes an infinite loop, because for each iteration, Perl is calling FETCH() on the $db handle, resulting in a "new" hash for foo every time, so @@ -950,20 +907,20 @@ and the C, C, C, C and C functions. The object must have first been created using type CTYPE_ARRAY>, or simply be a nested array reference inside a hash. Example: - my $db = DBM::Deep->new( - file => "foo-array.db", - type => DBM::Deep->TYPE_ARRAY - ); + my $db = DBM::Deep->new( + file => "foo-array.db", + type => DBM::Deep->TYPE_ARRAY + ); - $db->[0] = "foo"; - push @$db, "bar", "baz"; - unshift @$db, "bah"; + $db->[0] = "foo"; + push @$db, "bar", "baz"; + unshift @$db, "bah"; - my $last_elem = pop @$db; # baz - my $first_elem = shift @$db; # bah - my $second_elem = $db->[1]; # bar + my $last_elem = pop @$db; # baz + my $first_elem = shift @$db; # bah + my $second_elem = $db->[1]; # bar - my $num_elements = scalar @$db; + my $num_elements = scalar @$db; =head1 OO INTERFACE @@ -985,8 +942,8 @@ Stores a new hash key/value pair, or sets an array element value. Takes two arguments, the hash key or array index, and the new value. The value can be a scalar, hash ref or array ref. Returns true on success, false on failure. - $db->put("foo", "bar"); # for hashes - $db->put(1, "bar"); # for arrays + $db->put("foo", "bar"); # for hashes + $db->put(1, "bar"); # for arrays =item * get() / fetch() @@ -994,16 +951,16 @@ Fetches the value of a hash key or array element. Takes one argument: the hash key or array index. Returns a scalar, hash ref or array ref, depending on the data type stored. - my $value = $db->get("foo"); # for hashes - my $value = $db->get(1); # for arrays + my $value = $db->get("foo"); # for hashes + my $value = $db->get(1); # for arrays =item * exists() Checks if a hash key or array index exists. Takes one argument: the hash key or array index. Returns true if it exists, false if not. - if ($db->exists("foo")) { print "yay!\n"; } # for hashes - if ($db->exists(1)) { print "yay!\n"; } # for arrays + if ($db->exists("foo")) { print "yay!\n"; } # for hashes + if ($db->exists(1)) { print "yay!\n"; } # for arrays =item * delete() @@ -1015,8 +972,8 @@ internal arrays work. Please note that the space occupied by the deleted key/value or element is B reused again -- see L below for details and workarounds. - $db->delete("foo"); # for hashes - $db->delete(1); # for arrays + $db->delete("foo"); # for hashes + $db->delete(1); # for arrays =item * clear() @@ -1025,7 +982,7 @@ value. Please note that the space occupied by the deleted keys/values or elements is B reused again -- see L below for details and workarounds. - $db->clear(); # hashes or arrays + $db->clear(); # hashes or arrays =item * lock() / unlock() @@ -1055,35 +1012,35 @@ Returns the "first" key in the hash. As with built-in Perl hashes, keys are fetched in an undefined order (which appears random). Takes no arguments, returns the key as a scalar value. - my $key = $db->first_key(); + my $key = $db->first_key(); =item * next_key() Returns the "next" key in the hash, given the previous one as the sole argument. Returns undef if there are no more keys to be fetched. - $key = $db->next_key($key); + $key = $db->next_key($key); =back Here are some examples of using hashes: - my $db = DBM::Deep->new( "foo.db" ); + my $db = DBM::Deep->new( "foo.db" ); - $db->put("foo", "bar"); - print "foo: " . $db->get("foo") . "\n"; + $db->put("foo", "bar"); + print "foo: " . $db->get("foo") . "\n"; - $db->put("baz", {}); # new child hash ref - $db->get("baz")->put("buz", "biz"); - print "buz: " . $db->get("baz")->get("buz") . "\n"; + $db->put("baz", {}); # new child hash ref + $db->get("baz")->put("buz", "biz"); + print "buz: " . $db->get("baz")->get("buz") . "\n"; - my $key = $db->first_key(); - while ($key) { - print "$key: " . $db->get($key) . "\n"; - $key = $db->next_key($key); - } + my $key = $db->first_key(); + while ($key) { + print "$key: " . $db->get($key) . "\n"; + $key = $db->next_key($key); + } - if ($db->exists("foo")) { $db->delete("foo"); } + if ($db->exists("foo")) { $db->delete("foo"); } =head2 ARRAYS @@ -1097,21 +1054,21 @@ C and C. Returns the number of elements in the array. Takes no arguments. - my $len = $db->length(); + my $len = $db->length(); =item * push() Adds one or more elements onto the end of the array. Accepts scalars, hash refs or array refs. No return value. - $db->push("foo", "bar", {}); + $db->push("foo", "bar", {}); =item * pop() Fetches the last element in the array, and deletes it. Takes no arguments. Returns undef if array is empty. Returns the element value. - my $elem = $db->pop(); + my $elem = $db->pop(); =item * shift() @@ -1120,7 +1077,7 @@ remaining elements over to take up the space. Returns the element value. This method is not recommended with large arrays -- see L below for details. - my $elem = $db->shift(); + my $elem = $db->shift(); =item * unshift() @@ -1129,7 +1086,7 @@ existing elements over to make room. Accepts scalars, hash refs or array refs. No return value. This method is not recommended with large arrays -- see below for details. - $db->unshift("foo", "bar", {}); + $db->unshift("foo", "bar", {}); =item * splice() @@ -1141,37 +1098,37 @@ not recommended with large arrays -- see L below for details. Here are some examples of using arrays: - my $db = DBM::Deep->new( - file => "foo.db", - type => DBM::Deep->TYPE_ARRAY - ); + my $db = DBM::Deep->new( + file => "foo.db", + type => DBM::Deep->TYPE_ARRAY + ); - $db->push("bar", "baz"); - $db->unshift("foo"); - $db->put(3, "buz"); + $db->push("bar", "baz"); + $db->unshift("foo"); + $db->put(3, "buz"); - my $len = $db->length(); - print "length: $len\n"; # 4 + my $len = $db->length(); + print "length: $len\n"; # 4 - for (my $k=0; $k<$len; $k++) { - print "$k: " . $db->get($k) . "\n"; - } + for (my $k=0; $k<$len; $k++) { + print "$k: " . $db->get($k) . "\n"; + } - $db->splice(1, 2, "biz", "baf"); + $db->splice(1, 2, "biz", "baf"); - while (my $elem = shift @$db) { - print "shifted: $elem\n"; - } + while (my $elem = shift @$db) { + print "shifted: $elem\n"; + } =head1 LOCKING Enable automatic file locking by passing a true value to the C parameter when constructing your DBM::Deep object (see L above). - my $db = DBM::Deep->new( - file => "foo.db", - locking => 1 - ); + my $db = DBM::Deep->new( + file => "foo.db", + locking => 1 + ); This causes DBM::Deep to C the underlying filehandle with exclusive mode for writes, and shared mode for reads. This is required if you have @@ -1187,17 +1144,17 @@ optional lock mode argument (defaults to exclusive mode). This is particularly useful for things like counters, where the current value needs to be fetched, then incremented, then stored again. - $db->lock(); - my $counter = $db->get("counter"); - $counter++; - $db->put("counter", $counter); - $db->unlock(); + $db->lock(); + my $counter = $db->get("counter"); + $counter++; + $db->put("counter", $counter); + $db->unlock(); - # or... + # or... - $db->lock(); - $db->{counter}++; - $db->unlock(); + $db->lock(); + $db->{counter}++; + $db->unlock(); You can pass C an optional argument, which specifies which mode to use (exclusive or shared). Use one of these two constants: @@ -1205,9 +1162,9 @@ CLOCK_EX> or CLOCK_SH>. These are passed directly to C, and are the same as the constants defined in Perl's L module. - $db->lock( $db->LOCK_SH ); - # something here - $db->unlock(); + $db->lock( $db->LOCK_SH ); + # something here + $db->unlock(); =head1 IMPORTING/EXPORTING @@ -1222,20 +1179,20 @@ walking the structure and adding keys/elements to the database as you go, simply pass a reference to the C method. This recursively adds everything to an existing DBM::Deep object for you. Here is an example: - my $struct = { - key1 => "value1", - key2 => "value2", - array1 => [ "elem0", "elem1", "elem2" ], - hash1 => { - subkey1 => "subvalue1", - subkey2 => "subvalue2" - } - }; + my $struct = { + key1 => "value1", + key2 => "value2", + array1 => [ "elem0", "elem1", "elem2" ], + hash1 => { + subkey1 => "subvalue1", + subkey2 => "subvalue2" + } + }; - my $db = DBM::Deep->new( "foo.db" ); - $db->import( $struct ); + my $db = DBM::Deep->new( "foo.db" ); + $db->import( $struct ); - print $db->{key1} . "\n"; # prints "value1" + print $db->{key1} . "\n"; # prints "value1" This recursively imports the entire C<$struct> object into C<$db>, including all nested hashes and arrays. If the DBM::Deep object contains exsiting data, @@ -1254,17 +1211,17 @@ a reference to a new in-memory copy of the database. The export is done recursively, so all nested hashes/arrays are all exported to standard Perl objects. Here is an example: - my $db = DBM::Deep->new( "foo.db" ); + my $db = DBM::Deep->new( "foo.db" ); - $db->{key1} = "value1"; - $db->{key2} = "value2"; - $db->{hash1} = {}; - $db->{hash1}->{subkey1} = "subvalue1"; - $db->{hash1}->{subkey2} = "subvalue2"; + $db->{key1} = "value1"; + $db->{key2} = "value2"; + $db->{hash1} = {}; + $db->{hash1}->{subkey1} = "subvalue1"; + $db->{hash1}->{subkey2} = "subvalue2"; - my $struct = $db->export(); + my $struct = $db->export(); - print $struct->{key1} . "\n"; # prints "value1" + print $struct->{key1} . "\n"; # prints "value1" This makes a complete copy of the database in memory, and returns a reference to it. The C method can be called on any database level (not just @@ -1313,16 +1270,16 @@ It is passed the transformed value, and expected to return the plain value. Here are the two ways to setup a filter hook: - my $db = DBM::Deep->new( - file => "foo.db", - filter_store_value => \&my_filter_store, - filter_fetch_value => \&my_filter_fetch - ); + my $db = DBM::Deep->new( + file => "foo.db", + filter_store_value => \&my_filter_store, + filter_fetch_value => \&my_filter_fetch + ); - # or... + # or... - $db->set_filter( "filter_store_value", \&my_filter_store ); - $db->set_filter( "filter_fetch_value", \&my_filter_fetch ); + $db->set_filter( "filter_store_value", \&my_filter_store ); + $db->set_filter( "filter_fetch_value", \&my_filter_fetch ); Your filter function will be called only when dealing with SCALAR keys or values. When nested hashes and arrays are being stored/fetched, filtering @@ -1330,7 +1287,7 @@ is bypassed. Filters are called as static functions, passed a single SCALAR argument, and expected to return a single SCALAR value. If you want to remove a filter, set the function reference to C: - $db->set_filter( "filter_store_value", undef ); + $db->set_filter( "filter_store_value", undef ); =head2 REAL-TIME ENCRYPTION EXAMPLE @@ -1339,41 +1296,41 @@ do real-time encryption / decryption of keys & values with DBM::Deep Filters. Please visit L for more on I. You'll also need the I module. - use DBM::Deep; - use Crypt::Blowfish; - use Crypt::CBC; - - my $cipher = Crypt::CBC->new({ - 'key' => 'my secret key', - 'cipher' => 'Blowfish', - 'iv' => '$KJh#(}q', - 'regenerate_key' => 0, - 'padding' => 'space', - 'prepend_iv' => 0 - }); - - my $db = DBM::Deep->new( - file => "foo-encrypt.db", - filter_store_key => \&my_encrypt, - filter_store_value => \&my_encrypt, - filter_fetch_key => \&my_decrypt, - filter_fetch_value => \&my_decrypt, - ); - - $db->{key1} = "value1"; - $db->{key2} = "value2"; - print "key1: " . $db->{key1} . "\n"; - print "key2: " . $db->{key2} . "\n"; - - undef $db; - exit; - - sub my_encrypt { - return $cipher->encrypt( $_[0] ); - } - sub my_decrypt { - return $cipher->decrypt( $_[0] ); - } + use DBM::Deep; + use Crypt::Blowfish; + use Crypt::CBC; + + my $cipher = Crypt::CBC->new({ + 'key' => 'my secret key', + 'cipher' => 'Blowfish', + 'iv' => '$KJh#(}q', + 'regenerate_key' => 0, + 'padding' => 'space', + 'prepend_iv' => 0 + }); + + my $db = DBM::Deep->new( + file => "foo-encrypt.db", + filter_store_key => \&my_encrypt, + filter_store_value => \&my_encrypt, + filter_fetch_key => \&my_decrypt, + filter_fetch_value => \&my_decrypt, + ); + + $db->{key1} = "value1"; + $db->{key2} = "value2"; + print "key1: " . $db->{key1} . "\n"; + print "key2: " . $db->{key2} . "\n"; + + undef $db; + exit; + + sub my_encrypt { + return $cipher->encrypt( $_[0] ); + } + sub my_decrypt { + return $cipher->decrypt( $_[0] ); + } =head2 REAL-TIME COMPRESSION EXAMPLE @@ -1382,31 +1339,31 @@ compression / decompression of keys & values with DBM::Deep Filters. Please visit L for more on I. - use DBM::Deep; - use Compress::Zlib; - - my $db = DBM::Deep->new( - file => "foo-compress.db", - filter_store_key => \&my_compress, - filter_store_value => \&my_compress, - filter_fetch_key => \&my_decompress, - filter_fetch_value => \&my_decompress, - ); - - $db->{key1} = "value1"; - $db->{key2} = "value2"; - print "key1: " . $db->{key1} . "\n"; - print "key2: " . $db->{key2} . "\n"; - - undef $db; - exit; - - sub my_compress { - return Compress::Zlib::memGzip( $_[0] ) ; - } - sub my_decompress { - return Compress::Zlib::memGunzip( $_[0] ) ; - } + use DBM::Deep; + use Compress::Zlib; + + my $db = DBM::Deep->new( + file => "foo-compress.db", + filter_store_key => \&my_compress, + filter_store_value => \&my_compress, + filter_fetch_key => \&my_decompress, + filter_fetch_value => \&my_decompress, + ); + + $db->{key1} = "value1"; + $db->{key2} = "value2"; + print "key1: " . $db->{key1} . "\n"; + print "key2: " . $db->{key2} . "\n"; + + undef $db; + exit; + + sub my_compress { + return Compress::Zlib::memGzip( $_[0] ) ; + } + sub my_decompress { + return Compress::Zlib::memGunzip( $_[0] ) ; + } B Filtering of keys only applies to hashes. Array "keys" are actually numerical index numbers, and are not filtered. @@ -1416,10 +1373,10 @@ actually numerical index numbers, and are not filtered. Most DBM::Deep methods return a true value for success, and call die() on failure. You can wrap calls in an eval block to catch the die. - my $db = DBM::Deep->new( "foo.db" ); # create hash - eval { $db->push("foo"); }; # ILLEGAL -- push is array-only call + my $db = DBM::Deep->new( "foo.db" ); # create hash + eval { $db->push("foo"); }; # ILLEGAL -- push is array-only call - print $@; # prints error message + print $@; # prints error message =head1 LARGEFILE SUPPORT @@ -1428,10 +1385,10 @@ and 64-bit support, you I be able to create databases larger than 2 GB. DBM::Deep by default uses 32-bit file offset tags, but these can be changed by specifying the 'pack_size' parameter when constructing the file. - DBM::Deep->new( - filename => $filename, - pack_size => 'large', - ); + DBM::Deep->new( + filename => $filename, + pack_size => 'large', + ); This tells DBM::Deep to pack all file offsets with 8-byte (64-bit) quad words instead of 32-bit longs. After setting these values your DB files have a @@ -1455,15 +1412,15 @@ this does indeed work! If you require low-level access to the underlying filehandle that DBM::Deep uses, you can call the C<_fh()> method, which returns the handle: - my $fh = $db->_fh(); + my $fh = $db->_fh(); This method can be called on the root level of the datbase, or any child hashes or arrays. All levels share a I structure, which contains things like the filehandle, a reference counter, and all the options specified when you created the object. You can get access to this file object by -calling the C<_fileobj()> method. +calling the C<_storage()> method. - my $file_obj = $db->_fileobj(); + my $file_obj = $db->_storage(); This is useful for changing options after the object has already been created, such as enabling/disabling locking. You can also store your own temporary user @@ -1485,28 +1442,28 @@ parameter. Here is a working example that uses a 256-bit hash from the I module. Please see L for more information. - use DBM::Deep; - use Digest::SHA256; + use DBM::Deep; + use Digest::SHA256; - my $context = Digest::SHA256::new(256); + my $context = Digest::SHA256::new(256); - my $db = DBM::Deep->new( - filename => "foo-sha.db", - digest => \&my_digest, - hash_size => 32, - ); + my $db = DBM::Deep->new( + filename => "foo-sha.db", + digest => \&my_digest, + hash_size => 32, + ); - $db->{key1} = "value1"; - $db->{key2} = "value2"; - print "key1: " . $db->{key1} . "\n"; - print "key2: " . $db->{key2} . "\n"; + $db->{key1} = "value1"; + $db->{key2} = "value2"; + print "key1: " . $db->{key1} . "\n"; + print "key2: " . $db->{key2} . "\n"; - undef $db; - exit; + undef $db; + exit; - sub my_digest { - return substr( $context->hash($_[0]), 0, 32 ); - } + sub my_digest { + return substr( $context->hash($_[0]), 0, 32 ); + } B Your returned digest strings must be B the number of bytes you specify in the hash_size parameter (in this case 32). @@ -1521,13 +1478,13 @@ can have a nested hash key or array element that points to a parent object. This relationship is stored in the DB file, and is preserved between sessions. Here is an example: - my $db = DBM::Deep->new( "foo.db" ); + my $db = DBM::Deep->new( "foo.db" ); - $db->{foo} = "bar"; - $db->{circle} = $db; # ref to self + $db->{foo} = "bar"; + $db->{circle} = $db; # ref to self - print $db->{foo} . "\n"; # prints "bar" - print $db->{circle}->{foo} . "\n"; # prints "bar" again + print $db->{foo} . "\n"; # prints "bar" + print $db->{circle}->{foo} . "\n"; # prints "bar" again B: Passing the object to a function that recursively walks the object tree (such as I or even the built-in C or @@ -1582,7 +1539,7 @@ and adding new keys, your file will continuously grow. I am working on this, but in the meantime you can call the built-in C method from time to time (perhaps in a crontab or something) to recover all your unused space. - $db->optimize(); # returns true on success + $db->optimize(); # returns true on success This rebuilds the ENTIRE database into a new file, then moves it on top of the original. The new file will have no unused space, thus it will take up as @@ -1673,7 +1630,7 @@ Beware of copying tied objects in Perl. Very strange things can happen. Instead, use DBM::Deep's C method which safely copies the object and returns a new, blessed, tied hash or array to the same level in the DB. - my $copy = $db->clone(); + my $copy = $db->clone(); B: Since clone() here is cloning the object, not the database location, any modifications to either $db or $copy will be visible to both.