Have a 98% solution to making references work.
r8205@rob-kinyons-computer-2 (orig r10027): rkinyon | 2007-09-30 13:59:07 -0400
cached singletons for most cases. The external reference issue is starting to come into larger focus
r8206@rob-kinyons-computer-2 (orig r10031): rkinyon | 2007-10-01 11:15:50 -0400
Added coverage report and tests that were wrong
r8207@rob-kinyons-computer-2 (orig r10032): rkinyon | 2007-10-01 11:16:12 -0400
Fixed date on release of 1.0005
Revision history for DBM::Deep.
+1.0005 Oct 01 11:15:00 2007 EDT
+ - (This version is compatible with 1.0004)
+ - Added proper singleton support. This means that the following now works:
+ $db->{foo} = [ 1 .. 3];
+ my $x = $db->{foo};
+ my $y = $db->{foo};
+ is( $x, $y ); # Now passes
+ - This means that Data::Dumper now properly reports when $db->{foo} = $db->{bar}
+
1.0004 Sep 28 12:15:00 2007 EDT
- (This version is compatible with 1.0003)
- Fixed the Changes file (wrong version was displayed for 1.0003)
use strict;
use warnings;
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
use Fcntl qw( :flock );
use DBM::Deep::Engine;
use DBM::Deep::File;
+use overload
+ '""' => sub { overload::StrVal( $_[0] ) },
+ fallback => 1;
+
##
# Setup constants for users to pass to new()
##
);
$self->lock();
- #DBM::Deep::Engine::Sector::Reference->_clear_cache;
+ $self->_engine->clear_cache;
$self->_copy_node( $db_temp );
undef $db_temp;
=back
-=head2 Data::Dumper and references
+=head2 External references and transactions
-As of 1.0003, support for independent Perl datastructures was added (q.v. L</CIRCULAR REFERENCES>
-for more info). However, because DBM::Deep doesn't properly provide the same
-in-memory data-structure for a given location on disk, Data::Dumper (and
-friends) doesn't properly note this. This will be addressed in a future release.
+If you do C<my $x = $db-E<gt>{foo};>, then start a transaction, $x will be
+referencing the database from outside the transaction. A fix for this (and other
+issues with how external references into the database) is being looked into. This
+is the skipped set of tests in t/39_singletons.t and a related issue is the focus
+of t/37_delete_edge_cases.t
=head2 File corruption
------------------------------------------ ------ ------ ------ ------ ------
File stmt bran cond sub total
------------------------------------------ ------ ------ ------ ------ ------
- blib/lib/DBM/Deep.pm 94.5 85.0 90.5 100.0 93.6
- blib/lib/DBM/Deep/Array.pm 100.0 94.3 100.0 100.0 98.7
- blib/lib/DBM/Deep/Engine.pm 95.9 84.9 81.7 100.0 92.8
+ blib/lib/DBM/Deep.pm 96.9 88.3 90.5 100.0 95.7
+ blib/lib/DBM/Deep/Array.pm 100.0 95.7 100.0 100.0 99.0
+ blib/lib/DBM/Deep/Engine.pm 95.5 84.7 81.6 98.4 92.4
blib/lib/DBM/Deep/File.pm 97.2 81.6 66.7 100.0 91.9
blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0
- Total 96.5 86.5 83.5 100.0 94.0
+ Total 96.7 87.0 83.3 99.2 94.1
------------------------------------------ ------ ------ ------ ------ ------
=head1 MORE INFORMATION
use strict;
use warnings;
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
# This is to allow DBM::Deep::Array to handle negative indices on
# its own. Otherwise, Perl would intercept the call to negative
use strict;
use warnings;
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
use Scalar::Util ();
my ($offset) = @_;
# Add a catch for offset of 0 or 1
- return if $offset <= 1;
+ return if !$offset || $offset <= 1;
my $type = $self->storage->read_at( $offset, 1 );
return if $type eq chr(0);
sub chains_loc { $_[0]{chains_loc} }
sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
+sub cache { $_[0]{cache} ||= {} }
+sub clear_cache { %{$_[0]->cache} = () }
+
sub _dump_file {
my $self = shift;
);
my $return = "";
+
+ # Header values
+ $return .= "NumTxns: " . $self->num_txns . $/;
+
# Read the free sector chains
my %sectors;
foreach my $multiple ( 0 .. 2 ) {
$return .= sprintf "%08d", unpack($StP{$self->byte_size},
substr( $bucket->[-1], $self->hash_size, $self->byte_size),
);
- foreach my $txn ( 0 .. $self->num_txns - 1 ) {
+ my $l = unpack( $StP{$self->byte_size},
+ substr( $bucket->[-1],
+ $self->hash_size + $self->byte_size,
+ $self->byte_size,
+ ),
+ );
+ $return .= sprintf " %08d", $l;
+ foreach my $txn ( 0 .. $self->num_txns - 2 ) {
my $l = unpack( $StP{$self->byte_size},
substr( $bucket->[-1],
- $self->hash_size + $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
+ $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
$self->byte_size,
),
);
return $self->engine->_load_sector( $class_offset )->data;
}
-#XXX Add singleton handling here
-{
- my %cache;
- # XXX This is insufficient
-# sub _clear_cache { %cache = (); }
- sub data {
- my $self = shift;
+sub data {
+ my $self = shift;
-# unless ( $cache{ $self->offset } ) {
- my $new_obj = DBM::Deep->new({
- type => $self->type,
- base_offset => $self->offset,
- staleness => $self->staleness,
- storage => $self->engine->storage,
- engine => $self->engine,
- });
+ unless ( $self->engine->cache->{ $self->offset } ) {
+ my $new_obj = DBM::Deep->new({
+ type => $self->type,
+ base_offset => $self->offset,
+ staleness => $self->staleness,
+ storage => $self->engine->storage,
+ engine => $self->engine,
+ });
- if ( $self->engine->storage->{autobless} ) {
- my $classname = $self->get_classname;
- if ( defined $classname ) {
- bless $new_obj, $classname;
- }
+ if ( $self->engine->storage->{autobless} ) {
+ my $classname = $self->get_classname;
+ if ( defined $classname ) {
+ bless $new_obj, $classname;
}
+ }
- $cache{$self->offset} = $new_obj;
-# }
- return $cache{$self->offset};
+ $self->engine->cache->{$self->offset} = $new_obj;
}
+ return $self->engine->cache->{$self->offset};
+}
- sub free {
- my $self = shift;
+sub free {
+ my $self = shift;
- # We're not ready to be removed yet.
- if ( $self->decrement_refcount > 0 ) {
- return;
- }
+ # We're not ready to be removed yet.
+ if ( $self->decrement_refcount > 0 ) {
+ return;
+ }
- # Rebless the object into DBM::Deep::Null.
-# %{$cache{ $self->offset }} = ();
-# bless $cache{$self->offset}, 'DBM::Deep::Null';
+ # Rebless the object into DBM::Deep::Null.
+ %{ $self->engine->cache->{ $self->offset } } = ();
+ bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
+ delete $self->engine->cache->{ $self->offset };
- my $blist_loc = $self->get_blist_loc;
- $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
+ my $blist_loc = $self->get_blist_loc;
+ $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
- my $class_loc = $self->get_class_offset;
- $self->engine->_load_sector( $class_loc )->free if $class_loc;
+ my $class_loc = $self->get_class_offset;
+ $self->engine->_load_sector( $class_loc )->free if $class_loc;
- $self->SUPER::free();
- }
+ $self->SUPER::free();
}
sub increment_refcount {
my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size, $e->byte_size ) );
my $s = $e->_load_sector( $l ); $s->free if $s;
- foreach my $txn ( 0 .. $e->num_txns - 1 ) {
+ # Delete the HEAD sector
+ $l = unpack( $StP{$e->byte_size},
+ substr( $rest,
+ $e->hash_size + $e->byte_size,
+ $e->byte_size,
+ ),
+ );
+ $s = $e->_load_sector( $l ); $s->free if $s;
+
+ foreach my $txn ( 0 .. $e->num_txns - 2 ) {
my $l = unpack( $StP{$e->byte_size},
substr( $rest,
- $e->hash_size + $e->byte_size + $txn * ($e->byte_size + $STALE_SIZE),
+ $e->hash_size + 2 * $e->byte_size + $txn * ($e->byte_size + $STALE_SIZE),
$e->byte_size,
),
);
package DBM::Deep::Null;
use overload
- 'bool' => sub { undef},
+ 'bool' => sub { undef },
'""' => sub { undef },
- '0+' => sub { undef},
- fallback => 1;
+ '0+' => sub { undef },
+ fallback => 1,
+ nomethod => 'AUTOLOAD';
sub AUTOLOAD { return; }
use strict;
use warnings;
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
use Fcntl qw( :DEFAULT :flock :seek );
use strict;
use warnings;
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
use base 'DBM::Deep';
use strict;
use Test::More tests => 16;
+use Test::Deep;
use Test::Exception;
use t::common qw( new_fh );
isa_ok( tied(%hash), 'DBM::Deep::Hash' );
is( $db->{hash}{foo}, 1 );
-is_deeply( $db->{hash}{bar}, [ 1 .. 3 ] );
-is_deeply( $db->{hash}{baz}, { a => 42 } );
+cmp_deeply( $db->{hash}{bar}, noclass([ 1 .. 3 ]) );
+cmp_deeply( $db->{hash}{baz}, noclass({ a => 42 }) );
$hash{foo} = 2;
is( $db->{hash}{foo}, 2 );
isa_ok( tied(@array), 'DBM::Deep::Array' );
is( $db->{array}[0], 1 );
-is_deeply( $db->{array}[1], [ 1 .. 3 ] );
-is_deeply( $db->{array}[2], { a => 42 } );
+cmp_deeply( $db->{array}[1], noclass([ 1 .. 3 ]) );
+cmp_deeply( $db->{array}[2], noclass({ a => 42 }) );
$array[0] = 2;
is( $db->{array}[0], 2 );
}
__END__
-
-Tests to add:
-* Two transactions running at the same time
-* Doing a clear on the head while a transaction is running
use strict;
-use Test::More tests => 5;
+use Test::More tests => 11;
use Test::Deep;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
-);
+{
+ my ($fh, $filename) = new_fh();
+ my $db = DBM::Deep->new(
+ file => $filename,
+ locking => 1,
+ autoflush => 1,
+ );
-$db->{foo} = { a => 'b' };
-my $x = $db->{foo};
-my $y = $db->{foo};
+ $db->{a} = 1;
+ $db->{foo} = { a => 'b' };
+ my $x = $db->{foo};
+ my $y = $db->{foo};
-print "$x -> $y\n";
-
-TODO: {
- local $TODO = "Singletons are unimplmeneted yet";
is( $x, $y, "The references are the same" );
delete $db->{foo};
is( $x, undef );
is( $y, undef );
+ is( $x + 0, undef );
+ is( $y + 0, undef );
+ is( $db->{foo}, undef );
+
+ # These shenanigans work to get another hashref
+ # into the same data location as $db->{foo} was.
+ $db->{foo} = {};
+ delete $db->{foo};
+ $db->{foo} = {};
+ $db->{bar} = {};
+
+ is( $x, undef );
+ is( $y, undef );
+}
+
+SKIP: {
+ skip "What do we do with external references and txns?", 2;
+ my ($fh, $filename) = new_fh();
+ my $db = DBM::Deep->new(
+ file => $filename,
+ locking => 1,
+ autoflush => 1,
+ num_txns => 2,
+ );
+
+ $db->{foo} = { a => 'b' };
+ my $x = $db->{foo};
+
+ $db->begin_work;
+
+ $db->{foo} = { c => 'd' };
+ my $y = $db->{foo};
+
+ # XXX What should happen here with $x and $y?
+ is( $x, $y );
+ is( $x->{c}, 'd' );
+
+ $db->rollback;
}
-is( $db->{foo}, undef );
file => $filename,
locking => 1,
autoflush => 1,
- num_txns => 16,
+ num_txns => 2,
);
my $db2 = DBM::Deep->new(
file => $filename,
locking => 1,
autoflush => 1,
- num_txns => 16,
+ num_txns => 2,
);
$db1->{x} = { foo => 'y' };
}
}
-plan tests => 202;
+plan tests => 212;
use t::common qw( new_fh );
use File::Spec;
'0.981', '0.982', '0.983',
'0.99_01', '0.99_02', '0.99_03', '0.99_04',
'1.00', '1.000', '1.0000', '1.0001', '1.0002',
- '1.0003', '1.0004',
+ '1.0003', '1.0004', '1.0005',
);
foreach my $input_filename (
eval "use DBM::Deep::10002";
$db = DBM::Deep::10002->new( $output_filename );
}
- elsif ( $v =~ /^1\.000[34]/ ) {
+ elsif ( $v =~ /^1\.000[3-5]/ ) {
push @INC, 'lib';
eval "use DBM::Deep";
$db = DBM::Deep->new( $output_filename );
);
is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
+NumTxns: 1
Chains(B):
Chains(D):
Chains(I):
$db->{foo} = 'bar';
is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
+NumTxns: 1
Chains(B):
Chains(D):
Chains(I):
my %opts = (
man => 0,
help => 0,
- version => '1.0004',
+ version => '1.0005',
autobless => 1,
);
GetOptions( \%opts,
elsif ( $ver =~ /^1\.000?[0-2]?/) {
$ver = 2;
}
- elsif ( $ver =~ /^1\.000[34]/) {
+ elsif ( $ver =~ /^1\.000[3-5]/) {
$ver = 3;
}
else {
projects / dbsrgits/DBM-Deep.git / commitdiff