sub ACTION_test {
my $self = shift;
- if ( $self->notes('TEST_MYSQL_DSN') ) {
+ if ( $self->notes(\'TEST_MYSQL_DSN\') ) {
$ENV{$_} = $self->notes($_) for qw(
TEST_MYSQL_DSN TEST_MYSQL_USER TEST_MYSQL_PASS
);
* clear() should use the Engine to clear. In the File backend, this would mean
that Sector::File::Reference should have a function similar to get_bucket_list
that iterates and deletes as appropriate.
+* Does the cache work with reblessing?
use strict;
use warnings FATAL => 'all';
+no warnings 'recursion';
our $VERSION = q(1.0019_003);
my $class = shift;
my $args = $class->_get_args( @_ );
my $self;
-
+
if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
$class = 'DBM::Deep::Array';
require DBM::Deep::Array;
*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, @_ );
}
$self->lock_exclusive;
$self->_engine->clear_cache;
$self->_copy_node( $db_temp );
+ $self->unlock;
$db_temp->_engine->storage->close;
undef $db_temp;
}
sub clone {
- ##
- # Make copy of object and return
- ##
my $self = shift->_get_self;
return __PACKAGE__->new(
sub rollback {
my $self = shift->_get_self;
+
$self->lock_exclusive;
my $rv = eval {
local $SIG{'__DIE__'};
}
$self->lock_exclusive;
-
- $engine->clear;
+ eval {
+ local $SIG{'__DIE__'};
+ $engine->clear( $self );
+ };
+ my $e = $@;
+ warn "$e\n" if $e;
$self->unlock;
+ die $e if $e;
+
return 1;
}
=cut
-sub clear {
- my $self = shift;
- my $obj = shift;
-
- my $sector = $self->_load_sector( $obj->_base_offset )
- or return;
-
- return unless $sector->staleness == $obj->_staleness;
-
- $sector->clear;
-
- return;
-}
-
=head2 cache / clear_cache
This is the cache of loaded Reference sectors.
use strict;
use warnings FATAL => 'all';
+no warnings 'recursion';
use base 'DBM::Deep::Engine';
return;
}
+sub clear {
+ my $self = shift;
+ my $obj = shift;
+
+ my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+ or return;
+
+ $sector->clear;
+
+ return;
+}
+
1;
__END__
use strict;
use warnings FATAL => 'all';
+no warnings 'recursion';
use base qw( DBM::Deep::Engine );
return;
}
+sub clear {
+ my $self = shift;
+ my $obj = shift;
+
+ my $sector = $self->load_sector( $obj->_base_offset )
+ or return;
+
+ return unless $sector->staleness == $obj->_staleness;
+
+ $sector->clear;
+
+ return;
+}
+
=head2 _dump_file()
This method takes no arguments. It's used to print out a textual representation
sub next_key { (shift)->NEXTKEY(@_) }
sub _clear {
- my $self = shift;
+ my $self = shift->_get_self;
- while ( defined( my $key = $self->first_key ) ) {
+ while ( defined(my $key = $self->first_key) ) {
+ do {
$self->_engine->delete_key( $self, $key, $key );
+ } while defined($key = $self->next_key($key));
}
return;
my ($args) = @_;
$args ||= {};
- my $obj;
- unless ( $obj = $self->engine->cache->{ $self->offset } ) {
- $obj = DBM::Deep->new({
+ my $engine = $self->engine;
+# if ( !exists $engine->cache->{ $self->offset } ) {
+ my $obj = DBM::Deep->new({
type => $self->type,
base_offset => $self->offset,
- storage => $self->engine->storage,
- engine => $self->engine,
+ storage => $engine->storage,
+ engine => $engine,
});
- if ( $self->engine->storage->{autobless} ) {
+# $engine->cache->{$self->offset} = $obj;
+# }
+# my $obj = $engine->cache->{$self->offset};
+
+ # We're not exporting, so just return.
+ unless ( $args->{export} ) {
+ if ( $engine->storage->{autobless} ) {
my $classname = $self->get_classname;
if ( defined $classname ) {
bless $obj, $classname;
}
}
- $self->engine->cache->{$self->offset} = $obj;
- }
-
- # We're not exporting, so just return.
- unless ( $args->{export} ) {
return $obj;
}
);
}
+sub clear {
+ my $self = shift;
+
+ DBM::Deep->new({
+ type => $self->type,
+ base_offset => $self->offset,
+ storage => $self->engine->storage,
+ engine => $self->engine,
+ })->_clear;
+
+ return;
+}
+
1;
__END__
$engine->storage->print_at( $self->offset + $self->base_size,
pack( $StP{$engine->byte_size}, $loc ),
);
-
}
sub get_blist_loc {
return unpack( $StP{$e->byte_size}, $blist_loc );
}
-#sub clear {
-# my $self = shift;
-# my ($args) = @_;
-# $args ||= {};
-#
-# my $engine = $self->engine;
-#
-# # If there's nothing pointed to from this reference, there's nothing to do.
-# my $loc = $self->get_blist_loc
-# or return;
-#
-# my $sector = $engine->load_sector( $loc )
-# or DBM::Deep->_throw_error( "Cannot read sector at $loc in clear()" );
-#
-# $sector->clear;
-#
-# $self->write_blist_loc( 0 );
-#
-# return;
-#}
-
sub get_bucket_list {
my $self = shift;
my ($args) = @_;
my ($args) = @_;
$args ||= {};
- my $obj;
- unless ( $obj = $self->engine->cache->{ $self->offset } ) {
- $obj = DBM::Deep->new({
+ my $engine = $self->engine;
+# if ( !exists $engine->cache->{ $self->offset } ) {
+ my $obj = DBM::Deep->new({
type => $self->type,
base_offset => $self->offset,
staleness => $self->staleness,
- storage => $self->engine->storage,
- engine => $self->engine,
+ storage => $engine->storage,
+ engine => $engine,
});
- if ( $self->engine->storage->{autobless} ) {
+# $engine->cache->{$self->offset} = $obj;
+# }
+# my $obj = $engine->cache->{$self->offset};
+
+ # We're not exporting, so just return.
+ unless ( $args->{export} ) {
+ if ( $engine->storage->{autobless} ) {
my $classname = $self->get_classname;
if ( defined $classname ) {
bless $obj, $classname;
}
}
- $self->engine->cache->{$self->offset} = $obj;
- }
-
- # We're not exporting, so just return.
- unless ( $args->{export} ) {
return $obj;
}
);
}
+sub clear {
+ my $self = shift;
+
+ my $blist_loc = $self->get_blist_loc or return;
+
+ my $engine = $self->engine;
+
+ # This won't work with autoblessed items.
+ if ($engine->get_running_txn_ids) {
+ # ~~~ Temporary; the code below this block needs to be modified to
+ # take transactions into account.
+ $self->data->_get_self->_clear;
+ return;
+ }
+
+ my $sector = $engine->load_sector( $blist_loc )
+ or DBM::Deep->_throw_error(
+ "Cannot read sector at $blist_loc in clear()"
+ );
+
+ # Set blist offset to 0
+ $engine->storage->print_at( $self->offset + $self->base_size,
+ pack( $StP{$engine->byte_size}, 0 ),
+ );
+
+ # Free the blist
+ $sector->free;
+
+ return;
+}
+
1;
__END__
is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" );
is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+
+ cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
+ cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
+
$db1->begin_work;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
eval {
$db->{bar} = $bar;
$db->{bar} = $bar;
- };
+ }; if ( $@ ) { warn $@ }
ok(!$@, "repeated object assignment");
isa_ok($db->{bar}, 'Foo');
}
}
-
+done_testing;
+__END__
# This is bug #29957, reported by HANENKAMP
{
my $dbm_factory = new_dbm();
projects / dbsrgits/DBM-Deep.git / commitdiff