use strict;
use warnings FATAL => 'all';
+no warnings 'recursion';
-our $VERSION = q(1.0015);
+our $VERSION = q(1.0019_003);
use Scalar::Util ();
-use DBM::Deep::Engine::File ();
-
-use DBM::Deep::SQL::Util;
-use DBM::Deep::SQL::Array;
-use DBM::Deep::SQL::Hash;
-
use overload
'""' => sub { overload::StrVal( $_[0] ) },
fallback => 1;
use constant DEBUG => 0;
+use DBM::Deep::Engine;
+
sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH }
sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY }
my $class = shift;
my $args = $class->_get_args( @_ );
my $self;
-
- ##
- # Check for SQL storage
- ##
- if (exists $args->{dbi}) {
- eval {
- require DBIx::Abstract;
- }; if ( $@ ) {
- DBM::Deep->_throw_error('DBIx::Abstract not installed. You cannot use the SQL mode.');
- }
- unless (UNIVERSAL::isa($args->{dbi}, 'DBIx::Abstract')) {
- $args->{dbi} = DBIx::Abstract->connect($args->{dbi});
- }
-
- if (defined $args->{id}) {
- unless ($args->{id} =~ /^\d+$/ && $args->{id} > 0) {
- DBM::Deep->_throw_error('Invalid SQL record id');
- }
- my $util = {dbi => $args->{dbi}};
- bless $util, 'DBM::Deep::SQL::Util';
- my $q = $util->_select(
- table => 'rec_item',
- fields => 'item_type',
- where => {id => $args->{id}},
- );
- if ($q->[0]->[0] eq 'array') {
- $args->{type} = TYPE_ARRAY;
- }
- elsif ($q->[0]->[0] eq 'hash') {
- $args->{type} = TYPE_HASH;
- }
- else {
- DBM::Deep->_throw_error('Unknown SQL record id');
- }
- }
- else {
- my $util = {dbi => $args->{dbi}};
- bless $util, 'DBM::Deep::SQL::Util';
- if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
- $args->{id} = $util->_create('array');
- }
- else {
- $args->{id} = $util->_create('hash');
- }
- }
- if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
- $class = 'DBM::Deep::SQL::Array';
- require DBM::Deep::SQL::Array;
- tie @$self, $class, %$args;
- if ($args->{prefetch}) {
- (tied(@$self))->_prefetch();
- }
- return bless $self, $class;
- }
- else {
- $class = 'DBM::Deep::SQL::Hash';
- require DBM::Deep::SQL::Hash;
- tie %$self, $class, %$args;
- if ($args->{prefetch}) {
- (tied(%$self))->_prefetch();
- }
- return bless $self, $class;
- }
- }
-
- ##
- # Check if we want a tied hash or array.
- ##
if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
$class = 'DBM::Deep::Array';
require DBM::Deep::Array;
engine => undef,
}, $class;
- $args->{engine} = DBM::Deep::Engine::File->new( { %{$args}, obj => $self } )
- unless exists $args->{engine};
+ unless ( exists $args->{engine} ) {
+ my $class = exists $args->{dbi}
+ ? 'DBM::Deep::Engine::DBI'
+ : 'DBM::Deep::Engine::File';
+
+ eval "use $class"; die $@ if $@;
+ $args->{engine} = $class->new({
+ %{$args},
+ obj => $self,
+ });
+ }
# Grab the parameters we want to use
foreach my $param ( keys %$self ) {
}
eval {
- local $SIG{'__DIE__'};
+ local $SIG{'__DIE__'};
- $self->lock_exclusive;
- $self->_engine->setup_fh( $self );
- $self->unlock;
+ $self->lock_exclusive;
+ $self->_engine->setup( $self );
+ $self->unlock;
}; if ( $@ ) {
- my $e = $@;
- eval { local $SIG{'__DIE__'}; $self->unlock; };
- die $e;
+ my $e = $@;
+ eval { local $SIG{'__DIE__'}; $self->unlock; };
+ die $e;
}
return $self;
*lock = \&lock_exclusive;
sub lock_shared {
my $self = shift->_get_self;
+use Carp qw( cluck ); use Data::Dumper;
+cluck Dumper($self) unless $self->_engine;
return $self->_engine->lock_shared( $self, @_ );
}
if ( $r eq 'ARRAY' ) {
$tied = tied(@$value);
}
- # This assumes hash or array only. This is a bad assumption moving
- # forward. -RobK, 2008-05-27
- else {
+ elsif ( $r eq 'HASH' ) {
$tied = tied(%$value);
}
+ else {
+ __PACKAGE__->_throw_error( "Unknown type for '$value'" );
+ }
- if ( eval { local $SIG{__DIE__}; $tied->isa( 'DBM::Deep' ) } ) {
+ if ( eval { local $SIG{'__DIE__'}; $tied->isa( __PACKAGE__ ) } ) {
${$spot} = $tied->_repr;
$tied->_copy_node( ${$spot} );
}
}
my $c = Scalar::Util::blessed( $value );
- if ( defined $c && !$c->isa( 'DBM::Deep') ) {
+ if ( defined $c && !$c->isa( __PACKAGE__ ) ) {
${$spot} = bless ${$spot}, $c
}
}
return $r if 'HASH' eq $r;
return $r if 'ARRAY' eq $r;
- DBM::Deep->_throw_error(
+ __PACKAGE__->_throw_error(
"Storage of references of type '$r' is not supported."
);
}
my $type = $self->_check_legality( $struct );
if ( !$type ) {
- DBM::Deep->_throw_error( "Cannot import a scalar" );
+ __PACKAGE__->_throw_error( "Cannot import a scalar" );
}
if ( substr( $type, 0, 1 ) ne $self->_type ) {
- DBM::Deep->_throw_error(
+ __PACKAGE__->_throw_error(
"Cannot import " . ('HASH' eq $type ? 'a hash' : 'an array')
. " into " . ('HASH' eq $type ? 'an array' : 'a hash')
);
#XXX Should we use tempfile() here instead of a hard-coded name?
my $temp_filename = $self->_engine->storage->{file} . '.tmp';
- my $db_temp = DBM::Deep->new(
+ my $db_temp = __PACKAGE__->new(
file => $temp_filename,
type => $self->_type,
$self->lock_exclusive;
$self->_engine->clear_cache;
$self->_copy_node( $db_temp );
+ $self->unlock;
$db_temp->_engine->storage->close;
undef $db_temp;
$self->_engine->storage->open;
$self->lock_exclusive;
- $self->_engine->setup_fh( $self );
+ $self->_engine->setup( $self );
$self->unlock;
return 1;
}
sub clone {
- ##
- # Make copy of object and return
- ##
my $self = shift->_get_self;
- return DBM::Deep->new(
+ return __PACKAGE__->new(
type => $self->_type,
base_offset => $self->_base_offset,
staleness => $self->_staleness,
);
}
+sub supports {
+ my $self = shift;
+ return $self->_engine->supports( @_ );
+}
+
#XXX Migrate this to the engine, where it really belongs and go through some
# API - stop poking in the innards of someone else..
{
sub begin_work {
my $self = shift->_get_self;
$self->lock_exclusive;
- my $rv = eval { $self->_engine->begin_work( $self, @_ ) };
+ my $rv = eval {
+ local $SIG{'__DIE__'};
+ $self->_engine->begin_work( $self, @_ );
+ };
my $e = $@;
$self->unlock;
die $e if $e;
sub rollback {
my $self = shift->_get_self;
+
$self->lock_exclusive;
- my $rv = eval { $self->_engine->rollback( $self, @_ ) };
+ my $rv = eval {
+ local $SIG{'__DIE__'};
+ $self->_engine->rollback( $self, @_ );
+ };
my $e = $@;
$self->unlock;
die $e if $e;
sub commit {
my $self = shift->_get_self;
$self->lock_exclusive;
- my $rv = eval { $self->_engine->commit( $self, @_ ) };
+ my $rv = eval {
+ local $SIG{'__DIE__'};
+ $self->_engine->commit( $self, @_ );
+ };
my $e = $@;
$self->unlock;
die $e if $e;
$value = $self->_engine->storage->{filter_store_value}->( $value );
}
- $self->_engine->write_value( $self, $key, $value);
+ eval {
+ local $SIG{'__DIE__'};
+ $self->_engine->write_value( $self, $key, $value );
+ }; if ( my $e = $@ ) {
+ $self->unlock;
+ die $e;
+ }
$self->unlock;
$self->lock_shared;
- my $result = $self->_engine->read_value( $self, $key);
+ my $result = $self->_engine->read_value( $self, $key );
$self->unlock;
my $self = shift->_get_self;
warn "CLEAR($self)\n" if DEBUG;
- unless ( $self->_engine->storage->is_writable ) {
+ my $engine = $self->_engine;
+ unless ( $engine->storage->is_writable ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
$self->lock_exclusive;
-
- #XXX Rewrite this dreck to do it in the engine as a tight loop vs.
- # iterating over keys - such a WASTE - is this required for transactional
- # clearning?! Surely that can be detected in the engine ...
- 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 );
- $self->_engine->delete_key( $self, $key, $key );
- $key = $next_key;
- }
- }
- else {
- my $size = $self->FETCHSIZE;
- for my $key ( 0 .. $size - 1 ) {
- $self->_engine->delete_key( $self, $key, $key );
- }
- $self->STORESIZE( 0 );
- }
+ eval {
+ local $SIG{'__DIE__'};
+ $engine->clear( $self );
+ };
+ my $e = $@;
+ warn "$e\n" if $e;
$self->unlock;
+ die $e if $e;
+
return 1;
}
projects / dbsrgits/DBM-Deep.git / blobdiff