Revision history for DBM::Deep.
-1.0009_01 Sep 24 14:00:00 2007 EDT
+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)
+ - Added filter sugar methods to be more API-compatible with other DBMs
+ - This was added to support a patch provided to IO::All so it can
+ use DBM::Deep as a DBM provider.
+ - Implemented _dump_file in order to display the file structure. As a
+ result, the following bugs were fixed:
+ - Arrays and hashes now clean up after themselves better.
+ - Bucketlists now clean up after themselves better.
+ - Reindexing properly clears the old bucketlist before freeing it.
+
+1.0003 Sep 24 14:00:00 2007 EDT
- THIS VERSION IS INCOMPATIBLE WITH FILES FROM ALL OTHER PRIOR VERSIONS.
- Further fixes for unshift/shift/splice and references (RT# 29583)
- To fix that, I had to put support for real references in.
t/43_transaction_maximum.t
t/44_upgrade_db.t
t/45_references.t
+t/97_dump_file.t
t/98_pod.t
t/99_pod_coverage.t
t/common.pm
use strict;
use warnings;
-our $VERSION = q(1.0003);
+our $VERSION = q(1.0004);
use Fcntl qw( :flock );
type => $self->_type,
# Bring over all the parameters that we need to bring over
- num_txns => $self->_engine->num_txns,
- byte_size => $self->_engine->byte_size,
- max_buckets => $self->_engine->max_buckets,
+ ( map { $_ => $self->_engine->$_ } qw(
+ byte_size max_buckets data_sector_size num_txns
+ )),
);
$self->lock();
+ #DBM::Deep::Engine::Sector::Reference->_clear_cache;
$self->_copy_node( $db_temp );
undef $db_temp;
);
sub set_filter {
- ##
- # Setup filter function for storing or fetching the key or value
- ##
my $self = shift->_get_self;
my $type = lc shift;
my $func = shift;
return;
}
+
+ sub filter_store_key { $_[0]->set_filter( store_key => $_[1] ); }
+ sub filter_store_value { $_[0]->set_filter( store_value => $_[1] ); }
+ sub filter_fetch_key { $_[0]->set_filter( fetch_key => $_[1] ); }
+ sub filter_fetch_value { $_[0]->set_filter( fetch_value => $_[1] ); }
}
sub begin_work {
##
sub _throw_error {
- die "DBM::Deep: $_[1]\n";
my $n = 0;
while( 1 ) {
my @caller = caller( ++$n );
next if $caller[0] =~ m/^DBM::Deep/;
die "DBM::Deep: $_[1] at $0 line $caller[2]\n";
- last;
}
}
sub exists { (shift)->EXISTS( @_ ) }
sub clear { (shift)->CLEAR( @_ ) }
+sub _dump_file {shift->_get_self->_engine->_dump_file;}
+
1;
__END__
B<Devel::Cover> is used to test the code coverage of the tests. Below is the
B<Devel::Cover> report on this distribution's test suite.
- ----------------------------------- ------ ------ ------ ------ ------ ------
- File stmt bran cond sub time total
- ----------------------------------- ------ ------ ------ ------ ------ ------
- blib/lib/DBM/Deep.pm 94.4 85.0 90.5 100.0 5.0 93.4
- blib/lib/DBM/Deep/Array.pm 100.0 94.6 100.0 100.0 4.7 98.8
- blib/lib/DBM/Deep/Engine.pm 97.2 85.8 82.4 100.0 51.3 93.8
- blib/lib/DBM/Deep/File.pm 97.2 81.6 66.7 100.0 36.5 91.9
- blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 2.5 100.0
- Total 97.2 87.4 83.9 100.0 100.0 94.6
- ----------------------------------- ------ ------ ------ ------ ------ ------
+ ------------------------------------------ ------ ------ ------ ------ ------
+ 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/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
+ ------------------------------------------ ------ ------ ------ ------ ------
=head1 MORE INFORMATION
use strict;
use warnings;
-our $VERSION = q(1.0003);
+our $VERSION = q(1.0004);
# This is to allow DBM::Deep::Array to handle negative indices on
# its own. Otherwise, Perl would intercept the call to negative
$self->lock( $self->LOCK_SH );
if ( !defined $key ) {
+ $self->unlock;
DBM::Deep->_throw_error( "Cannot use an undefined array index." );
}
elsif ( $key =~ /^-?\d+$/ ) {
my $size;
my $idx_is_numeric;
if ( !defined $key ) {
+ $self->unlock;
DBM::Deep->_throw_error( "Cannot use an undefined array index." );
}
elsif ( $key =~ /^-?\d+$/ ) {
$self->lock( $self->LOCK_SH );
if ( !defined $key ) {
+ $self->unlock;
DBM::Deep->_throw_error( "Cannot use an undefined array index." );
}
elsif ( $key =~ /^-?\d+$/ ) {
my $size = $self->FETCHSIZE;
if ( !defined $key ) {
+ $self->unlock;
DBM::Deep->_throw_error( "Cannot use an undefined array index." );
}
elsif ( $key =~ /^-?\d+$/ ) {
use strict;
use warnings;
-our $VERSION = q(1.0003);
+our $VERSION = q(1.0004);
use Scalar::Util ();
return unpack( $StP{$STALE_SIZE},
$self->storage->read_at(
- $self->trans_loc + 4 + $STALE_SIZE * ($trans_id - 1),
- 4,
+ $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
+ $STALE_SIZE,
)
);
}
my ($trans_id) = @_;
# Hardcode staleness of 0 for the HEAD
- return unless $trans_id;
+ return 0 unless $trans_id;
$self->storage->print_at(
- $self->trans_loc + 4 + $STALE_SIZE * ($trans_id - 1),
+ $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
);
}
sub chains_loc { $_[0]{chains_loc} }
sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
+sub _dump_file {
+ my $self = shift;
+
+ # Read the header
+ my $spot = $self->_read_file_header();
+
+ my %types = (
+ 0 => 'B',
+ 1 => 'D',
+ 2 => 'I',
+ );
+
+ my %sizes = (
+ 'D' => $self->data_sector_size,
+ 'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
+ 'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
+ );
+
+ my $return = "";
+ # Read the free sector chains
+ my %sectors;
+ foreach my $multiple ( 0 .. 2 ) {
+ $return .= "Chains($types{$multiple}):";
+ my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
+ while ( 1 ) {
+ my $loc = unpack(
+ $StP{$self->byte_size},
+ $self->storage->read_at( $old_loc, $self->byte_size ),
+ );
+
+ # We're now out of free sectors of this kind.
+ unless ( $loc ) {
+ last;
+ }
+
+ $sectors{ $types{$multiple} }{ $loc } = undef;
+ $old_loc = $loc + SIG_SIZE + $STALE_SIZE;
+ $return .= " $loc";
+ }
+ $return .= $/;
+ }
+
+ SECTOR:
+ while ( $spot < $self->storage->{end} ) {
+ # Read each sector in order.
+ my $sector = $self->_load_sector( $spot );
+ if ( !$sector ) {
+ # Find it in the free-sectors that were found already
+ foreach my $type ( keys %sectors ) {
+ if ( exists $sectors{$type}{$spot} ) {
+ my $size = $sizes{$type};
+ $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
+ $spot += $size;
+ next SECTOR;
+ }
+ }
+
+ die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
+ }
+ else {
+ $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
+ if ( $sector->type eq 'D' ) {
+ $return .= ' ' . $sector->data;
+ }
+ elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
+ $return .= ' REF: ' . $sector->get_refcount;
+ }
+ elsif ( $sector->type eq 'B' ) {
+ foreach my $bucket ( $sector->chopped_up ) {
+ $return .= "\n ";
+ $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 + $txn * ($self->byte_size + $STALE_SIZE),
+ $self->byte_size,
+ ),
+ );
+ $return .= sprintf " %08d", $l;
+ }
+ }
+ }
+ $return .= $/;
+
+ $spot += $sector->size;
+ }
+ }
+
+ return $return;
+}
+
################################################################################
package DBM::Deep::Iterator;
return;
}
-sub free {
- my $self = shift;
-
- # We're not ready to be removed yet.
- if ( $self->decrement_refcount > 0 ) {
- return;
- }
-
- 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;
-
- $self->SUPER::free();
-}
-
sub staleness { $_[0]{staleness} }
sub get_data_for {
my @trans_ids = $self->engine->get_running_txn_ids;
+ # If we're the HEAD and there are running txns, then we need to clone this value to the other
+ # transactions to preserve Isolation.
if ( $self->engine->trans_id == 0 ) {
if ( @trans_ids ) {
foreach my $other_trans_id ( @trans_ids ) {
);
}
+ $sector->clear;
$sector->free;
$sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
}
#XXX Add singleton handling here
-sub data {
- my $self = shift;
+{
+ my %cache;
+ # XXX This is insufficient
+# sub _clear_cache { %cache = (); }
+ sub data {
+ my $self = shift;
- my $new_obj = DBM::Deep->new({
- type => $self->type,
- base_offset => $self->offset,
- staleness => $self->staleness,
- storage => $self->engine->storage,
- engine => $self->engine,
- });
+# 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,
+ });
- 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};
}
- return $new_obj;
+ sub free {
+ my $self = shift;
+
+ # 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';
+
+ 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;
+
+ $self->SUPER::free();
+ }
}
sub increment_refcount {
my $self = shift;
- my $e = $self->engine;
- my $refcount = unpack(
- $StP{$e->byte_size},
- $e->storage->read_at(
- $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
- ),
- );
+ my $refcount = $self->get_refcount;
$refcount++;
- $e->storage->print_at(
- $self->offset + $self->base_size + 2 * $e->byte_size,
- pack( $StP{$e->byte_size}, $refcount ),
- );
+ $self->write_refcount( $refcount );
return $refcount;
}
sub decrement_refcount {
my $self = shift;
- my $e = $self->engine;
- my $refcount = unpack(
- $StP{$e->byte_size},
- $e->storage->read_at(
- $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
- ),
- );
+ my $refcount = $self->get_refcount;
$refcount--;
- $e->storage->print_at(
- $self->offset + $self->base_size + 2 * $e->byte_size,
- pack( $StP{$e->byte_size}, $refcount ),
- );
+ $self->write_refcount( $refcount );
return $refcount;
}
);
}
+sub write_refcount {
+ my $self = shift;
+ my ($num) = @_;
+
+ my $e = $self->engine;
+ $e->storage->print_at(
+ $self->offset + $self->base_size + 2 * $e->byte_size,
+ pack( $StP{$e->byte_size}, $num ),
+ );
+}
+
package DBM::Deep::Engine::Sector::BucketList;
our @ISA = qw( DBM::Deep::Engine::Sector );
return $self;
}
+sub clear {
+ my $self = shift;
+ $self->engine->storage->print_at( $self->offset + $self->base_size,
+ chr(0) x ($self->size - $self->base_size), # Zero-fill the data
+ );
+}
+
sub size {
my $self = shift;
unless ( $self->{size} ) {
sub free_meth { return '_add_free_blist_sector' }
+sub free {
+ my $self = shift;
+
+ my $e = $self->engine;
+ foreach my $bucket ( $self->chopped_up ) {
+ my $rest = $bucket->[-1];
+
+ # Delete the keysector
+ 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 ) {
+ my $l = unpack( $StP{$e->byte_size},
+ substr( $rest,
+ $e->hash_size + $e->byte_size + $txn * ($e->byte_size + $STALE_SIZE),
+ $e->byte_size,
+ ),
+ );
+ my $s = $e->_load_sector( $l ); $s->free if $s;
+ }
+ }
+
+ $self->SUPER::free();
+}
+
sub bucket_size {
my $self = shift;
unless ( $self->{bucket_size} ) {
);
}
+# This was copied from MARCEL's Class::Null. However, I couldn't use it because
+# I need an undef value, not an implementation of the Null Class pattern.
+package DBM::Deep::Null;
+
+use overload
+ 'bool' => sub { undef},
+ '""' => sub { undef },
+ '0+' => sub { undef},
+ fallback => 1;
+
+sub AUTOLOAD { return; }
+
1;
__END__
use strict;
use warnings;
-our $VERSION = q(1.0003);
+our $VERSION = q(1.0004);
use Fcntl qw( :DEFAULT :flock :seek );
use strict;
use warnings;
-our $VERSION = q(1.0003);
+our $VERSION = q(1.0004);
use base 'DBM::Deep';
# DBM::Deep Test
##
use strict;
-use Test::More tests => 125;
+use Test::More tests => 128;
use Test::Exception;
use t::common qw( new_fh );
is($db->[1], "elem last");
is($returned[0], "middle ABC");
+@returned = $db->splice;
+is( $db->length, 0 );
+is( $returned[0], "elem first" );
+is( $returned[1], "elem last" );
+
$db->[0] = [ 1 .. 3 ];
$db->[1] = { a => 'foo' };
is( $db->[0]->length, 3, "Reuse of same space with array successful" );
##
# Now clear all filters, and make sure all is unfiltered
##
-ok( $db->set_filter( 'store_key', undef ), "Unset store_key filter" );
-ok( $db->set_filter( 'store_value', undef ), "Unset store_value filter" );
-ok( $db->set_filter( 'fetch_key', undef ), "Unset fetch_key filter" );
-ok( $db->set_filter( 'fetch_value', undef ), "Unset fetch_value filter" );
+ok( $db->filter_store_key( undef ), "Unset store_key filter" );
+ok( $db->filter_store_value( undef ), "Unset store_value filter" );
+ok( $db->filter_fetch_key( undef ), "Unset fetch_key filter" );
+ok( $db->filter_fetch_value( undef ), "Unset fetch_value filter" );
is( $db->{MYFILTERkey2}, "MYFILTERvalue2", "We get the right unfiltered value" );
{
open(my $fh, '<', $filename) || die("Can't open '$filename' for reading: $!\n");
- my $db;
-
# test if we can open and read a db using its filehandle
- ok(($db = DBM::Deep->new(fh => $fh)), "open db in filehandle");
- ok($db->{hash}->{foo}->[1] eq 'b', "and get at stuff in the database");
+ my $db;
+ ok( ($db = DBM::Deep->new( fh => $fh )), "open db in filehandle" );
+ ok( $db->{hash}{foo}[1] eq 'b', "and get at stuff in the database" );
throws_ok {
$db->{foo} = 1;
- } qr/Cannot write to a readonly filehandle/,
- "Can't write to a read-only filehandle";
+ } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
ok( !$db->exists( 'foo' ), "foo doesn't exist" );
my $db_obj = $db->_get_self;
-##
-# DBM::Deep Test
-##
use strict;
+
use Test::More tests => 16;
use Test::Exception;
use t::common qw( new_fh );
my %hash2 = ( abc => [ 1 .. 3 ] );
$array[3] = \%hash2;
-SKIP: {
- skip "Internal references are not supported right now", 1;
- $hash2{ def } = \%hash;
- is( $array[3]{def}{foo}, 2 );
-}
+$hash2{ def } = \%hash;
+is( $array[3]{def}{foo}, 2 );
use strict;
-use Test::More tests => 2;
+use Test::More tests => 5;
use Test::Deep;
use t::common qw( new_fh );
print "$x -> $y\n";
TODO: {
- local $TODO = "Singletons aren't working yet";
-is( $x, $y, "The references are the same" );
+ local $TODO = "Singletons are unimplmeneted yet";
+ is( $x, $y, "The references are the same" );
+
+ delete $db->{foo};
+ is( $x, undef );
+ is( $y, undef );
}
+is( $db->{foo}, undef );
}
}
-plan tests => 192;
+plan tests => 202;
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.0003', '1.0004',
);
foreach my $input_filename (
eval "use DBM::Deep::10002";
$db = DBM::Deep::10002->new( $output_filename );
}
- elsif ( $v =~ /^1\.000[3]/ ) {
+ elsif ( $v =~ /^1\.000[34]/ ) {
push @INC, 'lib';
eval "use DBM::Deep";
$db = DBM::Deep->new( $output_filename );
# DBM::Deep Test
##
use strict;
-use Test::More tests => 10;
+use Test::More tests => 15;
use Test::Exception;
use t::common qw( new_fh );
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
- file => $filename,
+ file => $filename,
+ locking => 1,
+ autoflush => 1,
+ num_txns => 16,
+);
+
+my $db2 = DBM::Deep->new(
+ file => $filename,
+ locking => 1,
+ autoflush => 1,
+ num_txns => 16,
);
$db->{foo} = 5;
delete $db->{foo};
is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+
+$db->{foo} = $db->{bar};
+$db2->begin_work;
+
+ delete $db2->{bar};
+ delete $db2->{foo};
+
+ is( $db2->{bar}, undef, "It's deleted in the transaction" );
+ is( $db->{bar}[3], 42, "... but not in the main" );
+
+$db2->rollback;
+
+# Why hasn't this failed!? Is it because stuff isn't getting deleted as expected?
+# I need a test that walks the sectors
+is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+is( $db2->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+
+delete $db->{foo};
+
+is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+
+__END__
+warn "-2\n";
+$db2->begin_work;
+
+warn "-1\n";
+ delete $db2->{bar};
+
+warn "0\n";
+$db2->commit;
+
+warn "1\n";
+ok( !exists $db->{bar}, "After commit, bar is gone" );
+warn "2\n";
--- /dev/null
+use strict;
+use Test::More tests => 3;
+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,
+);
+
+is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
+Chains(B):
+Chains(D):
+Chains(I):
+00000030: H 0064 REF: 1
+__END_DUMP__
+
+$db->{foo} = 'bar';
+
+is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
+Chains(B):
+Chains(D):
+Chains(I):
+00000030: H 0064 REF: 1
+00000094: D 0064 bar
+00000158: B 0387
+ 00000545 00000094
+00000545: D 0064 foo
+__END_DUMP__
+
my %opts = (
man => 0,
help => 0,
- version => '1.0003',
+ version => '1.0004',
autobless => 1,
);
GetOptions( \%opts,
elsif ( $ver =~ /^1\.000?[0-2]?/) {
$ver = 2;
}
- elsif ( $ver =~ /^1\.000[3]/) {
+ elsif ( $ver =~ /^1\.000[34]/) {
$ver = 3;
}
else {
projects / dbsrgits/DBM-Deep.git / commitdiff