Revision history for DBM::Deep.
+1.0008 Mar 09 20:00:00 2008 EDT
+ - (This version is compatible with 1.0007)
+ - Fixed a number of Win32 issues (Reported by Steven Samelson - thank you!)
+ - Much thanks to Nigel Sandever and David Golden for their help
+ debugging the issues, particularly with DBM::Deep's usage of
+ File::Temp (which removes a number of warnings).
+ - Autovivification now works on Win32. It turns out that when a
+ process takes a shared flock on a file, it's not allowed to write to
+ it under Win32, unlike *nix. This is probably a good catch.
+ - Note: The fix is a hack. All locks are now exclusive until a
+ better fix is found.
+
1.0007 Jan 10 00:00:00 2008 EDT
- (This version is compatible with 1.0006)
- Applied a patch+failing test submitted by sprout@cpan.org. Thanks!
use strict;
use warnings;
-our $VERSION = q(1.0007);
+our $VERSION = q(1.0008);
use Fcntl qw( :flock );
# something here
$db->unlock();
+=head2 Win32/Cygwin
+
+Due to Win32 actually enforcing the read-only status of a shared lock, all
+locks on Win32 and cygwin are exclusive. This is because of how autovivification
+currently works. Hopefully, this will go away in a future release.
+
=head1 IMPORTING/EXPORTING
You can import existing complex structures by calling the C<import()> method,
=head1 CODE COVERAGE
-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.
+L<Devel::Cover/> is used to test the code coverage of the tests. Below is the
+L<Devel::Cover/> report on this distribution's test suite.
------------------------------------------ ------ ------ ------ ------ ------
File stmt bran cond sub total
use strict;
use warnings;
-our $VERSION = q(1.0007);
+our $VERSION = q(1.0008);
# 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.0007);
+our $VERSION = q(1.0008);
use Scalar::Util ();
);
my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, $buffer );
+ # XXX Merge the two if-clauses below
if ( $args->{trans_id} ) {
# We have found an entry that is old, so get rid of it
if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) {
idx => $args->{idx},
});
}
+
return $loc <= 1 ? 0 : $loc;
}
use strict;
use warnings;
-our $VERSION = q(1.0007);
+our $VERSION = q(1.0008);
use Fcntl qw( :DEFAULT :flock :seek );
seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
}
- print( $fh @_ );
+ print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
return 1;
}
$type = LOCK_EX unless defined $type;
+ #XXX This is a temporary fix for Win32 and autovivification. It
+ # needs to improve somehow. -RobK, 2008-03-09
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
+ $type = LOCK_EX;
+ }
+
if (!defined($self->{fh})) { return; }
+ #XXX This either needs to allow for upgrading a shared lock to an
+ # exclusive lock or something else with autovivification.
+ # -RobK, 2008-03-09
if ($self->{locking}) {
if (!$self->{locked}) {
flock($self->{fh}, $type);
use strict;
use warnings;
-our $VERSION = q(1.0007);
+our $VERSION = q(1.0008);
use base 'DBM::Deep';
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $db = DBM::Deep->new(
+ file => $filename,
+ fh => $fh,
+);
##
# put/get key
# Make sure DB still works after closing / opening
##
undef $db;
-$db = DBM::Deep->new( $filename );
+open $fh, '+<', $filename;
+$db = DBM::Deep->new(
+ file => $filename,
+ fh => $fh,
+);
is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" );
##
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_ARRAY
+ file => $filename,
+ fh => $fh,
+ type => DBM::Deep->TYPE_ARRAY
);
##
throws_ok {
$db->[-6] = 'whoops!';
-} qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown";
+} qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown";
my $popped = $db->pop;
is( $db->length, 4, "... and we have four after popping" );
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_ARRAY
);
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
+ file => $filename,
+ fh => $fh,
+ locking => 1,
);
lives_ok {
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_HASH,
);
}
{
+ open $fh, '+<', $filename;
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_HASH,
);
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_ARRAY,
);
}
{
+ open $fh, '+<', $filename;
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_ARRAY,
);
# DBM::Deep Test
##
use strict;
-use Test::More tests => 9;
-use File::Temp qw( tmpnam );
+use Test::More;
+
+plan skip_all => "Skipping the optimize tests on Win32/cygwin for now."
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
+
+plan tests => 9;
+
+use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
-my $filename = tmpnam();
+my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
- file => $filename,
- autoflush => 1,
+ file => $filename,
+ autoflush => 1,
);
##
is( $db->{key1}, 'value1', "key1's value is still there after optimize" );
is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" );
+$db->_get_self->_storage->close( $db->_get_self );
+
##
# now for the tricky one -- try to store a new key while file is being
-# optimized and locked by another process. filehandle should be invalidated,
-# and automatically re-opened transparently. Cannot test on Win32, due to
+# optimized and locked by another process. filehandle should be invalidated,
+# and automatically re-opened transparently. Cannot test on Win32, due to
# problems with fork()ing, flock()ing, etc. Win32 very bad.
##
SKIP: {
+ skip "Fork tests skipped until fh/filename question solved.", 4;
skip "Fork tests skipped on Win32", 4
if $^O eq 'MSWin32' || $^O eq 'cygwin';
##
- # first things first, get us about 1000 keys so the optimize() will take
+ # first things first, get us about 1000 keys so the optimize() will take
# at least a few seconds on any machine, and re-open db with locking
##
for (1..1000) { $db->STORE( $_, $_ +1 ); }
unless ( $pid ) {
# child fork
-
+
# re-open db
$db = DBM::Deep->new(
file => $filename,
autoflush => 1,
locking => 1
);
-
+
# optimize and exit
$db->optimize();
}
# parent fork
ok( defined($pid), "fork was successful" ); # make sure fork was successful
-
+
# re-open db
$db = DBM::Deep->new(
file => $filename,
# sleep for 1 second to make sure optimize() is running in the other fork
sleep(1);
-
+
# now, try to get a lock and store a key
$db->{parentfork} = "hello";
-
+
# see if it was stored successfully
is( $db->{parentfork}, "hello", "stored key while optimize took place" );
autoflush => 1,
locking => 1
);
-
+
# now check some existing values from before
is( $db->{key1}, 'value1', "key1's value is still there after optimize" );
is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" );
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $db = DBM::Deep->new( file => $filename, fh => $fh, );
##
# put/get simple keys
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
type => $type,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autobless => 1,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_ARRAY,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autobless => 1,
});
my $x;
my $struct = {
key1 => [
- 2, \$x, 3,
+ 2, \$x, 3,
],
};
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autobless => 1,
});
use_ok( 'DBM::Deep' );
my ($fh2, $filename2) = new_fh();
-my $db2 = DBM::Deep->new( $filename2 );
+my $db2 = DBM::Deep->new( file => $filename2, fh => $fh2, );
SKIP: {
skip "Apparently, we cannot detect a tied scalar?", 1;
{
my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
+ my $db = DBM::Deep->new( file => $filename, fh => $fh, );
##
# Create structure in $db
$hash{key1} = 'value';
is( $hash{key1}, 'value', 'Set and retrieved key1' );
+ tied( %hash )->_get_self->_storage->close( tied( %hash )->_get_self );
}
{
is( keys %hash, 1, "There's one key so far" );
ok( exists $hash{key1}, "... and it's key1" );
+ tied( %hash )->_get_self->_storage->close( tied( %hash )->_get_self );
}
{
file => $filename,
type => DBM::Deep->TYPE_ARRAY,
};
+ tied( @array )->_get_self->_storage->close( tied( @array )->_get_self );
} qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type";
}
{
my ($fh, $filename) = new_fh();
- DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY );
+ my $db = DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY );
throws_ok {
tie my %hash, 'DBM::Deep', {
type => DBM::Deep->TYPE_HASH,
};
} qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type";
+ $db->_get_self->_storage->close( $db->_get_self );
}
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $db = DBM::Deep->new( file => $filename, fh => $fh, );
##
# Create structure in $db
##
$db->import({
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2",
- },
+ hash1 => {
+ subkey1 => "subvalue1",
+ subkey2 => "subvalue2",
+ },
hash2 => {
subkey3 => 'subvalue3',
},
my ($fh2, $filename2) = new_fh();
{
- my $db = DBM::Deep->new( $filename2 );
+ my $db = DBM::Deep->new( file => $filename2, fh => $fh2, );
$db->{foo} = [ 1 .. 3 ];
for ( 0 .. $max_keys ) {
$db->{'foo' . $_} = $db->{foo};
}
+ ## Rewind handle otherwise the signature is not recognised below.
+ ## The signature check should probably rewind the fh?
+ seek $db->_get_self->_storage->{fh}, 0, 0;
}
{
- my $db = DBM::Deep->new( $filename2 );
+ my $db = DBM::Deep->new( fh => $fh2, );
my $base_offset = $db->{foo}->_base_offset;
my $count = -1;
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
autobless => 1,
);
is( $db->{unblessed}{b}[2], 3 );
$db->{blessed_long} = bless {}, 'a' x 1000;
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
is( $db->{blessed}{c}, 'new' );
isa_ok( $db->{blessed_long}, 'a' x 1000 );
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
my $structure = $db->export();
use Data::Dumper;print Dumper $structure;
-
+
my $obj = $structure->{blessed};
isa_ok( $obj, 'Foo' );
can_ok( $obj, 'export', 'foo' );
is( $structure->{unblessed}{b}[0], 1 );
is( $structure->{unblessed}{b}[1], 2 );
is( $structure->{unblessed}{b}[2], 3 );
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
is( $db->{unblessed}{b}[0], 1 );
is( $db->{unblessed}{b}[1], 2 );
is( $db->{unblessed}{b}[2], 3 );
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
{
my $db = DBM::Deep->new(
file => $filename2,
+ fh => $fh2,
autobless => 1,
);
my $obj = bless {
}, 'Foo';
$db->import( { blessed => $obj } );
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
my $blessed = $db->{blessed};
isa_ok( $blessed, 'Foo' );
is( $blessed->{a}, 1 );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
{
- ##
- # test blessing hash into short named class (Foo), then re-blessing into
- # longer named class (FooFoo) and replacing key in db file, then validating
- # content after that point in file to check for corruption.
- ##
+ ##
+ # test blessing hash into short named class (Foo), then re-blessing into
+ # longer named class (FooFoo) and replacing key in db file, then validating
+ # content after that point in file to check for corruption.
+ ##
my ($fh3, $filename3) = new_fh();
my $db = DBM::Deep->new(
file => $filename3,
+ fh => $fh3,
autobless => 1,
);
$db->{blessed} = $obj;
$db->{after} = "hello";
-
+
my $obj2 = bless {}, 'FooFoo';
-
+
$db->{blessed} = $obj2;
is( $db->{after}, "hello" );
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $db = DBM::Deep->new( file => $filename, fh => $fh, );
my %hash = (
foo => 1,
cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
SKIP: {
- skip "Optimize tests skipped on Win32", 5
+ skip "Optimize tests skipped on Win32", 7
if $^O eq 'MSWin32' || $^O eq 'cygwin';
$db1->optimize;
use t::common qw( new_fh );
+sub do_stuff {
+ my ($db) = @_;
+
+ $db->{foo}{bar} = [ 1 .. 3 ];
+}
+
+sub verify {
+ my ($db) = @_;
+
+ cmp_ok( $db->{foo}{bar}[2], '==', 3, "Correct value found" );
+}
+
use_ok( 'DBM::Deep' );
my %sizes;
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
data_sector_size => 32,
);
$sizes{32} = -s $filename;
{
- my $db = DBM::Deep->new( $filename );
+ my $db = DBM::Deep->new( file => $filename );
verify( $db );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
data_sector_size => 64,
);
{
my $db = DBM::Deep->new( $filename );
verify( $db );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
data_sector_size => 128,
);
{
my $db = DBM::Deep->new( $filename );
verify( $db );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
data_sector_size => 256,
);
{
my $db = DBM::Deep->new( $filename );
verify( $db );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
cmp_ok( $sizes{128}, '>', $sizes{64}, "Filesize for 128 > filesize for 64" );
cmp_ok( $sizes{64}, '>', $sizes{32}, "Filesize for 64 > filesize for 32" );
-sub do_stuff {
- my ($db) = @_;
-
- $db->{foo}{bar} = [ 1 .. 3 ];
-}
-
-sub verify {
- my ($db) = @_;
-
- cmp_ok( $db->{foo}{bar}[2], '==', 3, "Correct value found" );
-}
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autoflush => 1,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autoflush => 1,
});
# trigger a reindex. This requires knowing how much space is taken. Good thing
# we wrote this dreck ...
my $size = -s $filename;
-
+
my $data_sector_size = $db->_engine->data_sector_size;
my $expected = $size + 9 * ( 2 * $data_sector_size );
use strict;
-use Test::More tests => 33;
+use Test::More tests => 41;
use Test::Deep;
use t::common qw( new_fh );
my ($fh, $filename) = new_fh();
my $db1 = DBM::Deep->new(
file => $filename,
+ fh => $fh,
locking => 1,
autoflush => 1,
num_txns => 2,
);
+seek $db1->_get_self->_storage->{fh}, 0, 0;
my $db2 = DBM::Deep->new(
file => $filename,
+ fh => $fh,
locking => 1,
autoflush => 1,
num_txns => 2,
);
-$db1->{x} = { foo => 'y' };
-is( $db1->{x}{foo}, 'y', "Before transaction, DB1's X is Y" );
-is( $db2->{x}{foo}, 'y', "Before transaction, DB2's X is Y" );
+$db1->{x} = { xy => { foo => 'y' } };
+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" );
$db1->begin_work;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( foo )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X keys correct" );
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
- is( $db1->{x}{foo}, 'y', "After transaction, DB1's X is Y" );
- is( $db2->{x}{foo}, 'y', "After transaction, DB2's X is Y" );
+ 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->{x} = { bar => 30 };
- ok( !exists $db1->{x}{foo}, "DB1: After reassignment of X, X->FOO is gone" );
- is( $db2->{x}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" );
+ is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" );
+ is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( bar )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X keys correct" );
+ $db1->{x} = { yz => { bar => 30 } };
+ ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" );
+ is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" );
+
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
$db1->rollback;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-cmp_bag( [ keys %{$db1->{x}} ], [qw( foo )], "DB1->X keys correct" );
-cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X 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" );
-is( $db1->{x}{foo}, 'y', "Before transaction, DB1's X is Y" );
-is( $db2->{x}{foo}, 'y', "Before transaction, DB2's X is Y" );
+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" );
$db1->begin_work;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( foo )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X 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" );
- is( $db1->{x}{foo}, 'y', "After transaction, DB1's X is Y" );
- is( $db2->{x}{foo}, 'y', "After transaction, DB2's X is Y" );
+ is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" );
+ is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" );
- $db1->{x} = { bar => 30 };
- ok( !exists $db1->{x}{foo}, "DB1: After reassignment of X, X->FOO is gone" );
- is( $db2->{x}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" );
+ $db1->{x} = { yz => { bar => 30 } };
+ ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" );
+ is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X->YZ is Y" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( bar )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X keys correct" );
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
$db1->commit;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-cmp_bag( [ keys %{$db1->{x}} ], [qw( bar )], "DB1->X keys correct" );
-cmp_bag( [ keys %{$db2->{x}} ], [qw( bar )], "DB2->X keys correct" );
+cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+cmp_bag( [ keys %{$db2->{x}} ], [qw( yz )], "DB2->X keys correct" );
+
+cmp_bag( [ keys %{$db1->{x}{yz}} ], [qw( bar )], "DB1->X->XY keys correct" );
+cmp_bag( [ keys %{$db2->{x}{yz}} ], [qw( bar )], "DB2->X->XY keys correct" );
+
+$db1->_get_self->_storage->close( $db1->_get_self );
+$db2->_get_self->_storage->close( $db2->_get_self );
# Add skips here
BEGIN {
+ plan skip_all => "Skipping the upgrade_db.pl tests on Win32/cygwin for now."
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
+
my @failures;
eval { use Pod::Usage 1.3; }; push @failures, 'Pod::Usage' if $@;
eval { use IO::Scalar; }; push @failures, 'IO::Scalar' if $@;
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
locking => 1,
autoflush => 1,
num_txns => 16,
);
+seek $db->_get_self->_storage->{fh}, 0, 0;
+
my $db2 = DBM::Deep->new(
file => $filename,
+ fh => $fh,
locking => 1,
autoflush => 1,
num_txns => 16,
#my $dir = tempdir( DIR => '.' );
sub new_fh {
- my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir );
+ my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir, UNLINK => 1 );
# This is because tempfile() returns a flock'ed $fh on MacOSX.
flock $fh, LOCK_UN;
projects / dbsrgits/DBM-Deep.git / commitdiff