6 use warnings FATAL => 'all';
7 no warnings 'recursion';
9 our $VERSION = q(1.0020);
14 '""' => sub { overload::StrVal( $_[0] ) },
17 use constant DEBUG => 0;
19 use DBM::Deep::Engine;
21 sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH }
22 sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY }
24 # This is used in all the children of this class in their TIE<type> methods.
31 $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] );
36 unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) {
37 $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] );
42 $args = { file => shift };
48 # Class constructor method for Perl OO interface.
49 # Calls tie() and returns blessed reference to tied hash or array,
50 # providing a hybrid OO/tie interface.
53 my $args = $class->_get_args( @_ );
56 if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
57 $class = 'DBM::Deep::Array';
58 require DBM::Deep::Array;
59 tie @$self, $class, %$args;
62 $class = 'DBM::Deep::Hash';
63 require DBM::Deep::Hash;
64 tie %$self, $class, %$args;
67 return bless $self, $class;
70 # This initializer is called from the various TIE* methods. new() calls tie(),
71 # which allows for a single point of entry.
76 # locking implicitly enables autoflush
77 if ($args->{locking}) { $args->{autoflush} = 1; }
79 # These are the defaults to be optionally overridden below
87 unless ( exists $args->{engine} ) {
89 exists $args->{dbi} ? 'DBM::Deep::Engine::DBI' :
90 exists $args->{_test} ? 'DBM::Deep::Engine::Test' :
91 'DBM::Deep::Engine::File' ;
93 eval "use $class"; die $@ if $@;
94 $args->{engine} = $class->new({
100 # Grab the parameters we want to use
101 foreach my $param ( keys %$self ) {
102 next unless exists $args->{$param};
103 $self->{$param} = $args->{$param};
107 local $SIG{'__DIE__'};
109 $self->lock_exclusive;
110 $self->_engine->setup( $self );
114 eval { local $SIG{'__DIE__'}; $self->unlock; };
123 require DBM::Deep::Hash;
124 return DBM::Deep::Hash->TIEHASH( @_ );
129 require DBM::Deep::Array;
130 return DBM::Deep::Array->TIEARRAY( @_ );
134 my $self = shift->_get_self;
135 return $self->_engine->lock_exclusive( $self, @_ );
137 *lock = \&lock_exclusive;
140 my $self = shift->_get_self;
141 # cluck() the problem with cached File objects.
142 unless ( $self->_engine ) {
144 require Data::Dumper;
145 Carp::cluck( Data::Dumper->Dump( [$self], ['self'] ) );
147 return $self->_engine->lock_shared( $self, @_ );
151 my $self = shift->_get_self;
152 return $self->_engine->unlock( $self, @_ );
156 my $self = shift->_get_self;
157 my ($spot, $value) = @_;
163 my $r = Scalar::Util::reftype( $value );
165 if ( $r eq 'ARRAY' ) {
166 $tied = tied(@$value);
168 elsif ( $r eq 'HASH' ) {
169 $tied = tied(%$value);
172 __PACKAGE__->_throw_error( "Unknown type for '$value'" );
175 if ( eval { local $SIG{'__DIE__'}; $tied->isa( __PACKAGE__ ) } ) {
176 ${$spot} = $tied->_repr;
177 $tied->_copy_node( ${$spot} );
180 if ( $r eq 'ARRAY' ) {
181 ${$spot} = [ @{$value} ];
184 ${$spot} = { %{$value} };
188 my $c = Scalar::Util::blessed( $value );
189 if ( defined $c && !$c->isa( __PACKAGE__ ) ) {
190 ${$spot} = bless ${$spot}, $c
198 my $self = shift->_get_self;
200 my $temp = $self->_repr;
202 $self->lock_exclusive;
203 $self->_copy_node( $temp );
206 my $classname = $self->_engine->get_classname( $self );
207 if ( defined $classname ) {
208 bless $temp, $classname;
214 sub _check_legality {
218 my $r = Scalar::Util::reftype( $val );
220 return $r if !defined $r || '' eq $r;
221 return $r if 'HASH' eq $r;
222 return $r if 'ARRAY' eq $r;
224 __PACKAGE__->_throw_error(
225 "Storage of references of type '$r' is not supported."
230 return if !ref $_[0]; # Perl calls import() on use -- ignore
232 my $self = shift->_get_self;
235 my $type = $self->_check_legality( $struct );
237 __PACKAGE__->_throw_error( "Cannot import a scalar" );
240 if ( substr( $type, 0, 1 ) ne $self->_type ) {
241 __PACKAGE__->_throw_error(
242 "Cannot import " . ('HASH' eq $type ? 'a hash' : 'an array')
243 . " into " . ('HASH' eq $type ? 'an array' : 'a hash')
252 my $obj = 'HASH' eq Scalar::Util::reftype( $db ) ? tied(%$db) : tied(@$db);
255 my $r = $self->_check_legality( $val );
256 if ( 'HASH' eq $r ) {
257 while ( my ($k, $v) = each %$val ) {
258 my $r = $self->_check_legality( $v );
260 my $temp = 'HASH' eq $r ? {} : [];
261 if ( my $c = Scalar::Util::blessed( $v ) ) {
264 $obj->put( $k, $temp );
265 $recurse->( $temp, $v );
272 elsif ( 'ARRAY' eq $r ) {
273 foreach my $k ( 0 .. $#$val ) {
275 my $r = $self->_check_legality( $v );
277 my $temp = 'HASH' eq $r ? {} : [];
278 if ( my $c = Scalar::Util::blessed( $v ) ) {
281 $obj->put( $k, $temp );
282 $recurse->( $temp, $v );
290 $recurse->( $self, $struct );
295 #XXX Need to keep track of who has a fh to this file in order to
296 #XXX close them all prior to optimize on Win32/cygwin
297 # Rebuild entire database into new file, then move
298 # it back on top of original.
300 my $self = shift->_get_self;
302 # Optimizing is only something we need to do when we're working with our
303 # own file format. Otherwise, let the other guy do the optimizations.
304 return unless $self->_engine->isa( 'DBM::Deep::Engine::File' );
306 #XXX Need to create a new test for this
307 # if ($self->_engine->storage->{links} > 1) {
308 # $self->_throw_error("Cannot optimize: reference count is greater than 1");
311 #XXX Do we have to lock the tempfile?
313 #XXX Should we use tempfile() here instead of a hard-coded name?
314 my $temp_filename = $self->_engine->storage->{file} . '.tmp';
315 my $db_temp = __PACKAGE__->new(
316 file => $temp_filename,
317 type => $self->_type,
319 # Bring over all the parameters that we need to bring over
320 ( map { $_ => $self->_engine->$_ } qw(
321 byte_size max_buckets data_sector_size num_txns
325 $self->lock_exclusive;
326 $self->_engine->clear_cache;
327 $self->_copy_node( $db_temp );
329 $db_temp->_engine->storage->close;
333 # Attempt to copy user, group and permissions over to new file
335 $self->_engine->storage->copy_stats( $temp_filename );
337 # q.v. perlport for more information on this variable
338 if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
340 # Potential race condition when optmizing on Win32 with locking.
341 # The Windows filesystem requires that the filehandle be closed
342 # before it is overwritten with rename(). This could be redone
346 $self->_engine->storage->close;
349 if (!rename $temp_filename, $self->_engine->storage->{file}) {
350 unlink $temp_filename;
352 $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
356 $self->_engine->storage->close;
358 $self->_engine->storage->open;
359 $self->lock_exclusive;
360 $self->_engine->setup( $self );
367 my $self = shift->_get_self;
369 return __PACKAGE__->new(
370 type => $self->_type,
371 base_offset => $self->_base_offset,
372 staleness => $self->_staleness,
373 engine => $self->_engine,
378 my $self = shift->_get_self;
379 return $self->_engine->supports( @_ );
382 #XXX Migrate this to the engine, where it really belongs and go through some
383 # API - stop poking in the innards of someone else..
385 my %is_legal_filter = map {
388 store_key store_value
389 fetch_key fetch_value
393 my $self = shift->_get_self;
397 if ( $is_legal_filter{$type} ) {
398 $self->_engine->storage->{"filter_$type"} = $func;
405 sub filter_store_key { $_[0]->set_filter( store_key => $_[1] ); }
406 sub filter_store_value { $_[0]->set_filter( store_value => $_[1] ); }
407 sub filter_fetch_key { $_[0]->set_filter( fetch_key => $_[1] ); }
408 sub filter_fetch_value { $_[0]->set_filter( fetch_value => $_[1] ); }
412 my $self = shift->_get_self;
413 $self->lock_exclusive;
415 local $SIG{'__DIE__'};
416 $self->_engine->begin_work( $self, @_ );
425 my $self = shift->_get_self;
427 $self->lock_exclusive;
429 local $SIG{'__DIE__'};
430 $self->_engine->rollback( $self, @_ );
439 my $self = shift->_get_self;
440 $self->lock_exclusive;
442 local $SIG{'__DIE__'};
443 $self->_engine->commit( $self, @_ );
453 my $self = $_[0]->_get_self;
454 return $self->{engine};
458 my $self = $_[0]->_get_self;
459 return $self->{type};
463 my $self = $_[0]->_get_self;
464 return $self->{base_offset};
468 my $self = $_[0]->_get_self;
469 return $self->{staleness};
476 my @caller = caller( ++$n );
477 next if $caller[0] =~ m/^DBM::Deep/;
479 die "DBM::Deep: $_[1] at $0 line $caller[2]\n";
483 # Store single hash key/value or array element in database.
485 my $self = shift->_get_self;
486 my ($key, $value) = @_;
487 warn "STORE($self, '$key', '@{[defined$value?$value:'undef']}')\n" if DEBUG;
489 unless ( $self->_engine->storage->is_writable ) {
490 $self->_throw_error( 'Cannot write to a readonly filehandle' );
493 $self->lock_exclusive;
495 # User may be storing a complex value, in which case we do not want it run
496 # through the filtering system.
497 if ( !ref($value) && $self->_engine->storage->{filter_store_value} ) {
498 $value = $self->_engine->storage->{filter_store_value}->( $value );
502 local $SIG{'__DIE__'};
503 $self->_engine->write_value( $self, $key, $value );
504 }; if ( my $e = $@ ) {
514 # Fetch single value or element given plain key or array index
516 my $self = shift->_get_self;
518 warn "FETCH($self, '$key')\n" if DEBUG;
522 my $result = $self->_engine->read_value( $self, $key );
526 # Filters only apply to scalar values, so the ref check is making
527 # sure the fetched bucket is a scalar, not a child hash or array.
528 return ($result && !ref($result) && $self->_engine->storage->{filter_fetch_value})
529 ? $self->_engine->storage->{filter_fetch_value}->($result)
533 # Delete single key/value pair or element given plain key or array index
535 my $self = shift->_get_self;
537 warn "DELETE($self, '$key')\n" if DEBUG;
539 unless ( $self->_engine->storage->is_writable ) {
540 $self->_throw_error( 'Cannot write to a readonly filehandle' );
543 $self->lock_exclusive;
548 my $value = $self->_engine->delete_key( $self, $key);
550 if (defined $value && !ref($value) && $self->_engine->storage->{filter_fetch_value}) {
551 $value = $self->_engine->storage->{filter_fetch_value}->($value);
559 # Check if a single key or element exists given plain key or array index
561 my $self = shift->_get_self;
563 warn "EXISTS($self, '$key')\n" if DEBUG;
567 my $result = $self->_engine->key_exists( $self, $key );
574 # Clear all keys from hash, or all elements from array.
576 my $self = shift->_get_self;
577 warn "CLEAR($self)\n" if DEBUG;
579 my $engine = $self->_engine;
580 unless ( $engine->storage->is_writable ) {
581 $self->_throw_error( 'Cannot write to a readonly filehandle' );
584 $self->lock_exclusive;
586 local $SIG{'__DIE__'};
587 $engine->clear( $self );
599 # Public method aliases
600 sub put { (shift)->STORE( @_ ) }
601 sub get { (shift)->FETCH( @_ ) }
602 sub store { (shift)->STORE( @_ ) }
603 sub fetch { (shift)->FETCH( @_ ) }
604 sub delete { (shift)->DELETE( @_ ) }
605 sub exists { (shift)->EXISTS( @_ ) }
606 sub clear { (shift)->CLEAR( @_ ) }
608 sub _dump_file {shift->_get_self->_engine->_dump_file;}