From: Rob Kinyon Date: Mon, 22 Feb 2010 12:51:53 +0000 (-0500) Subject: Merged with master and am ready to merge back X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;p=dbsrgits%2FDBM-Deep.git Merged with master and am ready to merge back --- 24b0b7b9c405df7f75babe1e6ebd48680c9853a5 diff --cc Build.PL index 956bbc4,3f769a1..e691c3f --- a/Build.PL +++ b/Build.PL @@@ -40,9 -25,9 +40,10 @@@ my $build = Module::Build->subclass '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.88', # done_testing 'Test::Exception' => '0.21', 'IO::Scalar' => '0.01', }, diff --cc Changes index f3ab5a8,3655c52..2ec0519 --- a/Changes +++ b/Changes @@@ -1,81 -1,19 +1,95 @@@ -Revision history for DBM::Deep. +Revision history for DBM::Deep (ordered by revision number). + +1.0020 Feb 16 22:00:00 2010 EST + (This version is compatible with 1.0016) + - Fixed t/43_transaction_maximum.t so that it doesn't error out on systems + which cannot fork > 255 children at one time. + - Improved code coverage + - Added t/96_virtual_functions.t which helps describe what actually + needs to be overridden in a new plugin. + + +1.0019_003 Feb 16 22:00:00 2010 EST + (This is the third developer release for 1.0020.) + (This version is compatible with 1.0016) + - Fixed problem where "./Build test" wouldn't actually -do- anything. + - (No-one apparently tried to install this till Steven Lembark. Thanks!) + - Fixed speed regression with keys in the File backend. + - Introduced in 1.0019_002 to fix #50541 + - Thanks, SPROUT! + - (RT #53575) Recursion failure in STORE (Thanks, SPROUT) + - Merged the rest of the fixes from 1.0015 and 1.0016 + - Thanks to our new co-maintainer, SPROUT! :) + - Had to turn off singleton support in the File backend because the caching + was causing havoc with transactions. Turning on fatal warnings does give + apparently important information. + - Oh - forgot to mention that fatal warnings are now on in all files. + +1.0019_002 Jan 05 22:30:00 2010 EST + (This is the second developer release for 1.0020.) + (This version is compatible with 1.0014) + - Fixed bug where attempting to store a value tied to something other than + DBM::Deep would leave the file flocked. + - Added support for DBD::SQLite + - Build.PL has been extended to support sqlite vs. mysql + - Storage::DBI now detects between the two DBDs + - (RT #51888) Applied POD patch (Thanks, FWIE!) + - (RT #44981) Added VERSION to ::Array, ::Engine, and ::Hash + - Removed extraneous slashes from POD links (Thanks ilmari!) + - (RT #50541) Fixed bug in clear() for hashes in the File backend. + - This has caused a regression in speed for clear() when clearing + large hashes using running with the File backend. ->clear() (on my + machine) now takes ( N / 40 ) ** (1.66) seconds. So, clearing 4000 + keys (as is the test in t/03_bighash.t) would take ~2070 seconds. + - (RT #40782) Fixed bug when handling a key of '0' (Thanks Sterling!) + - (RT #48031) Fixed bug with localized $, (Thanks, SPROUT!) + +1.0019_001 Dec 31 22:00:00 2009 EST + (This is the first developer release for 1.0020.) + (This version is compatible with 1.0014) + - DBM::Deep has been refactored to allow for multiple engines. There are two + engines built so far: + - File (the original engine) + - DBI (an engine based on DBI) + - The DBI engine has only been tested on MySQL and isn't transactional. + - InnoDB sucks horribly. When run in a sufficient isolation mode, it + creates deadlocks. + - A custom Build.PL has been written to allow for running tests under + CPAN.pm against the various engines. + - This also allows running the long tests under CPAN.pm + - This has meant a ton of refactoring. Hopefullly, this refactoring will + allow finding some of the niggly bugs more easily. Those tests have not + been enabled yet. That's the next developer release. + - Hopefully, this multi-engine support will allow deprecation of the file + format in the future. + +1.0016 Feb 05 22:10:00 2010 PST + - (This version is compatible with 1.0015) + - New caveat in the docs explaining stale references (RT#42129) + - All included modules now have the same version in META.yml, so + the CPAN shell will no longer try to downgrade. + - Fixed bug in clear() for hashes (RT#50541) + +1.0015 Jan 25 22:05:00 2010 PST + - (This version is compatible with 1.0014) + - Fix deep recursion errors (RT#53575) + - Avoid leaving temp files lying around (RT#32462) + - (RT #48031) Fixed bug with localized $, (Thanks, SPROUT!) + 1.0016 Feb 05 22:10:00 2010 PST + - (This version is compatible with 1.0015) + - New caveat in the docs explaining stale references (RT#42129) + - All included modules now have the same version in META.yml, so + the CPAN shell will no longer try to downgrade. + - Fixed bug in clear() for hashes (RT#50541) + + 1.0015 Jan 25 22:05:00 2010 PST + - (This version is compatible with 1.0014) + - Fix deep recursion errors (RT#53575) + - Avoid leaving temp files lying around (RT#32462) + - (RT #48031) Fixed bug with localized $, (Thanks, SPROUT!) + - (RT #40782) Fixed bug when handling a key of '0' (Thanks Sterling!) + 1.0014 Jun 13 23:15:00 2008 EST - (This version is compatible with 1.0013) - Fix for RT#36781 (t/44 has an unrequired dependency) diff --cc MANIFEST index 9078113,fe83126..32ae0ca --- a/MANIFEST +++ b/MANIFEST @@@ -83,7 -73,6 +83,8 @@@ t/50_deletes. t/52_memory_leak.t t/53_misc_transactions.t t/54_output_punct_vars.t +t/55_recursion.t ++t/96_virtual_functions.t t/97_dump_file.t t/98_pod.t t/99_pod_coverage.t diff --cc lib/DBM/Deep.pm index 80900e8,828124b..277fbe9 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@@ -582,12 -581,9 +582,12 @@@ sub CLEAR } $self->lock_exclusive; - - # Dispatch to the specific clearing functionality. - $engine->clear($self); + eval { + local $SIG{'__DIE__'}; + $engine->clear( $self ); + }; + my $e = $@; - warn "$e\n" if $e; ++ warn "$e\n" if $e && DEBUG; $self->unlock; diff --cc lib/DBM/Deep.pod index b11fcbc,5179182..b93ee71 --- a/lib/DBM/Deep.pod +++ b/lib/DBM/Deep.pod @@@ -1128,37 -1048,16 +1148,37 @@@ reading the data L is used to test the code coverage of the tests. Below is the L report on this distribution's test suite. - ------------------------------------------ ------ ------ ------ ------ ------ - File stmt bran cond sub total - ------------------------------------------ ------ ------ ------ ------ ------ - blib/lib/DBM/Deep.pm 97.2 90.9 83.3 100.0 95.4 - blib/lib/DBM/Deep/Array.pm 100.0 95.7 100.0 100.0 99.0 - blib/lib/DBM/Deep/Engine.pm 95.6 84.7 81.6 98.4 92.5 - blib/lib/DBM/Deep/File.pm 97.2 81.6 66.7 100.0 91.9 - blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0 - Total 96.7 87.5 82.2 99.2 94.1 - ------------------------------------------ ------ ------ ------ ------ ------ + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + File stmt bran cond sub pod time total + ---------------------------- ------ ------ ------ ------ ------ ------ ------ - blib/lib/DBM/Deep.pm 100.0 90.0 81.8 100.0 100.0 32.4 98.2 ++ blib/lib/DBM/Deep.pm 100.0 89.1 82.9 100.0 100.0 32.5 98.1 + blib/lib/DBM/Deep/Array.pm 100.0 94.4 100.0 100.0 100.0 5.2 98.8 - blib/lib/DBM/Deep/Engine.pm 100.0 92.9 100.0 100.0 100.0 7.5 100.0 - ...ib/DBM/Deep/Engine/DBI.pm 93.3 71.2 100.0 100.0 100.0 1.5 89.0 - ...b/DBM/Deep/Engine/File.pm 91.8 77.8 88.9 100.0 100.0 4.9 89.9 - blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0 3.9 100.0 ++ blib/lib/DBM/Deep/Engine.pm 100.0 92.9 100.0 100.0 100.0 7.4 100.0 ++ ...ib/DBM/Deep/Engine/DBI.pm 95.0 73.1 100.0 100.0 100.0 1.5 90.4 ++ ...b/DBM/Deep/Engine/File.pm 92.3 78.5 88.9 100.0 100.0 4.9 90.3 ++ blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0 3.8 100.0 + .../lib/DBM/Deep/Iterator.pm 100.0 n/a n/a 100.0 100.0 0.0 100.0 - .../DBM/Deep/Iterator/DBI.pm 100.0 100.0 n/a 100.0 100.0 1.4 100.0 ++ .../DBM/Deep/Iterator/DBI.pm 100.0 100.0 n/a 100.0 100.0 1.2 100.0 + ...DBM/Deep/Iterator/File.pm 92.5 84.6 n/a 100.0 66.7 0.6 90.0 + ...erator/File/BucketList.pm 100.0 75.0 n/a 100.0 66.7 0.4 93.8 + ...ep/Iterator/File/Index.pm 100.0 100.0 n/a 100.0 100.0 0.2 100.0 + blib/lib/DBM/Deep/Null.pm 87.5 n/a n/a 75.0 n/a 0.0 83.3 + blib/lib/DBM/Deep/Sector.pm 91.7 n/a n/a 83.3 0.0 6.7 74.4 + ...ib/DBM/Deep/Sector/DBI.pm 96.8 83.3 n/a 100.0 0.0 1.0 89.8 - ...p/Sector/DBI/Reference.pm 98.9 86.4 100.0 100.0 0.0 2.2 89.2 ++ ...p/Sector/DBI/Reference.pm 100.0 95.5 100.0 100.0 0.0 2.2 91.2 + ...Deep/Sector/DBI/Scalar.pm 100.0 100.0 n/a 100.0 0.0 1.1 92.9 + ...b/DBM/Deep/Sector/File.pm 96.0 87.5 100.0 92.3 25.0 2.2 91.0 + ...Sector/File/BucketList.pm 98.2 85.7 83.3 100.0 0.0 3.3 89.4 + .../Deep/Sector/File/Data.pm 100.0 n/a n/a 100.0 0.0 0.1 90.9 + ...Deep/Sector/File/Index.pm 100.0 80.0 33.3 100.0 0.0 0.8 83.1 + .../Deep/Sector/File/Null.pm 100.0 100.0 n/a 100.0 0.0 0.0 91.7 + .../Sector/File/Reference.pm 100.0 90.0 80.0 100.0 0.0 1.4 91.5 - ...eep/Sector/File/Scalar.pm 98.3 87.5 n/a 100.0 0.0 0.8 91.5 ++ ...eep/Sector/File/Scalar.pm 98.4 87.5 n/a 100.0 0.0 0.8 91.9 + blib/lib/DBM/Deep/Storage.pm 100.0 n/a n/a 100.0 100.0 0.0 100.0 + ...b/DBM/Deep/Storage/DBI.pm 97.3 70.8 n/a 100.0 38.5 6.7 87.0 - .../DBM/Deep/Storage/File.pm 96.6 77.1 80.0 95.7 100.0 15.8 91.8 - Total 99.2 84.8 84.7 99.8 63.3 100.0 97.6 ++ .../DBM/Deep/Storage/File.pm 96.6 77.1 80.0 95.7 100.0 16.0 91.8 ++ Total 99.3 85.2 84.9 99.8 63.3 100.0 97.6 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ =head1 MORE INFORMATION diff --cc lib/DBM/Deep/Engine.pm index 9713426,dc6b14c..ab1fa60 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@@ -54,8 -86,10 +54,10 @@@ is the following =item * get_next_key -=item * clear +=item * setup -=item * setup_fh ++=item * clear + =item * begin_work =item * commit diff --cc lib/DBM/Deep/Hash.pm index 40f0bf6,3188dd1..633e6d5 --- a/lib/DBM/Deep/Hash.pm +++ b/lib/DBM/Deep/Hash.pm @@@ -98,11 -105,14 +98,11 @@@ sub NEXTKEY : $result; } -## -# Public method aliases -## sub first_key { (shift)->FIRSTKEY(@_) } -sub next_key { (shift)->NEXTKEY(@_) } +sub next_key { (shift)->NEXTKEY(@_) } sub _clear { - my $self = shift->_get_self; + my $self = shift; while ( defined(my $key = $self->first_key) ) { do { diff --cc lib/DBM/Deep/Sector/File/Scalar.pm index eab145c,f045f51..c31909b --- a/lib/DBM/Deep/Sector/File/Scalar.pm +++ b/lib/DBM/Deep/Sector/File/Scalar.pm @@@ -4,8 -4,9 +4,9 @@@ use 5.006_000 use strict; use warnings FATAL => 'all'; + no warnings 'recursion'; -use base qw( DBM::Deep::Engine::Sector::Data ); +use base qw( DBM::Deep::Sector::File::Data ); my $STALE_SIZE = 2; diff --cc t/04_array.t index 07c9763,a75c349..fe518db --- a/t/04_array.t +++ b/t/04_array.t @@@ -7,248 -8,253 +7,247 @@@ use t::common qw( new_dbm ) use_ok( 'DBM::Deep' ); -my ($fh, $filename) = new_fh(); -my $db = DBM::Deep->new( - file => $filename, - fh => $fh, - 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"; +} - done_testing; - __END__ + # 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 { @@@ -271,4 -277,18 +270,22 @@@ is( $db->[5]{foo}, 1, "Right hashref there" ); } +done_testing; ++__END__ + { # Make sure we do not trigger a deep recursion warning [RT #53575] + my $w; + local $SIG{__WARN__} = sub { $w = shift }; + my ($fh, $filename) = new_fh(); + my $db = DBM::Deep->new( file => $filename, fh => $fh, ); + my $a = []; + my $tmp = $a; + for(1..100) { + ($tmp) = @$tmp = []; + } + ok eval { + $db->{""} = $a; + }, 'deep recursion in array assignment' or diag $@; + is $w, undef, 'no warnings with deep recursion in array assignment'; + } ++ ++done_testing; diff --cc t/27_filehandle.t index 5c9ee60,be5f58c..d84040d --- a/t/27_filehandle.t +++ b/t/27_filehandle.t @@@ -67,11 -56,19 +67,19 @@@ Test::More->builder->{Curr_Test} = $pre use_ok( 'DBM::Deep' ); -my $db = DBM::Deep->new({ +my \$db = DBM::Deep->new({ fh => *DATA, }); -is($db->{x}, 'b', "and get at stuff in the database"); +is(\$db->{x}, 'b', "and get at stuff in the database"); __END_FH__ + + # The exec below prevents END blocks from doing this. + (my $esc_dir = $t::common::dir) =~ s/(.)/sprintf "\\x{%x}", ord $1/egg; + print $fh <<__END_FH_AGAIN__; + use File::Path 'rmtree'; + rmtree "$esc_dir"; + __END_FH_AGAIN__ + print $fh "__DATA__\n"; close $fh; diff --cc t/29_largedata.t index ebbd311,16a9b32..28dcd5a --- a/t/29_largedata.t +++ b/t/29_largedata.t @@@ -6,20 -7,21 +6,20 @@@ 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; ++ my $val1 = "a" x 6000; -## -# large keys -## -my $val1 = "a" x 6000; + $db->{foo} = $val1; - is( $db->{foo}, $val1, "1000 char value stored and retrieved" ); ++ is( $db->{foo}, $val1, "6000 char value stored and retrieved" ); -$db->{foo} = $val1; -is( $db->{foo}, $val1, "6000 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; diff --cc t/96_virtual_functions.t index 5ff7d41,0000000..7b21045 mode 100644,000000..100644 --- a/t/96_virtual_functions.t +++ b/t/96_virtual_functions.t @@@ -1,172 -1,0 +1,169 @@@ +#vim: ft=perl + +use strict; +use warnings FATAL => 'all'; + +use Test::More; +use Test::Exception; + +use lib 't/lib'; + +use_ok( 'DBM::Deep' ); + +throws_ok { + DBM::Deep->new({ _test => 1 }); +} qr/lock_exclusive must be implemented in a child class/, 'Must define lock_exclusive in Storage'; + +{ + no strict 'refs'; + *{"DBM::Deep::Storage::Test::lock_exclusive"} = sub { 1 }; +} + +throws_ok { + DBM::Deep->new({ _test => 1 }); +} qr/setup must be implemented in a child class/, 'Must define setup in Engine'; + +{ + no strict 'refs'; + *{"DBM::Deep::Engine::Test::setup"} = sub { 1 }; +} + +throws_ok { + DBM::Deep->new({ _test => 1 }); +} qr/unlock must be implemented in a child class/, 'Must define unlock in Storage'; + +{ + no strict 'refs'; + *{"DBM::Deep::Storage::Test::unlock"} = sub { 1 }; +} + +throws_ok { + DBM::Deep->new({ _test => 1 }); +} qr/flush must be implemented in a child class/, 'Must define flush in Storage'; + +{ + no strict 'refs'; + *{"DBM::Deep::Storage::Test::flush"} = sub { 1 }; +} + +my $db; +lives_ok { + $db = DBM::Deep->new({ _test => 1 }); +} "We finally have enough defined to instantiate"; + +throws_ok { + $db->lock_shared; +} qr/lock_shared must be implemented in a child class/, 'Must define lock_shared in Storage'; + +{ + no strict 'refs'; + *{"DBM::Deep::Storage::Test::lock_shared"} = sub { 1 }; +} + +lives_ok { + $db->lock_shared; +} 'We have lock_shared defined'; + +# Yes, this is ordered for good reason. Think about it. +my @methods = ( + 'begin_work' => [ + Engine => 'begin_work', + ], + 'rollback' => [ + Engine => 'rollback', + ], + 'commit' => [ + Engine => 'commit', + ], + 'supports' => [ + Engine => 'supports', + ], + 'store' => [ + Storage => 'is_writable', + Engine => 'write_value', + ], + 'fetch' => [ + Engine => 'read_value', + ], + 'delete' => [ + Engine => 'delete_key', + ], + 'exists' => [ + Engine => 'key_exists', + ], + # Why is this one's error message bleeding through? + 'clear' => [ + Engine => 'clear', + ], +); + +# Add the following: +# in_txn + +# If only I could use natatime(). *sighs* +while ( @methods ) { + my ($entry, $requirements) = splice @methods, 0, 2; - if ( $entry eq 'clear' ) { - diag "Please ignore the spurious die for clear. I can't figure out how to prevent it" - } + while ( @$requirements ) { + my ($class, $child_method) = splice @$requirements, 0, 2; + + throws_ok { + $db->$entry( 1 ); + } qr/$child_method must be implemented in a child class/, + "'$entry' requires '$child_method' to be defined in the '$class'"; + + { + no strict 'refs'; + *{"DBM::Deep::${class}::Test::${child_method}"} = sub { 1 }; + } + } + + lives_ok { + $db->$entry( 1 ); + } "Finally have enough for '$entry' to work"; +} + +throws_ok { + $db->_engine->sector_type; +} qr/sector_type must be implemented in a child class/, 'Must define sector_type in Storage'; + +{ + no strict 'refs'; + *{"DBM::Deep::Engine::Test::sector_type"} = sub { 'DBM::Deep::Iterator::Test' }; +} + +lives_ok { + $db->_engine->sector_type; +} 'We have sector_type defined'; + +throws_ok { + $db->first_key; +} qr/iterator_class must be implemented in a child class/, 'Must define iterator_class in Iterator'; + +{ + no strict 'refs'; + *{"DBM::Deep::Engine::Test::iterator_class"} = sub { 'DBM::Deep::Iterator::Test' }; +} + +throws_ok { + $db->first_key; +} qr/reset must be implemented in a child class/, 'Must define reset in Iterator'; + +{ + no strict 'refs'; + *{"DBM::Deep::Iterator::Test::reset"} = sub { 1 }; +} + +throws_ok { + $db->first_key; +} qr/get_next_key must be implemented in a child class/, 'Must define get_next_key in Iterator'; + +{ + no strict 'refs'; + *{"DBM::Deep::Iterator::Test::get_next_key"} = sub { 1 }; +} + +lives_ok { + $db->first_key; +} 'Finally have enough for first_key to work.'; + +done_testing; diff --cc t/common.pm index a4c61d6,135ed66..eda627c --- a/t/common.pm +++ b/t/common.pm @@@ -15,7 -18,8 +15,7 @@@ use File::Temp qw( tempfile tempdir ) use Fcntl qw( :flock ); my $parent = $ENV{WORK_DIR} || File::Spec->tmpdir; - my $dir = tempdir( CLEANUP => 1, DIR => $parent ); + our $dir = tempdir( CLEANUP => 1, DIR => $parent ); -#my $dir = tempdir( DIR => '.' ); sub new_fh { my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir, UNLINK => 1 );