7 # Multi-level database module for storing hash trees, arrays and simple
8 # key/value pairs into FTP-able, cross-platform binary database files.
10 # Type `perldoc DBM::Deep` for complete documentation.
14 # tie %db, 'DBM::Deep', 'my_database.db'; # standard tie() method
16 # my $db = new DBM::Deep( 'my_database.db' ); # preferred OO method
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";
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.
37 our $VERSION = q(0.99_03);
39 use Fcntl qw( :flock );
41 use Clone::Any '_clone_data';
43 use FileHandle::Fmode ();
46 use DBM::Deep::Engine;
50 # Setup constants for users to pass to new()
52 sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH }
53 sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY }
55 # This is used in all the children of this class in their TIE<type> methods.
62 $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] );
67 unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) {
68 $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] );
73 $args = { file => shift };
81 # Class constructor method for Perl OO interface.
82 # Calls tie() and returns blessed reference to tied hash or array,
83 # providing a hybrid OO/tie interface.
86 my $args = $class->_get_args( @_ );
89 # Check if we want a tied hash or array.
92 if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
93 $class = 'DBM::Deep::Array';
94 require DBM::Deep::Array;
95 tie @$self, $class, %$args;
98 $class = 'DBM::Deep::Hash';
99 require DBM::Deep::Hash;
100 tie %$self, $class, %$args;
103 return bless $self, $class;
106 # This initializer is called from the various TIE* methods. new() calls tie(),
107 # which allows for a single point of entry.
112 $args->{storage} = DBM::Deep::File->new( $args )
113 unless exists $args->{storage};
115 # locking implicitly enables autoflush
116 if ($args->{locking}) { $args->{autoflush} = 1; }
118 # These are the defaults to be optionally overridden below
121 base_offset => undef,
128 $args->{engine} = DBM::Deep::Engine->new( { %{$args}, obj => $self } )
129 unless exists $args->{engine};
131 # Grab the parameters we want to use
132 foreach my $param ( keys %$self ) {
133 next unless exists $args->{$param};
134 $self->{$param} = $args->{$param};
138 local $SIG{'__DIE__'};
141 $self->_engine->setup_fh( $self );
142 $self->_storage->set_inode;
146 eval { local $SIG{'__DIE__'}; $self->unlock; };
155 require DBM::Deep::Hash;
156 return DBM::Deep::Hash->TIEHASH( @_ );
161 require DBM::Deep::Array;
162 return DBM::Deep::Array->TIEARRAY( @_ );
166 my $self = shift->_get_self;
167 return $self->_storage->lock( $self, @_ );
171 my $self = shift->_get_self;
172 return $self->_storage->unlock( $self, @_ );
176 my $self = shift->_get_self;
177 my ($spot, $value) = @_;
182 elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep' ) } ) {
183 ${$spot} = $value->_repr;
184 $value->_copy_node( ${$spot} );
187 my $r = Scalar::Util::reftype( $value );
188 my $c = Scalar::Util::blessed( $value );
189 if ( $r eq 'ARRAY' ) {
190 ${$spot} = [ @{$value} ];
193 ${$spot} = { %{$value} };
195 ${$spot} = bless ${$spot}, $c
203 # die "Must be implemented in a child class\n";
207 # die "Must be implemented in a child class\n";
212 # Recursively export into standard Perl hashes and arrays.
214 my $self = shift->_get_self;
216 my $temp = $self->_repr;
219 $self->_copy_node( $temp );
222 my $classname = $self->_engine->get_classname( $self );
223 if ( defined $classname ) {
224 bless $temp, $classname;
232 # Recursively import Perl hash/array structure
234 if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
236 my $self = shift->_get_self;
239 # struct is not a reference, so just import based on our type
241 $struct = $self->_repr( @_ );
244 #XXX This isn't the best solution. Better would be to use Data::Walker,
245 #XXX but that's a lot more thinking than I want to do right now.
247 local $SIG{'__DIE__'};
249 $self->_import( _clone_data( $struct ) );
251 }; if ( my $e = $@ ) {
259 #XXX Need to keep track of who has a fh to this file in order to
260 #XXX close them all prior to optimize on Win32/cygwin
263 # Rebuild entire database into new file, then move
264 # it back on top of original.
266 my $self = shift->_get_self;
268 #XXX Need to create a new test for this
269 # if ($self->_storage->{links} > 1) {
270 # $self->_throw_error("Cannot optimize: reference count is greater than 1");
273 #XXX Do we have to lock the tempfile?
275 my $db_temp = DBM::Deep->new(
276 file => $self->_storage->{file} . '.tmp',
277 type => $self->_type,
279 # Bring over all the parameters that we need to bring over
280 num_txns => $self->_engine->num_txns,
281 byte_size => $self->_engine->byte_size,
282 max_buckets => $self->_engine->max_buckets,
286 $self->_copy_node( $db_temp );
290 # Attempt to copy user, group and permissions over to new file
292 my @stats = stat($self->_fh);
293 my $perms = $stats[2] & 07777;
296 chown( $uid, $gid, $self->_storage->{file} . '.tmp' );
297 chmod( $perms, $self->_storage->{file} . '.tmp' );
299 # q.v. perlport for more information on this variable
300 if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
302 # Potential race condition when optmizing on Win32 with locking.
303 # The Windows filesystem requires that the filehandle be closed
304 # before it is overwritten with rename(). This could be redone
308 $self->_storage->close;
311 if (!rename $self->_storage->{file} . '.tmp', $self->_storage->{file}) {
312 unlink $self->_storage->{file} . '.tmp';
314 $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
318 $self->_storage->close;
320 $self->_storage->open;
322 $self->_engine->setup_fh( $self );
330 # Make copy of object and return
332 my $self = shift->_get_self;
334 return DBM::Deep->new(
335 type => $self->_type,
336 base_offset => $self->_base_offset,
337 staleness => $self->_staleness,
338 storage => $self->_storage,
339 engine => $self->_engine,
343 #XXX Migrate this to the engine, where it really belongs and go through some
344 # API - stop poking in the innards of someone else..
346 my %is_legal_filter = map {
349 store_key store_value
350 fetch_key fetch_value
355 # Setup filter function for storing or fetching the key or value
357 my $self = shift->_get_self;
361 if ( $is_legal_filter{$type} ) {
362 $self->_storage->{"filter_$type"} = $func;
371 my $self = shift->_get_self;
372 return $self->_engine->begin_work( $self, @_ );
376 my $self = shift->_get_self;
377 return $self->_engine->rollback( $self, @_ );
381 my $self = shift->_get_self;
382 return $self->_engine->commit( $self, @_ );
390 my $self = $_[0]->_get_self;
391 return $self->{engine};
395 my $self = $_[0]->_get_self;
396 return $self->{storage};
400 my $self = $_[0]->_get_self;
401 return $self->{type};
405 my $self = $_[0]->_get_self;
406 return $self->{base_offset};
410 my $self = $_[0]->_get_self;
411 return $self->{staleness};
415 my $self = $_[0]->_get_self;
416 return $self->_storage->{fh};
424 die "DBM::Deep: $_[1]\n";
429 # Store single hash key/value or array element in database.
431 my $self = shift->_get_self;
432 my ($key, $value) = @_;
434 if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
435 $self->_throw_error( 'Cannot write to a readonly filehandle' );
439 # Request exclusive lock for writing
441 $self->lock( LOCK_EX );
443 # User may be storing a complex value, in which case we do not want it run
444 # through the filtering system.
445 if ( !ref($value) && $self->_storage->{filter_store_value} ) {
446 $value = $self->_storage->{filter_store_value}->( $value );
449 $self->_engine->write_value( $self, $key, $value);
458 # Fetch single value or element given plain key or array index
460 my $self = shift->_get_self;
464 # Request shared lock for reading
466 $self->lock( LOCK_SH );
468 my $result = $self->_engine->read_value( $self, $key);
472 # Filters only apply to scalar values, so the ref check is making
473 # sure the fetched bucket is a scalar, not a child hash or array.
474 return ($result && !ref($result) && $self->_storage->{filter_fetch_value})
475 ? $self->_storage->{filter_fetch_value}->($result)
481 # Delete single key/value pair or element given plain key or array index
483 my $self = shift->_get_self;
486 if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
487 $self->_throw_error( 'Cannot write to a readonly filehandle' );
491 # Request exclusive lock for writing
493 $self->lock( LOCK_EX );
498 my $value = $self->_engine->delete_key( $self, $key);
500 if (defined $value && !ref($value) && $self->_storage->{filter_fetch_value}) {
501 $value = $self->_storage->{filter_fetch_value}->($value);
511 # Check if a single key or element exists given plain key or array index
513 my $self = shift->_get_self;
517 # Request shared lock for reading
519 $self->lock( LOCK_SH );
521 my $result = $self->_engine->key_exists( $self, $key );
530 # Clear all keys from hash, or all elements from array.
532 my $self = shift->_get_self;
534 if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
535 $self->_throw_error( 'Cannot write to a readonly filehandle' );
539 # Request exclusive lock for writing
541 $self->lock( LOCK_EX );
543 #XXX Rewrite this dreck to do it in the engine as a tight loop vs.
544 # iterating over keys - such a WASTE - is this required for transactional
545 # clearning?! Surely that can be detected in the engine ...
546 if ( $self->_type eq TYPE_HASH ) {
547 my $key = $self->first_key;
549 # Retrieve the key before deleting because we depend on next_key
550 my $next_key = $self->next_key( $key );
551 $self->_engine->delete_key( $self, $key, $key );
556 my $size = $self->FETCHSIZE;
557 for my $key ( 0 .. $size - 1 ) {
558 $self->_engine->delete_key( $self, $key, $key );
560 $self->STORESIZE( 0 );
569 # Public method aliases
571 sub put { (shift)->STORE( @_ ) }
572 sub store { (shift)->STORE( @_ ) }
573 sub get { (shift)->FETCH( @_ ) }
574 sub fetch { (shift)->FETCH( @_ ) }
575 sub delete { (shift)->DELETE( @_ ) }
576 sub exists { (shift)->EXISTS( @_ ) }
577 sub clear { (shift)->CLEAR( @_ ) }