'File::Path' => '0.01',
'File::Temp' => '0.01',
'Pod::Usage' => '1.3',
+ 'Test::More' => '0.88',
'Test::Deep' => '0.095',
'Test::Warn' => '0.08',
- 'Test::More' => '0.61',
'Test::Exception' => '0.21',
'IO::Scalar' => '0.01',
},
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 3;
+use warnings FATAL => 'all';
+
+use Test::More;
use t::common qw( new_fh );
my $db = eval {
local $SIG{__DIE__};
DBM::Deep->new( $filename );
-};
-if ( $@ ) {
+}; if ( $@ ) {
diag "ERROR: $@";
Test::More->builder->BAIL_OUT( "Opening a new file fails." );
}
ok(1, "We can successfully open a file!" );
$db->{foo} = 'bar';
+is( $db->{foo}, 'bar', 'We can write and read.' );
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 49;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_dbm );
my $dbm_factory = new_dbm();
while ( my $dbm_maker = $dbm_factory->() ) {
-my $db = $dbm_maker->();
-
-##
-# put/get key
-##
-$db->{key1} = "value1";
-is( $db->get("key1"), "value1", "get() works with hash assignment" );
-is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" );
-is( $db->{key1}, "value1", "... and hash-access also works" );
-
-$db->put("key2", undef);
-is( $db->get("key2"), undef, "get() works with put()" );
-is( $db->fetch("key2"), undef, "... fetch() works with put()" );
-is( $db->{key2}, undef, "... and hash-access also works" );
-
-$db->store( "key3", "value3" );
-is( $db->get("key3"), "value3", "get() works with store()" );
-is( $db->fetch("key3"), "value3", "... fetch() works with put()" );
-is( $db->{key3}, 'value3', "... and hash-access also works" );
-
-# Verify that the keyval pairs are still correct.
-is( $db->{key1}, "value1", "Key1 is still correct" );
-is( $db->{key2}, undef, "Key2 is still correct" );
-is( $db->{key3}, 'value3', "Key3 is still correct" );
-
-ok( $db->exists("key1"), "exists() function works" );
-ok( exists $db->{key2}, "exists() works against tied hash" );
-
-ok( !exists $db->{key4}, "exists() function works for keys that aren't there" );
-is( $db->{key4}, undef, "Autovivified key4" );
-ok( exists $db->{key4}, "Autovivified key4 now exists" );
-
-delete $db->{key4};
-ok( !exists $db->{key4}, "And key4 doesn't exists anymore" );
-
-# Keys will be done via an iterator that keeps a breadcrumb trail of the last
-# key it provided. There will also be an "edit revision number" on the
-# reference so that resetting the iterator can be done.
-#
-# Q: How do we make sure that the iterator is unique? Is it supposed to be?
-
-##
-# count keys
-##
-is( scalar keys %$db, 3, "keys() works against tied hash" );
-
-##
-# step through keys
-##
-my $temphash = {};
-while ( my ($key, $value) = each %$db ) {
- $temphash->{$key} = $value;
-}
-
-is( $temphash->{key1}, 'value1', "First key copied successfully using tied interface" );
-is( $temphash->{key2}, undef, "Second key copied successfully" );
-is( $temphash->{key3}, 'value3', "Third key copied successfully" );
-
-$temphash = {};
-my $key = $db->first_key();
-while ($key) {
- $temphash->{$key} = $db->get($key);
- $key = $db->next_key($key);
+ my $db = $dbm_maker->();
+
+ ##
+ # put/get key
+ ##
+ $db->{key1} = "value1";
+ is( $db->get("key1"), "value1", "get() works with hash assignment" );
+ is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" );
+ is( $db->{key1}, "value1", "... and hash-access also works" );
+
+ $db->put("key2", undef);
+ is( $db->get("key2"), undef, "get() works with put()" );
+ is( $db->fetch("key2"), undef, "... fetch() works with put()" );
+ is( $db->{key2}, undef, "... and hash-access also works" );
+
+ $db->store( "key3", "value3" );
+ is( $db->get("key3"), "value3", "get() works with store()" );
+ is( $db->fetch("key3"), "value3", "... fetch() works with put()" );
+ is( $db->{key3}, 'value3', "... and hash-access also works" );
+
+ # Verify that the keyval pairs are still correct.
+ is( $db->{key1}, "value1", "Key1 is still correct" );
+ is( $db->{key2}, undef, "Key2 is still correct" );
+ is( $db->{key3}, 'value3', "Key3 is still correct" );
+
+ ok( $db->exists("key1"), "exists() function works" );
+ ok( exists $db->{key2}, "exists() works against tied hash" );
+
+ ok( !exists $db->{key4}, "exists() function works for keys that aren't there" );
+ is( $db->{key4}, undef, "Autovivified key4" );
+ ok( exists $db->{key4}, "Autovivified key4 now exists" );
+
+ delete $db->{key4};
+ ok( !exists $db->{key4}, "And key4 doesn't exists anymore" );
+
+ # Keys will be done via an iterator that keeps a breadcrumb trail of the last
+ # key it provided. There will also be an "edit revision number" on the
+ # reference so that resetting the iterator can be done.
+ #
+ # Q: How do we make sure that the iterator is unique? Is it supposed to be?
+
+ ##
+ # count keys
+ ##
+ is( scalar keys %$db, 3, "keys() works against tied hash" );
+
+ ##
+ # step through keys
+ ##
+ my $temphash = {};
+ while ( my ($key, $value) = each %$db ) {
+ $temphash->{$key} = $value;
+ }
+
+ is( $temphash->{key1}, 'value1', "First key copied successfully using tied interface" );
+ is( $temphash->{key2}, undef, "Second key copied successfully" );
+ is( $temphash->{key3}, 'value3', "Third key copied successfully" );
+
+ $temphash = {};
+ my $key = $db->first_key();
+ while ($key) {
+ $temphash->{$key} = $db->get($key);
+ $key = $db->next_key($key);
+ }
+
+ is( $temphash->{key1}, 'value1', "First key copied successfully using OO interface" );
+ is( $temphash->{key2}, undef, "Second key copied successfully" );
+ is( $temphash->{key3}, 'value3', "Third key copied successfully" );
+
+ ##
+ # delete keys
+ ##
+ is( delete $db->{key2}, undef, "delete through tied inteface works" );
+ is( $db->delete("key1"), 'value1', "delete through OO inteface works" );
+ is( $db->{key3}, 'value3', "The other key is still there" );
+ ok( !exists $db->{key1}, "key1 doesn't exist" );
+ ok( !exists $db->{key2}, "key2 doesn't exist" );
+
+ is( scalar keys %$db, 1, "After deleting two keys, 1 remains" );
+
+ ##
+ # delete all keys
+ ##
+ ok( $db->clear(), "clear() returns true" );
+
+ is( scalar keys %$db, 0, "After clear(), everything is removed" );
+
+ ##
+ # replace key
+ ##
+ $db->put("key1", "value1");
+ is( $db->get("key1"), "value1", "Assignment still works" );
+
+ $db->put("key1", "value2");
+ is( $db->get("key1"), "value2", "... and replacement works" );
+
+ $db->put("key1", "value222222222222222222222222");
+ is( $db->get("key1"), "value222222222222222222222222", "We set a value before closing the file" );
+
+ ##
+ # Make sure DB still works after closing / opening
+ ##
+ undef $db;
+ $db = $dbm_maker->();
+ is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" );
+
+ ##
+ # Make sure keys are still fetchable after replacing values
+ # with smaller ones (bug found by John Cardenas, DBM::Deep 0.93)
+ ##
+ $db->clear();
+ $db->put("key1", "long value here");
+ $db->put("key2", "longer value here");
+
+ $db->put("key1", "short value");
+ $db->put("key2", "shorter v");
+
+ my $first_key = $db->first_key();
+ my $next_key = $db->next_key($first_key);
+
+ ok(
+ (($first_key eq "key1") || ($first_key eq "key2")) &&
+ (($next_key eq "key1") || ($next_key eq "key2")) &&
+ ($first_key ne $next_key)
+ ,"keys() still works if you replace long values with shorter ones"
+ );
+
+ # Test autovivification
+ $db->{unknown}{bar} = 1;
+ ok( $db->{unknown}, 'Autovivified hash exists' );
+ cmp_ok( $db->{unknown}{bar}, '==', 1, 'And the value stored is there' );
+
+ # Test failures
+ throws_ok {
+ $db->fetch();
+ } qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key";
+
+ throws_ok {
+ $db->fetch(undef);
+ } qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key";
+
+ throws_ok {
+ $db->store();
+ } qr/Cannot use an undefined hash key/, "STORE fails on an undefined key";
+
+ throws_ok {
+ $db->store(undef, undef);
+ } qr/Cannot use an undefined hash key/, "STORE fails on an undefined key";
+
+ throws_ok {
+ $db->delete();
+ } qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key";
+
+ throws_ok {
+ $db->delete(undef);
+ } qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key";
+
+ throws_ok {
+ $db->exists();
+ } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
+
+ throws_ok {
+ $db->exists(undef);
+ } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
}
-is( $temphash->{key1}, 'value1', "First key copied successfully using OO interface" );
-is( $temphash->{key2}, undef, "Second key copied successfully" );
-is( $temphash->{key3}, 'value3', "Third key copied successfully" );
-
-##
-# delete keys
-##
-is( delete $db->{key2}, undef, "delete through tied inteface works" );
-is( $db->delete("key1"), 'value1', "delete through OO inteface works" );
-is( $db->{key3}, 'value3', "The other key is still there" );
-ok( !exists $db->{key1}, "key1 doesn't exist" );
-ok( !exists $db->{key2}, "key2 doesn't exist" );
-
-is( scalar keys %$db, 1, "After deleting two keys, 1 remains" );
-
-##
-# delete all keys
-##
-ok( $db->clear(), "clear() returns true" );
-
-is( scalar keys %$db, 0, "After clear(), everything is removed" );
-
-##
-# replace key
-##
-$db->put("key1", "value1");
-is( $db->get("key1"), "value1", "Assignment still works" );
-
-$db->put("key1", "value2");
-is( $db->get("key1"), "value2", "... and replacement works" );
-
-$db->put("key1", "value222222222222222222222222");
-is( $db->get("key1"), "value222222222222222222222222", "We set a value before closing the file" );
-
-##
-# Make sure DB still works after closing / opening
-##
-undef $db;
-$db = $dbm_maker->();
-is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" );
-
-##
-# Make sure keys are still fetchable after replacing values
-# with smaller ones (bug found by John Cardenas, DBM::Deep 0.93)
-##
-$db->clear();
-$db->put("key1", "long value here");
-$db->put("key2", "longer value here");
-
-$db->put("key1", "short value");
-$db->put("key2", "shorter v");
-
-my $first_key = $db->first_key();
-my $next_key = $db->next_key($first_key);
-
-ok(
- (($first_key eq "key1") || ($first_key eq "key2")) &&
- (($next_key eq "key1") || ($next_key eq "key2")) &&
- ($first_key ne $next_key)
- ,"keys() still works if you replace long values with shorter ones"
-);
-
-# Test autovivification
-$db->{unknown}{bar} = 1;
-ok( $db->{unknown}, 'Autovivified hash exists' );
-cmp_ok( $db->{unknown}{bar}, '==', 1, 'And the value stored is there' );
-
-# Test failures
-throws_ok {
- $db->fetch();
-} qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key";
-
-throws_ok {
- $db->fetch(undef);
-} qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key";
-
-throws_ok {
- $db->store();
-} qr/Cannot use an undefined hash key/, "STORE fails on an undefined key";
-
-throws_ok {
- $db->store(undef, undef);
-} qr/Cannot use an undefined hash key/, "STORE fails on an undefined key";
-
-throws_ok {
- $db->delete();
-} qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key";
-
-throws_ok {
- $db->delete(undef);
-} qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key";
-
-throws_ok {
- $db->exists();
-} qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
-
-throws_ok {
- $db->exists(undef);
-} qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
-
-}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests"
unless $ENV{LONG_TESTS};
use Test::Deep;
-use t::common qw( new_fh );
-
-plan tests => 9;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-diag "This test can take up to a minute to run. Please be patient.";
-
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_HASH,
-);
-
-$db->{foo} = {};
-my $foo = $db->{foo};
-
-##
-# put/get many keys
-##
-my $max_keys = 4000;
-
-for ( 0 .. $max_keys ) {
- $foo->put( "hello $_" => "there " . $_ * 2 );
-}
-
-my $count = -1;
-for ( 0 .. $max_keys ) {
- $count = $_;
- unless ( $foo->get( "hello $_" ) eq "there " . $_ * 2 ) {
- last;
- };
+diag "This test can take up to several minutes to run. Please be patient.";
+
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_HASH );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ $db->{foo} = {};
+ my $foo = $db->{foo};
+
+ ##
+ # put/get many keys
+ ##
+ my $max_keys = 4000;
+
+ for ( 0 .. $max_keys ) {
+ $foo->put( "hello $_" => "there " . $_ * 2 );
+ }
+
+ my $count = -1;
+ for ( 0 .. $max_keys ) {
+ $count = $_;
+ unless ( $foo->get( "hello $_" ) eq "there " . $_ * 2 ) {
+ last;
+ };
+ }
+ is( $count, $max_keys, "We read $count keys" );
+
+ my @keys = sort keys %$foo;
+ cmp_ok( scalar(@keys), '==', $max_keys + 1, "Number of keys is correct" );
+ my @control = sort map { "hello $_" } 0 .. $max_keys;
+ cmp_deeply( \@keys, \@control, "Correct keys are there" );
+
+ ok( !exists $foo->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" );
+ is( $foo->{does_not_exist}, undef, "autovivification works on large hashes" );
+ ok( exists $foo->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" );
+ cmp_ok( scalar(keys %$foo), '==', $max_keys + 2, "Number of keys after autovivify is correct" );
+
+ $db->clear;
+ cmp_ok( scalar(keys %$db), '==', 0, "Number of keys after clear() is correct" );
}
-is( $count, $max_keys, "We read $count keys" );
-
-my @keys = sort keys %$foo;
-cmp_ok( scalar(@keys), '==', $max_keys + 1, "Number of keys is correct" );
-my @control = sort map { "hello $_" } 0 .. $max_keys;
-cmp_deeply( \@keys, \@control, "Correct keys are there" );
-
-ok( !exists $foo->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" );
-is( $foo->{does_not_exist}, undef, "autovivification works on large hashes" );
-ok( exists $foo->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" );
-cmp_ok( scalar(keys %$foo), '==', $max_keys + 2, "Number of keys after autovivify is correct" );
-$db->clear;
-cmp_ok( scalar(keys %$db), '==', 0, "Number of keys after clear() is correct" );
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 128;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_ARRAY
-);
-
-##
-# basic put/get/push
-##
-$db->[0] = "elem1";
-$db->push( "elem2" );
-$db->put(2, "elem3");
-$db->store(3, "elem4");
-$db->unshift("elem0");
-
-is( $db->[0], 'elem0', "Array get for shift works" );
-is( $db->[1], 'elem1', "Array get for array set works" );
-is( $db->[2], 'elem2', "Array get for push() works" );
-is( $db->[3], 'elem3', "Array get for put() works" );
-is( $db->[4], 'elem4', "Array get for store() works" );
-
-is( $db->get(0), 'elem0', "get() for shift() works" );
-is( $db->get(1), 'elem1', "get() for array set works" );
-is( $db->get(2), 'elem2', "get() for push() works" );
-is( $db->get(3), 'elem3', "get() for put() works" );
-is( $db->get(4), 'elem4', "get() for store() works" );
-
-is( $db->fetch(0), 'elem0', "fetch() for shift() works" );
-is( $db->fetch(1), 'elem1', "fetch() for array set works" );
-is( $db->fetch(2), 'elem2', "fetch() for push() works" );
-is( $db->fetch(3), 'elem3', "fetch() for put() works" );
-is( $db->fetch(4), 'elem4', "fetch() for store() works" );
-
-is( $db->length, 5, "... and we have five elements" );
-
-is( $db->[-1], $db->[4], "-1st index is 4th index" );
-is( $db->[-2], $db->[3], "-2nd index is 3rd index" );
-is( $db->[-3], $db->[2], "-3rd index is 2nd index" );
-is( $db->[-4], $db->[1], "-4th index is 1st index" );
-is( $db->[-5], $db->[0], "-5th index is 0th index" );
-
-# This is for Perls older than 5.8.0 because of is()'s prototype
-{ my $v = $db->[-6]; is( $v, undef, "-6th index is undef" ); }
-
-is( $db->length, 5, "... and we have five elements after abortive -6 index lookup" );
-
-$db->[-1] = 'elem4.1';
-is( $db->[-1], 'elem4.1' );
-is( $db->[4], 'elem4.1' );
-is( $db->get(4), 'elem4.1' );
-is( $db->fetch(4), 'elem4.1' );
-
-throws_ok {
- $db->[-6] = 'whoops!';
-} 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" );
-is( $db->[0], 'elem0', "0th element still there after popping" );
-is( $db->[1], 'elem1', "1st element still there after popping" );
-is( $db->[2], 'elem2', "2nd element still there after popping" );
-is( $db->[3], 'elem3', "3rd element still there after popping" );
-is( $popped, 'elem4.1', "Popped value is correct" );
-
-my $shifted = $db->shift;
-is( $db->length, 3, "... and we have three after shifting" );
-is( $db->[0], 'elem1', "0th element still there after shifting" );
-is( $db->[1], 'elem2', "1st element still there after shifting" );
-is( $db->[2], 'elem3', "2nd element still there after shifting" );
-is( $db->[3], undef, "There is no third element now" );
-is( $shifted, 'elem0', "Shifted value is correct" );
-
-##
-# delete
-##
-my $deleted = $db->delete(0);
-is( $db->length, 3, "... and we still have three after deleting" );
-is( $db->[0], undef, "0th element now undef" );
-is( $db->[1], 'elem2', "1st element still there after deleting" );
-is( $db->[2], 'elem3', "2nd element still there after deleting" );
-is( $deleted, 'elem1', "Deleted value is correct" );
-
-is( $db->delete(99), undef, 'delete on an element not in the array returns undef' );
-is( $db->length, 3, "... and we still have three after a delete on an out-of-range index" );
-
-is( delete $db->[99], undef, 'DELETE on an element not in the array returns undef' );
-is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range index" );
-
-is( $db->delete(-99), undef, 'delete on an element (neg) not in the array returns undef' );
-is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
-
-is( delete $db->[-99], undef, 'DELETE on an element (neg) not in the array returns undef' );
-is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
-
-$deleted = $db->delete(-2);
-is( $db->length, 3, "... and we still have three after deleting" );
-is( $db->[0], undef, "0th element still undef" );
-is( $db->[1], undef, "1st element now undef" );
-is( $db->[2], 'elem3', "2nd element still there after deleting" );
-is( $deleted, 'elem2', "Deleted value is correct" );
-
-$db->[1] = 'elem2';
-
-##
-# exists
-##
-ok( $db->exists(1), "The 1st value exists" );
-ok( $db->exists(0), "The 0th value doesn't exist" );
-ok( !$db->exists(22), "The 22nd value doesn't exists" );
-ok( $db->exists(-1), "The -1st value does exists" );
-ok( !$db->exists(-22), "The -22nd value doesn't exists" );
-
-##
-# clear
-##
-ok( $db->clear(), "clear() returns true if the file was ever non-empty" );
-is( $db->length(), 0, "After clear(), no more elements" );
-
-is( $db->pop, undef, "pop on an empty array returns undef" );
-is( $db->length(), 0, "After pop() on empty array, length is still 0" );
-
-is( $db->shift, undef, "shift on an empty array returns undef" );
-is( $db->length(), 0, "After shift() on empty array, length is still 0" );
-
-is( $db->unshift( 1, 2, 3 ), 3, "unshift returns the number of elements in the array" );
-is( $db->unshift( 1, 2, 3 ), 6, "unshift returns the number of elements in the array" );
-is( $db->push( 1, 2, 3 ), 9, "push returns the number of elements in the array" );
-
-is( $db->length(), 9, "After unshift and push on empty array, length is now 9" );
-
-$db->clear;
-
-##
-# multi-push
-##
-$db->push( 'elem first', "elem middle", "elem last" );
-is( $db->length, 3, "3-element push results in three elements" );
-is($db->[0], "elem first", "First element is 'elem first'");
-is($db->[1], "elem middle", "Second element is 'elem middle'");
-is($db->[2], "elem last", "Third element is 'elem last'");
-
-##
-# splice with length 1
-##
-my @returned = $db->splice( 1, 1, "middle A", "middle B" );
-is( scalar(@returned), 1, "One element was removed" );
-is( $returned[0], 'elem middle', "... and it was correctly removed" );
-is($db->length(), 4);
-is($db->[0], "elem first");
-is($db->[1], "middle A");
-is($db->[2], "middle B");
-is($db->[3], "elem last");
-
-##
-# splice with length of 0
-##
-@returned = $db->splice( -1, 0, "middle C" );
-is( scalar(@returned), 0, "No elements were removed" );
-is($db->length(), 5);
-is($db->[0], "elem first");
-is($db->[1], "middle A");
-is($db->[2], "middle B");
-is($db->[3], "middle C");
-is($db->[4], "elem last");
-
-##
-# splice with length of 3
-##
-my $returned = $db->splice( 1, 3, "middle ABC" );
-is( $returned, 'middle C', "Just the last element was returned" );
-is($db->length(), 3);
-is($db->[0], "elem first");
-is($db->[1], "middle ABC");
-is($db->[2], "elem last");
-
-@returned = $db->splice( 1 );
-is($db->length(), 1);
-is($db->[0], "elem first");
-is($returned[0], "middle ABC");
-is($returned[1], "elem last");
-
-$db->push( @returned );
-
-@returned = $db->splice( 1, -1 );
-is($db->length(), 2);
-is($db->[0], "elem first");
-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" );
-is( $db->[1]->fetch('a'), 'foo', "Reuse of same space with hash successful" );
-
-# Test autovivification
-$db->[9999]{bar} = 1;
-ok( $db->[9999] );
-cmp_ok( $db->[9999]{bar}, '==', 1 );
-
-# Test failures
-throws_ok {
- $db->fetch( 'foo' );
-} qr/Cannot use 'foo' as an array index/, "FETCH fails on an illegal key";
-
-throws_ok {
- $db->fetch();
-} qr/Cannot use an undefined array index/, "FETCH fails on an undefined key";
-
-throws_ok {
- $db->store( 'foo', 'bar' );
-} qr/Cannot use 'foo' as an array index/, "STORE fails on an illegal key";
-
-throws_ok {
- $db->store();
-} qr/Cannot use an undefined array index/, "STORE fails on an undefined key";
-
-throws_ok {
- $db->delete( 'foo' );
-} qr/Cannot use 'foo' as an array index/, "DELETE fails on an illegal key";
-
-throws_ok {
- $db->delete();
-} qr/Cannot use an undefined array index/, "DELETE fails on an undefined key";
-
-throws_ok {
- $db->exists( 'foo' );
-} qr/Cannot use 'foo' as an array index/, "EXISTS fails on an illegal key";
-
-throws_ok {
- $db->exists();
-} qr/Cannot use an undefined array index/, "EXISTS fails on an undefined key";
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # basic put/get/push
+ ##
+ $db->[0] = "elem1";
+ $db->push( "elem2" );
+ $db->put(2, "elem3");
+ $db->store(3, "elem4");
+ $db->unshift("elem0");
+
+ is( $db->[0], 'elem0', "Array get for shift works" );
+ is( $db->[1], 'elem1', "Array get for array set works" );
+ is( $db->[2], 'elem2', "Array get for push() works" );
+ is( $db->[3], 'elem3', "Array get for put() works" );
+ is( $db->[4], 'elem4', "Array get for store() works" );
+
+ is( $db->get(0), 'elem0', "get() for shift() works" );
+ is( $db->get(1), 'elem1', "get() for array set works" );
+ is( $db->get(2), 'elem2', "get() for push() works" );
+ is( $db->get(3), 'elem3', "get() for put() works" );
+ is( $db->get(4), 'elem4', "get() for store() works" );
+
+ is( $db->fetch(0), 'elem0', "fetch() for shift() works" );
+ is( $db->fetch(1), 'elem1', "fetch() for array set works" );
+ is( $db->fetch(2), 'elem2', "fetch() for push() works" );
+ is( $db->fetch(3), 'elem3', "fetch() for put() works" );
+ is( $db->fetch(4), 'elem4', "fetch() for store() works" );
+
+ is( $db->length, 5, "... and we have five elements" );
+
+ is( $db->[-1], $db->[4], "-1st index is 4th index" );
+ is( $db->[-2], $db->[3], "-2nd index is 3rd index" );
+ is( $db->[-3], $db->[2], "-3rd index is 2nd index" );
+ is( $db->[-4], $db->[1], "-4th index is 1st index" );
+ is( $db->[-5], $db->[0], "-5th index is 0th index" );
+
+ # This is for Perls older than 5.8.0 because of is()'s prototype
+ { my $v = $db->[-6]; is( $v, undef, "-6th index is undef" ); }
+
+ is( $db->length, 5, "... and we have five elements after abortive -6 index lookup" );
+
+ $db->[-1] = 'elem4.1';
+ is( $db->[-1], 'elem4.1' );
+ is( $db->[4], 'elem4.1' );
+ is( $db->get(4), 'elem4.1' );
+ is( $db->fetch(4), 'elem4.1' );
+
+ throws_ok {
+ $db->[-6] = 'whoops!';
+ } 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" );
+ is( $db->[0], 'elem0', "0th element still there after popping" );
+ is( $db->[1], 'elem1', "1st element still there after popping" );
+ is( $db->[2], 'elem2', "2nd element still there after popping" );
+ is( $db->[3], 'elem3', "3rd element still there after popping" );
+ is( $popped, 'elem4.1', "Popped value is correct" );
+
+ my $shifted = $db->shift;
+ is( $db->length, 3, "... and we have three after shifting" );
+ is( $db->[0], 'elem1', "0th element still there after shifting" );
+ is( $db->[1], 'elem2', "1st element still there after shifting" );
+ is( $db->[2], 'elem3', "2nd element still there after shifting" );
+ is( $db->[3], undef, "There is no third element now" );
+ is( $shifted, 'elem0', "Shifted value is correct" );
+
+ ##
+ # delete
+ ##
+ my $deleted = $db->delete(0);
+ is( $db->length, 3, "... and we still have three after deleting" );
+ is( $db->[0], undef, "0th element now undef" );
+ is( $db->[1], 'elem2', "1st element still there after deleting" );
+ is( $db->[2], 'elem3', "2nd element still there after deleting" );
+ is( $deleted, 'elem1', "Deleted value is correct" );
+
+ is( $db->delete(99), undef, 'delete on an element not in the array returns undef' );
+ is( $db->length, 3, "... and we still have three after a delete on an out-of-range index" );
+
+ is( delete $db->[99], undef, 'DELETE on an element not in the array returns undef' );
+ is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range index" );
+
+ is( $db->delete(-99), undef, 'delete on an element (neg) not in the array returns undef' );
+ is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
+
+ is( delete $db->[-99], undef, 'DELETE on an element (neg) not in the array returns undef' );
+ is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
+
+ $deleted = $db->delete(-2);
+ is( $db->length, 3, "... and we still have three after deleting" );
+ is( $db->[0], undef, "0th element still undef" );
+ is( $db->[1], undef, "1st element now undef" );
+ is( $db->[2], 'elem3', "2nd element still there after deleting" );
+ is( $deleted, 'elem2', "Deleted value is correct" );
+
+ $db->[1] = 'elem2';
+
+ ##
+ # exists
+ ##
+ ok( $db->exists(1), "The 1st value exists" );
+ ok( $db->exists(0), "The 0th value doesn't exist" );
+ ok( !$db->exists(22), "The 22nd value doesn't exists" );
+ ok( $db->exists(-1), "The -1st value does exists" );
+ ok( !$db->exists(-22), "The -22nd value doesn't exists" );
+
+ ##
+ # clear
+ ##
+ ok( $db->clear(), "clear() returns true if the file was ever non-empty" );
+ is( $db->length(), 0, "After clear(), no more elements" );
+
+ is( $db->pop, undef, "pop on an empty array returns undef" );
+ is( $db->length(), 0, "After pop() on empty array, length is still 0" );
+
+ is( $db->shift, undef, "shift on an empty array returns undef" );
+ is( $db->length(), 0, "After shift() on empty array, length is still 0" );
+
+ is( $db->unshift( 1, 2, 3 ), 3, "unshift returns the number of elements in the array" );
+ is( $db->unshift( 1, 2, 3 ), 6, "unshift returns the number of elements in the array" );
+ is( $db->push( 1, 2, 3 ), 9, "push returns the number of elements in the array" );
+
+ is( $db->length(), 9, "After unshift and push on empty array, length is now 9" );
+
+ $db->clear;
+
+ ##
+ # multi-push
+ ##
+ $db->push( 'elem first', "elem middle", "elem last" );
+ is( $db->length, 3, "3-element push results in three elements" );
+ is($db->[0], "elem first", "First element is 'elem first'");
+ is($db->[1], "elem middle", "Second element is 'elem middle'");
+ is($db->[2], "elem last", "Third element is 'elem last'");
+
+ ##
+ # splice with length 1
+ ##
+ my @returned = $db->splice( 1, 1, "middle A", "middle B" );
+ is( scalar(@returned), 1, "One element was removed" );
+ is( $returned[0], 'elem middle', "... and it was correctly removed" );
+ is($db->length(), 4);
+ is($db->[0], "elem first");
+ is($db->[1], "middle A");
+ is($db->[2], "middle B");
+ is($db->[3], "elem last");
+
+ ##
+ # splice with length of 0
+ ##
+ @returned = $db->splice( -1, 0, "middle C" );
+ is( scalar(@returned), 0, "No elements were removed" );
+ is($db->length(), 5);
+ is($db->[0], "elem first");
+ is($db->[1], "middle A");
+ is($db->[2], "middle B");
+ is($db->[3], "middle C");
+ is($db->[4], "elem last");
+
+ ##
+ # splice with length of 3
+ ##
+ my $returned = $db->splice( 1, 3, "middle ABC" );
+ is( $returned, 'middle C', "Just the last element was returned" );
+ is($db->length(), 3);
+ is($db->[0], "elem first");
+ is($db->[1], "middle ABC");
+ is($db->[2], "elem last");
+
+ @returned = $db->splice( 1 );
+ is($db->length(), 1);
+ is($db->[0], "elem first");
+ is($returned[0], "middle ABC");
+ is($returned[1], "elem last");
+
+ $db->push( @returned );
+
+ @returned = $db->splice( 1, -1 );
+ is($db->length(), 2);
+ is($db->[0], "elem first");
+ 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" );
+ is( $db->[1]->fetch('a'), 'foo', "Reuse of same space with hash successful" );
+
+ # Test autovivification
+ $db->[9999]{bar} = 1;
+ ok( $db->[9999] );
+ cmp_ok( $db->[9999]{bar}, '==', 1 );
+
+ # Test failures
+ throws_ok {
+ $db->fetch( 'foo' );
+ } qr/Cannot use 'foo' as an array index/, "FETCH fails on an illegal key";
+
+ throws_ok {
+ $db->fetch();
+ } qr/Cannot use an undefined array index/, "FETCH fails on an undefined key";
+
+ throws_ok {
+ $db->store( 'foo', 'bar' );
+ } qr/Cannot use 'foo' as an array index/, "STORE fails on an illegal key";
+
+ throws_ok {
+ $db->store();
+ } qr/Cannot use an undefined array index/, "STORE fails on an undefined key";
+
+ throws_ok {
+ $db->delete( 'foo' );
+ } qr/Cannot use 'foo' as an array index/, "DELETE fails on an illegal key";
+
+ throws_ok {
+ $db->delete();
+ } qr/Cannot use an undefined array index/, "DELETE fails on an undefined key";
+
+ throws_ok {
+ $db->exists( 'foo' );
+ } qr/Cannot use 'foo' as an array index/, "EXISTS fails on an illegal key";
+
+ throws_ok {
+ $db->exists();
+ } qr/Cannot use an undefined array index/, "EXISTS fails on an undefined key";
+}
# Bug reported by Mike Schilli
# Also, RT #29583 reported by HANENKAMP
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- type => DBM::Deep->TYPE_ARRAY
- );
+$dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
push @{$db}, 3, { foo => 1 };
lives_ok {
is( $db->[4][3][1], 2, "Right arrayref there" );
is( $db->[5]{foo}, 1, "Right hashref there" );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests"
unless $ENV{LONG_TESTS};
-plan tests => 4;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-diag "This test can take up to a minute to run. Please be patient.";
-
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_ARRAY,
-);
-
-##
-# put/get many keys
-##
-my $max_keys = 4000;
-
-for ( 0 .. $max_keys ) {
- $db->put( $_ => $_ * 2 );
-}
-
-my $count = -1;
-for ( 0 .. $max_keys ) {
- $count = $_;
- unless ( $db->get( $_ ) == $_ * 2 ) {
- last;
- };
+diag "This test can take up to several minutes to run. Please be patient.";
+
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # put/get many keys
+ ##
+ my $max_keys = 4000;
+
+ for ( 0 .. $max_keys ) {
+ $db->put( $_ => $_ * 2 );
+ }
+
+ my $count = -1;
+ for ( 0 .. $max_keys ) {
+ $count = $_;
+ unless ( $db->get( $_ ) == $_ * 2 ) {
+ last;
+ };
+ }
+ is( $count, $max_keys, "We read $count keys" );
+
+ cmp_ok( scalar(@$db), '==', $max_keys + 1, "Number of elements is correct" );
+ $db->clear;
+ cmp_ok( scalar(@$db), '==', 0, "Number of elements after clear() is correct" );
}
-is( $count, $max_keys, "We read $count keys" );
-cmp_ok( scalar(@$db), '==', $max_keys + 1, "Number of elements is correct" );
-$db->clear;
-cmp_ok( scalar(@$db), '==', 0, "Number of elements after clear() is correct" );
+done_testing;
-##
-# DBM::Deep Test
-##
+
$|++;
use strict;
-use Test::More tests => 23;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use Test::Warn;
use t::common qw( new_fh );
DBM::Deep->new( 't/etc/db-0-99_04' );
} qr/DBM::Deep: Wrong file version found - 1 - expected 3/, "Fail if opening a file version 1";
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 5;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
-);
-
-lives_ok {
- $db->unlock;
-} "Can call unlock on an unlocked DB.";
-
-##
-# basic put/get
-##
-$db->{key1} = "value1";
-is( $db->{key1}, "value1", "key1 is set" );
-
-$db->{key2} = [ 1 .. 3 ];
-is( $db->{key2}[1], 2, "The value is set properly" );
-
-##
-# explicit lock
-##
-$db->lock_exclusive;
-$db->{key1} = "value2";
-$db->unlock();
-is( $db->{key1}, "value2", "key1 is overridden" );
+my $dbm_factory = new_dbm( locking => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ lives_ok {
+ $db->unlock;
+ } "Can call unlock on an unlocked DB.";
+
+ ##
+ # basic put/get
+ ##
+ $db->{key1} = "value1";
+ is( $db->{key1}, "value1", "key1 is set" );
+
+ $db->{key2} = [ 1 .. 3 ];
+ is( $db->{key2}[1], 2, "The value is set properly" );
+
+ ##
+ # explicit lock
+ ##
+ $db->lock_exclusive;
+ $db->{key1} = "value2";
+ $db->unlock();
+ is( $db->{key1}, "value2", "key1 is overridden" );
+}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests"
unless $ENV{LONG_TESTS};
-plan tests => 5;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
-diag "This test can take up to a minute to run. Please be patient.";
+diag "This test can take up to several minutes to run. Please be patient.";
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-
-my $max_levels = 1000;
-
-{
- my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_HASH,
- );
-
- ##
- # basic deep hash
- ##
- $db->{company} = {};
- $db->{company}->{name} = "My Co.";
- $db->{company}->{employees} = {};
- $db->{company}->{employees}->{"Henry Higgins"} = {};
- $db->{company}->{employees}->{"Henry Higgins"}->{salary} = 90000;
-
- is( $db->{company}->{name}, "My Co.", "Set and retrieved a second-level value" );
- is( $db->{company}->{employees}->{"Henry Higgins"}->{salary}, 90000, "Set and retrieved a fourth-level value" );
-
- ##
- # super deep hash
- ##
- $db->{base_level} = {};
- my $temp_db = $db->{base_level};
-
- for my $k ( 0 .. $max_levels ) {
- $temp_db->{"level$k"} = {};
- $temp_db = $temp_db->{"level$k"};
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_HASH );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $max_levels = 1000;
+
+ {
+ my $db = $dbm_maker->();
+
+ ##
+ # basic deep hash
+ ##
+ $db->{company} = {};
+ $db->{company}->{name} = "My Co.";
+ $db->{company}->{employees} = {};
+ $db->{company}->{employees}->{"Henry Higgins"} = {};
+ $db->{company}->{employees}->{"Henry Higgins"}->{salary} = 90000;
+
+ is( $db->{company}->{name}, "My Co.", "Set and retrieved a second-level value" );
+ is( $db->{company}->{employees}->{"Henry Higgins"}->{salary}, 90000, "Set and retrieved a fourth-level value" );
+
+ ##
+ # super deep hash
+ ##
+ $db->{base_level} = {};
+ my $temp_db = $db->{base_level};
+
+ for my $k ( 0 .. $max_levels ) {
+ $temp_db->{"level$k"} = {};
+ $temp_db = $temp_db->{"level$k"};
+ }
+ $temp_db->{deepkey} = "deepvalue";
}
- $temp_db->{deepkey} = "deepvalue";
-}
-{
- open $fh, '+<', $filename;
- my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_HASH,
- );
-
- my $cur_level = -1;
- my $temp_db = $db->{base_level};
- for my $k ( 0 .. $max_levels ) {
- $cur_level = $k;
- $temp_db = $temp_db->{"level$k"};
- eval { $temp_db->isa( 'DBM::Deep' ) } or last;
+ {
+ my $db = $dbm_maker->();
+
+ my $cur_level = -1;
+ my $temp_db = $db->{base_level};
+ for my $k ( 0 .. $max_levels ) {
+ $cur_level = $k;
+ $temp_db = $temp_db->{"level$k"};
+ eval { $temp_db->isa( 'DBM::Deep' ) } or last;
+ }
+ is( $cur_level, $max_levels, "We read all the way down to level $cur_level" );
+ is( $temp_db->{deepkey}, "deepvalue", "And we retrieved the value at the bottom of the ocean" );
}
- is( $cur_level, $max_levels, "We read all the way down to level $cur_level" );
- is( $temp_db->{deepkey}, "deepvalue", "And we retrieved the value at the bottom of the ocean" );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests"
unless $ENV{LONG_TESTS};
-plan tests => 3;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
-diag "This test can take up to a minute to run. Please be patient.";
+diag "This test can take up to several minutes to run. Please be patient.";
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-
-my $max_levels = 1000;
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $max_levels = 1000;
-{
- my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_ARRAY,
- );
+ {
+ my $db = $dbm_maker->();
- $db->[0] = [];
- my $temp_db = $db->[0];
- for my $k ( 0 .. $max_levels ) {
- $temp_db->[$k] = [];
- $temp_db = $temp_db->[$k];
+ $db->[0] = [];
+ my $temp_db = $db->[0];
+ for my $k ( 0 .. $max_levels ) {
+ $temp_db->[$k] = [];
+ $temp_db = $temp_db->[$k];
+ }
+ $temp_db->[0] = "deepvalue";
}
- $temp_db->[0] = "deepvalue";
-}
-{
- open $fh, '+<', $filename;
- my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_ARRAY,
- );
-
- my $cur_level = -1;
- my $temp_db = $db->[0];
- for my $k ( 0 .. $max_levels ) {
- $cur_level = $k;
- $temp_db = $temp_db->[$k];
- eval { $temp_db->isa( 'DBM::Deep' ) } or last;
+ {
+ my $db = $dbm_maker->();
+
+ my $cur_level = -1;
+ my $temp_db = $db->[0];
+ for my $k ( 0 .. $max_levels ) {
+ $cur_level = $k;
+ $temp_db = $temp_db->[$k];
+ eval { $temp_db->isa( 'DBM::Deep' ) } or last;
+ }
+ is( $cur_level, $max_levels, "We read all the way down to level $cur_level" );
+ is( $temp_db->[0], "deepvalue", "And we retrieved the value at the bottom of the ocean" );
}
- is( $cur_level, $max_levels, "We read all the way down to level $cur_level" );
- is( $temp_db->[0], "deepvalue", "And we retrieved the value at the bottom of the ocean" );
}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 14;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
+
+use Test::More;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
-);
-
-##
-# large keys
-##
-my $key1 = "Now is the time for all good men to come to the aid of their country." x 100;
-my $key2 = "The quick brown fox jumped over the lazy, sleeping dog." x 1000;
-my $key3 = "Lorem dolor ipsum latinum suckum causum Ium cannotum rememberum squatum." x 1000;
-
-$db->put($key1, "value1");
-$db->store($key2, "value2");
-$db->{$key3} = "value3";
-
-is( $db->{$key1}, 'value1', "Hash retrieval of put()" );
-is( $db->{$key2}, 'value2', "Hash retrieval of store()" );
-is( $db->{$key3}, 'value3', "Hash retrieval of hashstore" );
-is( $db->get($key1), 'value1', "get() retrieval of put()" );
-is( $db->get($key2), 'value2', "get() retrieval of store()" );
-is( $db->get($key3), 'value3', "get() retrieval of hashstore" );
-is( $db->fetch($key1), 'value1', "fetch() retrieval of put()" );
-is( $db->fetch($key2), 'value2', "fetch() retrieval of store()" );
-is( $db->fetch($key3), 'value3', "fetch() retrieval of hashstore" );
-
-my $test_key = $db->first_key();
-ok(
- ($test_key eq $key1) ||
- ($test_key eq $key2) ||
- ($test_key eq $key3)
-);
-
-$test_key = $db->next_key($test_key);
-ok(
- ($test_key eq $key1) ||
- ($test_key eq $key2) ||
- ($test_key eq $key3)
-);
-
-$test_key = $db->next_key($test_key);
-ok(
- ($test_key eq $key1) ||
- ($test_key eq $key2) ||
- ($test_key eq $key3)
-);
-
-$test_key = $db->next_key($test_key);
-ok( !$test_key );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # large keys
+ ##
+ my $key1 = "Now is the time for all good men to come to the aid of their country." x 100;
+ my $key2 = "The quick brown fox jumped over the lazy, sleeping dog." x 1000;
+ my $key3 = "Lorem dolor ipsum latinum suckum causum Ium cannotum rememberum squatum." x 1000;
+
+ $db->put($key1, "value1");
+ $db->store($key2, "value2");
+ $db->{$key3} = "value3";
+
+ is( $db->{$key1}, 'value1', "Hash retrieval of put()" );
+ is( $db->{$key2}, 'value2', "Hash retrieval of store()" );
+ is( $db->{$key3}, 'value3', "Hash retrieval of hashstore" );
+ is( $db->get($key1), 'value1', "get() retrieval of put()" );
+ is( $db->get($key2), 'value2', "get() retrieval of store()" );
+ is( $db->get($key3), 'value3', "get() retrieval of hashstore" );
+ is( $db->fetch($key1), 'value1', "fetch() retrieval of put()" );
+ is( $db->fetch($key2), 'value2', "fetch() retrieval of store()" );
+ is( $db->fetch($key3), 'value3', "fetch() retrieval of hashstore" );
+
+ my $test_key = $db->first_key();
+ ok(
+ ($test_key eq $key1) ||
+ ($test_key eq $key2) ||
+ ($test_key eq $key3)
+ );
+
+ $test_key = $db->next_key($test_key);
+ ok(
+ ($test_key eq $key1) ||
+ ($test_key eq $key2) ||
+ ($test_key eq $key3)
+ );
+
+ $test_key = $db->next_key($test_key);
+ ok(
+ ($test_key eq $key1) ||
+ ($test_key eq $key2) ||
+ ($test_key eq $key3)
+ );
+
+ $test_key = $db->next_key($test_key);
+ ok( !$test_key );
+}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
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' );
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" );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 14;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
-use_ok( 'DBM::Deep' );
+use Test::More;
+use t::common qw( new_dbm );
-my ($fh, $filename) = new_fh();
+use_ok( 'DBM::Deep' );
-{
- my $clone;
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
{
- my $db = DBM::Deep->new(
- file => $filename,
- );
+ my $clone;
- $db->{key1} = "value1";
+ {
+ my $db = $dbm_maker->();
- ##
- # clone db handle, make sure both are usable
- ##
- $clone = $db->clone();
+ $db->{key1} = "value1";
- is($clone->{key1}, "value1");
+ ##
+ # clone db handle, make sure both are usable
+ ##
+ $clone = $db->clone();
- $clone->{key2} = "value2";
- $db->{key3} = "value3";
+ is($clone->{key1}, "value1");
- is($db->{key1}, "value1");
- is($db->{key2}, "value2");
- is($db->{key3}, "value3");
+ $clone->{key2} = "value2";
+ $db->{key3} = "value3";
+
+ is($db->{key1}, "value1");
+ is($db->{key2}, "value2");
+ is($db->{key3}, "value3");
+
+ is($clone->{key1}, "value1");
+ is($clone->{key2}, "value2");
+ is($clone->{key3}, "value3");
+ }
is($clone->{key1}, "value1");
is($clone->{key2}, "value2");
is($clone->{key3}, "value3");
}
- is($clone->{key1}, "value1");
- is($clone->{key2}, "value2");
- is($clone->{key3}, "value3");
-}
-
-{
- my $db = DBM::Deep->new(
- file => $filename,
- );
+ {
+ my $db = $dbm_maker->();
- is($db->{key1}, "value1");
- is($db->{key2}, "value2");
- is($db->{key3}, "value3");
+ is($db->{key1}, "value1");
+ is($db->{key2}, "value2");
+ is($db->{key3}, "value3");
+ }
}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Config;
-use Test::More tests => 10;
+use Test::More;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
# }
#
#}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 21;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
-);
+sub my_filter_store_key { return 'MYFILTER' . $_[0]; }
+sub my_filter_store_value { return 'MYFILTER' . $_[0]; }
-ok( !$db->set_filter( 'floober', sub {} ), "floober isn't a value filter key" );
+sub my_filter_fetch_key { $_[0] =~ s/^MYFILTER//; return $_[0]; }
+sub my_filter_fetch_value { $_[0] =~ s/^MYFILTER//; return $_[0]; }
-##
-# First try store filters only (values will be unfiltered)
-##
-ok( $db->set_filter( 'store_key', \&my_filter_store_key ), "set the store_key filter" );
-ok( $db->set_filter( 'store_value', \&my_filter_store_value ), "set the store_value filter" );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-$db->{key1} = "value1";
-$db->{key2} = "value2";
+ ok( !$db->set_filter( 'floober', sub {} ), "floober isn't a value filter key" );
-is($db->{key1}, "MYFILTERvalue1", "The value for key1 was filtered correctly" );
-is($db->{key2}, "MYFILTERvalue2", "The value for key2 was filtered correctly" );
+ ##
+ # First try store filters only (values will be unfiltered)
+ ##
+ ok( $db->set_filter( 'store_key', \&my_filter_store_key ), "set the store_key filter" );
+ ok( $db->set_filter( 'store_value', \&my_filter_store_value ), "set the store_value filter" );
-##
-# Now try fetch filters as well
-##
-ok( $db->set_filter( 'fetch_key', \&my_filter_fetch_key ), "Set the fetch_key filter" );
-ok( $db->set_filter( 'fetch_value', \&my_filter_fetch_value), "Set the fetch_value filter" );
+ $db->{key1} = "value1";
+ $db->{key2} = "value2";
-is($db->{key1}, "value1", "Fetchfilters worked right");
-is($db->{key2}, "value2", "Fetchfilters worked right");
+ is($db->{key1}, "MYFILTERvalue1", "The value for key1 was filtered correctly" );
+ is($db->{key2}, "MYFILTERvalue2", "The value for key2 was filtered correctly" );
-##
-# Try fetching keys as well as values
-##
-cmp_bag( [ keys %$db ], [qw( key1 key2 )], "DB keys correct" );
+ ##
+ # Now try fetch filters as well
+ ##
+ ok( $db->set_filter( 'fetch_key', \&my_filter_fetch_key ), "Set the fetch_key filter" );
+ ok( $db->set_filter( 'fetch_value', \&my_filter_fetch_value), "Set the fetch_value filter" );
-# Exists and delete tests
-ok( exists $db->{key1}, "Key1 exists" );
-ok( exists $db->{key2}, "Key2 exists" );
+ is($db->{key1}, "value1", "Fetchfilters worked right");
+ is($db->{key2}, "value2", "Fetchfilters worked right");
-is( delete $db->{key1}, 'value1', "Delete returns the right value" );
+ ##
+ # Try fetching keys as well as values
+ ##
+ cmp_bag( [ keys %$db ], [qw( key1 key2 )], "DB keys correct" );
-ok( !exists $db->{key1}, "Key1 no longer exists" );
-ok( exists $db->{key2}, "Key2 exists" );
+ # Exists and delete tests
+ ok( exists $db->{key1}, "Key1 exists" );
+ ok( exists $db->{key2}, "Key2 exists" );
-##
-# Now clear all filters, and make sure all is unfiltered
-##
-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( delete $db->{key1}, 'value1', "Delete returns the right value" );
-is( $db->{MYFILTERkey2}, "MYFILTERvalue2", "We get the right unfiltered value" );
+ ok( !exists $db->{key1}, "Key1 no longer exists" );
+ ok( exists $db->{key2}, "Key2 exists" );
-sub my_filter_store_key { return 'MYFILTER' . $_[0]; }
-sub my_filter_store_value { return 'MYFILTER' . $_[0]; }
+ ##
+ # Now clear all filters, and make sure all is unfiltered
+ ##
+ 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" );
-sub my_filter_fetch_key { $_[0] =~ s/^MYFILTER//; return $_[0]; }
-sub my_filter_fetch_value { $_[0] =~ s/^MYFILTER//; return $_[0]; }
+ is( $db->{MYFILTERkey2}, "MYFILTERvalue2", "We get the right unfiltered value" );
+}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 14;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
-use_ok( 'DBM::Deep' );
+use Test::More;
+use t::common qw( new_dbm );
-my ($fh, $filename) = new_fh();
+use_ok( 'DBM::Deep' );
my $salt = 38473827;
-my $db = DBM::Deep->new(
- file => $filename,
- digest => \&my_digest,
- hash_size => 8,
-);
-
-##
-# put/get key
-##
-$db->{key1} = "value1";
-ok( $db->{key1} eq "value1" );
-
-$db->put("key2", "value2");
-ok( $db->get("key2") eq "value2" );
-
-##
-# key exists
-##
-ok( $db->exists("key1") );
-ok( exists $db->{key2} );
-
-##
-# count keys
-##
-ok( scalar keys %$db == 2 );
-
-##
-# step through keys
-##
-my $temphash = {};
-while ( my ($key, $value) = each %$db ) {
- $temphash->{$key} = $value;
+# Warning: This digest function is for testing ONLY.
+# It is NOT intended for actual use. If you do so, I will laugh at you.
+sub my_digest {
+ my $key = shift;
+ my $num = $salt;
+
+ for (my $k=0; $k<length($key); $k++) {
+ $num += ord( substr($key, $k, 1) );
+ }
+
+ return sprintf("%00000008d", $num);
}
-ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") );
+my $dbm_factory = new_dbm( digest => \&my_digest, hash_size => 8 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-$temphash = {};
-my $key = $db->first_key();
-while ($key) {
- $temphash->{$key} = $db->get($key);
- $key = $db->next_key($key);
-}
+ ##
+ # put/get key
+ ##
+ $db->{key1} = "value1";
+ ok( $db->{key1} eq "value1" );
-ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") );
+ $db->put("key2", "value2");
+ ok( $db->get("key2") eq "value2" );
-##
-# delete keys
-##
-ok( delete $db->{key1} );
-ok( $db->delete("key2") );
+ ##
+ # key exists
+ ##
+ ok( $db->exists("key1") );
+ ok( exists $db->{key2} );
-ok( scalar keys %$db == 0 );
+ ##
+ # count keys
+ ##
+ ok( scalar keys %$db == 2 );
-##
-# delete all keys
-##
-$db->put("another", "value");
-$db->clear();
+ ##
+ # step through keys
+ ##
+ my $temphash = {};
+ while ( my ($key, $value) = each %$db ) {
+ $temphash->{$key} = $value;
+ }
-ok( scalar keys %$db == 0 );
+ ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") );
-##
-# replace key
-##
-$db->put("key1", "value1");
-$db->put("key1", "value2");
+ $temphash = {};
+ my $key = $db->first_key();
+ while ($key) {
+ $temphash->{$key} = $db->get($key);
+ $key = $db->next_key($key);
+ }
-ok( $db->get("key1") eq "value2" );
+ ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") );
-$db->put("key1", "value222222222222222222222222");
+ ##
+ # delete keys
+ ##
+ ok( delete $db->{key1} );
+ ok( $db->delete("key2") );
-ok( $db->get("key1") eq "value222222222222222222222222" );
+ ok( scalar keys %$db == 0 );
-sub my_digest {
- ##
- # Warning: This digest function is for testing ONLY
- # It is NOT intended for actual use
- ##
- my $key = shift;
- my $num = $salt;
-
- for (my $k=0; $k<length($key); $k++) {
- $num += ord( substr($key, $k, 1) );
- }
-
- return sprintf("%00000008d", $num);
+ ##
+ # delete all keys
+ ##
+ $db->put("another", "value");
+ $db->clear();
+
+ ok( scalar keys %$db == 0 );
+
+ ##
+ # replace key
+ ##
+ $db->put("key1", "value1");
+ $db->put("key1", "value2");
+
+ ok( $db->get("key1") eq "value2" );
+
+ $db->put("key1", "value222222222222222222222222");
+
+ ok( $db->get("key1") eq "value222222222222222222222222" );
}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 32;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
-use_ok( 'DBM::Deep' );
+use Test::More;
+use t::common qw( new_dbm );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
-
-##
-# put/get simple keys
-##
-$db->{key1} = "value1";
-$db->{key2} = "value2";
-
-my @keys_1 = sort keys %$db;
-
-$db->{key3} = $db->{key1};
-
-my @keys_2 = sort keys %$db;
-is( @keys_2 + 0, @keys_1 + 1, "Correct number of keys" );
-is_deeply(
- [ @keys_1, 'key3' ],
- [ @keys_2 ],
- "Keys still match after circular reference is added",
-);
-
-$db->{key4} = { 'foo' => 'bar' };
-$db->{key5} = $db->{key4};
-$db->{key6} = $db->{key5};
-
-my @keys_3 = sort keys %$db;
-
-is( @keys_3 + 0, @keys_2 + 3, "Correct number of keys" );
-is_deeply(
- [ @keys_2, 'key4', 'key5', 'key6', ],
- [ @keys_3 ],
- "Keys still match after circular reference is added (@keys_3)",
-);
-
-##
-# Insert circular reference
-##
-$db->{circle} = $db;
-
-my @keys_4 = sort keys %$db;
-
-is( @keys_4 + 0, @keys_3 + 1, "Correct number of keys" );
-is_deeply(
- [ 'circle', @keys_3 ],
- [ @keys_4 ],
- "Keys still match after circular reference is added",
-);
-
-##
-# Make sure keys exist in both places
-##
-is( $db->{key1}, 'value1', "The value is there directly" );
-is( $db->{circle}{key1}, 'value1', "The value is there in one loop of the circle" );
-is( $db->{circle}{circle}{key1}, 'value1', "The value is there in two loops of the circle" );
-is( $db->{circle}{circle}{circle}{key1}, 'value1', "The value is there in three loops of the circle" );
-
-##
-# Make sure changes are reflected in both places
-##
-$db->{key1} = "another value";
-
-isnt( $db->{key3}, 'another value', "Simple scalars are copied by value" );
-
-is( $db->{key1}, 'another value', "The value is there directly" );
-is( $db->{circle}{key1}, 'another value', "The value is there in one loop of the circle" );
-is( $db->{circle}{circle}{key1}, 'another value', "The value is there in two loops of the circle" );
-is( $db->{circle}{circle}{circle}{key1}, 'another value', "The value is there in three loops of the circle" );
-
-$db->{circle}{circle}{circle}{circle}{key1} = "circles";
-
-is( $db->{key1}, 'circles', "The value is there directly" );
-is( $db->{circle}{key1}, 'circles', "The value is there in one loop of the circle" );
-is( $db->{circle}{circle}{key1}, 'circles', "The value is there in two loops of the circle" );
-is( $db->{circle}{circle}{circle}{key1}, 'circles', "The value is there in three loops of the circle" );
-
-is( $db->{key4}{foo}, 'bar' );
-is( $db->{key5}{foo}, 'bar' );
-is( $db->{key6}{foo}, 'bar' );
-
-$db->{key4}{foo2} = 'bar2';
-is( $db->{key4}{foo2}, 'bar2' );
-is( $db->{key5}{foo2}, 'bar2' );
-is( $db->{key6}{foo2}, 'bar2' );
-
-$db->{key4}{foo3} = 'bar3';
-is( $db->{key4}{foo3}, 'bar3' );
-is( $db->{key5}{foo3}, 'bar3' );
-is( $db->{key6}{foo3}, 'bar3' );
-
-$db->{key4}{foo4} = 'bar4';
-is( $db->{key4}{foo4}, 'bar4' );
-is( $db->{key5}{foo4}, 'bar4' );
-is( $db->{key6}{foo4}, 'bar4' );
+use_ok( 'DBM::Deep' );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # put/get simple keys
+ ##
+ $db->{key1} = "value1";
+ $db->{key2} = "value2";
+
+ my @keys_1 = sort keys %$db;
+
+ $db->{key3} = $db->{key1};
+
+ my @keys_2 = sort keys %$db;
+ is( @keys_2 + 0, @keys_1 + 1, "Correct number of keys" );
+ is_deeply(
+ [ @keys_1, 'key3' ],
+ [ @keys_2 ],
+ "Keys still match after circular reference is added",
+ );
+
+ $db->{key4} = { 'foo' => 'bar' };
+ $db->{key5} = $db->{key4};
+ $db->{key6} = $db->{key5};
+
+ my @keys_3 = sort keys %$db;
+
+ is( @keys_3 + 0, @keys_2 + 3, "Correct number of keys" );
+ is_deeply(
+ [ @keys_2, 'key4', 'key5', 'key6', ],
+ [ @keys_3 ],
+ "Keys still match after circular reference is added (@keys_3)",
+ );
+
+ ##
+ # Insert circular reference
+ ##
+ $db->{circle} = $db;
+
+ my @keys_4 = sort keys %$db;
+
+ is( @keys_4 + 0, @keys_3 + 1, "Correct number of keys" );
+ is_deeply(
+ [ 'circle', @keys_3 ],
+ [ @keys_4 ],
+ "Keys still match after circular reference is added",
+ );
+
+ ##
+ # Make sure keys exist in both places
+ ##
+ is( $db->{key1}, 'value1', "The value is there directly" );
+ is( $db->{circle}{key1}, 'value1', "The value is there in one loop of the circle" );
+ is( $db->{circle}{circle}{key1}, 'value1', "The value is there in two loops of the circle" );
+ is( $db->{circle}{circle}{circle}{key1}, 'value1', "The value is there in three loops of the circle" );
+
+ ##
+ # Make sure changes are reflected in both places
+ ##
+ $db->{key1} = "another value";
+
+ isnt( $db->{key3}, 'another value', "Simple scalars are copied by value" );
+
+ is( $db->{key1}, 'another value', "The value is there directly" );
+ is( $db->{circle}{key1}, 'another value', "The value is there in one loop of the circle" );
+ is( $db->{circle}{circle}{key1}, 'another value', "The value is there in two loops of the circle" );
+ is( $db->{circle}{circle}{circle}{key1}, 'another value', "The value is there in three loops of the circle" );
+
+ $db->{circle}{circle}{circle}{circle}{key1} = "circles";
+
+ is( $db->{key1}, 'circles', "The value is there directly" );
+ is( $db->{circle}{key1}, 'circles', "The value is there in one loop of the circle" );
+ is( $db->{circle}{circle}{key1}, 'circles', "The value is there in two loops of the circle" );
+ is( $db->{circle}{circle}{circle}{key1}, 'circles', "The value is there in three loops of the circle" );
+
+ is( $db->{key4}{foo}, 'bar' );
+ is( $db->{key5}{foo}, 'bar' );
+ is( $db->{key6}{foo}, 'bar' );
+
+ $db->{key4}{foo2} = 'bar2';
+ is( $db->{key4}{foo2}, 'bar2' );
+ is( $db->{key5}{foo2}, 'bar2' );
+ is( $db->{key6}{foo2}, 'bar2' );
+
+ $db->{key4}{foo3} = 'bar3';
+ is( $db->{key4}{foo3}, 'bar3' );
+ is( $db->{key5}{foo3}, 'bar3' );
+ is( $db->{key6}{foo3}, 'bar3' );
+
+ $db->{key4}{foo4} = 'bar4';
+ is( $db->{key4}{foo4}, 'bar4' );
+ is( $db->{key5}{foo4}, 'bar4' );
+ is( $db->{key6}{foo4}, 'bar4' );
+}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 17;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
# Failure cases to make sure that things are caught right.
foreach my $type ( DBM::Deep->TYPE_HASH, DBM::Deep->TYPE_ARRAY ) {
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new({
- file => $filename,
- type => $type,
- });
-
- # Load a scalar
- throws_ok {
- $db->import( 'foo' );
- } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails";
-
- # Load a ref of the wrong type
- # Load something with bad stuff in it
- my $x = 3;
- if ( $type eq 'A' ) {
- throws_ok {
- $db->import( { foo => 'bar' } );
- } qr/Cannot import a hash into an array/, "Wrong type fails";
+ my $dbm_factory = new_dbm( type => $type );
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+ # Load a scalar
throws_ok {
- $db->import( [ \$x ] );
- } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
- }
- else {
- throws_ok {
- $db->import( [ 1 .. 3 ] );
- } qr/Cannot import an array into a hash/, "Wrong type fails";
-
- throws_ok {
- $db->import( { foo => \$x } );
- } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
+ $db->import( 'foo' );
+ } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails";
+
+ # Load a ref of the wrong type
+ # Load something with bad stuff in it
+ my $x = 3;
+ if ( $type eq 'A' ) {
+ throws_ok {
+ $db->import( { foo => 'bar' } );
+ } qr/Cannot import a hash into an array/, "Wrong type fails";
+
+ throws_ok {
+ $db->import( [ \$x ] );
+ } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
+ }
+ else {
+ throws_ok {
+ $db->import( [ 1 .. 3 ] );
+ } qr/Cannot import an array into a hash/, "Wrong type fails";
+
+ throws_ok {
+ $db->import( { foo => \$x } );
+ } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
+ }
}
}
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new({
- file => $filename,
- autobless => 1,
- });
+my $dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-##
-# Create structure in memory
-##
+ ##
+ # Create structure in memory
+ ##
my $struct = {
key1 => "value1",
key2 => "value2",
ok( !exists $db->{hash1}->{foo}, "\$db->{hash1} doesn't have the 'foo' key, so \$struct->{hash1} is not tied" );
}
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new({
- file => $filename,
- type => DBM::Deep->TYPE_ARRAY,
- });
+$dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
my $struct = [
1 .. 3,
}
# Failure case to verify that rollback occurs
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new({
- file => $filename,
- autobless => 1,
- });
+$dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
$db->{foo} = 'bar';
}
}
+done_testing;
+
__END__
Need to add tests for:
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 6;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
},
);
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new({
- file => $filename,
- autobless => 1,
-});
+my $dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-##
-# Create structure in DB
-##
-$db->import( \%struct );
+ ##
+ # Create structure in DB
+ ##
+ $db->import( \%struct );
-##
-# Export entire thing
-##
-my $compare = $db->export();
+ ##
+ # Export entire thing
+ ##
+ my $compare = $db->export();
-cmp_deeply(
- $compare,
- {
- key1 => "value1",
- key2 => "value2",
- array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ] ],
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2",
- subkey3 => bless( {
- sub_obj => bless([
- bless([], 'Foo'),
- ], 'Foo'),
- sub_obj2 => bless([], 'Foo'),
- }, 'Foo' ),
+ cmp_deeply(
+ $compare,
+ {
+ key1 => "value1",
+ key2 => "value2",
+ array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ] ],
+ hash1 => {
+ subkey1 => "subvalue1",
+ subkey2 => "subvalue2",
+ subkey3 => bless( {
+ sub_obj => bless([
+ bless([], 'Foo'),
+ ], 'Foo'),
+ sub_obj2 => bless([], 'Foo'),
+ }, 'Foo' ),
+ },
},
- },
- "Everything matches",
-);
+ "Everything matches",
+ );
+
+ isa_ok( tied(%{$db->{hash1}{subkey3}})->export, 'Foo' );
+ isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}})->export, 'Foo' );
+ isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}[0]})->export, 'Foo' );
+ isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj2}})->export, 'Foo' );
+}
-isa_ok( tied(%{$db->{hash1}{subkey3}})->export, 'Foo' );
-isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}})->export, 'Foo' );
-isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}[0]})->export, 'Foo' );
-isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj2}})->export, 'Foo' );
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 9;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh2, $filename2) = new_fh();
-my $db2 = DBM::Deep->new( $filename2 );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-SKIP: {
- skip "Apparently, we cannot detect a tied scalar?", 1;
- tie my $foo, 'Tied::Scalar';
- throws_ok {
- $db2->{failure} = $foo;
- } qr/Cannot store something that is tied\./, "tied scalar storage fails";
-}
+ SKIP: {
+ skip "Apparently, we cannot detect a tied scalar?", 1;
+ tie my $foo, 'Tied::Scalar';
+ throws_ok {
+ $db->{failure} = $foo;
+ } qr/Cannot store something that is tied\./, "tied scalar storage fails";
+ }
-{
- tie my @foo, 'Tied::Array';
- throws_ok {
- $db2->{failure} = \@foo;
- } qr/Cannot store something that is tied\./, "tied array storage fails";
-}
+ {
+ tie my @foo, 'Tied::Array';
+ throws_ok {
+ $db->{failure} = \@foo;
+ } qr/Cannot store something that is tied\./, "tied array storage fails";
+ }
-{
- tie my %foo, 'Tied::Hash';
- throws_ok {
- $db2->{failure} = \%foo;
- } qr/Cannot store something that is tied\./, "tied hash storage fails";
-}
+ {
+ tie my %foo, 'Tied::Hash';
+ throws_ok {
+ $db->{failure} = \%foo;
+ } qr/Cannot store something that is tied\./, "tied hash storage fails";
+ }
+
+ my $dbm_factory2 = new_dbm();
+ while ( my $dbm_maker2 = $dbm_factory2->() ) {
+ my $db2 = $dbm_maker2->();
+
+ $db2->import({
+ hash1 => {
+ subkey1 => "subvalue1",
+ subkey2 => "subvalue2",
+ }
+ });
+ is( $db2->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
+ is( $db2->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
+
+ # Test cross-ref nested hash accross DB objects
+ throws_ok {
+ $db->{copy} = $db2->{hash1};
+ } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails";
+
+ # This error text is for when internal cross-refs are implemented
+ #} qr/Cannot cross-reference\. Use export\(\) instead\./
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
+ $db->{copy} = $db2->{hash1}->export;
+ }
##
- # Create structure in $db
+ # Make sure $db has copy of $db2's hash structure
##
- $db->import({
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2",
- }
- });
- is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
- is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
-
- # Test cross-ref nested hash accross DB objects
- throws_ok {
- $db2->{copy} = $db->{hash1};
- } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails";
-
- # This error text is for when internal cross-refs are implemented
- #} qr/Cannot cross-reference\. Use export\(\) instead\./, "cross-ref fails";
-
- $db2->{copy} = $db->{hash1}->export;
+ is( $db->{copy}{subkey1}, 'subvalue1', "Value copied correctly" );
+ is( $db->{copy}{subkey2}, 'subvalue2', "Value copied correctly" );
}
-##
-# Make sure $db2 has copy of $db's hash structure
-##
-is( $db2->{copy}{subkey1}, 'subvalue1', "Value copied correctly" );
-is( $db2->{copy}{subkey2}, 'subvalue2', "Value copied correctly" );
+done_testing;
package Tied::Scalar;
sub TIESCALAR { bless {}, $_[0]; }
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 11;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
-##
# testing the various modes of opening a file
-##
{
my ($fh, $filename) = new_fh();
my %hash;
throws_ok {
tie my @array, 'DBM::Deep', undef, file => $filename;
} qr/Odd number of parameters/, "Odd number of params to TIEARRAY fails";
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 7;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
} qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type";
$db->_get_self->_engine->storage->close( $db->_get_self );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 13;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
+
+use Test::More;
+use t::common qw( new_dbm new_fh );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-##
-# Create structure in $db
-##
-$db->import({
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2",
- },
- hash2 => {
- subkey3 => 'subvalue3',
- },
-});
+ $db->import({
+ hash1 => {
+ subkey1 => "subvalue1",
+ subkey2 => "subvalue2",
+ },
+ hash2 => {
+ subkey3 => 'subvalue3',
+ },
+ });
-is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
-is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
+ is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
+ is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
-$db->{copy} = $db->{hash1};
+ $db->{copy} = $db->{hash1};
-is( $db->{copy}{subkey1}, 'subvalue1', "Value copied correctly" );
-is( $db->{copy}{subkey2}, 'subvalue2', "Value copied correctly" );
+ is( $db->{copy}{subkey1}, 'subvalue1', "Value copied correctly" );
+ is( $db->{copy}{subkey2}, 'subvalue2', "Value copied correctly" );
-$db->{copy}{subkey1} = "another value";
-is( $db->{copy}{subkey1}, 'another value', "New value is set correctly" );
-is( $db->{hash1}{subkey1}, 'another value', "Old value is set to the new one" );
+ $db->{copy}{subkey1} = "another value";
+ is( $db->{copy}{subkey1}, 'another value', "New value is set correctly" );
+ is( $db->{hash1}{subkey1}, 'another value', "Old value is set to the new one" );
-is( scalar(keys %{$db->{hash1}}), 2, "Start with 2 keys in the original" );
-is( scalar(keys %{$db->{copy}}), 2, "Start with 2 keys in the copy" );
+ is( scalar(keys %{$db->{hash1}}), 2, "Start with 2 keys in the original" );
+ is( scalar(keys %{$db->{copy}}), 2, "Start with 2 keys in the copy" );
-delete $db->{copy}{subkey2};
+ delete $db->{copy}{subkey2};
-is( scalar(keys %{$db->{copy}}), 1, "Now only have 1 key in the copy" );
-is( scalar(keys %{$db->{hash1}}), 1, "... and only 1 key in the original" );
+ is( scalar(keys %{$db->{copy}}), 1, "Now only have 1 key in the copy" );
+ is( scalar(keys %{$db->{hash1}}), 1, "... and only 1 key in the original" );
-$db->{copy} = $db->{hash2};
-is( $db->{copy}{subkey3}, 'subvalue3', "After the second copy, we're still good" );
-my $max_keys = 1000;
+ $db->{copy} = $db->{hash2};
+ is( $db->{copy}{subkey3}, 'subvalue3', "After the second copy, we're still good" );
+}
-my ($fh2, $filename2) = new_fh();
{
- my $db = DBM::Deep->new( file => $filename2, fh => $fh2, );
+ my $max_keys = 1000;
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ {
+ my $db = $dbm_maker->();
- $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->_engine->storage->{fh}, 0, 0;
-}
+ $db->{foo} = [ 1 .. 3 ];
+ for ( 0 .. $max_keys ) {
+ $db->{'foo' . $_} = $db->{foo};
+ }
+ }
-{
- my $db = DBM::Deep->new( fh => $fh2, );
-
- my $base_offset = $db->{foo}->_base_offset;
- my $count = -1;
- for ( 0 .. $max_keys ) {
- $count = $_;
- unless ( $base_offset == $db->{'foo'.$_}->_base_offset ) {
- last;
+ {
+ my $db = $dbm_maker->();
+
+ my $base_offset = $db->{foo}->_base_offset;
+ my $count = -1;
+ for ( 0 .. $max_keys ) {
+ $count = $_;
+ unless ( $base_offset == $db->{'foo'.$_}->_base_offset ) {
+ last;
+ }
+ }
+ is( $count, $max_keys, "We read $count keys" );
}
}
- is( $count, $max_keys, "We read $count keys" );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 7;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
$db->_get_self->_engine->storage->close( $db->_get_self );
ok( !$db->unlock, "Calling unlock() on a closed database returns false" );
}
+
+done_testing;
use strict;
+use warnings FATAL => 'all';
{
package Foo;
sub foo { 'foo' };
}
-use Test::More tests => 65;
-use t::common qw( new_fh );
+use Test::More;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-{
- my $db = DBM::Deep->new(
- file => $filename,
- autobless => 1,
- );
+my $dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ {
+ my $db = $dbm_maker->();
- my $obj = bless {
- a => 1,
- b => [ 1 .. 3 ],
- }, 'Foo';
+ my $obj = bless {
+ a => 1,
+ b => [ 1 .. 3 ],
+ }, 'Foo';
- $db->{blessed} = $obj;
- is( $db->{blessed}{a}, 1 );
- is( $db->{blessed}{b}[0], 1 );
- is( $db->{blessed}{b}[1], 2 );
- is( $db->{blessed}{b}[2], 3 );
-
- my $obj2 = bless [
- { a => 'foo' },
- 2,
- ], 'Foo';
- $db->{blessed2} = $obj2;
-
- is( $db->{blessed2}[0]{a}, 'foo' );
- is( $db->{blessed2}[1], '2' );
-
- $db->{unblessed} = {};
- $db->{unblessed}{a} = 1;
- $db->{unblessed}{b} = [];
- $db->{unblessed}{b}[0] = 1;
- $db->{unblessed}{b}[1] = 2;
- $db->{unblessed}{b}[2] = 3;
-
- is( $db->{unblessed}{a}, 1 );
- is( $db->{unblessed}{b}[0], 1 );
- is( $db->{unblessed}{b}[1], 2 );
- is( $db->{unblessed}{b}[2], 3 );
-
- $db->{blessed_long} = bless {}, 'a' x 1000;
- $db->_get_self->_engine->storage->close( $db->_get_self );
-}
+ $db->{blessed} = $obj;
+ is( $db->{blessed}{a}, 1 );
+ is( $db->{blessed}{b}[0], 1 );
+ is( $db->{blessed}{b}[1], 2 );
+ is( $db->{blessed}{b}[2], 3 );
+
+ my $obj2 = bless [
+ { a => 'foo' },
+ 2,
+ ], 'Foo';
+ $db->{blessed2} = $obj2;
+
+ is( $db->{blessed2}[0]{a}, 'foo' );
+ is( $db->{blessed2}[1], '2' );
+
+ $db->{unblessed} = {};
+ $db->{unblessed}{a} = 1;
+ $db->{unblessed}{b} = [];
+ $db->{unblessed}{b}[0] = 1;
+ $db->{unblessed}{b}[1] = 2;
+ $db->{unblessed}{b}[2] = 3;
+
+ is( $db->{unblessed}{a}, 1 );
+ is( $db->{unblessed}{b}[0], 1 );
+ is( $db->{unblessed}{b}[1], 2 );
+ is( $db->{unblessed}{b}[2], 3 );
+
+ $db->{blessed_long} = bless {}, 'a' x 1000;
+ $db->_get_self->_engine->storage->close( $db->_get_self );
+ }
-{
- my $db = DBM::Deep->new(
- file => $filename,
- autobless => 1,
- );
-
- my $obj = $db->{blessed};
- isa_ok( $obj, 'Foo' );
- can_ok( $obj, 'export', 'foo' );
- ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
-
- is( $obj->{a}, 1 );
- is( $obj->{b}[0], 1 );
- is( $obj->{b}[1], 2 );
- is( $obj->{b}[2], 3 );
-
- my $obj2 = $db->{blessed2};
- isa_ok( $obj2, 'Foo' );
- can_ok( $obj2, 'export', 'foo' );
- ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
-
- is( $obj2->[0]{a}, 'foo' );
- is( $obj2->[1], '2' );
-
- is( $db->{unblessed}{a}, 1 );
- is( $db->{unblessed}{b}[0], 1 );
- is( $db->{unblessed}{b}[1], 2 );
- is( $db->{unblessed}{b}[2], 3 );
-
- $obj->{c} = 'new';
- is( $db->{blessed}{c}, 'new' );
-
- isa_ok( $db->{blessed_long}, 'a' x 1000 );
- $db->_get_self->_engine->storage->close( $db->_get_self );
-}
+ {
+ my $db = $dbm_maker->();
-{
- my $db = DBM::Deep->new(
- file => $filename,
- autobless => 1,
- );
- is( $db->{blessed}{c}, 'new' );
-
- my $structure = $db->export();
- use Data::Dumper;print Dumper $structure;
-
- my $obj = $structure->{blessed};
- isa_ok( $obj, 'Foo' );
- can_ok( $obj, 'export', 'foo' );
- ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
-
- is( $obj->{a}, 1 );
- is( $obj->{b}[0], 1 );
- is( $obj->{b}[1], 2 );
- is( $obj->{b}[2], 3 );
-
- my $obj2 = $structure->{blessed2};
- isa_ok( $obj2, 'Foo' );
- can_ok( $obj2, 'export', 'foo' );
- ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
-
- is( $obj2->[0]{a}, 'foo' );
- is( $obj2->[1], '2' );
-
- is( $structure->{unblessed}{a}, 1 );
- is( $structure->{unblessed}{b}[0], 1 );
- is( $structure->{unblessed}{b}[1], 2 );
- is( $structure->{unblessed}{b}[2], 3 );
- $db->_get_self->_engine->storage->close( $db->_get_self );
-}
+ my $obj = $db->{blessed};
+ isa_ok( $obj, 'Foo' );
+ can_ok( $obj, 'export', 'foo' );
+ ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
-{
- my $db = DBM::Deep->new(
- file => $filename,
- autobless => 0,
- );
-
- my $obj = $db->{blessed};
- isa_ok( $obj, 'DBM::Deep' );
- can_ok( $obj, 'export', 'STORE' );
- ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
-
- is( $obj->{a}, 1 );
- is( $obj->{b}[0], 1 );
- is( $obj->{b}[1], 2 );
- is( $obj->{b}[2], 3 );
-
- my $obj2 = $db->{blessed2};
- isa_ok( $obj2, 'DBM::Deep' );
- can_ok( $obj2, 'export', 'STORE' );
- ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
-
- is( $obj2->[0]{a}, 'foo' );
- is( $obj2->[1], '2' );
-
- is( $db->{unblessed}{a}, 1 );
- is( $db->{unblessed}{b}[0], 1 );
- is( $db->{unblessed}{b}[1], 2 );
- is( $db->{unblessed}{b}[2], 3 );
- $db->_get_self->_engine->storage->close( $db->_get_self );
+ is( $obj->{a}, 1 );
+ is( $obj->{b}[0], 1 );
+ is( $obj->{b}[1], 2 );
+ is( $obj->{b}[2], 3 );
+
+ my $obj2 = $db->{blessed2};
+ isa_ok( $obj2, 'Foo' );
+ can_ok( $obj2, 'export', 'foo' );
+ ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+ is( $obj2->[0]{a}, 'foo' );
+ is( $obj2->[1], '2' );
+
+ is( $db->{unblessed}{a}, 1 );
+ is( $db->{unblessed}{b}[0], 1 );
+ is( $db->{unblessed}{b}[1], 2 );
+ is( $db->{unblessed}{b}[2], 3 );
+
+ $obj->{c} = 'new';
+ is( $db->{blessed}{c}, 'new' );
+
+ isa_ok( $db->{blessed_long}, 'a' x 1000 );
+ $db->_get_self->_engine->storage->close( $db->_get_self );
+ }
+
+ {
+ my $db = $dbm_maker->();
+ is( $db->{blessed}{c}, 'new' );
+
+ my $structure = $db->export();
+ use Data::Dumper;print Dumper $structure;
+
+ my $obj = $structure->{blessed};
+ isa_ok( $obj, 'Foo' );
+ can_ok( $obj, 'export', 'foo' );
+ ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+ is( $obj->{a}, 1 );
+ is( $obj->{b}[0], 1 );
+ is( $obj->{b}[1], 2 );
+ is( $obj->{b}[2], 3 );
+
+ my $obj2 = $structure->{blessed2};
+ isa_ok( $obj2, 'Foo' );
+ can_ok( $obj2, 'export', 'foo' );
+ ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+ is( $obj2->[0]{a}, 'foo' );
+ is( $obj2->[1], '2' );
+
+ is( $structure->{unblessed}{a}, 1 );
+ is( $structure->{unblessed}{b}[0], 1 );
+ is( $structure->{unblessed}{b}[1], 2 );
+ is( $structure->{unblessed}{b}[2], 3 );
+ $db->_get_self->_engine->storage->close( $db->_get_self );
+ }
+
+ {
+ my $db = $dbm_maker->( autobless => 0 );
+
+ my $obj = $db->{blessed};
+ isa_ok( $obj, 'DBM::Deep' );
+ can_ok( $obj, 'export', 'STORE' );
+ ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
+
+ is( $obj->{a}, 1 );
+ is( $obj->{b}[0], 1 );
+ is( $obj->{b}[1], 2 );
+ is( $obj->{b}[2], 3 );
+
+ my $obj2 = $db->{blessed2};
+ isa_ok( $obj2, 'DBM::Deep' );
+ can_ok( $obj2, 'export', 'STORE' );
+ ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
+
+ is( $obj2->[0]{a}, 'foo' );
+ is( $obj2->[1], '2' );
+
+ is( $db->{unblessed}{a}, 1 );
+ is( $db->{unblessed}{b}[0], 1 );
+ is( $db->{unblessed}{b}[1], 2 );
+ is( $db->{unblessed}{b}[2], 3 );
+ $db->_get_self->_engine->storage->close( $db->_get_self );
+ }
}
-{
- my ($fh2, $filename2) = new_fh();
+$dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
{
- my $db = DBM::Deep->new(
- file => $filename2,
- autobless => 1,
- );
+ my $db = $dbm_maker->();
my $obj = bless {
a => 1,
b => [ 1 .. 3 ],
}, 'Foo';
$db->import( { blessed => $obj } );
- $db->_get_self->_engine->storage->close( $db->_get_self );
}
{
- my $db = DBM::Deep->new(
- file => $filename2,
- autobless => 1,
- );
+ my $db = $dbm_maker->();
my $blessed = $db->{blessed};
isa_ok( $blessed, 'Foo' );
is( $blessed->{a}, 1 );
- $db->_get_self->_engine->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.
- ##
- my ($fh3, $filename3) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename3,
- autobless => 1,
- );
+# 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.
+$dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
my $obj = bless {}, 'Foo';
is( $db->{after}, "hello" );
}
+
+done_testing;
use strict;
+use warnings FATAL => 'all';
-use Test::More tests => 5;
+use Test::More;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
isa_ok( $obj, 'DBM::Deep' );
is( reftype( $obj ), 'HASH', "... and its underlying representation is an HASH" );
}
+
+done_testing;
use strict;
+use warnings FATAL => 'all';
-use Test::More tests => 10;
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm new_fh );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-
my $x = 25;
-{
- my $db = DBM::Deep->new( $filename );
-
- throws_ok {
- $db->{scalarref} = \$x;
- } qr/Storage of references of type 'SCALAR' is not supported/,
- 'Storage of scalar refs not supported';
-
- throws_ok {
- $db->{scalarref} = \\$x;
- } qr/Storage of references of type 'REF' is not supported/,
- 'Storage of ref refs not supported';
-
- throws_ok {
- $db->{scalarref} = sub { 1 };
- } qr/Storage of references of type 'CODE' is not supported/,
- 'Storage of code refs not supported';
-
- throws_ok {
- $db->{scalarref} = $fh;
- } qr/Storage of references of type 'GLOB' is not supported/,
- 'Storage of glob refs not supported';
-
- $db->{scalar} = $x;
- TODO: {
- todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2;
- lives_ok {
- $db->{selfref} = \$db->{scalar};
- } "Refs to DBM::Deep objects are ok";
-
- is( ${$db->{selfref}}, $x, "A ref to a DBM::Deep object is ok" );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ {
+ my $db = $dbm_maker->();
+
+ throws_ok {
+ $db->{scalarref} = \$x;
+ } qr/Storage of references of type 'SCALAR' is not supported/,
+ 'Storage of scalar refs not supported';
+
+ throws_ok {
+ $db->{scalarref} = \\$x;
+ } qr/Storage of references of type 'REF' is not supported/,
+ 'Storage of ref refs not supported';
+
+ throws_ok {
+ $db->{scalarref} = sub { 1 };
+ } qr/Storage of references of type 'CODE' is not supported/,
+ 'Storage of code refs not supported';
+
+ throws_ok {
+ my ($fh, $filename) = new_fh;
+ $db->{scalarref} = $fh;
+ } qr/Storage of references of type 'GLOB' is not supported/,
+ 'Storage of glob refs not supported';
+
+ $db->{scalar} = $x;
+ TODO: {
+ todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2;
+ lives_ok {
+ $db->{selfref} = \$db->{scalar};
+ } "Refs to DBM::Deep objects are ok";
+
+ is( ${$db->{selfref}}, $x, "A ref to a DBM::Deep object is ok" );
+ }
}
-}
-{
- my $db = DBM::Deep->new( $filename );
+ {
+ my $db = $dbm_maker->();
- is( $db->{scalar}, $x, "Scalar retrieved ok" );
- TODO: {
- todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2;
- is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" );
- is( ${$db->{selfref}}, 26, "Scalarref to stored scalar retrieved ok" );
+ is( $db->{scalar}, $x, "Scalar retrieved ok" );
+ TODO: {
+ todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2;
+ is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" );
+ is( ${$db->{selfref}}, 26, "Scalarref to stored scalar retrieved ok" );
+ }
}
}
+
+done_testing;
-use 5.006_000;
-
use strict;
use warnings FATAL => 'all';
+# Need to have an explicit plan in order for the sub-testing to work right.
+#XXX Figure out how to use subtests for that.
use Test::More tests => 14;
use Test::Exception;
use t::common qw( new_fh );
my $db = DBM::Deep->new({
file => $filename,
file_offset => $offset,
-#XXX For some reason, this is needed to make the test pass. Figure out why later.
-locking => 0,
+ #XXX For some reason, this is needed to make the test pass. Figure
+ #XXX out why later.
+ locking => 0,
});
$db->{x} = 'b';
use strict;
-use Test::More tests => 40;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
+my $dbm_factory = new_dbm(
+ locking => 1,
autoflush => 1,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-for ( 1 .. 17 ) {
- $db->{ $_ } = $_;
- is( $db->{$_}, $_, "Addition of $_ is still $_" );
-}
+ for ( 1 .. 17 ) {
+ $db->{ $_ } = $_;
+ is( $db->{$_}, $_, "Addition of $_ is still $_" );
+ }
-for ( 1 .. 17 ) {
- is( $db->{$_}, $_, "Verification of $_ is still $_" );
-}
+ for ( 1 .. 17 ) {
+ is( $db->{$_}, $_, "Verification of $_ is still $_" );
+ }
-my @keys = keys %$db;
-cmp_ok( scalar(@keys), '==', 17, "Right number of keys returned" );
+ my @keys = keys %$db;
+ cmp_ok( scalar(@keys), '==', 17, "Right number of keys returned" );
-ok( !exists $db->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" );
-is( $db->{does_not_exist}, undef, "autovivification works on large hashes" );
-ok( exists $db->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" );
-cmp_ok( scalar(keys %$db), '==', 18, "Number of keys after autovivify is correct" );
+ ok( !exists $db->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" );
+ is( $db->{does_not_exist}, undef, "autovivification works on large hashes" );
+ ok( exists $db->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" );
+ cmp_ok( scalar(keys %$db), '==', 18, "Number of keys after autovivify is correct" );
+}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 4;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
+
+use Test::More;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
-);
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ my $val1 = "a" x 1000;
-##
-# large keys
-##
-my $val1 = "a" x 1000;
+ $db->{foo} = $val1;
+ is( $db->{foo}, $val1, "1000 char value stored and retrieved" );
-$db->{foo} = $val1;
-is( $db->{foo}, $val1, "1000 char value stored and retrieved" );
+# delete $db->{foo};
+# my $size = -s $filename;
+# $db->{bar} = "a" x 300;
+# is( $db->{bar}, 'a' x 300, "New 256 char value is stored" );
+# cmp_ok( $size, '==', -s $filename, "Freespace is reused" );
+}
-delete $db->{foo};
-my $size = -s $filename;
-$db->{bar} = "a" x 300;
-is( $db->{bar}, 'a' x 300, "New 256 char value is stored" );
-cmp_ok( $size, '==', -s $filename, "Freespace is reused" );
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 7;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-{
{
- package My::Tie::Hash;
+ {
+ package My::Tie::Hash;
- sub TIEHASH {
- my $class = shift;
+ sub TIEHASH {
+ my $class = shift;
- return bless {
- }, $class;
+ return bless {
+ }, $class;
+ }
}
- }
- my %hash;
- tie %hash, 'My::Tie::Hash';
- isa_ok( tied(%hash), 'My::Tie::Hash' );
+ my %hash;
+ tie %hash, 'My::Tie::Hash';
+ isa_ok( tied(%hash), 'My::Tie::Hash' );
- throws_ok {
- $db->{foo} = \%hash;
- } qr/Cannot store something that is tied/, "Cannot store tied hashes";
-}
+ throws_ok {
+ $db->{foo} = \%hash;
+ } qr/Cannot store something that is tied/, "Cannot store tied hashes";
+ }
-{
{
- package My::Tie::Array;
+ {
+ package My::Tie::Array;
- sub TIEARRAY {
- my $class = shift;
+ sub TIEARRAY {
+ my $class = shift;
- return bless {
- }, $class;
- }
+ return bless {
+ }, $class;
+ }
- sub FETCHSIZE { 0 }
- }
+ sub FETCHSIZE { 0 }
+ }
- my @array;
- tie @array, 'My::Tie::Array';
- isa_ok( tied(@array), 'My::Tie::Array' );
+ my @array;
+ tie @array, 'My::Tie::Array';
+ isa_ok( tied(@array), 'My::Tie::Array' );
- throws_ok {
- $db->{foo} = \@array;
- } qr/Cannot store something that is tied/, "Cannot store tied arrays";
-}
+ throws_ok {
+ $db->{foo} = \@array;
+ } qr/Cannot store something that is tied/, "Cannot store tied arrays";
+ }
{
- package My::Tie::Scalar;
+ {
+ package My::Tie::Scalar;
- sub TIESCALAR {
- my $class = shift;
+ sub TIESCALAR {
+ my $class = shift;
- return bless {
- }, $class;
+ return bless {
+ }, $class;
+ }
}
- }
- my $scalar;
- tie $scalar, 'My::Tie::Scalar';
- isa_ok( tied($scalar), 'My::Tie::Scalar' );
+ my $scalar;
+ tie $scalar, 'My::Tie::Scalar';
+ isa_ok( tied($scalar), 'My::Tie::Scalar' );
+
+ throws_ok {
+ $db->{foo} = \$scalar;
+ } qr/Storage of references of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars";
+ }
+}
-throws_ok {
- $db->{foo} = \$scalar;
-} qr/Storage of references of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars";
+done_testing;
use strict;
+use warnings FATAL => 'all';
-use Test::More tests => 16;
+use Test::More;
use Test::Deep;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+ my %hash = (
+ foo => 1,
+ bar => [ 1 .. 3 ],
+ baz => { a => 42 },
+ );
-my %hash = (
- foo => 1,
- bar => [ 1 .. 3 ],
- baz => { a => 42 },
-);
+ $db->{hash} = \%hash;
+ isa_ok( tied(%hash), 'DBM::Deep::Hash' );
-$db->{hash} = \%hash;
-isa_ok( tied(%hash), 'DBM::Deep::Hash' );
+ is( $db->{hash}{foo}, 1 );
+ cmp_deeply( $db->{hash}{bar}, noclass([ 1 .. 3 ]) );
+ cmp_deeply( $db->{hash}{baz}, noclass({ a => 42 }) );
-is( $db->{hash}{foo}, 1 );
-cmp_deeply( $db->{hash}{bar}, noclass([ 1 .. 3 ]) );
-cmp_deeply( $db->{hash}{baz}, noclass({ a => 42 }) );
+ $hash{foo} = 2;
+ is( $db->{hash}{foo}, 2 );
-$hash{foo} = 2;
-is( $db->{hash}{foo}, 2 );
+ $hash{bar}[1] = 90;
+ is( $db->{hash}{bar}[1], 90 );
-$hash{bar}[1] = 90;
-is( $db->{hash}{bar}[1], 90 );
+ $hash{baz}{b} = 33;
+ is( $db->{hash}{baz}{b}, 33 );
-$hash{baz}{b} = 33;
-is( $db->{hash}{baz}{b}, 33 );
+ my @array = (
+ 1, [ 1 .. 3 ], { a => 42 },
+ );
-my @array = (
- 1, [ 1 .. 3 ], { a => 42 },
-);
+ $db->{array} = \@array;
+ isa_ok( tied(@array), 'DBM::Deep::Array' );
-$db->{array} = \@array;
-isa_ok( tied(@array), 'DBM::Deep::Array' );
+ is( $db->{array}[0], 1 );
+ cmp_deeply( $db->{array}[1], noclass([ 1 .. 3 ]) );
+ cmp_deeply( $db->{array}[2], noclass({ a => 42 }) );
-is( $db->{array}[0], 1 );
-cmp_deeply( $db->{array}[1], noclass([ 1 .. 3 ]) );
-cmp_deeply( $db->{array}[2], noclass({ a => 42 }) );
+ $array[0] = 2;
+ is( $db->{array}[0], 2 );
-$array[0] = 2;
-is( $db->{array}[0], 2 );
+ $array[1][2] = 9;
+ is( $db->{array}[1][2], 9 );
-$array[1][2] = 9;
-is( $db->{array}[1][2], 9 );
+ $array[2]{b} = 'floober';
+ is( $db->{array}[2]{b}, 'floober' );
-$array[2]{b} = 'floober';
-is( $db->{array}[2]{b}, 'floober' );
+ my %hash2 = ( abc => [ 1 .. 3 ] );
+ $array[3] = \%hash2;
-my %hash2 = ( abc => [ 1 .. 3 ] );
-$array[3] = \%hash2;
+ $hash2{ def } = \%hash;
+ is( $array[3]{def}{foo}, 2 );
+}
-$hash2{ def } = \%hash;
-is( $array[3]{def}{foo}, 2 );
+done_testing;
#!/usr/bin/perl -l
-##
-# DBM::Deep Test
-#
# Test for interference from -l on the commandline.
-##
use strict;
-use Test::More tests => 4;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
is( $db->get("key1"), "value1", "get() works with hash assignment" );
is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" );
is( $db->{key1}, "value1", "... and hash-access also works" );
+
+done_testing;
use strict;
-use Test::More tests => 99;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db1 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
-);
-
-my $db2 = DBM::Deep->new(
- file => $filename,
+my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ my $db2 = $dbm_maker->();
-$db1->{x} = 'y';
-is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
-is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
+ $db1->{x} = 'y';
+ is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
+ is( $db2->{x}, '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" );
-
-throws_ok {
- $db1->rollback;
-} qr/Cannot rollback without an active transaction/, "Attempting to rollback without a transaction throws an error";
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-throws_ok {
- $db1->commit;
-} qr/Cannot commit without an active transaction/, "Attempting to commit without a transaction throws an error";
+ throws_ok {
+ $db1->rollback;
+ } qr/Cannot rollback without an active transaction/, "Attempting to rollback without a transaction throws an error";
-$db1->begin_work;
+ throws_ok {
+ $db1->commit;
+ } qr/Cannot commit without an active transaction/, "Attempting to commit without a transaction throws an error";
-throws_ok {
$db1->begin_work;
-} qr/Cannot begin_work within an active transaction/, "Attempting to begin_work within a transaction throws an error";
-lives_ok {
- $db1->rollback;
-} "Rolling back an empty transaction is ok.";
+ throws_ok {
+ $db1->begin_work;
+ } qr/Cannot begin_work within an active transaction/, "Attempting to begin_work within a transaction throws an error";
-cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-
-$db1->begin_work;
-
-lives_ok {
- $db1->commit;
-} "Committing an empty transaction is ok.";
-
-cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-
-$db1->begin_work;
+ lives_ok {
+ $db1->rollback;
+ } "Rolling back an empty transaction is ok.";
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
- is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
+ $db1->begin_work;
- $db2->{x} = 'a';
- is( $db1->{x}, 'y', "Within DB1 transaction, DB1's X is still Y" );
- is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is now A" );
+ lives_ok {
+ $db1->commit;
+ } "Committing an empty transaction is ok.";
- $db1->{x} = 'z';
- is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
- is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is still A" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- $db1->{z} = 'a';
- is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" );
- ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." );
+ $db1->begin_work;
- $db2->{other_x} = 'foo';
- is( $db2->{other_x}, 'foo', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
- ok( !exists $db1->{other_x}, "Since other_x was added after the transaction began, DB1 doesn't see it." );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- # Reset to an expected value
- $db2->{x} = 'y';
- is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is istill Z" );
- is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is now Y" );
+ is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
+ is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
- cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
+ $db2->{x} = 'a';
+ is( $db1->{x}, 'y', "Within DB1 transaction, DB1's X is still Y" );
+ is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is now A" );
-$db1->rollback;
+ $db1->{x} = 'z';
+ is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
+ is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is still A" );
-is( $db1->{x}, 'y', "After rollback, DB1's X is Y" );
-is( $db2->{x}, 'y', "After rollback, DB2's X is Y" );
+ $db1->{z} = 'a';
+ is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" );
+ ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." );
-is( $db1->{other_x}, 'foo', "After DB1 transaction is over, DB1 can see other_x" );
-is( $db2->{other_x}, 'foo', "After DB1 transaction is over, DB2 can still see other_x" );
+ $db2->{other_x} = 'foo';
+ is( $db2->{other_x}, 'foo', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
+ ok( !exists $db1->{other_x}, "Since other_x was added after the transaction began, DB1 doesn't see it." );
-$db1->begin_work;
+ # Reset to an expected value
+ $db2->{x} = 'y';
+ is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is istill Z" );
+ is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is now Y" );
- cmp_bag( [ keys %$db1 ], [qw( x other_x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
- is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
- is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
+ $db1->rollback;
- $db1->{x} = 'z';
- is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
- is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is still Y" );
+ is( $db1->{x}, 'y', "After rollback, DB1's X is Y" );
+ is( $db2->{x}, 'y', "After rollback, DB2's X is Y" );
- $db2->{other_x} = 'bar';
- is( $db2->{other_x}, 'bar', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
- is( $db1->{other_x}, 'foo', "Since other_x was modified after the transaction began, DB1 doesn't see the change." );
+ is( $db1->{other_x}, 'foo', "After DB1 transaction is over, DB1 can see other_x" );
+ is( $db2->{other_x}, 'foo', "After DB1 transaction is over, DB2 can still see other_x" );
- $db1->{z} = 'a';
- is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" );
- ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." );
+ $db1->begin_work;
- cmp_bag( [ keys %$db1 ], [qw( x other_x z )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x other_x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
-$db1->commit;
+ is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
+ is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
-is( $db1->{x}, 'z', "After commit, DB1's X is Z" );
-is( $db2->{x}, 'z', "After commit, DB2's X is Z" );
+ $db1->{x} = 'z';
+ is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
+ is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is still Y" );
-is( $db1->{z}, 'a', "After commit, DB1's Z is A" );
-is( $db2->{z}, 'a', "After commit, DB2's Z is A" );
+ $db2->{other_x} = 'bar';
+ is( $db2->{other_x}, 'bar', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
+ is( $db1->{other_x}, 'foo', "Since other_x was modified after the transaction began, DB1 doesn't see the change." );
-is( $db1->{other_x}, 'bar', "After commit, DB1's other_x is bar" );
-is( $db2->{other_x}, 'bar', "After commit, DB2's other_x is bar" );
+ $db1->{z} = 'a';
+ is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" );
+ ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." );
-$db1->begin_work;
+ cmp_bag( [ keys %$db1 ], [qw( x other_x z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
- cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x z other_x )], "DB2 keys correct" );
+ $db1->commit;
is( $db1->{x}, 'z', "After commit, DB1's X is Z" );
is( $db2->{x}, 'z', "After commit, DB2's X is Z" );
is( $db1->{z}, 'a', "After commit, DB1's Z is A" );
is( $db2->{z}, 'a', "After commit, DB2's Z is A" );
- is( $db1->{other_x}, 'bar', "After begin_work, DB1's other_x is still bar" );
- is( $db2->{other_x}, 'bar', "After begin_work, DB2's other_x is still bar" );
+ is( $db1->{other_x}, 'bar', "After commit, DB1's other_x is bar" );
+ is( $db2->{other_x}, 'bar', "After commit, DB2's other_x is bar" );
+
+ $db1->begin_work;
- delete $db2->{other_x};
- ok( !exists $db2->{other_x}, "DB2 deleted other_x in DB1's transaction, so it can't see it anymore" );
- is( $db1->{other_x}, 'bar', "Since other_x was deleted after the transaction began, DB1 still sees it." );
+ cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z other_x )], "DB2 keys correct" );
- cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
+ is( $db1->{x}, 'z', "After commit, DB1's X is Z" );
+ is( $db2->{x}, 'z', "After commit, DB2's X is Z" );
- delete $db1->{x};
- ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" );
- is( $db2->{x}, 'z', "But, DB2 can still see it" );
+ is( $db1->{z}, 'a', "After commit, DB1's Z is A" );
+ is( $db2->{z}, 'a', "After commit, DB2's Z is A" );
- cmp_bag( [ keys %$db1 ], [qw( other_x z )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
+ is( $db1->{other_x}, 'bar', "After begin_work, DB1's other_x is still bar" );
+ is( $db2->{other_x}, 'bar', "After begin_work, DB2's other_x is still bar" );
-$db1->rollback;
+ delete $db2->{other_x};
+ ok( !exists $db2->{other_x}, "DB2 deleted other_x in DB1's transaction, so it can't see it anymore" );
+ is( $db1->{other_x}, 'bar', "Since other_x was deleted after the transaction began, DB1 still sees it." );
-ok( !exists $db2->{other_x}, "It's still deleted for DB2" );
-ok( !exists $db1->{other_x}, "And now DB1 sees the deletion" );
+ cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
-is( $db1->{x}, 'z', "The transaction was rolled back, so DB1 can see X now" );
-is( $db2->{x}, 'z', "DB2 can still see it" );
+ delete $db1->{x};
+ ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" );
+ is( $db2->{x}, 'z', "But, DB2 can still see it" );
-cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( other_x z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
-$db1->begin_work;
+ $db1->rollback;
- delete $db1->{x};
- ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" );
+ ok( !exists $db2->{other_x}, "It's still deleted for DB2" );
+ ok( !exists $db1->{other_x}, "And now DB1 sees the deletion" );
- is( $db2->{x}, 'z', "But, DB2 can still see it" );
+ is( $db1->{x}, 'z', "The transaction was rolled back, so DB1 can see X now" );
+ is( $db2->{x}, 'z', "DB2 can still see it" );
- cmp_bag( [ keys %$db1 ], [qw( z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
-$db1->commit;
-
-ok( !exists $db1->{x}, "The transaction was committed, so DB1 still deleted X" );
-ok( !exists $db2->{x}, "DB2 can now see the deletion of X" );
+ $db1->begin_work;
-$db1->{foo} = 'bar';
-is( $db1->{foo}, 'bar', "Set foo to bar in DB1" );
-is( $db2->{foo}, 'bar', "Set foo to bar in DB2" );
+ delete $db1->{x};
+ ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" );
-cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
+ is( $db2->{x}, 'z', "But, DB2 can still see it" );
-$db1->begin_work;
+ cmp_bag( [ keys %$db1 ], [qw( z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
- %$db1 = (); # clear()
- ok( !exists $db1->{foo}, "Cleared foo" );
- is( $db2->{foo}, 'bar', "But in DB2, we can still see it" );
+ $db1->commit;
- cmp_bag( [ keys %$db1 ], [qw()], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
+ ok( !exists $db1->{x}, "The transaction was committed, so DB1 still deleted X" );
+ ok( !exists $db2->{x}, "DB2 can now see the deletion of X" );
-$db1->rollback;
+ $db1->{foo} = 'bar';
+ is( $db1->{foo}, 'bar', "Set foo to bar in DB1" );
+ is( $db2->{foo}, 'bar', "Set foo to bar in DB2" );
-is( $db1->{foo}, 'bar', "Rollback means 'foo' is still there" );
-is( $db2->{foo}, 'bar', "Rollback means 'foo' is still there" );
+ cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
+ $db1->begin_work;
-SKIP: {
- skip "Optimize tests skipped on Win32", 7
- if $^O eq 'MSWin32' || $^O eq 'cygwin';
+ %$db1 = (); # clear()
+ ok( !exists $db1->{foo}, "Cleared foo" );
+ is( $db2->{foo}, 'bar', "But in DB2, we can still see it" );
- $db1->optimize;
+ cmp_bag( [ keys %$db1 ], [qw()], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
- is( $db1->{foo}, 'bar', 'After optimize, everything is ok' );
- is( $db2->{foo}, 'bar', 'After optimize, everything is ok' );
+ $db1->rollback;
- is( $db1->{z}, 'a', 'After optimize, everything is ok' );
- is( $db2->{z}, 'a', 'After optimize, everything is ok' );
+ is( $db1->{foo}, 'bar', "Rollback means 'foo' is still there" );
+ is( $db2->{foo}, 'bar', "Rollback means 'foo' is still there" );
cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
- $db1->begin_work;
+ SKIP: {
+ skip "Optimize tests skipped on Win32", 7
+ if $^O eq 'MSWin32' || $^O eq 'cygwin';
- cmp_ok( $db1->_engine->trans_id, '==', 1, "Transaction ID has been reset after optimize" );
+ $db1->optimize;
- $db1->rollback;
+ is( $db1->{foo}, 'bar', 'After optimize, everything is ok' );
+ is( $db2->{foo}, 'bar', 'After optimize, everything is ok' );
+
+ is( $db1->{z}, 'a', 'After optimize, everything is ok' );
+ is( $db2->{z}, 'a', 'After optimize, everything is ok' );
+
+ cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
+
+ $db1->begin_work;
+
+ cmp_ok( $db1->_engine->trans_id, '==', 1, "Transaction ID has been reset after optimize" );
+
+ $db1->rollback;
+ }
}
-__END__
+done_testing;
use strict;
-use Test::More tests => 47;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db1 = DBM::Deep->new(
- file => $filename,
+my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
type => DBM::Deep->TYPE_ARRAY,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ my $db2 = $dbm_maker->();
-my $db2 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
- type => DBM::Deep->TYPE_ARRAY,
-);
+ $db1->[0] = 'y';
+ is( $db1->[0], 'y', "Before transaction, DB1's 0 is Y" );
+ is( $db2->[0], 'y', "Before transaction, DB2's 0 is Y" );
-$db1->[0] = 'y';
-is( $db1->[0], 'y', "Before transaction, DB1's 0 is Y" );
-is( $db2->[0], 'y', "Before transaction, DB2's 0 is Y" );
+ $db1->begin_work;
-$db1->begin_work;
+ is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
+ is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
- is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
- is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
+ $db1->[0] = 'z';
+ is( $db1->[0], 'z', "Within DB1 transaction, DB1's 0 is Z" );
+ is( $db2->[0], 'y', "Within DB1 transaction, DB2's 0 is still Y" );
- $db1->[0] = 'z';
- is( $db1->[0], 'z', "Within DB1 transaction, DB1's 0 is Z" );
- is( $db2->[0], 'y', "Within DB1 transaction, DB2's 0 is still Y" );
+ $db2->[1] = 'foo';
+ is( $db2->[1], 'foo', "DB2 set 1 within DB1's transaction, so DB2 can see it" );
+ ok( !exists $db1->[1], "Since 1 was added after the transaction began, DB1 doesn't see it." );
- $db2->[1] = 'foo';
- is( $db2->[1], 'foo', "DB2 set 1 within DB1's transaction, so DB2 can see it" );
- ok( !exists $db1->[1], "Since 1 was added after the transaction began, DB1 doesn't see it." );
+ cmp_ok( scalar(@$db1), '==', 1, "DB1 has 1 element" );
+ cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
- cmp_ok( scalar(@$db1), '==', 1, "DB1 has 1 element" );
- cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
+ $db1->rollback;
-$db1->rollback;
+ is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
+ is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
-is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
-is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
+ is( $db1->[1], 'foo', "After DB1 transaction is over, DB1 can see 1" );
+ is( $db2->[1], 'foo', "After DB1 transaction is over, DB2 can still see 1" );
-is( $db1->[1], 'foo', "After DB1 transaction is over, DB1 can see 1" );
-is( $db2->[1], 'foo', "After DB1 transaction is over, DB2 can still see 1" );
+ cmp_ok( scalar(@$db1), '==', 2, "DB1 now has 2 elements" );
+ cmp_ok( scalar(@$db2), '==', 2, "DB2 still has 2 elements" );
-cmp_ok( scalar(@$db1), '==', 2, "DB1 now has 2 elements" );
-cmp_ok( scalar(@$db2), '==', 2, "DB2 still has 2 elements" );
+ $db1->begin_work;
-$db1->begin_work;
+ is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
+ is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
- is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
- is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
+ $db1->[2] = 'z';
+ is( $db1->[2], 'z', "Within DB1 transaction, DB1's 2 is Z" );
+ ok( !exists $db2->[2], "Within DB1 transaction, DB2 cannot see 2" );
- $db1->[2] = 'z';
- is( $db1->[2], 'z', "Within DB1 transaction, DB1's 2 is Z" );
- ok( !exists $db2->[2], "Within DB1 transaction, DB2 cannot see 2" );
+ cmp_ok( scalar(@$db1), '==', 3, "DB1 has 3 elements" );
+ cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
- cmp_ok( scalar(@$db1), '==', 3, "DB1 has 3 elements" );
- cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
+ $db1->commit;
-$db1->commit;
+ is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
+ is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
-is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
-is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
+ is( $db1->[2], 'z', "After DB1 transaction is over, DB1 can still see 2" );
+ is( $db2->[2], 'z', "After DB1 transaction is over, DB2 can now see 2" );
-is( $db1->[2], 'z', "After DB1 transaction is over, DB1 can still see 2" );
-is( $db2->[2], 'z', "After DB1 transaction is over, DB2 can now see 2" );
+ cmp_ok( scalar(@$db1), '==', 3, "DB1 now has 2 elements" );
+ cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 2 elements" );
-cmp_ok( scalar(@$db1), '==', 3, "DB1 now has 2 elements" );
-cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 2 elements" );
+ $db1->begin_work;
-$db1->begin_work;
+ push @$db1, 'foo';
+ unshift @$db1, 'bar';
- push @$db1, 'foo';
- unshift @$db1, 'bar';
+ cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
+ cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
- cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
- cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
+ is( $db1->[0], 'bar' );
+ is( $db1->[-1], 'foo' );
- is( $db1->[0], 'bar' );
- is( $db1->[-1], 'foo' );
+ $db1->rollback;
-$db1->rollback;
+ cmp_ok( scalar(@$db1), '==', 3, "DB1 is back to 3 elements" );
+ cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
-cmp_ok( scalar(@$db1), '==', 3, "DB1 is back to 3 elements" );
-cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
+ $db1->begin_work;
-$db1->begin_work;
+ push @$db1, 'foo';
+ unshift @$db1, 'bar';
- push @$db1, 'foo';
- unshift @$db1, 'bar';
+ cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
+ cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
- cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
- cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
+ $db1->commit;
-$db1->commit;
+ cmp_ok( scalar(@$db1), '==', 5, "DB1 is still at 5 elements" );
+ cmp_ok( scalar(@$db2), '==', 5, "DB2 now has 5 elements" );
-cmp_ok( scalar(@$db1), '==', 5, "DB1 is still at 5 elements" );
-cmp_ok( scalar(@$db2), '==', 5, "DB2 now has 5 elements" );
-
-is( $db1->[0], 'bar' );
-is( $db1->[-1], 'foo' );
+ is( $db1->[0], 'bar' );
+ is( $db1->[-1], 'foo' );
-is( $db2->[0], 'bar' );
-is( $db2->[-1], 'foo' );
+ is( $db2->[0], 'bar' );
+ is( $db2->[-1], 'foo' );
-$db1->begin_work;
+ $db1->begin_work;
- @$db1 = (); # clear()
+ @$db1 = (); # clear()
- cmp_ok( scalar(@$db1), '==', 0, "DB1 now has 0 elements" );
- cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" );
+ cmp_ok( scalar(@$db1), '==', 0, "DB1 now has 0 elements" );
+ cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" );
-$db1->rollback;
+ $db1->rollback;
-cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
-cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" );
+ cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
+ cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" );
+}
+done_testing;
use strict;
-use Test::More tests => 51;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db1 = DBM::Deep->new(
- file => $filename,
+my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
-my $db2 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
-);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ my $db2 = $dbm_maker->();
+ my $db3 = $dbm_maker->();
-my $db3 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
-);
+ $db1->{foo} = 'bar';
+ is( $db1->{foo}, 'bar', "Before transaction, DB1's foo is bar" );
+ is( $db2->{foo}, 'bar', "Before transaction, DB2's foo is bar" );
+ is( $db3->{foo}, 'bar', "Before transaction, DB3's foo is bar" );
-$db1->{foo} = 'bar';
-is( $db1->{foo}, 'bar', "Before transaction, DB1's foo is bar" );
-is( $db2->{foo}, 'bar', "Before transaction, DB2's foo is bar" );
-is( $db3->{foo}, 'bar', "Before transaction, DB3's foo is bar" );
+ $db1->begin_work;
-$db1->begin_work;
+ is( $db1->{foo}, 'bar', "Before transaction work, DB1's foo is bar" );
+ is( $db2->{foo}, 'bar', "Before transaction work, DB2's foo is bar" );
+ is( $db3->{foo}, 'bar', "Before transaction work, DB3's foo is bar" );
-is( $db1->{foo}, 'bar', "Before transaction work, DB1's foo is bar" );
-is( $db2->{foo}, 'bar', "Before transaction work, DB2's foo is bar" );
-is( $db3->{foo}, 'bar', "Before transaction work, DB3's foo is bar" );
+ $db1->{foo} = 'bar2';
-$db1->{foo} = 'bar2';
+ is( $db1->{foo}, 'bar2', "After DB1 foo to bar2, DB1's foo is bar2" );
+ is( $db2->{foo}, 'bar', "After DB1 foo to bar2, DB2's foo is bar" );
+ is( $db3->{foo}, 'bar', "After DB1 foo to bar2, DB3's foo is bar" );
-is( $db1->{foo}, 'bar2', "After DB1 foo to bar2, DB1's foo is bar2" );
-is( $db2->{foo}, 'bar', "After DB1 foo to bar2, DB2's foo is bar" );
-is( $db3->{foo}, 'bar', "After DB1 foo to bar2, DB3's foo is bar" );
+ $db1->{bar} = 'foo';
-$db1->{bar} = 'foo';
+ ok( exists $db1->{bar}, "After DB1 set bar to foo, DB1's bar exists" );
+ ok( !exists $db2->{bar}, "After DB1 set bar to foo, DB2's bar doesn't exist" );
+ ok( !exists $db3->{bar}, "After DB1 set bar to foo, DB3's bar doesn't exist" );
+
+ $db2->begin_work;
-ok( exists $db1->{bar}, "After DB1 set bar to foo, DB1's bar exists" );
-ok( !exists $db2->{bar}, "After DB1 set bar to foo, DB2's bar doesn't exist" );
-ok( !exists $db3->{bar}, "After DB1 set bar to foo, DB3's bar doesn't exist" );
-
-$db2->begin_work;
+ is( $db1->{foo}, 'bar2', "After DB2 transaction begin, DB1's foo is still bar2" );
+ is( $db2->{foo}, 'bar', "After DB2 transaction begin, DB2's foo is still bar" );
+ is( $db3->{foo}, 'bar', "After DB2 transaction begin, DB3's foo is still bar" );
-is( $db1->{foo}, 'bar2', "After DB2 transaction begin, DB1's foo is still bar2" );
-is( $db2->{foo}, 'bar', "After DB2 transaction begin, DB2's foo is still bar" );
-is( $db3->{foo}, 'bar', "After DB2 transaction begin, DB3's foo is still bar" );
+ ok( exists $db1->{bar}, "After DB2 transaction begin, DB1's bar exists" );
+ ok( !exists $db2->{bar}, "After DB2 transaction begin, DB2's bar doesn't exist" );
+ ok( !exists $db3->{bar}, "After DB2 transaction begin, DB3's bar doesn't exist" );
-ok( exists $db1->{bar}, "After DB2 transaction begin, DB1's bar exists" );
-ok( !exists $db2->{bar}, "After DB2 transaction begin, DB2's bar doesn't exist" );
-ok( !exists $db3->{bar}, "After DB2 transaction begin, DB3's bar doesn't exist" );
+ $db2->{foo} = 'bar333';
-$db2->{foo} = 'bar333';
+ is( $db1->{foo}, 'bar2', "After DB2 foo to bar2, DB1's foo is bar2" );
+ is( $db2->{foo}, 'bar333', "After DB2 foo to bar2, DB2's foo is bar333" );
+ is( $db3->{foo}, 'bar', "After DB2 foo to bar2, DB3's foo is bar" );
-is( $db1->{foo}, 'bar2', "After DB2 foo to bar2, DB1's foo is bar2" );
-is( $db2->{foo}, 'bar333', "After DB2 foo to bar2, DB2's foo is bar333" );
-is( $db3->{foo}, 'bar', "After DB2 foo to bar2, DB3's foo is bar" );
+ $db2->{bar} = 'mybar';
-$db2->{bar} = 'mybar';
+ ok( exists $db1->{bar}, "After DB2 set bar to mybar, DB1's bar exists" );
+ ok( exists $db2->{bar}, "After DB2 set bar to mybar, DB2's bar exists" );
+ ok( !exists $db3->{bar}, "After DB2 set bar to mybar, DB3's bar doesn't exist" );
-ok( exists $db1->{bar}, "After DB2 set bar to mybar, DB1's bar exists" );
-ok( exists $db2->{bar}, "After DB2 set bar to mybar, DB2's bar exists" );
-ok( !exists $db3->{bar}, "After DB2 set bar to mybar, DB3's bar doesn't exist" );
+ is( $db1->{bar}, 'foo', "DB1's bar is still foo" );
+ is( $db2->{bar}, 'mybar', "DB2's bar is now mybar" );
-is( $db1->{bar}, 'foo', "DB1's bar is still foo" );
-is( $db2->{bar}, 'mybar', "DB2's bar is now mybar" );
+ $db2->{mykey} = 'myval';
-$db2->{mykey} = 'myval';
+ ok( !exists $db1->{mykey}, "After DB2 set mykey to myval, DB1's mykey doesn't exist" );
+ ok( exists $db2->{mykey}, "After DB2 set mykey to myval, DB2's mykey exists" );
+ ok( !exists $db3->{mykey}, "After DB2 set mykey to myval, DB3's mykey doesn't exist" );
-ok( !exists $db1->{mykey}, "After DB2 set mykey to myval, DB1's mykey doesn't exist" );
-ok( exists $db2->{mykey}, "After DB2 set mykey to myval, DB2's mykey exists" );
-ok( !exists $db3->{mykey}, "After DB2 set mykey to myval, DB3's mykey doesn't exist" );
+ cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db3 ], [qw( foo )], "DB3 keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
-cmp_bag( [ keys %$db3 ], [qw( foo )], "DB3 keys correct" );
+ $db1->commit;
-$db1->commit;
+ is( $db1->{foo}, 'bar2', "After DB1 commit, DB1's foo is bar2" );
+ is( $db2->{foo}, 'bar333', "After DB1 commit, DB2's foo is bar333" );
+ is( $db3->{foo}, 'bar2', "After DB1 commit, DB3's foo is bar2" );
-is( $db1->{foo}, 'bar2', "After DB1 commit, DB1's foo is bar2" );
-is( $db2->{foo}, 'bar333', "After DB1 commit, DB2's foo is bar333" );
-is( $db3->{foo}, 'bar2', "After DB1 commit, DB3's foo is bar2" );
+ is( $db1->{bar}, 'foo', "DB1's bar is still foo" );
+ is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" );
+ is( $db3->{bar}, 'foo', "DB3's bar is now foo" );
-is( $db1->{bar}, 'foo', "DB1's bar is still foo" );
-is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" );
-is( $db3->{bar}, 'foo', "DB3's bar is now foo" );
+ cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db3 ], [qw( foo bar )], "DB3 keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
-cmp_bag( [ keys %$db3 ], [qw( foo bar )], "DB3 keys correct" );
+ $db2->commit;
-$db2->commit;
+ is( $db1->{foo}, 'bar333', "After DB2 commit, DB1's foo is bar333" );
+ is( $db2->{foo}, 'bar333', "After DB2 commit, DB2's foo is bar333" );
+ is( $db3->{foo}, 'bar333', "After DB2 commit, DB3's foo is bar333" );
-is( $db1->{foo}, 'bar333', "After DB2 commit, DB1's foo is bar333" );
-is( $db2->{foo}, 'bar333', "After DB2 commit, DB2's foo is bar333" );
-is( $db3->{foo}, 'bar333', "After DB2 commit, DB3's foo is bar333" );
+ is( $db1->{bar}, 'mybar', "DB1's bar is now mybar" );
+ is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" );
+ is( $db3->{bar}, 'mybar', "DB3's bar is now mybar" );
-is( $db1->{bar}, 'mybar', "DB1's bar is now mybar" );
-is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" );
-is( $db3->{bar}, 'mybar', "DB3's bar is now mybar" );
+ cmp_bag( [ keys %$db1 ], [qw( foo bar mykey )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db3 ], [qw( foo bar mykey )], "DB3 keys correct" );
+}
-cmp_bag( [ keys %$db1 ], [qw( foo bar mykey )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
-cmp_bag( [ keys %$db3 ], [qw( foo bar mykey )], "DB3 keys correct" );
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 8;
+use warnings FATAL => 'all';
+
+use Test::More;
use t::common qw( new_fh );
cmp_ok( $sizes{128}, '>', $sizes{64}, "Filesize for 128 > filesize for 64" );
cmp_ok( $sizes{64}, '>', $sizes{32}, "Filesize for 64 > filesize for 32" );
+done_testing;
use strict;
-use Test::More tests => 11;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- );
+my $dbm_factory = new_dbm(
+ locking => 1,
+ autoflush => 1,
+);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
$db->{a} = 1;
$db->{foo} = { a => 'b' };
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,
+
+ my $dbm_factory = new_dbm(
+ locking => 1,
autoflush => 1,
- num_txns => 2,
+ num_txns => 2,
);
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- $db->{foo} = { a => 'b' };
- my $x = $db->{foo};
+ $db->{foo} = { a => 'b' };
+ my $x = $db->{foo};
- $db->begin_work;
+ $db->begin_work;
- $db->{foo} = { c => 'd' };
- my $y = $db->{foo};
+ $db->{foo} = { c => 'd' };
+ my $y = $db->{foo};
- # XXX What should happen here with $x and $y?
- is( $x, $y );
- is( $x->{c}, 'd' );
+ # XXX What should happen here with $x and $y?
+ is( $x, $y );
+ is( $x->{c}, 'd' );
- $db->rollback;
+ $db->rollback;
+ }
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 13;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
cmp_ok( $expected, '==', -s $filename, "No reindexing after deletion" );
}
+
+done_testing;
use strict;
use Test::More tests => 41;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db1 = DBM::Deep->new(
- file => $filename,
- locking => 1,
+my $dbm_factory = new_dbm(
+ locking => 1,
autoflush => 1,
num_txns => 2,
);
-seek $db1->_get_self->_engine->storage->{fh}, 0, 0;
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ my $db2 = $dbm_maker->();
-my $db2 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 2,
-);
+ $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( xy )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
-$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" );
+ 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;
+ 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} = { 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}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
- 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" );
+ 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->{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" );
+ $db1->begin_work;
- cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-$db1->rollback;
+ 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 ], [qw( x )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 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" );
-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}{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}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
-cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY 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->YZ 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" );
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
-$db1->begin_work;
+ $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( 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}{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} = { 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( 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( yz )], "DB1->X keys correct" );
-cmp_bag( [ keys %{$db2->{x}} ], [qw( yz )], "DB2->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" );
+ 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->_engine->storage->close( $db1->_get_self );
-$db2->_get_self->_engine->storage->close( $db2->_get_self );
+done_testing;
use strict;
-use Test::More tests => 81;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
# can occur as early as 18 keys and as late as 4097 (256*16+1) keys.
{
- my ($fh, $filename) = new_fh();
- my $db1 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
- );
-
- my $db2 = DBM::Deep->new(
- file => $filename,
+ my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ my $db2 = $dbm_maker->();
- $db1->{x} = 'y';
- is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
- is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
+ $db1->{x} = 'y';
+ is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
+ is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
- $db1->begin_work;
+ $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 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- # Add enough keys to force a reindex
- $db1->{"K$_"} = "V$_" for 1 .. 16;
+ # Add enough keys to force a reindex
+ $db1->{"K$_"} = "V$_" for 1 .. 16;
- cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- $db1->rollback;
+ $db1->rollback;
- cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- ok( !exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16;
- ok( !exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16;
+ ok( !exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16;
+ ok( !exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16;
+ }
}
{
- my ($fh, $filename) = new_fh();
- my $db1 = DBM::Deep->new(
- file => $filename,
+ my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ my $db2 = $dbm_maker->();
- my $db2 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
- );
+ $db1->{x} = 'y';
+ is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
+ is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
- $db1->{x} = 'y';
- is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
- is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
+ $db1->begin_work;
- $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 ], [qw( x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ # Add enough keys to force a reindex
+ $db1->{"K$_"} = "V$_" for 1 .. 16;
- # Add enough keys to force a reindex
- $db1->{"K$_"} = "V$_" for 1 .. 16;
+ cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-
- $db1->commit;
+ $db1->commit;
- cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], ['x', (map { "K$_" } 1 .. 16)], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], ['x', (map { "K$_" } 1 .. 16)], "DB2 keys correct" );
- ok( exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16;
- ok( exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16;
+ ok( exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16;
+ ok( exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16;
+ }
}
+
+done_testing;
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
use Test::Deep;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
-use DBM::Deep;
+use_ok( 'DBM::Deep' );
my $max_txns = 255;
-my ($fh, $filename) = new_fh();
-
-my @dbs = grep { $_ } map {
- eval {
- DBM::Deep->new(
- file => $filename,
- num_txns => $max_txns,
- );
- };
-} 1 .. $max_txns;
-
-my $num = $#dbs;
-
-plan tests => do {
- my $n = $num + 1;
- 2 * $n;
-};
-
-my %trans_ids;
-for my $n (0 .. $num) {
- lives_ok {
- $dbs[$n]->begin_work
- } "DB $n can begin_work";
-
- my $trans_id = $dbs[$n]->_engine->trans_id;
- ok( !exists $trans_ids{ $trans_id }, "DB $n has a unique transaction ID ($trans_id)" );
- $trans_ids{ $trans_id } = $n;
+my $dbm_factory = new_dbm(
+ num_txns => $max_txns,
+);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my @dbs = grep { $_ } map {
+ eval { $dbm_maker->() }
+ } 1 .. $max_txns;
+
+
+ cmp_ok( scalar(@dbs), '==', $max_txns, "We could open enough DB handles" );
+
+ my %trans_ids;
+ for my $n (0 .. $#dbs) {
+ lives_ok {
+ $dbs[$n]->begin_work
+ } "DB $n can begin_work";
+
+ my $trans_id = $dbs[$n]->_engine->trans_id;
+ ok( !exists $trans_ids{ $trans_id }, "DB $n has a unique transaction ID ($trans_id)" );
+ $trans_ids{ $trans_id } = $n;
+ }
}
+
+done_testing;
use strict;
use Test::More;
+plan skip_all => "upgrade_db.pl doesn't actually do anything correct.";
+
# Add skips here
BEGIN {
plan skip_all => "Skipping the upgrade_db.pl tests on Win32/cygwin for now."
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 15;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
+my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ my $db2 = $dbm_maker->();
-seek $db->_get_self->_engine->storage->{fh}, 0, 0;
+ $db1->{foo} = 5;
+ $db1->{bar} = $db1->{foo};
-my $db2 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
-);
-
-$db->{foo} = 5;
-$db->{bar} = $db->{foo};
+ is( $db1->{foo}, 5, "Foo is still 5" );
+ is( $db1->{bar}, 5, "Bar is now 5" );
-is( $db->{foo}, 5, "Foo is still 5" );
-is( $db->{bar}, 5, "Bar is now 5" );
+ $db1->{foo} = 6;
-$db->{foo} = 6;
+ is( $db1->{foo}, 6, "Foo is now 6" );
+ is( $db1->{bar}, 5, "Bar is still 5" );
-is( $db->{foo}, 6, "Foo is now 6" );
-is( $db->{bar}, 5, "Bar is still 5" );
+ $db1->{foo} = [ 1 .. 3 ];
+ $db1->{bar} = $db1->{foo};
-$db->{foo} = [ 1 .. 3 ];
-$db->{bar} = $db->{foo};
+ is( $db1->{foo}[1], 2, "Foo[1] is still 2" );
+ is( $db1->{bar}[1], 2, "Bar[1] is now 2" );
-is( $db->{foo}[1], 2, "Foo[1] is still 2" );
-is( $db->{bar}[1], 2, "Bar[1] is now 2" );
+ $db1->{foo}[3] = 42;
-$db->{foo}[3] = 42;
+ is( $db1->{foo}[3], 42, "Foo[3] is now 42" );
+ is( $db1->{bar}[3], 42, "Bar[3] is also 42" );
-is( $db->{foo}[3], 42, "Foo[3] is now 42" );
-is( $db->{bar}[3], 42, "Bar[3] is also 42" );
+ delete $db1->{foo};
+ is( $db1->{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" );
+ $db1->{foo} = $db1->{bar};
+ $db2->begin_work;
-$db->{foo} = $db->{bar};
-$db2->begin_work;
+ delete $db2->{bar};
+ delete $db2->{foo};
- delete $db2->{bar};
- delete $db2->{foo};
+ is( $db2->{bar}, undef, "It's deleted in the transaction" );
+ is( $db1->{bar}[3], 42, "... but not in the main" );
- is( $db2->{bar}, undef, "It's deleted in the transaction" );
- is( $db->{bar}[3], 42, "... but not in the main" );
+ $db2->rollback;
-$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( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+ is( $db2->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
-# 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 $db1->{foo};
-delete $db->{foo};
+ is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+}
-is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+done_testing;
__END__
warn "-2\n";
$db2->commit;
warn "1\n";
-ok( !exists $db->{bar}, "After commit, bar is gone" );
+ok( !exists $db1->{bar}, "After commit, bar is gone" );
warn "2\n";
# This test (and accompanying patch) was submitted by Father Chrysostomos (sprout@cpan.org)
-use 5.006;
-
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 5;
+use Test::More;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- ok eval {
- for ( # the checksums of all these begin with ^@:
+ ok eval {
+ for ( # the checksums of all these begin with ^@:
+ qw/ s340l 1970 thronos /,
+ "\320\277\320\276\320\262\320\265\320\273\320\265\320\275".
+ "\320\275\320\276\320\265", qw/ mr094 despite
+ geographically binding bed handmaiden infer lela infranarii
+ lxv evtropia recognizes maladies /
+ ) {
+ $db->{$_} = undef;
+ }
+ 1;
+ }, '2 indices can be created at once';
+
+ is_deeply [sort keys %$db], [ sort
qw/ s340l 1970 thronos /,
"\320\277\320\276\320\262\320\265\320\273\320\265\320\275".
"\320\275\320\276\320\265", qw/ mr094 despite
geographically binding bed handmaiden infer lela infranarii
lxv evtropia recognizes maladies /
- ) {
- $db->{$_} = undef;
- }
- 1;
- }, '2 indices can be created at once';
-
- is_deeply [sort keys %$db], [ sort
- qw/ s340l 1970 thronos /,
- "\320\277\320\276\320\262\320\265\320\273\320\265\320\275".
- "\320\275\320\276\320\265", qw/ mr094 despite
- geographically binding bed handmaiden infer lela infranarii
- lxv evtropia recognizes maladies /
- ], 'and the keys were stored correctly';
+ ], 'and the keys were stored correctly';
+ }
}
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- ok eval {
- for ( # the checksums of all these begin with ^@^@^@:
+ ok eval {
+ for ( # the checksums of all these begin with ^@^@^@:
+ qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda
+ lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII
+ FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW /
+ ) {
+ $db->{$_} = undef;
+ }
+ 1;
+ }, 'multiple nested indices can be created at once';
+
+ is_deeply [sort keys %$db], [ sort
qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda
lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII
FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW /
- ) {
- $db->{$_} = undef;
- }
- 1;
- }, 'multiple nested indices can be created at once';
-
- is_deeply [sort keys %$db], [ sort
- qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda
- lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII
- FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW /
- ], 'and the keys were stored correctly';
+ ], 'and the keys were stored correctly';
+ }
}
-__END__
+done_testing;
-use 5.006;
-
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 13;
+use Test::More;
use Test::Exception;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
# This is bug #34819, reported by EJS
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- my $bar = bless { foo => 'ope' }, 'Foo';
+ my $bar = bless { foo => 'ope' }, 'Foo';
- eval {
- $db->{bar} = $bar;
- $db->{bar} = $bar;
- };
+ eval {
+ $db->{bar} = $bar;
+ $db->{bar} = $bar;
+ };
- ok(!$@, "repeated object assignment");
- isa_ok($db->{bar}, 'Foo');
+ ok(!$@, "repeated object assignment");
+ isa_ok($db->{bar}, 'Foo');
+ }
}
# This is bug #29957, reported by HANENKAMP
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- $db->{foo} = [];
+ $db->{foo} = [];
- for my $value ( 1 .. 3 ) {
- lives_ok {
- my $ref = $db->{foo};
- push @$ref, $value;
- $db->{foo} = $ref;
- } "Successfully added value $value";
- }
+ for my $value ( 1 .. 3 ) {
+ lives_ok {
+ my $ref = $db->{foo};
+ push @$ref, $value;
+ $db->{foo} = $ref;
+ } "Successfully added value $value";
+ }
- cmp_deeply( [1,2,3], noclass($db->{foo}), "Everything looks ok" );
+ cmp_deeply( [1,2,3], noclass($db->{foo}), "Everything looks ok" );
+ }
}
# This is bug #33863, reported by PJS
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
-
- $db->{foo} = [ 42 ];
- my $foo = shift @{ $db->{foo} };
- cmp_ok( @{ $db->{foo} }, '==', 0, "Shifting a scalar leaves no values" );
- cmp_ok( $foo, '==', 42, "... And the value is correct." );
-
- $db->{bar} = [ [] ];
- my $bar = shift @{ $db->{bar} };
- cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" );
-
- $db->{baz} = { foo => [ 1 .. 3 ] };
- $db->{baz2} = [ $db->{baz} ];
- my $baz2 = shift @{ $db->{baz2} };
- cmp_ok( @{ $db->{baz2} }, '==', 0, "Shifting an arrayref leaves no values" );
- ok( exists $db->{baz}{foo} );
- ok( exists $baz2->{foo} );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ $db->{foo} = [ 42 ];
+ my $foo = shift @{ $db->{foo} };
+ cmp_ok( @{ $db->{foo} }, '==', 0, "Shifting a scalar leaves no values" );
+ cmp_ok( $foo, '==', 42, "... And the value is correct." );
+
+ $db->{bar} = [ [] ];
+ my $bar = shift @{ $db->{bar} };
+ cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" );
+
+ $db->{baz} = { foo => [ 1 .. 3 ] };
+ $db->{baz2} = [ $db->{baz} ];
+ my $baz2 = shift @{ $db->{baz2} };
+ cmp_ok( @{ $db->{baz2} }, '==', 0, "Shifting an arrayref leaves no values" );
+ ok( exists $db->{baz}{foo} );
+ ok( exists $baz2->{foo} );
+ }
}
-__END__
+done_testing;
-use 5.006;
-
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 2;
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-{
- my ($fh, $filename) = t::common::new_fh();
- my $db = DBM::Deep->new( $filename );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
# Add a self-referencing connection to test export
my %struct = (
);
}
-__END__
+done_testing;
-use 5.006_000;
-
use strict;
use warnings FATAL => 'all';
use Test::More;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
my $max = 10;
-plan tests => $max + 1;
-
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-my $x = 1;
-while( $x <= $max ) {
- eval {
- delete $db->{borked}{test};
- $db->{borked}{test} = 1;
- };
+ my $x = 1;
+ while( $x <= $max ) {
+ eval {
+ delete $db->{borked}{test};
+ $db->{borked}{test} = 1;
+ };
- ok(!$@, "No eval failure after ${x}th iteration");
- $x++;
+ ok(!$@, "No eval failure after ${x}th iteration");
+ $x++;
+ }
}
+
+done_testing;
-
# This was discussed here:
# http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab
# brought up by Alex Gallichotte
use warnings FATAL => 'all';
use Test::More;
-use DBM::Deep;
plan skip_all => "Need to figure out what platforms this runs on";
-use t::common qw( new_fh );
+use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+use t::common qw( new_dbm );
-my $todo = 1000;
-my $allow = $todo*0.02; # NOTE: a 2% fail rate is hardly a failure
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-$db->{randkey()} = 1 for 1 .. 1000;
+ my $todo = 1000;
+ my $allow = $todo*0.02; # NOTE: a 2% fail rate is hardly a failure
-plan tests => $todo*2;
+ $db->{randkey()} = 1 for 1 .. 1000;
-my $error_count = 0;
-my @mem = (mem(0), mem(1));
-for my $i (1 .. $todo) {
- $db->{randkey()} = [@mem];
+ my $error_count = 0;
+ my @mem = (mem(0), mem(1));
+ for my $i (1 .. $todo) {
+ $db->{randkey()} = [@mem];
- ## DEBUG ## print STDERR " @mem \r";
+ ## DEBUG ## print STDERR " @mem \r";
- my @tm = (mem(0), mem(1));
+ my @tm = (mem(0), mem(1));
- skip( not($mem[0]), ($tm[0] <= $mem[0] or --$allow>0) );
- skip( not($mem[1]), ($tm[1] <= $mem[1] or --$allow>0) );
+ skip( not($mem[0]), ($tm[0] <= $mem[0] or --$allow>0) );
+ skip( not($mem[1]), ($tm[1] <= $mem[1] or --$allow>0) );
- $error_count ++ if $tm[0] > $mem[0] or $tm[1] > $mem[1];
- die " ERROR: that's enough failures to prove the point ... " if $error_count > 20;
+ $error_count ++ if $tm[0] > $mem[0] or $tm[1] > $mem[1];
+ die " ERROR: that's enough failures to prove the point ... " if $error_count > 20;
- @mem = @tm;
+ @mem = @tm;
+ }
}
sub randkey {
-
# This was discussed here:
# http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab
# brought up by Alex Gallichotte
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 4;
-use t::common qw( new_fh );
+use Test::More;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+ eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures");
-eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures");
+ eval {
+ #$db->begin_work;
+ $db->{randkey()} = randkey() for 1 .. 10;
+ #$db->commit;
+ };
+ ok(!$@, "No eval failures from the transaction");
-eval {
-# $db->begin_work;
- $db->{randkey()} = randkey() for 1 .. 10;
-# $db->commit;
-};
-ok(!$@, "No eval failures from the transaction");
+ eval { $db->{randkey()} = randkey() for 1 .. 10; };
+ ok(!$@, "No eval failures");
+}
-eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures");
+done_testing;
sub randkey {
- our $i ++;
+ our $i++;
my @k = map { int rand 100 } 1 .. 10;
local $" = "-";
use strict;
-use Test::More tests => 3;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
use t::common qw( new_fh );
$db->{foo} = 'bar';
-is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
+is( $db->_dump_file, <<"__END_DUMP__", "Dump of file after single assignment" );
NumTxns: 1
Chains(B):
Chains(D):
00000545: D 0064 foo
__END_DUMP__
+done_testing;
my @these_args = @{ shift @extra_args };
return sub {
DBM::Deep->new(
- @these_args, @args,
+ @these_args, @args, @_,
);
};
};
projects / dbsrgits/DBM-Deep.git / commitdiff