├── .gitignore ├── t ├── etc │ ├── db-0-983 │ ├── db-1-0000 │ ├── db-1-0003 │ └── db-0-99_04 ├── lib │ └── DBM │ │ └── Deep │ │ ├── Iterator │ │ └── Test.pm │ │ ├── Storage │ │ └── Test.pm │ │ └── Engine │ │ └── Test.pm ├── 98_pod.t ├── 58_cache.t ├── 55_recursion.t ├── 57_old_db.t ├── 32_dash_ell.t ├── 29_largedata.t ├── 01_basic.t ├── 25_tie_return_value.t ├── 54_output_punct_vars.t ├── 50_deletes.t ├── 99_pod_coverage.t ├── 07_locking.t ├── 53_misc_transactions.t ├── 05_bigarray.t ├── 28_index_sector.t ├── 97_dump_file.t ├── 56_unicode.t ├── 12_clone.t ├── 09_deeparray.t ├── 31_references.t ├── 43_transaction_maximum.t ├── 21_tie_access.t ├── 48_autoexport_after_delete.t ├── 23_misc.t ├── 03_bighash.t ├── 20_tie.t ├── 18_export.t ├── 26_scalar_ref.t ├── 30_already_tied.t ├── 08_deephash.t ├── 45_references.t ├── 10_largekeys.t ├── 47_odd_reference_behaviors.t ├── 15_digest.t ├── 46_blist_reindex.t ├── 22_internal_copy.t ├── 19_crossref.t ├── 52_memory_leak.t ├── 14_filter.t ├── 40_freespace.t ├── 38_data_sector_size.t ├── 13_setpack.t ├── 42_transaction_indexsector.t ├── common.pm ├── 11_optimize.t ├── 16_circular.t ├── 27_filehandle.t ├── 41_transaction_multilevel.t ├── 34_transaction_arrays.t ├── 96_virtual_functions.t ├── 35_transaction_multiple.t ├── 17_import.t ├── 06_error.t ├── 24_autobless.t ├── 44_upgrade_db.t ├── 02_hash.t └── 39_singletons.t ├── .whitesource ├── TODO ├── MANIFEST.SKIP ├── lib └── DBM │ └── Deep │ ├── Sector │ ├── File │ │ ├── Data.pm │ │ ├── Null.pm │ │ ├── Index.pm │ │ └── Scalar.pm │ ├── DBI │ │ ├── Scalar.pm │ │ └── Reference.pm │ ├── DBI.pm │ └── File.pm │ ├── Sector.pm │ ├── Iterator │ ├── DBI.pm │ ├── File │ │ ├── Index.pm │ │ └── BucketList.pm │ └── File.pm │ ├── Null.pm │ ├── Iterator.pm │ ├── Storage.pm │ ├── Hash.pm │ ├── Storage │ └── DBI.pm │ └── Cookbook.pod ├── etc ├── sqlite_tables.sql ├── sql_example.pl └── mysql_tables.sql ├── t_attic ├── 37_delete_edge_cases.t ├── 36_verybighash.t └── TODO ├── MANIFEST ├── Build.PL └── utils └── upgrade_db.pl /.gitignore: -------------------------------------------------------------------------------- 1 | .*.sw? 2 | -------------------------------------------------------------------------------- /t/etc/db-0-983: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/dbm-deep/master/t/etc/db-0-983 -------------------------------------------------------------------------------- /t/etc/db-1-0000: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/dbm-deep/master/t/etc/db-1-0000 -------------------------------------------------------------------------------- /t/etc/db-1-0003: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/dbm-deep/master/t/etc/db-1-0003 -------------------------------------------------------------------------------- /.whitesource: -------------------------------------------------------------------------------- 1 | { 2 | "generalSettings": { 3 | "shouldScanRepo": true 4 | }, 5 | "checkRunSettings": { 6 | "vulnerableCheckRunConclusionLevel": "failure" 7 | } 8 | } -------------------------------------------------------------------------------- /t/lib/DBM/Deep/Iterator/Test.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Iterator::Test; 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use base qw( DBM::Deep::Iterator ); 7 | 8 | 1; 9 | __END__ 10 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * clear() should use the Engine to clear. In the File backend, this would mean 2 | that Sector::File::Reference should have a function similar to get_bucket_list 3 | that iterates and deletes as appropriate. 4 | -------------------------------------------------------------------------------- /t/lib/DBM/Deep/Storage/Test.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Storage::Test; 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use base qw( DBM::Deep::Storage ); 7 | 8 | sub new { 9 | return bless { 10 | }, shift; 11 | } 12 | 13 | 1; 14 | __END__ 15 | -------------------------------------------------------------------------------- /t/etc/db-0-99_04: -------------------------------------------------------------------------------- 1 | DPDBhH -------------------------------------------------------------------------------- /t/98_pod.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | 3 | use Test::More; 4 | 5 | eval "use Test::Pod 1.14"; 6 | plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; 7 | eval { require Pod::Simple }; 8 | plan skip_all => "Pod::Simple 3.21 has bugs" 9 | if $Pod::Simple::VERSION == 3.21; 10 | 11 | all_pod_files_ok(); 12 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^_build 2 | ^Build$ 3 | ^blib 4 | ~$ 5 | \.bak$ 6 | ^MANIFEST\.SKIP$ 7 | CVS 8 | \.svn 9 | cover_db 10 | \..*\.sw.?$ 11 | ^Makefile$ 12 | ^pm_to_blib$ 13 | ^MakeMaker-\d 14 | ^blibdirs$ 15 | \.old$ 16 | ^#.*#$ 17 | ^\.# 18 | ^\.DS_Store 19 | ^__MACOSX 20 | ^articles 21 | ^t_attic 22 | ^.gitignore 23 | ^MYMETA.yml$ 24 | -------------------------------------------------------------------------------- /t/lib/DBM/Deep/Engine/Test.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Engine::Test; 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use base qw( DBM::Deep::Engine ); 7 | 8 | use DBM::Deep::Storage::Test; 9 | 10 | sub new { 11 | return bless { 12 | storage => DBM::Deep::Storage::Test->new, 13 | }, shift; 14 | } 15 | 16 | 1; 17 | __END__ 18 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector/File/Data.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector::File::Data; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use base qw( DBM::Deep::Sector::File ); 9 | 10 | # This is in bytes 11 | sub size { $_[0]{engine}->data_sector_size } 12 | sub free_meth { return '_add_free_data_sector' } 13 | 14 | 1; 15 | __END__ 16 | -------------------------------------------------------------------------------- /t/58_cache.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_dbm ); 6 | use utf8; 7 | 8 | use DBM::Deep; 9 | 10 | my $dbm_factory = new_dbm(); 11 | while ( my $dbm_maker = $dbm_factory->() ) { 12 | my $db = $dbm_maker->(); 13 | 14 | $db->{h} = {1,2}; 15 | my $h = $db->{h}; 16 | undef $h; # now no longer cached 17 | $h = $db->{h}; # cached again 18 | ok $h, 'stale cache entries are not mistakenly reused'; 19 | } 20 | 21 | done_testing; 22 | -------------------------------------------------------------------------------- /t/55_recursion.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $dbm_factory = new_dbm(); 11 | while ( my $dbm_maker = $dbm_factory->() ) { 12 | my $db = $dbm_maker->(); 13 | 14 | my $h = {}; 15 | my $tmp = $h; 16 | for (1..99) { # 98 is ok, 99 is bad. 17 | %$tmp = ("" => {}); 18 | $tmp = $tmp->{""}; 19 | } 20 | lives_ok { 21 | $db->{""} = $h; 22 | } 'deep recursion causes no errors'; 23 | } 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /t/57_old_db.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use File::Spec::Functions 'catfile'; 5 | use Test::More; 6 | use t::common qw( new_fh ); 7 | 8 | use DBM::Deep; 9 | 10 | tie my %db, "DBM::Deep", catfile(< t etc db-1-0003 >); 11 | 12 | is join("-", keys %db), "foo", '1.0003 db has one key'; 13 | is "@{$db{foo}}", "1 2 3", 'values in 1.0003 db'; 14 | 15 | is tied(%db)->db_version, '1.0003', 'db_version on old db'; 16 | my ($fh, $filename) = new_fh; 17 | is new DBM::Deep file => $filename, fh=>$fh =>->db_version, '2', 18 | 'db_version on new db'; 19 | 20 | done_testing; 21 | -------------------------------------------------------------------------------- /etc/sqlite_tables.sql: -------------------------------------------------------------------------------- 1 | DROP TABLE IF EXISTS datas; 2 | DROP TABLE IF EXISTS refs; 3 | 4 | CREATE TABLE refs ( 5 | id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT 6 | ,ref_type STRING NOT NULL DEFAULT 'H' 7 | ,refcount INTEGER NOT NULL DEFAULT 1 8 | ,classname STRING 9 | ); 10 | 11 | CREATE TABLE datas ( 12 | id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT 13 | ,ref_id INTEGER NOT NULL 14 | ,data_type STRING DEFAULT 'S' 15 | ,`key` STRING NOT NULL 16 | ,value STRING 17 | ,FOREIGN KEY (ref_id) REFERENCES refs (id) 18 | ON DELETE CASCADE ON UPDATE CASCADE 19 | ,UNIQUE (ref_id, `key` ) 20 | ); 21 | -------------------------------------------------------------------------------- /t/32_dash_ell.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -l 2 | 3 | # Test for interference from -l on the commandline. 4 | use strict; 5 | use warnings FATAL => 'all'; 6 | 7 | use Test::More; 8 | use Test::Exception; 9 | use t::common qw( new_fh ); 10 | 11 | use_ok( 'DBM::Deep' ); 12 | 13 | my ($fh, $filename) = new_fh(); 14 | my $db = DBM::Deep->new( $filename ); 15 | 16 | ## 17 | # put/get key 18 | ## 19 | $db->{key1} = "value1"; 20 | is( $db->get("key1"), "value1", "get() works with hash assignment" ); 21 | is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" ); 22 | is( $db->{key1}, "value1", "... and hash-access also works" ); 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /etc/sql_example.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use DBM::Deep; 4 | use Data::Dumper; 5 | 6 | my $hash = new DBM::Deep( 7 | 'dbi' => { 8 | 'dsn' => 'DBI:mysql:database=perl;host=localhost', 9 | 'user' => 'perl', 10 | 'password' => '2A7Qcmh5CBQvLGUu', 11 | }, 12 | 'id' => 20, 13 | ); 14 | 15 | print Dumper( 16 | $hash, 17 | $hash->id(), 18 | ); 19 | 20 | my $array = new DBM::Deep( 21 | 'dbi' => { 22 | 'dsn' => 'DBI:mysql:database=perl;host=localhost', 23 | 'user' => 'perl', 24 | 'password' => '2A7Qcmh5CBQvLGUu', 25 | }, 26 | 'type' => DBM::Deep->TYPE_ARRAY, 27 | 'id' => 21, 28 | ); 29 | 30 | print Dumper( 31 | $array, 32 | $array->id(), 33 | ); 34 | 35 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector/DBI/Scalar.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector::DBI::Scalar; 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use base qw( DBM::Deep::Sector::DBI ); 7 | 8 | sub table { 'datas' } 9 | 10 | sub _init { 11 | my $self = shift; 12 | 13 | if ( $self->offset ) { 14 | my ($rows) = $self->engine->storage->read_from( 15 | datas => $self->offset, 16 | qw( id data_type key value ), 17 | ); 18 | 19 | $self->{$_} = $rows->[0]{$_} for qw( data_type key value ); 20 | } 21 | 22 | return; 23 | } 24 | 25 | sub data { 26 | my $self = shift; 27 | $self->{value}; 28 | } 29 | 30 | 1; 31 | __END__ 32 | -------------------------------------------------------------------------------- /t/29_largedata.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_dbm ); 6 | 7 | use_ok( 'DBM::Deep' ); 8 | 9 | my $dbm_factory = new_dbm(); 10 | while ( my $dbm_maker = $dbm_factory->() ) { 11 | my $db = $dbm_maker->(); 12 | 13 | my $val1 = "a" x 6000; 14 | 15 | $db->{foo} = $val1; 16 | is( $db->{foo}, $val1, "6000 char value stored and retrieved" ); 17 | 18 | # delete $db->{foo}; 19 | # my $size = -s $filename; 20 | # $db->{bar} = "a" x 300; 21 | # is( $db->{bar}, 'a' x 300, "New 256 char value is stored" ); 22 | # cmp_ok( $size, '==', -s $filename, "Freespace is reused" ); 23 | } 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /t/01_basic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | use t::common qw( new_fh ); 7 | 8 | diag "Testing DBM::Deep against Perl $] located at $^X"; 9 | 10 | use_ok( 'DBM::Deep' ); 11 | 12 | ## 13 | # basic file open 14 | ## 15 | my ($fh, $filename) = new_fh(); 16 | my $db = eval { 17 | local $SIG{__DIE__}; 18 | DBM::Deep->new( $filename ); 19 | }; if ( $@ ) { 20 | diag "ERROR: $@"; 21 | Test::More->builder->BAIL_OUT( "Opening a new file fails." ); 22 | } 23 | 24 | isa_ok( $db, 'DBM::Deep' ); 25 | ok(1, "We can successfully open a file!" ); 26 | 27 | $db->{foo} = 'bar'; 28 | is( $db->{foo}, 'bar', 'We can write and read.' ); 29 | 30 | done_testing; 31 | -------------------------------------------------------------------------------- /t_attic/37_delete_edge_cases.t: -------------------------------------------------------------------------------- 1 | ## 2 | # DBM::Deep Test 3 | ## 4 | use strict; 5 | use Test::More tests => 4; 6 | use Test::Deep; 7 | use Clone qw( clone ); 8 | use t::common qw( new_fh ); 9 | 10 | use_ok( 'DBM::Deep' ); 11 | 12 | my ($fh, $filename) = new_fh(); 13 | my $db = DBM::Deep->new( $filename ); 14 | 15 | my $x = { 16 | a => 1, 17 | b => 2, 18 | c => [ 1 .. 3 ], 19 | }; 20 | 21 | my $x_save = clone( $x ); 22 | 23 | $db->{foo} = $x; 24 | 25 | ok( tied(%$x), "\$x is tied" ); 26 | delete $db->{foo}; 27 | 28 | TODO: { 29 | local $TODO = "Delete isn't working right"; 30 | ok( !tied(%$x), "\$x is NOT tied" ); 31 | cmp_deeply( $x, $x_save, "When it's deleted, it's untied" ); 32 | } 33 | -------------------------------------------------------------------------------- /etc/mysql_tables.sql: -------------------------------------------------------------------------------- 1 | DROP TABLE IF EXISTS datas; 2 | DROP TABLE IF EXISTS refs; 3 | 4 | CREATE TABLE refs ( 5 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY 6 | ,ref_type ENUM( 'H', 'A' ) NOT NULL DEFAULT 'H' 7 | ,refcount BIGINT UNSIGNED NOT NULL DEFAULT 1 8 | ,classname LONGTEXT 9 | ) ENGINE=MyISAM; 10 | 11 | CREATE TABLE datas ( 12 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY 13 | ,ref_id BIGINT UNSIGNED NOT NULL 14 | ,data_type ENUM( 'S', 'R' ) DEFAULT 'S' 15 | ,`key` LONGTEXT NOT NULL 16 | ,value LONGTEXT 17 | ,FOREIGN KEY (ref_id) REFERENCES refs (id) 18 | ON DELETE CASCADE ON UPDATE CASCADE 19 | ,UNIQUE INDEX (ref_id, `key` (700) ) 20 | ) ENGINE=MyISAM; 21 | -------------------------------------------------------------------------------- /t/25_tie_return_value.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_fh ); 6 | 7 | use_ok( 'DBM::Deep' ); 8 | 9 | use Scalar::Util qw( reftype ); 10 | 11 | { 12 | my ($fh, $filename) = new_fh(); 13 | 14 | my %hash; 15 | my $obj = tie %hash, 'DBM::Deep', $filename; 16 | isa_ok( $obj, 'DBM::Deep' ); 17 | is( reftype( $obj ), 'HASH', "... and its underlying representation is an HASH" ); 18 | } 19 | 20 | { 21 | my ($fh, $filename) = new_fh(); 22 | 23 | my @array; 24 | my $obj = tie @array, 'DBM::Deep', $filename; 25 | isa_ok( $obj, 'DBM::Deep' ); 26 | is( reftype( $obj ), 'HASH', "... and its underlying representation is an HASH" ); 27 | } 28 | 29 | done_testing; 30 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use Scalar::Util (); 9 | 10 | sub new { 11 | my $self = bless $_[1], $_[0]; 12 | Scalar::Util::weaken( $self->{engine} ); 13 | $self->_init; 14 | return $self; 15 | } 16 | 17 | sub _init {} 18 | 19 | sub clone { 20 | my $self = shift; 21 | return ref($self)->new({ 22 | engine => $self->engine, 23 | type => $self->type, 24 | data => $self->data, 25 | }); 26 | } 27 | 28 | 29 | sub engine { $_[0]{engine} } 30 | sub offset { $_[0]{offset} } 31 | sub type { $_[0]{type} } 32 | sub staleness { $_[0]{staleness} } 33 | 34 | sub load { die "load must be implemented in a child class" } 35 | 36 | 1; 37 | __END__ 38 | -------------------------------------------------------------------------------- /t/54_output_punct_vars.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_fh ); 6 | 7 | use_ok( 'DBM::Deep' ); 8 | 9 | my ($fh, $filename) = new_fh(); 10 | ok eval { 11 | local $,="\t"; 12 | my $db = DBM::Deep->new( file => $filename, fh => $fh, ); 13 | $db->{34808} = "BVA/DIVISO"; 14 | $db->{34887} = "PRIMARYVEN"; 15 | }, '$, causes no hiccoughs or 150MB files'; 16 | 17 | 18 | ($fh, $filename) = new_fh(); 19 | ok eval { 20 | local $\="\n"; 21 | my $db = DBM::Deep->new( file => $filename, fh => $fh, ); 22 | $db->{foo} = ""; 23 | $db->{baz} = "11111"; 24 | $db->{foo} 25 | = "counterpneumonoultramicroscopicsilicovolcanoconiotically"; 26 | $db->{baz}; 27 | }, '$\ causes no problems'; 28 | 29 | done_testing; 30 | -------------------------------------------------------------------------------- /t/50_deletes.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | use t::common qw( new_dbm ); 7 | 8 | my $max = 10; 9 | 10 | use_ok( 'DBM::Deep' ); 11 | 12 | my $dbm_factory = new_dbm(); 13 | while ( my $dbm_maker = $dbm_factory->() ) { 14 | my $db = $dbm_maker->(); 15 | 16 | my $x = 1; 17 | while( $x <= $max ) { 18 | eval { 19 | delete $db->{borked}{test}; 20 | $db->{borked}{test} = 1; 21 | }; 22 | 23 | ok(!$@, "No eval failure after ${x}th iteration"); 24 | $x++; 25 | } 26 | 27 | $$db{foo} = []; 28 | $$db{bar} = $$db{foo}; 29 | delete $$db{foo}; 30 | is $$db{foo}, undef, 31 | 'deleting a key containing a reference that two keys point two works'; 32 | 33 | } 34 | 35 | done_testing; 36 | -------------------------------------------------------------------------------- /t/99_pod_coverage.t: -------------------------------------------------------------------------------- 1 | # Only DBM::Deep has any POD to test. All the other classes are private 2 | # classes. Hence, they have no POD outside of DBM::Deep::Internals 3 | 4 | use strict; 5 | 6 | use Test::More; 7 | 8 | eval "use Test::Pod::Coverage 1.04"; 9 | plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; 10 | 11 | plan tests => 1; 12 | 13 | # I don't know why TYPE_ARRAY isn't being caught and TYPE_HASH is. 14 | my @private_methods = qw( 15 | TYPE_ARRAY 16 | ); 17 | 18 | # These are method names that have been commented out, for now 19 | # max_of total_of 20 | # begin_page end_page 21 | 22 | my $private_regex = do { 23 | local $"='|'; 24 | qr/^(?:@private_methods)$/ 25 | }; 26 | 27 | pod_coverage_ok( 'DBM::Deep' => { 28 | also_private => [ $private_regex ], 29 | }); 30 | -------------------------------------------------------------------------------- /t/07_locking.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $dbm_factory = new_dbm( locking => 1 ); 11 | while ( my $dbm_maker = $dbm_factory->() ) { 12 | my $db = $dbm_maker->(); 13 | 14 | lives_ok { 15 | $db->unlock; 16 | } "Can call unlock on an unlocked DB."; 17 | 18 | ## 19 | # basic put/get 20 | ## 21 | $db->{key1} = "value1"; 22 | is( $db->{key1}, "value1", "key1 is set" ); 23 | 24 | $db->{key2} = [ 1 .. 3 ]; 25 | is( $db->{key2}[1], 2, "The value is set properly" ); 26 | 27 | ## 28 | # explicit lock 29 | ## 30 | $db->lock_exclusive; 31 | $db->{key1} = "value2"; 32 | $db->unlock(); 33 | is( $db->{key1}, "value2", "key1 is overridden" ); 34 | } 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Iterator/DBI.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Iterator::DBI; 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use base qw( DBM::Deep::Iterator ); 7 | 8 | sub reset { 9 | my $self = shift; 10 | 11 | eval { $self->{sth}->finish; }; 12 | delete $self->{sth}; 13 | 14 | return; 15 | } 16 | 17 | sub get_next_key { 18 | my $self = shift; 19 | my ($obj) = @_; 20 | 21 | unless ( exists $self->{sth} ) { 22 | # For mysql, this needs to be RAND() 23 | # For sqlite, this needs to be random() 24 | my $storage = $self->{engine}->storage; 25 | $self->{sth} = $storage->{dbh}->prepare( 26 | "SELECT `key` FROM datas WHERE ref_id = ? ORDER BY " 27 | . $storage->rand_function, 28 | ); 29 | $self->{sth}->execute( $self->{base_offset} ); 30 | } 31 | 32 | my ($key) = $self->{sth}->fetchrow_array; 33 | return $key; 34 | } 35 | 36 | 1; 37 | __END__ 38 | -------------------------------------------------------------------------------- /t/53_misc_transactions.t: -------------------------------------------------------------------------------- 1 | # This was discussed here: 2 | # http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab 3 | # brought up by Alex Gallichotte 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use Test::More; 9 | use t::common qw( new_dbm ); 10 | 11 | use_ok( 'DBM::Deep' ); 12 | 13 | my $dbm_factory = new_dbm(); 14 | while ( my $dbm_maker = $dbm_factory->() ) { 15 | my $db = $dbm_maker->(); 16 | eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures"); 17 | 18 | eval { 19 | #$db->begin_work; 20 | $db->{randkey()} = randkey() for 1 .. 10; 21 | #$db->commit; 22 | }; 23 | ok(!$@, "No eval failures from the transaction"); 24 | 25 | eval { $db->{randkey()} = randkey() for 1 .. 10; }; 26 | ok(!$@, "No eval failures"); 27 | } 28 | 29 | done_testing; 30 | 31 | sub randkey { 32 | our $i++; 33 | my @k = map { int rand 100 } 1 .. 10; 34 | local $" = "-"; 35 | 36 | return "$i-@k"; 37 | } 38 | -------------------------------------------------------------------------------- /t/05_bigarray.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests" 7 | unless $ENV{LONG_TESTS}; 8 | 9 | use t::common qw( new_dbm ); 10 | 11 | use_ok( 'DBM::Deep' ); 12 | 13 | diag "This test can take up to several minutes to run. Please be patient."; 14 | 15 | my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY ); 16 | while ( my $dbm_maker = $dbm_factory->() ) { 17 | my $db = $dbm_maker->(); 18 | 19 | ## 20 | # put/get many keys 21 | ## 22 | my $max_keys = 4000; 23 | 24 | for ( 0 .. $max_keys ) { 25 | $db->put( $_ => $_ * 2 ); 26 | } 27 | 28 | my $count = -1; 29 | for ( 0 .. $max_keys ) { 30 | $count = $_; 31 | unless ( $db->get( $_ ) == $_ * 2 ) { 32 | last; 33 | }; 34 | } 35 | is( $count, $max_keys, "We read $count keys" ); 36 | 37 | cmp_ok( scalar(@$db), '==', $max_keys + 1, "Number of elements is correct" ); 38 | $db->clear; 39 | cmp_ok( scalar(@$db), '==', 0, "Number of elements after clear() is correct" ); 40 | } 41 | 42 | done_testing; 43 | -------------------------------------------------------------------------------- /t/28_index_sector.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $dbm_factory = new_dbm( 11 | locking => 1, 12 | autoflush => 1, 13 | ); 14 | while ( my $dbm_maker = $dbm_factory->() ) { 15 | my $db = $dbm_maker->(); 16 | 17 | for ( 1 .. 17 ) { 18 | $db->{ $_ } = $_; 19 | is( $db->{$_}, $_, "Addition of $_ is still $_" ); 20 | } 21 | 22 | for ( 1 .. 17 ) { 23 | is( $db->{$_}, $_, "Verification of $_ is still $_" ); 24 | } 25 | 26 | my @keys = keys %$db; 27 | cmp_ok( scalar(@keys), '==', 17, "Right number of keys returned" ); 28 | 29 | ok( !exists $db->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" ); 30 | $db->{does_not_exist}{ling} = undef; 31 | ok( $db->{does_not_exist}, "autovivification works on large hashes" ); 32 | ok( exists $db->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" ); 33 | cmp_ok( scalar(keys %$db), '==', 18, "Number of keys after autovivify is correct" ); 34 | } 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t_attic/36_verybighash.t: -------------------------------------------------------------------------------- 1 | # This test was contributed by Fedor Soreks, Jan 2007. 2 | 3 | use strict; 4 | use Test::More; 5 | 6 | plan skip_all => "You must set \$ENV{LONG_TESTS} >= 2 to run the superlong tests" 7 | unless $ENV{LONG_TESTS} && $ENV{LONG_TESTS} >= 2; 8 | 9 | use Test::Deep; 10 | use t::common qw( new_fh ); 11 | 12 | plan tests => 2; 13 | 14 | use_ok( 'DBM::Deep' ); 15 | 16 | diag "This test can take up to several hours to run. Please be VERY patient."; 17 | 18 | my ($fh, $filename) = new_fh(); 19 | my $db = DBM::Deep->new( 20 | file => $filename, 21 | type => DBM::Deep->TYPE_HASH, 22 | ); 23 | 24 | my $gigs = 2; 25 | 26 | ## 27 | # put/get many keys 28 | ## 29 | my $max_keys = 4_000_000; 30 | my $max_record_keys = 10; 31 | 32 | for my $key_no ( 0 .. $max_keys ) { 33 | for my $rec_no ( 0 .. $max_record_keys ) { 34 | $db->{"key_$key_no"}{"rec_key_$rec_no"} = "rec_val_$rec_no"; 35 | } 36 | 37 | my $s = -s $filename; 38 | print "$key_no: $s\n"; 39 | 40 | if ( $s > $gigs * 2**30) { 41 | fail "DB file ($filename) size exceeds $gigs GB"; 42 | exit; 43 | } 44 | } 45 | 46 | ok( 1, "We passed the test!" ); 47 | -------------------------------------------------------------------------------- /t/97_dump_file.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use t::common qw( new_fh ); 7 | use utf8; 8 | 9 | use_ok( 'DBM::Deep' ); 10 | 11 | my ($fh, $filename) = new_fh(); 12 | my $db = DBM::Deep->new( $filename ); 13 | 14 | is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" ); 15 | NumTxns: 1 16 | Chains(B): 17 | Chains(D): 18 | Chains(I): 19 | 00000030: H 0064 REF: 1 20 | __END_DUMP__ 21 | 22 | $db->{foo} = 'bar'; 23 | 24 | is( $db->_dump_file, <<"__END_DUMP__", "Dump of file after single assignment" ); 25 | NumTxns: 1 26 | Chains(B): 27 | Chains(D): 28 | Chains(I): 29 | 00000030: H 0064 REF: 1 30 | 00000094: D 0064 bar 31 | 00000158: B 0387 32 | 00000545 00000094 33 | 00000545: D 0064 foo 34 | __END_DUMP__ 35 | 36 | $db->{ḟoo} = 'bār'; 37 | 38 | is( $db->_dump_file, <<"__END_DUMP__", "Dump after Unicode assignment" ); 39 | NumTxns: 1 40 | Chains(B): 41 | Chains(D): 42 | Chains(I): 43 | 00000030: H 0064 REF: 1 44 | 00000094: D 0064 bar 45 | 00000158: B 0387 46 | 00000545 00000094 47 | 00000673 00000609 48 | 00000545: D 0064 foo 49 | 00000609: U 0064 bār 50 | 00000673: U 0064 ḟoo 51 | __END_DUMP__ 52 | 53 | done_testing; 54 | -------------------------------------------------------------------------------- /t/56_unicode.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_dbm ); 6 | use utf8; 7 | 8 | use DBM::Deep; 9 | 10 | my $dbm_factory = new_dbm(); 11 | while ( my $dbm_maker = $dbm_factory->() ) { 12 | my $db = $dbm_maker->(); 13 | 14 | SKIP: { 15 | skip "This engine does not support Unicode", 1 16 | unless $db->supports( 'unicode' ); 17 | 18 | my $quote 19 | = 'Ἐγένετο δὲ λόγῳ μὲν δημοκρατία, λόγῳ δὲ τοῦ πρώτου ἀνδρὸς ἀρχή.' 20 | .' —Θουκυδίδης'; 21 | 22 | $db->{'тэкст'} = $quote; 23 | is join("-", keys %$db), 'тэкст', 'Unicode keys'; 24 | is $db->{'тэкст'}, $quote, 'Unicode values'; 25 | 26 | { 27 | no warnings 'utf8'; 28 | # extra stress test 29 | $db->{"\x{d800}"} = "\x{dc00}"; 30 | is join("-", sort keys %$db), "тэкст-\x{d800}", 31 | 'Surrogate keys'; 32 | is $db->{"\x{d800}"}, "\x{dc00}", 'Surrogate values'; 33 | } 34 | 35 | $db->{feen} = "plare\xff"; 36 | $db->{feen} = 'płare'; 37 | is $db->{feen}, 'płare', 'values can be upgraded to Unicode'; 38 | 39 | } 40 | 41 | } 42 | 43 | done_testing; 44 | -------------------------------------------------------------------------------- /t/12_clone.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_dbm ); 6 | 7 | use_ok( 'DBM::Deep' ); 8 | 9 | my $dbm_factory = new_dbm(); 10 | while ( my $dbm_maker = $dbm_factory->() ) { 11 | 12 | { 13 | my $clone; 14 | 15 | { 16 | my $db = $dbm_maker->(); 17 | 18 | $db->{key1} = "value1"; 19 | 20 | ## 21 | # clone db handle, make sure both are usable 22 | ## 23 | $clone = $db->clone(); 24 | 25 | is($clone->{key1}, "value1"); 26 | 27 | $clone->{key2} = "value2"; 28 | $db->{key3} = "value3"; 29 | 30 | is($db->{key1}, "value1"); 31 | is($db->{key2}, "value2"); 32 | is($db->{key3}, "value3"); 33 | 34 | is($clone->{key1}, "value1"); 35 | is($clone->{key2}, "value2"); 36 | is($clone->{key3}, "value3"); 37 | } 38 | 39 | is($clone->{key1}, "value1"); 40 | is($clone->{key2}, "value2"); 41 | is($clone->{key3}, "value3"); 42 | } 43 | 44 | { 45 | my $db = $dbm_maker->(); 46 | 47 | is($db->{key1}, "value1"); 48 | is($db->{key2}, "value2"); 49 | is($db->{key3}, "value3"); 50 | } 51 | } 52 | done_testing; 53 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector/DBI.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector::DBI; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use base qw( DBM::Deep::Sector ); 9 | 10 | use DBM::Deep::Sector::DBI::Reference (); 11 | use DBM::Deep::Sector::DBI::Scalar (); 12 | 13 | sub free { 14 | my $self = shift; 15 | 16 | $self->engine->storage->delete_from( 17 | $self->table, $self->offset, 18 | ); 19 | } 20 | 21 | sub reload { 22 | my $self = shift; 23 | $self->_init; 24 | } 25 | 26 | sub load { 27 | my $self = shift; 28 | my ($engine, $offset, $type) = @_; 29 | 30 | if ( !defined $type || $type eq 'refs' ) { 31 | return DBM::Deep::Sector::DBI::Reference->new({ 32 | engine => $engine, 33 | offset => $offset, 34 | }); 35 | } 36 | elsif ( $type eq 'datas' ) { 37 | my $sector = DBM::Deep::Sector::DBI::Scalar->new({ 38 | engine => $engine, 39 | offset => $offset, 40 | }); 41 | 42 | if ( $sector->{data_type} eq 'R' ) { 43 | return $self->load( 44 | $engine, $sector->{value}, 'refs', 45 | ); 46 | } 47 | 48 | return $sector; 49 | } 50 | 51 | DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" ); 52 | } 53 | 54 | 1; 55 | __END__ 56 | -------------------------------------------------------------------------------- /t/09_deeparray.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests" 7 | unless $ENV{LONG_TESTS}; 8 | 9 | use t::common qw( new_dbm ); 10 | 11 | diag "This test can take up to several minutes to run. Please be patient."; 12 | 13 | use_ok( 'DBM::Deep' ); 14 | 15 | my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY ); 16 | while ( my $dbm_maker = $dbm_factory->() ) { 17 | my $max_levels = 1000; 18 | 19 | { 20 | my $db = $dbm_maker->(); 21 | 22 | $db->[0] = []; 23 | my $temp_db = $db->[0]; 24 | for my $k ( 0 .. $max_levels ) { 25 | $temp_db->[$k] = []; 26 | $temp_db = $temp_db->[$k]; 27 | } 28 | $temp_db->[0] = "deepvalue"; 29 | } 30 | 31 | { 32 | my $db = $dbm_maker->(); 33 | 34 | my $cur_level = -1; 35 | my $temp_db = $db->[0]; 36 | for my $k ( 0 .. $max_levels ) { 37 | $cur_level = $k; 38 | $temp_db = $temp_db->[$k]; 39 | eval { $temp_db->isa( 'DBM::Deep' ) } or last; 40 | } 41 | is( $cur_level, $max_levels, "We read all the way down to level $cur_level" ); 42 | is( $temp_db->[0], "deepvalue", "And we retrieved the value at the bottom of the ocean" ); 43 | } 44 | } 45 | done_testing; 46 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Null.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Null; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | =head1 NAME 9 | 10 | DBM::Deep::Null - NULL object 11 | 12 | =head1 PURPOSE 13 | 14 | This is an internal-use-only object for L. It acts as a NULL object 15 | in the same vein as MARCEL's L. I couldn't use L 16 | because DBM::Deep needed an object that always evaluated as undef, not an 17 | implementation of the Null Class pattern. 18 | 19 | =head1 OVERVIEW 20 | 21 | It is used to represent null sectors in DBM::Deep. 22 | 23 | =cut 24 | 25 | use overload 26 | 'bool' => sub { undef }, 27 | '""' => sub { undef }, 28 | '0+' => sub { 0 }, 29 | ('cmp' => 30 | '<=>' => sub { 31 | return 0 if !defined $_[1] || !length $_[1]; 32 | return $_[2] ? 1 : -1; 33 | } 34 | )[0,2,1,2], # same sub for both ops 35 | '%{}' => sub { 36 | require Carp; 37 | Carp::croak("Can't use a stale reference as a HASH"); 38 | }, 39 | '@{}' => sub { 40 | require Carp; 41 | Carp::croak("Can't use a stale reference as an ARRAY"); 42 | }, 43 | fallback => 1, 44 | nomethod => 'AUTOLOAD'; 45 | 46 | sub AUTOLOAD { return; } 47 | 48 | 1; 49 | __END__ 50 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector/File/Null.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector::File::Null; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use base qw( DBM::Deep::Sector::File::Data ); 9 | 10 | my $STALE_SIZE = 2; 11 | 12 | # Please refer to the pack() documentation for further information 13 | my %StP = ( 14 | 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 15 | 2 => 'n', # Unsigned short in "network" (big-endian) order 16 | 4 => 'N', # Unsigned long in "network" (big-endian) order 17 | 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) 18 | ); 19 | 20 | sub type { $_[0]{engine}->SIG_NULL } 21 | sub data_length { 0 } 22 | sub data { return } 23 | 24 | sub _init { 25 | my $self = shift; 26 | 27 | my $engine = $self->engine; 28 | 29 | unless ( $self->offset ) { 30 | my $leftover = $self->size - $self->base_size - 1 * $engine->byte_size - 1; 31 | 32 | $self->{offset} = $engine->_request_data_sector( $self->size ); 33 | $engine->storage->print_at( $self->offset, $self->type ); # Sector type 34 | # Skip staleness counter 35 | $engine->storage->print_at( $self->offset + $self->base_size, 36 | pack( $StP{$engine->byte_size}, 0 ), # Chain loc 37 | pack( $StP{1}, $self->data_length ), # Data length 38 | chr(0) x $leftover, # Zero-fill the rest 39 | ); 40 | 41 | return; 42 | } 43 | } 44 | 45 | 1; 46 | __END__ 47 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Iterator.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Iterator; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | =head1 NAME 9 | 10 | DBM::Deep::Iterator - iterator for FIRSTKEY() and NEXTKEY() 11 | 12 | =head1 PURPOSE 13 | 14 | This is an internal-use-only object for L. It is the iterator 15 | for FIRSTKEY() and NEXTKEY(). 16 | 17 | =head1 OVERVIEW 18 | 19 | This object 20 | 21 | =head1 METHODS 22 | 23 | =head2 new(\%params) 24 | 25 | The constructor takes a hashref of params. The hashref is assumed to have the 26 | following elements: 27 | 28 | =over 4 29 | 30 | =item * engine (of type L 31 | 32 | =item * base_offset (the base_offset of the invoking DBM::Deep object) 33 | 34 | =back 35 | 36 | =cut 37 | 38 | sub new { 39 | my $class = shift; 40 | my ($args) = @_; 41 | 42 | my $self = bless { 43 | engine => $args->{engine}, 44 | base_offset => $args->{base_offset}, 45 | }, $class; 46 | 47 | Scalar::Util::weaken( $self->{engine} ); 48 | 49 | $self->reset; 50 | 51 | return $self; 52 | } 53 | 54 | =head2 reset() 55 | 56 | This method takes no arguments. 57 | 58 | It will reset the iterator so that it will start from the beginning again. 59 | 60 | This method returns nothing. 61 | 62 | =cut 63 | 64 | sub reset { die "reset must be implemented in a child class" } 65 | 66 | =head2 get_next_key( $obj ) 67 | 68 | =cut 69 | 70 | sub get_next_key { die "get_next_key must be implemented in a child class" } 71 | 72 | 1; 73 | __END__ 74 | -------------------------------------------------------------------------------- /t/31_references.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use Test::Exception; 7 | use t::common qw( new_dbm ); 8 | 9 | use_ok( 'DBM::Deep' ); 10 | my $dbm_factory = new_dbm(); 11 | while ( my $dbm_maker = $dbm_factory->() ) { 12 | my $db = $dbm_maker->(); 13 | 14 | my %hash = ( 15 | foo => 1, 16 | bar => [ 1 .. 3 ], 17 | baz => { a => 42 }, 18 | ); 19 | 20 | $db->{hash} = \%hash; 21 | isa_ok( tied(%hash), 'DBM::Deep::Hash' ); 22 | 23 | is( $db->{hash}{foo}, 1 ); 24 | cmp_deeply( $db->{hash}{bar}, noclass([ 1 .. 3 ]) ); 25 | cmp_deeply( $db->{hash}{baz}, noclass({ a => 42 }) ); 26 | 27 | $hash{foo} = 2; 28 | is( $db->{hash}{foo}, 2 ); 29 | 30 | $hash{bar}[1] = 90; 31 | is( $db->{hash}{bar}[1], 90 ); 32 | 33 | $hash{baz}{b} = 33; 34 | is( $db->{hash}{baz}{b}, 33 ); 35 | 36 | my @array = ( 37 | 1, [ 1 .. 3 ], { a => 42 }, 38 | ); 39 | 40 | $db->{array} = \@array; 41 | isa_ok( tied(@array), 'DBM::Deep::Array' ); 42 | 43 | is( $db->{array}[0], 1 ); 44 | cmp_deeply( $db->{array}[1], noclass([ 1 .. 3 ]) ); 45 | cmp_deeply( $db->{array}[2], noclass({ a => 42 }) ); 46 | 47 | $array[0] = 2; 48 | is( $db->{array}[0], 2 ); 49 | 50 | $array[1][2] = 9; 51 | is( $db->{array}[1][2], 9 ); 52 | 53 | $array[2]{b} = 'floober'; 54 | is( $db->{array}[2]{b}, 'floober' ); 55 | 56 | my %hash2 = ( abc => [ 1 .. 3 ] ); 57 | $array[3] = \%hash2; 58 | 59 | $hash2{ def } = \%hash; 60 | is( $array[3]{def}{foo}, 2 ); 61 | } 62 | 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/43_transaction_maximum.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use Test::Exception; 7 | use t::common qw( new_dbm ); 8 | 9 | use_ok( 'DBM::Deep' ); 10 | 11 | my $max_txns = 255; 12 | 13 | my $dbm_factory = new_dbm( 14 | num_txns => $max_txns, 15 | ); 16 | while ( my $dbm_maker = $dbm_factory->() ) { 17 | my @dbs = ( $dbm_maker->() ); 18 | next unless $dbs[0]->supports('transactions'); 19 | 20 | my $reached_max; 21 | push @dbs, grep { $_ } map { 22 | eval { $dbm_maker->() } 23 | || 24 | # A sysopen failure indicates a problem beyond DBM::Deep’s control, 25 | # probably a ‘Too many files open’ error, so it’s no use failing 26 | # our test because of that. 27 | scalar( 28 | $@ =~ /Cannot sysopen file/ && ( 29 | $reached_max++ or $max_txns = $_ 30 | ), 31 | () 32 | ) 33 | } 2 .. $max_txns-1; # -1 because the head is included in the number 34 | if($reached_max) { # of transactions 35 | diag "This OS apparently can open only $max_txns files."; 36 | } 37 | 38 | cmp_ok( 39 | scalar(@dbs), '==', $max_txns-1, 40 | "We could open enough DB handles" 41 | ); 42 | 43 | my %trans_ids; 44 | for my $n (0 .. $#dbs) { 45 | lives_ok { 46 | $dbs[$n]->begin_work 47 | } "DB $n can begin_work"; 48 | 49 | my $trans_id = $dbs[$n]->_engine->trans_id; 50 | ok( !exists $trans_ids{ $trans_id }, "DB $n has a unique transaction ID ($trans_id)" ); 51 | $trans_ids{ $trans_id } = $n; 52 | } 53 | } 54 | 55 | done_testing; 56 | -------------------------------------------------------------------------------- /t/21_tie_access.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_fh ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my ($fh, $filename) = new_fh(); 11 | 12 | { 13 | my %hash; 14 | tie %hash, 'DBM::Deep', $filename; 15 | 16 | $hash{key1} = 'value'; 17 | is( $hash{key1}, 'value', 'Set and retrieved key1' ); 18 | tied( %hash )->_get_self->_engine->storage->close( tied( %hash )->_get_self ); 19 | } 20 | 21 | { 22 | my %hash; 23 | tie %hash, 'DBM::Deep', $filename; 24 | 25 | is( $hash{key1}, 'value', 'Set and retrieved key1' ); 26 | 27 | is( keys %hash, 1, "There's one key so far" ); 28 | ok( exists $hash{key1}, "... and it's key1" ); 29 | tied( %hash )->_get_self->_engine->storage->close( tied( %hash )->_get_self ); 30 | } 31 | 32 | { 33 | throws_ok { 34 | tie my @array, 'DBM::Deep', { 35 | file => $filename, 36 | type => DBM::Deep->TYPE_ARRAY, 37 | }; 38 | tied( @array )->_get_self->_engine->storage->close( tied( @array )->_get_self ); 39 | } qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type"; 40 | } 41 | 42 | { 43 | my ($fh, $filename) = new_fh(); 44 | my $db = DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY ); 45 | 46 | throws_ok { 47 | tie my %hash, 'DBM::Deep', { 48 | file => $filename, 49 | type => DBM::Deep->TYPE_HASH, 50 | }; 51 | } qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type"; 52 | $db->_get_self->_engine->storage->close( $db->_get_self ); 53 | } 54 | 55 | done_testing; 56 | -------------------------------------------------------------------------------- /t/48_autoexport_after_delete.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | 7 | use t::common qw( new_dbm ); 8 | 9 | use_ok( 'DBM::Deep' ); 10 | 11 | my $dbm_factory = new_dbm(); 12 | while ( my $dbm_maker = $dbm_factory->() ) { 13 | my $db = $dbm_maker->(); 14 | 15 | # Add a self-referencing connection to test export 16 | my %struct = ( 17 | key1 => "value1", 18 | key2 => "value2", 19 | array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ], bless( [], 'Apple' ) ], 20 | hash1 => { 21 | subkey1 => "subvalue1", 22 | subkey2 => "subvalue2", 23 | subkey3 => bless( { 24 | sub_obj => bless([ 25 | bless([], 'Foo'), 26 | ], 'Foo'), 27 | sub_obj3 => bless([],'Foo'), 28 | }, 'Foo' ), 29 | }, 30 | ); 31 | 32 | $db->{foo} = \%struct; 33 | 34 | my $x = delete $db->{foo}; 35 | 36 | cmp_deeply( 37 | $x, 38 | { 39 | key1 => "value1", 40 | key2 => "value2", 41 | array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ], bless( [], 'Apple' ) ], 42 | hash1 => { 43 | subkey1 => "subvalue1", 44 | subkey2 => "subvalue2", 45 | subkey3 => bless( { 46 | sub_obj => bless([ 47 | bless([], 'Foo'), 48 | ], 'Foo'), 49 | sub_obj3 => bless([],'Foo'), 50 | }, 'Foo' ), 51 | }, 52 | }, 53 | "Everything matches", 54 | ); 55 | } 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/23_misc.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_fh ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | { 11 | my ($fh, $filename) = new_fh(); 12 | print $fh "Not a DBM::Deep file"; 13 | 14 | my $old_fh = select $fh; 15 | my $old_af = $|; $| = 1; $| = $old_af; 16 | select $old_fh; 17 | 18 | throws_ok { 19 | my $db = DBM::Deep->new( $filename ); 20 | } qr/^DBM::Deep: Signature not found -- file is not a Deep DB/, "Only DBM::Deep DB files will be opened"; 21 | } 22 | 23 | my ($fh, $filename) = new_fh(); 24 | my $db = DBM::Deep->new( $filename ); 25 | 26 | $db->{key1} = "value1"; 27 | is( $db->{key1}, "value1", "Value set correctly" ); 28 | 29 | # Testing to verify that the close() will occur if open is called on an open DB. 30 | #XXX WOW is this hacky ... 31 | $db->_get_self->_engine->storage->open; 32 | is( $db->{key1}, "value1", "Value still set after re-open" ); 33 | 34 | throws_ok { 35 | my $db = DBM::Deep->new( 't' ); 36 | } qr/^DBM::Deep: Cannot sysopen file 't': /, "Can't open a file we aren't allowed to touch"; 37 | 38 | { 39 | my $db = DBM::Deep->new( 40 | file => $filename, 41 | locking => 1, 42 | ); 43 | $db->_get_self->_engine->storage->close( $db->_get_self ); 44 | ok( !$db->lock, "Calling lock() on a closed database returns false" ); 45 | } 46 | 47 | { 48 | my $db = DBM::Deep->new( 49 | file => $filename, 50 | locking => 1, 51 | ); 52 | $db->lock; 53 | $db->_get_self->_engine->storage->close( $db->_get_self ); 54 | ok( !$db->unlock, "Calling unlock() on a closed database returns false" ); 55 | } 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/03_bighash.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests" 7 | unless $ENV{LONG_TESTS}; 8 | 9 | use Test::Deep; 10 | use t::common qw( new_dbm ); 11 | 12 | use_ok( 'DBM::Deep' ); 13 | 14 | diag "This test can take up to several minutes to run. Please be patient."; 15 | 16 | my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_HASH ); 17 | while ( my $dbm_maker = $dbm_factory->() ) { 18 | my $db = $dbm_maker->(); 19 | 20 | $db->{foo} = {}; 21 | my $foo = $db->{foo}; 22 | 23 | ## 24 | # put/get many keys 25 | ## 26 | my $max_keys = 4000; 27 | 28 | for ( 0 .. $max_keys ) { 29 | $foo->put( "hello $_" => "there " . $_ * 2 ); 30 | } 31 | 32 | my $count = -1; 33 | for ( 0 .. $max_keys ) { 34 | $count = $_; 35 | unless ( $foo->get( "hello $_" ) eq "there " . $_ * 2 ) { 36 | last; 37 | }; 38 | } 39 | is( $count, $max_keys, "We read $count keys" ); 40 | 41 | my @keys = sort keys %$foo; 42 | cmp_ok( scalar(@keys), '==', $max_keys + 1, "Number of keys is correct" ); 43 | my @control = sort map { "hello $_" } 0 .. $max_keys; 44 | cmp_deeply( \@keys, \@control, "Correct keys are there" ); 45 | 46 | ok( !exists $foo->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" ); 47 | $foo->{does_not_exist}{ling} = undef; 48 | ok( $foo->{does_not_exist}, "autovivification works on large hashes" ); 49 | ok( exists $foo->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" ); 50 | cmp_ok( scalar(keys %$foo), '==', $max_keys + 2, "Number of keys after autovivify is correct" ); 51 | 52 | $db->clear; 53 | cmp_ok( scalar(keys %$db), '==', 0, "Number of keys after clear() is correct" ); 54 | } 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/20_tie.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_fh ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | # testing the various modes of opening a file 11 | { 12 | my ($fh, $filename) = new_fh(); 13 | my %hash; 14 | my $db = tie %hash, 'DBM::Deep', $filename; 15 | 16 | ok(1, "Tied an hash with an array for params" ); 17 | } 18 | 19 | { 20 | my ($fh, $filename) = new_fh(); 21 | my %hash; 22 | my $db = tie %hash, 'DBM::Deep', { 23 | file => $filename, 24 | }; 25 | 26 | ok(1, "Tied a hash with a hashref for params" ); 27 | } 28 | 29 | { 30 | my ($fh, $filename) = new_fh(); 31 | my @array; 32 | my $db = tie @array, 'DBM::Deep', $filename; 33 | 34 | ok(1, "Tied an array with an array for params" ); 35 | 36 | is( $db->{type}, DBM::Deep->TYPE_ARRAY, "TIE_ARRAY sets the correct type" ); 37 | } 38 | 39 | { 40 | my ($fh, $filename) = new_fh(); 41 | my @array; 42 | my $db = tie @array, 'DBM::Deep', { 43 | file => $filename, 44 | }; 45 | 46 | ok(1, "Tied an array with a hashref for params" ); 47 | 48 | is( $db->{type}, DBM::Deep->TYPE_ARRAY, "TIE_ARRAY sets the correct type" ); 49 | } 50 | 51 | my ($fh, $filename) = new_fh(); 52 | throws_ok { 53 | tie my %hash, 'DBM::Deep', [ file => $filename ]; 54 | } qr/Not a hashref/, "Passing an arrayref to TIEHASH fails"; 55 | 56 | throws_ok { 57 | tie my @array, 'DBM::Deep', [ file => $filename ]; 58 | } qr/Not a hashref/, "Passing an arrayref to TIEARRAY fails"; 59 | 60 | throws_ok { 61 | tie my %hash, 'DBM::Deep', undef, file => $filename; 62 | } qr/Odd number of parameters/, "Odd number of params to TIEHASH fails"; 63 | 64 | throws_ok { 65 | tie my @array, 'DBM::Deep', undef, file => $filename; 66 | } qr/Odd number of parameters/, "Odd number of params to TIEARRAY fails"; 67 | 68 | done_testing; 69 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Storage.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Storage; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | =head1 NAME 9 | 10 | DBM::Deep::Storage - abstract base class for storage 11 | 12 | =head2 flush() 13 | 14 | This flushes the filehandle. This takes no parameters and returns nothing. 15 | 16 | =cut 17 | 18 | sub flush { die "flush must be implemented in a child class" } 19 | 20 | =head2 is_writable() 21 | 22 | This takes no parameters. It returns a boolean saying if this filehandle is 23 | writable. 24 | 25 | Taken from L. 26 | 27 | =cut 28 | 29 | sub is_writable { die "is_writable must be implemented in a child class" } 30 | 31 | =head1 LOCKING 32 | 33 | This is where the actual locking of the storage medium is performed. 34 | Nested locking is supported. 35 | 36 | B: It is unclear what will happen if a read lock is taken, then 37 | a write lock is taken as a nested lock, then the write lock is released. 38 | 39 | Currently, the only locking method supported is flock(1). This is a 40 | whole-file lock. In the future, more granular locking may be supported. 41 | The API for that is unclear right now. 42 | 43 | The following methods manage the locking status. In all cases, they take 44 | a L object and returns nothing. 45 | 46 | =over 4 47 | 48 | =item * lock_exclusive( $obj ) 49 | 50 | Take a lock usable for writing. 51 | 52 | =item * lock_shared( $obj ) 53 | 54 | Take a lock usable for reading. 55 | 56 | =item * unlock( $obj ) 57 | 58 | Releases the last lock taken. If this is the outermost lock, then the 59 | object is actually unlocked. 60 | 61 | =back 62 | 63 | =cut 64 | 65 | sub lock_exclusive { die "lock_exclusive must be implemented in a child class" } 66 | sub lock_shared { die "lock_shared must be implemented in a child class" } 67 | sub unlock { die "unlock must be implemented in a child class" } 68 | 69 | 1; 70 | __END__ 71 | -------------------------------------------------------------------------------- /t/18_export.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my %struct = ( 11 | key1 => "value1", 12 | key2 => "value2", 13 | array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ] ], 14 | hash1 => { 15 | subkey1 => "subvalue1", 16 | subkey2 => "subvalue2", 17 | subkey3 => bless( { 18 | sub_obj => bless([ 19 | bless([], 'Foo'), 20 | ], 'Foo'), 21 | sub_obj2 => bless([], 'Foo'), 22 | }, 'Foo' ), 23 | }, 24 | ); 25 | 26 | my $dbm_factory = new_dbm( autobless => 1 ); 27 | while ( my $dbm_maker = $dbm_factory->() ) { 28 | my $db = $dbm_maker->(); 29 | 30 | ## 31 | # Create structure in DB 32 | ## 33 | $db->import( \%struct ); 34 | 35 | ## 36 | # Export entire thing 37 | ## 38 | my $compare = $db->export(); 39 | 40 | cmp_deeply( 41 | $compare, 42 | { 43 | key1 => "value1", 44 | key2 => "value2", 45 | array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ] ], 46 | hash1 => { 47 | subkey1 => "subvalue1", 48 | subkey2 => "subvalue2", 49 | subkey3 => bless( { 50 | sub_obj => bless([ 51 | bless([], 'Foo'), 52 | ], 'Foo'), 53 | sub_obj2 => bless([], 'Foo'), 54 | }, 'Foo' ), 55 | }, 56 | }, 57 | "Everything matches", 58 | ); 59 | 60 | isa_ok( tied(%{$db->{hash1}{subkey3}})->export, 'Foo' ); 61 | isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}})->export, 'Foo' ); 62 | isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}[0]})->export, 'Foo' ); 63 | isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj2}})->export, 'Foo' ); 64 | } 65 | 66 | done_testing; 67 | -------------------------------------------------------------------------------- /t/26_scalar_ref.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_dbm new_fh ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $x = 25; 11 | my $dbm_factory = new_dbm(); 12 | while ( my $dbm_maker = $dbm_factory->() ) { 13 | { 14 | my $db = $dbm_maker->(); 15 | 16 | throws_ok { 17 | $db->{scalarref} = \$x; 18 | } qr/Storage of references of type 'SCALAR' is not supported/, 19 | 'Storage of scalar refs not supported'; 20 | 21 | throws_ok { 22 | $db->{scalarref} = \\$x; 23 | } qr/Storage of references of type 'REF' is not supported/, 24 | 'Storage of ref refs not supported'; 25 | 26 | throws_ok { 27 | $db->{scalarref} = sub { 1 }; 28 | } qr/Storage of references of type 'CODE' is not supported/, 29 | 'Storage of code refs not supported'; 30 | 31 | throws_ok { 32 | my ($fh, $filename) = new_fh; 33 | $db->{scalarref} = $fh; 34 | } qr/Storage of references of type 'GLOB' is not supported/, 35 | 'Storage of glob refs not supported'; 36 | 37 | $db->{scalar} = $x; 38 | TODO: { 39 | todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2; 40 | lives_ok { 41 | $db->{selfref} = \$db->{scalar}; 42 | } "Refs to DBM::Deep objects are ok"; 43 | 44 | is( ${$db->{selfref}}, $x, "A ref to a DBM::Deep object is ok" ); 45 | } 46 | } 47 | 48 | { 49 | my $db = $dbm_maker->(); 50 | 51 | is( $db->{scalar}, $x, "Scalar retrieved ok" ); 52 | TODO: { 53 | todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2; 54 | is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" ); 55 | is( ${$db->{selfref}}, 26, "Scalarref to stored scalar retrieved ok" ); 56 | } 57 | } 58 | } 59 | 60 | done_testing; 61 | -------------------------------------------------------------------------------- /t/30_already_tied.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $dbm_factory = new_dbm(); 11 | while ( my $dbm_maker = $dbm_factory->() ) { 12 | my $db = $dbm_maker->(); 13 | 14 | { 15 | { 16 | package My::Tie::Hash; 17 | 18 | sub TIEHASH { 19 | my $class = shift; 20 | 21 | return bless { 22 | }, $class; 23 | } 24 | } 25 | 26 | my %hash; 27 | tie %hash, 'My::Tie::Hash'; 28 | isa_ok( tied(%hash), 'My::Tie::Hash' ); 29 | 30 | throws_ok { 31 | $db->{foo} = \%hash; 32 | } qr/Cannot store something that is tied/, "Cannot store tied hashes"; 33 | } 34 | 35 | { 36 | { 37 | package My::Tie::Array; 38 | 39 | sub TIEARRAY { 40 | my $class = shift; 41 | 42 | return bless { 43 | }, $class; 44 | } 45 | 46 | sub FETCHSIZE { 0 } 47 | } 48 | 49 | my @array; 50 | tie @array, 'My::Tie::Array'; 51 | isa_ok( tied(@array), 'My::Tie::Array' ); 52 | 53 | throws_ok { 54 | $db->{foo} = \@array; 55 | } qr/Cannot store something that is tied/, "Cannot store tied arrays"; 56 | } 57 | 58 | { 59 | { 60 | package My::Tie::Scalar; 61 | 62 | sub TIESCALAR { 63 | my $class = shift; 64 | 65 | return bless { 66 | }, $class; 67 | } 68 | } 69 | 70 | my $scalar; 71 | tie $scalar, 'My::Tie::Scalar'; 72 | isa_ok( tied($scalar), 'My::Tie::Scalar' ); 73 | 74 | throws_ok { 75 | $db->{foo} = \$scalar; 76 | } qr/Storage of references of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars"; 77 | } 78 | } 79 | 80 | done_testing; 81 | -------------------------------------------------------------------------------- /t/08_deephash.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests" 7 | unless $ENV{LONG_TESTS}; 8 | 9 | use t::common qw( new_dbm ); 10 | 11 | diag "This test can take up to several minutes to run. Please be patient."; 12 | 13 | use_ok( 'DBM::Deep' ); 14 | 15 | my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_HASH ); 16 | while ( my $dbm_maker = $dbm_factory->() ) { 17 | my $max_levels = 1000; 18 | 19 | { 20 | my $db = $dbm_maker->(); 21 | 22 | ## 23 | # basic deep hash 24 | ## 25 | $db->{company} = {}; 26 | $db->{company}->{name} = "My Co."; 27 | $db->{company}->{employees} = {}; 28 | $db->{company}->{employees}->{"Henry Higgins"} = {}; 29 | $db->{company}->{employees}->{"Henry Higgins"}->{salary} = 90000; 30 | 31 | is( $db->{company}->{name}, "My Co.", "Set and retrieved a second-level value" ); 32 | is( $db->{company}->{employees}->{"Henry Higgins"}->{salary}, 90000, "Set and retrieved a fourth-level value" ); 33 | 34 | ## 35 | # super deep hash 36 | ## 37 | $db->{base_level} = {}; 38 | my $temp_db = $db->{base_level}; 39 | 40 | for my $k ( 0 .. $max_levels ) { 41 | $temp_db->{"level$k"} = {}; 42 | $temp_db = $temp_db->{"level$k"}; 43 | } 44 | $temp_db->{deepkey} = "deepvalue"; 45 | } 46 | 47 | { 48 | my $db = $dbm_maker->(); 49 | 50 | my $cur_level = -1; 51 | my $temp_db = $db->{base_level}; 52 | for my $k ( 0 .. $max_levels ) { 53 | $cur_level = $k; 54 | $temp_db = $temp_db->{"level$k"}; 55 | eval { $temp_db->isa( 'DBM::Deep' ) } or last; 56 | } 57 | is( $cur_level, $max_levels, "We read all the way down to level $cur_level" ); 58 | is( $temp_db->{deepkey}, "deepvalue", "And we retrieved the value at the bottom of the ocean" ); 59 | } 60 | } 61 | 62 | done_testing; 63 | -------------------------------------------------------------------------------- /t_attic/TODO: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | Testing TODO 4 | 5 | =head1 PURPOSE 6 | 7 | This file is to detail the tests, in a general sense, that have yet to be 8 | written so that I don't forget them. 9 | 10 | =head1 MISSING TESTS 11 | 12 | =over 4 13 | 14 | =item * Readonly filehandles 15 | 16 | =over 4 17 | 18 | =item * Mutations on readonly filehandles 19 | 20 | This is to verify that the appropriate errors are thrown 21 | 22 | =item * Run an optimize on a readonly FH 23 | 24 | =back 25 | 26 | =item * _copy_value() 27 | 28 | For some reason, $c doesn't seem to be undefinable in _copy_value. Maybe this 29 | means that the bless()ing should occur iff Cisa('DBM::Deep')>? 30 | 31 | =item * Splice 32 | 33 | =over 4 34 | 35 | =item * Undefined initial offset 36 | 37 | =item * splicing in a group that's equal to the target 38 | 39 | =back 40 | 41 | =item * Passing in a fh without a file_offset 42 | 43 | =item * Do I ever use print_at() without passing in offset? 44 | 45 | =item * How should the inode check for locking happen? 46 | 47 | =item * medium and large pack_sizes 48 | 49 | Need to make sure I only run the large pack_size test on 64-bit Perls 50 | 51 | =item * max_buckets check 52 | 53 | =item * get_classname() on a deleted sector 54 | 55 | How should this be triggered?! 56 | 57 | =item * Open a corrupted file that has a header, but not initial reference 58 | 59 | =item * Max out the number of transactions 60 | 61 | =item * Delete something in the head that has its own value in a transaction 62 | 63 | =item * Run an import within a transaction 64 | 65 | =over 4 66 | 67 | =item * Should all assignments with a non-scalar rvalue happen within a sub-transaction? 68 | 69 | =item * Does this mean that sub-transactions should just be done right now? 70 | 71 | It shouldn't be too hard to variablize which transaction is the base instead 72 | of hard-coding 0 . . . 73 | 74 | =back 75 | 76 | =item * Delete something within a transaction, then commit. 77 | 78 | Verify that the space is reusable by assigning more to the DB. 79 | 80 | =back 81 | 82 | =cut 83 | -------------------------------------------------------------------------------- /t/45_references.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $dbm_factory = new_dbm( 11 | locking => 1, 12 | autoflush => 1, 13 | num_txns => 16, 14 | ); 15 | while ( my $dbm_maker = $dbm_factory->() ) { 16 | my $db1 = $dbm_maker->(); 17 | next unless $db1->supports( 'transactions' ); 18 | my $db2 = $dbm_maker->(); 19 | 20 | $db1->{foo} = 5; 21 | $db1->{bar} = $db1->{foo}; 22 | 23 | is( $db1->{foo}, 5, "Foo is still 5" ); 24 | is( $db1->{bar}, 5, "Bar is now 5" ); 25 | 26 | $db1->{foo} = 6; 27 | 28 | is( $db1->{foo}, 6, "Foo is now 6" ); 29 | is( $db1->{bar}, 5, "Bar is still 5" ); 30 | 31 | $db1->{foo} = [ 1 .. 3 ]; 32 | $db1->{bar} = $db1->{foo}; 33 | 34 | is( $db1->{foo}[1], 2, "Foo[1] is still 2" ); 35 | is( $db1->{bar}[1], 2, "Bar[1] is now 2" ); 36 | 37 | $db1->{foo}[3] = 42; 38 | 39 | is( $db1->{foo}[3], 42, "Foo[3] is now 42" ); 40 | is( $db1->{bar}[3], 42, "Bar[3] is also 42" ); 41 | 42 | delete $db1->{foo}; 43 | is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); 44 | 45 | $db1->{foo} = $db1->{bar}; 46 | $db2->begin_work; 47 | 48 | delete $db2->{bar}; 49 | delete $db2->{foo}; 50 | 51 | is( $db2->{bar}, undef, "It's deleted in the transaction" ); 52 | is( $db1->{bar}[3], 42, "... but not in the main" ); 53 | 54 | $db2->rollback; 55 | 56 | # Why hasn't this failed!? Is it because stuff isn't getting deleted as 57 | # expected? I need a test that walks the sectors 58 | is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); 59 | is( $db2->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); 60 | 61 | delete $db1->{foo}; 62 | 63 | is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" ); 64 | } 65 | 66 | done_testing; 67 | 68 | __END__ 69 | $db2->begin_work; 70 | 71 | delete $db2->{bar}; 72 | 73 | $db2->commit; 74 | 75 | ok( !exists $db1->{bar}, "After commit, bar is gone" ); 76 | -------------------------------------------------------------------------------- /t/10_largekeys.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_dbm ); 6 | 7 | use_ok( 'DBM::Deep' ); 8 | 9 | my $dbm_factory = new_dbm(); 10 | while ( my $dbm_maker = $dbm_factory->() ) { 11 | my $db = $dbm_maker->(); 12 | 13 | ## 14 | # large keys 15 | ## 16 | my $key1 = "Now is the time for all good men to come to the aid of their country." x 100; 17 | my $key2 = "The quick brown fox jumped over the lazy, sleeping dog." x 1000; 18 | my $key3 = "Lorem dolor ipsum latinum suckum causum Ium cannotum rememberum squatum." x 1000; 19 | 20 | $db->put($key1, "value1"); 21 | $db->store($key2, "value2"); 22 | $db->{$key3} = "value3"; 23 | 24 | is( $db->{$key1}, 'value1', "Hash retrieval of put()" ); 25 | is( $db->{$key2}, 'value2', "Hash retrieval of store()" ); 26 | is( $db->{$key3}, 'value3', "Hash retrieval of hashstore" ); 27 | is( $db->get($key1), 'value1', "get() retrieval of put()" ); 28 | is( $db->get($key2), 'value2', "get() retrieval of store()" ); 29 | is( $db->get($key3), 'value3', "get() retrieval of hashstore" ); 30 | is( $db->fetch($key1), 'value1', "fetch() retrieval of put()" ); 31 | is( $db->fetch($key2), 'value2', "fetch() retrieval of store()" ); 32 | is( $db->fetch($key3), 'value3', "fetch() retrieval of hashstore" ); 33 | 34 | my $test_key = $db->first_key(); 35 | ok( 36 | ($test_key eq $key1) || 37 | ($test_key eq $key2) || 38 | ($test_key eq $key3), 39 | "First key found", 40 | ); 41 | 42 | $test_key = $db->next_key($test_key); 43 | ok( 44 | ($test_key eq $key1) || 45 | ($test_key eq $key2) || 46 | ($test_key eq $key3), 47 | "Second key found", 48 | ); 49 | 50 | $test_key = $db->next_key($test_key); 51 | ok( 52 | ($test_key eq $key1) || 53 | ($test_key eq $key2) || 54 | ($test_key eq $key3), 55 | "Third key found", 56 | ); 57 | 58 | $test_key = $db->next_key($test_key); 59 | ok( !$test_key, "No fourth key" ); 60 | } 61 | done_testing; 62 | -------------------------------------------------------------------------------- /t/47_odd_reference_behaviors.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use Test::Deep; 7 | 8 | use t::common qw( new_dbm ); 9 | 10 | use_ok( 'DBM::Deep' ); 11 | 12 | # This is bug #34819, reported by EJS 13 | { 14 | my $dbm_factory = new_dbm(); 15 | while ( my $dbm_maker = $dbm_factory->() ) { 16 | my $db = $dbm_maker->(); 17 | 18 | my $bar = bless { foo => 'ope' }, 'Foo'; 19 | 20 | eval { 21 | $db->{bar} = $bar; 22 | $db->{bar} = $bar; 23 | }; if ( $@ ) { warn $@ } 24 | 25 | ok(!$@, "repeated object assignment"); 26 | isa_ok($db->{bar}, 'Foo'); 27 | } 28 | } 29 | done_testing; 30 | __END__ 31 | # This is bug #29957, reported by HANENKAMP 32 | { 33 | my $dbm_factory = new_dbm(); 34 | while ( my $dbm_maker = $dbm_factory->() ) { 35 | my $db = $dbm_maker->(); 36 | 37 | $db->{foo} = []; 38 | 39 | for my $value ( 1 .. 3 ) { 40 | lives_ok { 41 | my $ref = $db->{foo}; 42 | push @$ref, $value; 43 | $db->{foo} = $ref; 44 | } "Successfully added value $value"; 45 | } 46 | 47 | cmp_deeply( [1,2,3], noclass($db->{foo}), "Everything looks ok" ); 48 | } 49 | } 50 | 51 | # This is bug #33863, reported by PJS 52 | { 53 | my $dbm_factory = new_dbm(); 54 | while ( my $dbm_maker = $dbm_factory->() ) { 55 | my $db = $dbm_maker->(); 56 | 57 | $db->{foo} = [ 42 ]; 58 | my $foo = shift @{ $db->{foo} }; 59 | cmp_ok( @{ $db->{foo} }, '==', 0, "Shifting a scalar leaves no values" ); 60 | cmp_ok( $foo, '==', 42, "... And the value is correct." ); 61 | 62 | $db->{bar} = [ [] ]; 63 | my $bar = shift @{ $db->{bar} }; 64 | cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" ); 65 | 66 | $db->{baz} = { foo => [ 1 .. 3 ] }; 67 | $db->{baz2} = [ $db->{baz} ]; 68 | my $baz2 = shift @{ $db->{baz2} }; 69 | cmp_ok( @{ $db->{baz2} }, '==', 0, "Shifting an arrayref leaves no values" ); 70 | ok( exists $db->{baz}{foo} ); 71 | ok( exists $baz2->{foo} ); 72 | } 73 | } 74 | 75 | done_testing; 76 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Iterator/File/Index.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Iterator::File::Index; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | =head1 NAME 9 | 10 | DBM::Deep::Iterator::Index - mediate between DBM::Deep::Iterator and DBM::Deep::Engine::Sector::Index 11 | 12 | =head1 PURPOSE 13 | 14 | This is an internal-use-only object for L. It acts as the mediator 15 | between the L object and a L 16 | sector. 17 | 18 | =head1 OVERVIEW 19 | 20 | This object, despite the implied class hierarchy, does B inherit from 21 | L. Instead, it delegates to it, essentially acting as a 22 | facade over it. L will instantiate one of 23 | these objects as needed to handle an Index sector. 24 | 25 | =head1 METHODS 26 | 27 | =head2 new(\%params) 28 | 29 | The constructor takes a hashref of params and blesses it into the invoking class. The 30 | hashref is assumed to have the following elements: 31 | 32 | =over 4 33 | 34 | =item * iterator (of type L 35 | 36 | =item * sector (of type L 37 | 38 | =back 39 | 40 | =cut 41 | 42 | sub new { 43 | my $self = bless $_[1] => $_[0]; 44 | $self->{curr_index} = 0; 45 | return $self; 46 | } 47 | 48 | =head2 at_end() 49 | 50 | This takes no arguments. 51 | 52 | This returns true/false indicating whether this sector has any more elements that can be 53 | iterated over. 54 | 55 | =cut 56 | 57 | sub at_end { 58 | my $self = shift; 59 | return $self->{curr_index} >= $self->{iterator}{engine}->hash_chars; 60 | } 61 | 62 | =head2 get_next_iterator() 63 | 64 | This takes no arguments. 65 | 66 | This returns an iterator (built by L) based 67 | on the sector pointed to by the next occupied location in this index. 68 | 69 | If the sector is exhausted, it returns nothing. 70 | 71 | =cut 72 | 73 | sub get_next_iterator { 74 | my $self = shift; 75 | 76 | my $loc; 77 | while ( !$loc ) { 78 | return if $self->at_end; 79 | $loc = $self->{sector}->get_entry( $self->{curr_index}++ ); 80 | } 81 | 82 | return $self->{iterator}->get_sector_iterator( $loc ); 83 | } 84 | 85 | 1; 86 | __END__ 87 | -------------------------------------------------------------------------------- /t/15_digest.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_dbm ); 6 | 7 | use_ok( 'DBM::Deep' ); 8 | 9 | my $salt = 38473827; 10 | 11 | # Warning: This digest function is for testing ONLY. 12 | # It is NOT intended for actual use. If you do so, I will laugh at you. 13 | sub my_digest { 14 | my $key = shift; 15 | my $num = $salt; 16 | 17 | for (my $k=0; $k \&my_digest, hash_size => 8 ); 25 | while ( my $dbm_maker = $dbm_factory->() ) { 26 | my $db = $dbm_maker->(); 27 | 28 | ## 29 | # put/get key 30 | ## 31 | $db->{key1} = "value1"; 32 | ok( $db->{key1} eq "value1" ); 33 | 34 | $db->put("key2", "value2"); 35 | ok( $db->get("key2") eq "value2" ); 36 | 37 | ## 38 | # key exists 39 | ## 40 | ok( $db->exists("key1") ); 41 | ok( exists $db->{key2} ); 42 | 43 | ## 44 | # count keys 45 | ## 46 | ok( scalar keys %$db == 2 ); 47 | 48 | ## 49 | # step through keys 50 | ## 51 | my $temphash = {}; 52 | while ( my ($key, $value) = each %$db ) { 53 | $temphash->{$key} = $value; 54 | } 55 | 56 | ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") ); 57 | 58 | $temphash = {}; 59 | my $key = $db->first_key(); 60 | while ($key) { 61 | $temphash->{$key} = $db->get($key); 62 | $key = $db->next_key($key); 63 | } 64 | 65 | ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") ); 66 | 67 | ## 68 | # delete keys 69 | ## 70 | ok( delete $db->{key1} ); 71 | ok( $db->delete("key2") ); 72 | 73 | ok( scalar keys %$db == 0 ); 74 | 75 | ## 76 | # delete all keys 77 | ## 78 | $db->put("another", "value"); 79 | $db->clear(); 80 | 81 | ok( scalar keys %$db == 0 ); 82 | 83 | ## 84 | # replace key 85 | ## 86 | $db->put("key1", "value1"); 87 | $db->put("key1", "value2"); 88 | 89 | ok( $db->get("key1") eq "value2" ); 90 | 91 | $db->put("key1", "value222222222222222222222222"); 92 | 93 | ok( $db->get("key1") eq "value222222222222222222222222" ); 94 | } 95 | done_testing; 96 | -------------------------------------------------------------------------------- /t/46_blist_reindex.t: -------------------------------------------------------------------------------- 1 | # This test (and accompanying patch) was submitted by Father Chrysostomos (sprout@cpan.org) 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More; 7 | 8 | use t::common qw( new_dbm ); 9 | 10 | use_ok( 'DBM::Deep' ); 11 | 12 | { 13 | my $dbm_factory = new_dbm(); 14 | while ( my $dbm_maker = $dbm_factory->() ) { 15 | my $db = $dbm_maker->(); 16 | 17 | ok eval { 18 | for ( # the checksums of all these begin with ^@: 19 | qw/ s340l 1970 thronos /, 20 | "\320\277\320\276\320\262\320\265\320\273\320\265\320\275". 21 | "\320\275\320\276\320\265", qw/ mr094 despite 22 | geographically binding bed handmaiden infer lela infranarii 23 | lxv evtropia recognizes maladies / 24 | ) { 25 | $db->{$_} = undef; 26 | } 27 | 1; 28 | }, '2 indices can be created at once'; 29 | 30 | is_deeply [sort keys %$db], [ sort 31 | qw/ s340l 1970 thronos /, 32 | "\320\277\320\276\320\262\320\265\320\273\320\265\320\275". 33 | "\320\275\320\276\320\265", qw/ mr094 despite 34 | geographically binding bed handmaiden infer lela infranarii 35 | lxv evtropia recognizes maladies / 36 | ], 'and the keys were stored correctly'; 37 | } 38 | } 39 | 40 | { 41 | my $dbm_factory = new_dbm(); 42 | while ( my $dbm_maker = $dbm_factory->() ) { 43 | my $db = $dbm_maker->(); 44 | 45 | ok eval { 46 | for ( # the checksums of all these begin with ^@^@^@: 47 | qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda 48 | lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII 49 | FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW / 50 | ) { 51 | $db->{$_} = undef; 52 | } 53 | 1; 54 | }, 'multiple nested indices can be created at once'; 55 | 56 | is_deeply [sort keys %$db], [ sort 57 | qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda 58 | lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII 59 | FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW / 60 | ], 'and the keys were stored correctly'; 61 | } 62 | } 63 | 64 | done_testing; 65 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Iterator/File/BucketList.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Iterator::File::BucketList; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | =head1 NAME 9 | 10 | DBM::Deep::Iterator::BucketList - mediate between DBM::Deep::Iterator and DBM::Deep::Engine::Sector::BucketList 11 | 12 | =head1 PURPOSE 13 | 14 | This is an internal-use-only object for L. It acts as the mediator 15 | between the L object and a L 16 | sector. 17 | 18 | =head1 OVERVIEW 19 | 20 | This object, despite the implied class hierarchy, does B inherit from 21 | L. Instead, it delegates to it, essentially acting as a 22 | facade over it. L will instantiate one of 23 | these objects as needed to handle an BucketList sector. 24 | 25 | =head1 METHODS 26 | 27 | =head2 new(\%params) 28 | 29 | The constructor takes a hashref of params and blesses it into the invoking class. The 30 | hashref is assumed to have the following elements: 31 | 32 | =over 4 33 | 34 | =item * iterator (of type L 35 | 36 | =item * sector (of type L 37 | 38 | =back 39 | 40 | =cut 41 | 42 | sub new { 43 | my $self = bless $_[1] => $_[0]; 44 | $self->{curr_index} = 0; 45 | return $self; 46 | } 47 | 48 | =head2 at_end() 49 | 50 | This takes no arguments. 51 | 52 | This returns true/false indicating whether this sector has any more elements that can be 53 | iterated over. 54 | 55 | =cut 56 | 57 | sub at_end { 58 | my $self = shift; 59 | return $self->{curr_index} >= $self->{iterator}{engine}->max_buckets; 60 | } 61 | 62 | =head2 get_next_iterator() 63 | 64 | This takes no arguments. 65 | 66 | This returns the next key pointed to by this bucketlist. This value is suitable for 67 | returning by FIRSTKEY or NEXTKEY(). 68 | 69 | If the bucketlist is exhausted, it returns nothing. 70 | 71 | =cut 72 | 73 | sub get_next_key { 74 | my $self = shift; 75 | 76 | return if $self->at_end; 77 | 78 | my $idx = $self->{curr_index}++; 79 | 80 | my $data_loc = $self->{sector}->get_data_location_for({ 81 | allow_head => 1, 82 | idx => $idx, 83 | }) or return; 84 | 85 | #XXX Do we want to add corruption checks here? 86 | return $self->{sector}->get_key_for( $idx )->data; 87 | } 88 | 89 | 1; 90 | __END__ 91 | -------------------------------------------------------------------------------- /t/22_internal_copy.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_dbm new_fh ); 6 | 7 | use_ok( 'DBM::Deep' ); 8 | 9 | my $dbm_factory = new_dbm(); 10 | while ( my $dbm_maker = $dbm_factory->() ) { 11 | my $db = $dbm_maker->(); 12 | 13 | $db->import({ 14 | hash1 => { 15 | subkey1 => "subvalue1", 16 | subkey2 => "subvalue2", 17 | }, 18 | hash2 => { 19 | subkey3 => 'subvalue3', 20 | }, 21 | }); 22 | 23 | is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" ); 24 | is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" ); 25 | 26 | $db->{copy} = $db->{hash1}; 27 | 28 | is( $db->{copy}{subkey1}, 'subvalue1', "Value copied correctly" ); 29 | is( $db->{copy}{subkey2}, 'subvalue2', "Value copied correctly" ); 30 | 31 | $db->{copy}{subkey1} = "another value"; 32 | is( $db->{copy}{subkey1}, 'another value', "New value is set correctly" ); 33 | is( $db->{hash1}{subkey1}, 'another value', "Old value is set to the new one" ); 34 | 35 | is( scalar(keys %{$db->{hash1}}), 2, "Start with 2 keys in the original" ); 36 | is( scalar(keys %{$db->{copy}}), 2, "Start with 2 keys in the copy" ); 37 | 38 | delete $db->{copy}{subkey2}; 39 | 40 | is( scalar(keys %{$db->{copy}}), 1, "Now only have 1 key in the copy" ); 41 | is( scalar(keys %{$db->{hash1}}), 1, "... and only 1 key in the original" ); 42 | 43 | $db->{copy} = $db->{hash2}; 44 | is( $db->{copy}{subkey3}, 'subvalue3', "After the second copy, we're still good" ); 45 | } 46 | 47 | { 48 | my $max_keys = 1000; 49 | my $dbm_factory = new_dbm(); 50 | while ( my $dbm_maker = $dbm_factory->() ) { 51 | { 52 | my $db = $dbm_maker->(); 53 | 54 | $db->{foo} = [ 1 .. 3 ]; 55 | for ( 0 .. $max_keys ) { 56 | $db->{'foo' . $_} = $db->{foo}; 57 | } 58 | } 59 | 60 | { 61 | my $db = $dbm_maker->(); 62 | 63 | my $base_offset = $db->{foo}->_base_offset; 64 | my $count = -1; 65 | for ( 0 .. $max_keys ) { 66 | $count = $_; 67 | unless ( $base_offset == $db->{'foo'.$_}->_base_offset ) { 68 | last; 69 | } 70 | } 71 | is( $count, $max_keys, "We read $count keys" ); 72 | } 73 | } 74 | } 75 | 76 | done_testing; 77 | -------------------------------------------------------------------------------- /t/19_crossref.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $dbm_factory = new_dbm(); 11 | while ( my $dbm_maker = $dbm_factory->() ) { 12 | my $db = $dbm_maker->(); 13 | 14 | SKIP: { 15 | skip "Apparently, we cannot detect a tied scalar?", 1; 16 | tie my $foo, 'Tied::Scalar'; 17 | throws_ok { 18 | $db->{failure} = $foo; 19 | } qr/Cannot store something that is tied\./, "tied scalar storage fails"; 20 | } 21 | 22 | { 23 | tie my @foo, 'Tied::Array'; 24 | throws_ok { 25 | $db->{failure} = \@foo; 26 | } qr/Cannot store something that is tied\./, "tied array storage fails"; 27 | } 28 | 29 | { 30 | tie my %foo, 'Tied::Hash'; 31 | throws_ok { 32 | $db->{failure} = \%foo; 33 | } qr/Cannot store something that is tied\./, "tied hash storage fails"; 34 | } 35 | 36 | # Need to create a second instance of a dbm here, but only of the type 37 | # being tested. 38 | if(0){ 39 | my $db2 = $dbm_maker->(); 40 | 41 | $db2->import({ 42 | hash1 => { 43 | subkey1 => "subvalue1", 44 | subkey2 => "subvalue2", 45 | } 46 | }); 47 | is( $db2->{hash1}{subkey1}, 'subvalue1', "Value1 imported correctly" ); 48 | is( $db2->{hash1}{subkey2}, 'subvalue2', "Value2 imported correctly" ); 49 | 50 | # Test cross-ref nested hash across DB objects 51 | throws_ok { 52 | $db->{copy} = $db2->{hash1}; 53 | } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails"; 54 | 55 | # This error text is for when internal cross-refs are implemented: 56 | # qr/Cannot cross-reference\. Use export\(\) instead\./ 57 | 58 | my $x = $db2->{hash1}->export; 59 | $db->{copy} = $x; 60 | } 61 | 62 | ## 63 | # Make sure $db has copy of $db2's hash structure 64 | ## 65 | # is( $db->{copy}{subkey1}, 'subvalue1', "Value1 copied correctly" ); 66 | # is( $db->{copy}{subkey2}, 'subvalue2', "Value2 copied correctly" ); 67 | } 68 | 69 | done_testing; 70 | 71 | package Tied::Scalar; 72 | sub TIESCALAR { bless {}, $_[0]; } 73 | sub FETCH{} 74 | 75 | package Tied::Array; 76 | sub TIEARRAY { bless {}, $_[0]; } 77 | 78 | package Tied::Hash; 79 | sub TIEHASH { bless {}, $_[0]; } 80 | -------------------------------------------------------------------------------- /t/52_memory_leak.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | use_ok( 'DBM::Deep' ); 7 | 8 | use t::common qw( new_dbm ); 9 | 10 | # RT #77746 11 | my $dbm_factory = new_dbm(); 12 | while ( my $dbm_maker = $dbm_factory->() ) { 13 | my $db = $dbm_maker->(); 14 | 15 | $db->{foo} = {}; 16 | my $data = $db->{foo}; 17 | 18 | use Scalar::Util 'weaken'; 19 | weaken $db; 20 | weaken $data; 21 | 22 | is $db, undef, 'no $db after weakening'; 23 | is $data, undef, 'hashes returned from db contain no circular refs'; 24 | } 25 | 26 | 27 | 28 | # This was discussed here: 29 | # http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab 30 | # brought up by Alex Gallichotte 31 | 32 | SKIP: { 33 | skip "Need to figure out what platforms this runs on", 1; 34 | } 35 | 36 | done_testing; 37 | exit; 38 | 39 | $dbm_factory = new_dbm(); 40 | while ( my $dbm_maker = $dbm_factory->() ) { 41 | my $db = $dbm_maker->(); 42 | 43 | my $todo = 1000; 44 | my $allow = $todo*0.02; # NOTE: a 2% fail rate is hardly a failure 45 | 46 | $db->{randkey()} = 1 for 1 .. 1000; 47 | 48 | my $error_count = 0; 49 | my @mem = (mem(0), mem(1)); 50 | for my $i (1 .. $todo) { 51 | $db->{randkey()} = [@mem]; 52 | 53 | ## DEBUG ## print STDERR " @mem \r"; 54 | 55 | my @tm = (mem(0), mem(1)); 56 | 57 | skip( not($mem[0]), ($tm[0] <= $mem[0] or --$allow>0) ); 58 | skip( not($mem[1]), ($tm[1] <= $mem[1] or --$allow>0) ); 59 | 60 | $error_count ++ if $tm[0] > $mem[0] or $tm[1] > $mem[1]; 61 | die " ERROR: that's enough failures to prove the point ... " if $error_count > 20; 62 | 63 | @mem = @tm; 64 | } 65 | } 66 | 67 | sub randkey { 68 | our $i ++; 69 | my @k = map { int rand 100 } 1 .. 10; 70 | local $" = "-"; 71 | 72 | return "$i-@k"; 73 | } 74 | 75 | sub mem { 76 | open my $in, "/proc/$$/statm" or return 0; 77 | my $line = [ split m/\s+/, <$in> ]; 78 | close $in; 79 | 80 | return $line->[shift]; 81 | } 82 | 83 | __END__ 84 | /proc/[number]/statm 85 | 86 | Provides information about memory status in pages. The columns are: 87 | 88 | size total program size 89 | resident resident set size 90 | share shared pages 91 | text text (code) 92 | lib library 93 | data data/stack 94 | dt dirty pages (unused in Linux 2.6) 95 | -------------------------------------------------------------------------------- /t/14_filter.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | 7 | use t::common qw( new_dbm ); 8 | 9 | use_ok( 'DBM::Deep' ); 10 | 11 | sub my_filter_store_key { return 'MYFILTER' . $_[0]; } 12 | sub my_filter_store_value { return 'MYFILTER' . $_[0]; } 13 | 14 | sub my_filter_fetch_key { $_[0] =~ s/^MYFILTER//; return $_[0]; } 15 | sub my_filter_fetch_value { $_[0] =~ s/^MYFILTER//; return $_[0]; } 16 | 17 | my $dbm_factory = new_dbm(); 18 | while ( my $dbm_maker = $dbm_factory->() ) { 19 | my $db = $dbm_maker->(); 20 | 21 | ok( !$db->set_filter( 'floober', sub {} ), "floober isn't a value filter key" ); 22 | 23 | ## 24 | # First try store filters only (values will be unfiltered) 25 | ## 26 | ok( $db->set_filter( 'store_key', \&my_filter_store_key ), "set the store_key filter" ); 27 | ok( $db->set_filter( 'store_value', \&my_filter_store_value ), "set the store_value filter" ); 28 | 29 | $db->{key1} = "value1"; 30 | $db->{key2} = "value2"; 31 | 32 | is($db->{key1}, "MYFILTERvalue1", "The value for key1 was filtered correctly" ); 33 | is($db->{key2}, "MYFILTERvalue2", "The value for key2 was filtered correctly" ); 34 | 35 | ## 36 | # Now try fetch filters as well 37 | ## 38 | ok( $db->set_filter( 'fetch_key', \&my_filter_fetch_key ), "Set the fetch_key filter" ); 39 | ok( $db->set_filter( 'fetch_value', \&my_filter_fetch_value), "Set the fetch_value filter" ); 40 | 41 | is($db->{key1}, "value1", "Fetchfilters worked right"); 42 | is($db->{key2}, "value2", "Fetchfilters worked right"); 43 | 44 | ## 45 | # Try fetching keys as well as values 46 | ## 47 | cmp_bag( [ keys %$db ], [qw( key1 key2 )], "DB keys correct" ); 48 | 49 | # Exists and delete tests 50 | ok( exists $db->{key1}, "Key1 exists" ); 51 | ok( exists $db->{key2}, "Key2 exists" ); 52 | 53 | is( delete $db->{key1}, 'value1', "Delete returns the right value" ); 54 | 55 | ok( !exists $db->{key1}, "Key1 no longer exists" ); 56 | ok( exists $db->{key2}, "Key2 exists" ); 57 | 58 | ## 59 | # Now clear all filters, and make sure all is unfiltered 60 | ## 61 | ok( $db->filter_store_key( undef ), "Unset store_key filter" ); 62 | ok( $db->filter_store_value( undef ), "Unset store_value filter" ); 63 | ok( $db->filter_fetch_key( undef ), "Unset fetch_key filter" ); 64 | ok( $db->filter_fetch_value( undef ), "Unset fetch_value filter" ); 65 | 66 | is( $db->{MYFILTERkey2}, "MYFILTERvalue2", "We get the right unfiltered value" ); 67 | } 68 | 69 | done_testing; 70 | -------------------------------------------------------------------------------- /t/40_freespace.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_fh ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | { 11 | my ($fh, $filename) = new_fh(); 12 | my $db = DBM::Deep->new({ 13 | file => $filename, 14 | autoflush => 1, 15 | }); 16 | 17 | $db->{foo} = '1234'; 18 | $db->{foo} = '2345'; 19 | 20 | my $size = -s $filename; 21 | $db->{foo} = '3456'; 22 | cmp_ok( $size, '==', -s $filename, "A second overwrite doesn't change size" ); 23 | 24 | $size = -s $filename; 25 | delete $db->{foo}; 26 | cmp_ok( $size, '==', -s $filename, "Deleted space isn't released" ); 27 | 28 | $db->{bar} = '2345'; 29 | cmp_ok( $size, '==', -s $filename, "Added a new key after a delete reuses space" ); 30 | 31 | $db->{baz} = {}; 32 | $size = -s $filename; 33 | 34 | delete $db->{baz}; 35 | $db->{baz} = {}; 36 | 37 | cmp_ok( $size, '==', -s $filename, "delete and rewrite reuses space" ); 38 | 39 | $db->{baz} = {}; 40 | $size = -s $filename; 41 | 42 | $db->{baz} = {}; 43 | 44 | cmp_ok( $size, '==', -s $filename, "delete and rewrite reuses space" ); 45 | 46 | my $x = { foo => 'bar' }; 47 | $db->{floober} = $x; 48 | 49 | delete $db->{floober}; 50 | 51 | ok( !exists $x->{foo}, "Deleting floober makes \$x empty (exists)" ); 52 | is( $x->{foo}, undef, "Deleting floober makes \$x empty (read)" ); 53 | is( delete $x->{foo}, undef, "Deleting floober makes \$x empty (delete)" ); 54 | 55 | eval { $x->{foo} = 'bar'; }; 56 | like( $@, qr/Cannot write to a deleted spot in DBM::Deep/, "Exception thrown when writing" ); 57 | 58 | cmp_ok( scalar( keys %$x ), '==', 0, "Keys returns nothing after deletion" ); 59 | } 60 | 61 | { 62 | my ($fh, $filename) = new_fh(); 63 | my $db = DBM::Deep->new({ 64 | file => $filename, 65 | autoflush => 1, 66 | }); 67 | 68 | $db->{ $_ } = undef for 1 .. 4; 69 | delete $db->{ $_ } for 1 .. 4; 70 | cmp_ok( keys %{ $db }, '==', 0, "We added and removed 4 keys" ); 71 | 72 | # So far, we've written 4 keys. Let's write 13 more keys. This should -not- 73 | # trigger a reindex. This requires knowing how much space is taken. Good thing 74 | # we wrote this dreck ... 75 | my $size = -s $filename; 76 | 77 | my $data_sector_size = $db->_engine->data_sector_size; 78 | my $expected = $size + 9 * ( 2 * $data_sector_size ); 79 | 80 | $db->{ $_ } = undef for 5 .. 17; 81 | 82 | cmp_ok( $expected, '==', -s $filename, "No reindexing after deletion" ); 83 | } 84 | 85 | done_testing; 86 | -------------------------------------------------------------------------------- /t/38_data_sector_size.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | use t::common qw( new_fh ); 7 | 8 | sub do_stuff { 9 | my ($db) = @_; 10 | 11 | $db->{foo}{bar} = [ 1 .. 3 ]; 12 | } 13 | 14 | sub verify { 15 | my ($db) = @_; 16 | 17 | cmp_ok( $db->{foo}{bar}[2], '==', 3, "Correct value found" ); 18 | } 19 | 20 | use_ok( 'DBM::Deep' ); 21 | 22 | my %sizes; 23 | 24 | { 25 | my ($fh, $filename) = new_fh(); 26 | { 27 | my $db = DBM::Deep->new( 28 | file => $filename, 29 | data_sector_size => 32, 30 | ); 31 | 32 | do_stuff( $db ); 33 | } 34 | 35 | $sizes{32} = -s $filename; 36 | 37 | { 38 | my $db = DBM::Deep->new( file => $filename ); 39 | verify( $db ); 40 | $db->_get_self->_engine->storage->close( $db->_get_self ); 41 | } 42 | } 43 | 44 | { 45 | my ($fh, $filename) = new_fh(); 46 | { 47 | my $db = DBM::Deep->new( 48 | file => $filename, 49 | data_sector_size => 64, 50 | ); 51 | 52 | do_stuff( $db ); 53 | } 54 | 55 | $sizes{64} = -s $filename; 56 | 57 | { 58 | my $db = DBM::Deep->new( $filename ); 59 | verify( $db ); 60 | $db->_get_self->_engine->storage->close( $db->_get_self ); 61 | } 62 | } 63 | 64 | { 65 | my ($fh, $filename) = new_fh(); 66 | { 67 | my $db = DBM::Deep->new( 68 | file => $filename, 69 | data_sector_size => 128, 70 | ); 71 | 72 | do_stuff( $db ); 73 | } 74 | 75 | $sizes{128} = -s $filename; 76 | 77 | { 78 | my $db = DBM::Deep->new( $filename ); 79 | verify( $db ); 80 | $db->_get_self->_engine->storage->close( $db->_get_self ); 81 | } 82 | } 83 | 84 | { 85 | my ($fh, $filename) = new_fh(); 86 | { 87 | my $db = DBM::Deep->new( 88 | file => $filename, 89 | data_sector_size => 256, 90 | ); 91 | 92 | do_stuff( $db ); 93 | } 94 | 95 | $sizes{256} = -s $filename; 96 | 97 | { 98 | my $db = DBM::Deep->new( $filename ); 99 | verify( $db ); 100 | $db->_get_self->_engine->storage->close( $db->_get_self ); 101 | } 102 | } 103 | 104 | cmp_ok( $sizes{256}, '>', $sizes{128}, "Filesize for 256 > filesize for 128" ); 105 | cmp_ok( $sizes{128}, '>', $sizes{64}, "Filesize for 128 > filesize for 64" ); 106 | cmp_ok( $sizes{64}, '>', $sizes{32}, "Filesize for 64 > filesize for 32" ); 107 | 108 | done_testing; 109 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector/File/Index.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector::File::Index; 2 | 3 | use base qw( DBM::Deep::Sector::File ); 4 | 5 | my $STALE_SIZE = 2; 6 | 7 | # Please refer to the pack() documentation for further information 8 | my %StP = ( 9 | 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 10 | 2 => 'n', # Unsigned short in "network" (big-endian) order 11 | 4 => 'N', # Unsigned long in "network" (big-endian) order 12 | 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) 13 | ); 14 | 15 | sub _init { 16 | my $self = shift; 17 | 18 | my $engine = $self->engine; 19 | 20 | unless ( $self->offset ) { 21 | my $leftover = $self->size - $self->base_size; 22 | 23 | $self->{offset} = $engine->_request_index_sector( $self->size ); 24 | $engine->storage->print_at( $self->offset, $engine->SIG_INDEX ); # Sector type 25 | # Skip staleness counter 26 | $engine->storage->print_at( $self->offset + $self->base_size, 27 | chr(0) x $leftover, # Zero-fill the rest 28 | ); 29 | } 30 | 31 | return $self; 32 | } 33 | 34 | #XXX Change here 35 | sub size { 36 | my $self = shift; 37 | unless ( $self->{size} ) { 38 | my $e = $self->engine; 39 | $self->{size} = $self->base_size + $e->byte_size * $e->hash_chars; 40 | } 41 | return $self->{size}; 42 | } 43 | 44 | sub free_meth { return '_add_free_index_sector' } 45 | 46 | sub free { 47 | my $self = shift; 48 | my $e = $self->engine; 49 | 50 | for my $i ( 0 .. $e->hash_chars - 1 ) { 51 | my $l = $self->get_entry( $i ) or next; 52 | $e->load_sector( $l )->free; 53 | } 54 | 55 | $self->SUPER::free(); 56 | } 57 | 58 | sub _loc_for { 59 | my $self = shift; 60 | my ($idx) = @_; 61 | return $self->offset + $self->base_size + $idx * $self->engine->byte_size; 62 | } 63 | 64 | sub get_entry { 65 | my $self = shift; 66 | my ($idx) = @_; 67 | 68 | my $e = $self->engine; 69 | 70 | DBM::Deep->_throw_error( "get_entry: Out of range ($idx)" ) 71 | if $idx < 0 || $idx >= $e->hash_chars; 72 | 73 | return unpack( 74 | $StP{$e->byte_size}, 75 | $e->storage->read_at( $self->_loc_for( $idx ), $e->byte_size ), 76 | ); 77 | } 78 | 79 | sub set_entry { 80 | my $self = shift; 81 | my ($idx, $loc) = @_; 82 | 83 | my $e = $self->engine; 84 | 85 | DBM::Deep->_throw_error( "set_entry: Out of range ($idx)" ) 86 | if $idx < 0 || $idx >= $e->hash_chars; 87 | 88 | $self->engine->storage->print_at( 89 | $self->_loc_for( $idx ), 90 | pack( $StP{$e->byte_size}, $loc ), 91 | ); 92 | } 93 | 94 | 1; 95 | __END__ 96 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Build.PL 2 | Changes 3 | lib/DBM/Deep.pm 4 | lib/DBM/Deep.pod 5 | lib/DBM/Deep/Array.pm 6 | lib/DBM/Deep/Cookbook.pod 7 | lib/DBM/Deep/Engine.pm 8 | lib/DBM/Deep/Engine/DBI.pm 9 | lib/DBM/Deep/Engine/File.pm 10 | lib/DBM/Deep/Hash.pm 11 | lib/DBM/Deep/Internals.pod 12 | lib/DBM/Deep/Iterator.pm 13 | lib/DBM/Deep/Iterator/DBI.pm 14 | lib/DBM/Deep/Iterator/File.pm 15 | lib/DBM/Deep/Iterator/File/BucketList.pm 16 | lib/DBM/Deep/Iterator/File/Index.pm 17 | lib/DBM/Deep/Null.pm 18 | lib/DBM/Deep/Sector.pm 19 | lib/DBM/Deep/Sector/DBI.pm 20 | lib/DBM/Deep/Sector/DBI/Reference.pm 21 | lib/DBM/Deep/Sector/DBI/Scalar.pm 22 | lib/DBM/Deep/Sector/File.pm 23 | lib/DBM/Deep/Sector/File/BucketList.pm 24 | lib/DBM/Deep/Sector/File/Data.pm 25 | lib/DBM/Deep/Sector/File/Index.pm 26 | lib/DBM/Deep/Sector/File/Null.pm 27 | lib/DBM/Deep/Sector/File/Reference.pm 28 | lib/DBM/Deep/Sector/File/Scalar.pm 29 | lib/DBM/Deep/Storage.pm 30 | lib/DBM/Deep/Storage/DBI.pm 31 | lib/DBM/Deep/Storage/File.pm 32 | Makefile.PL 33 | MANIFEST 34 | META.yml 35 | README 36 | t/01_basic.t 37 | t/02_hash.t 38 | t/03_bighash.t 39 | t/04_array.t 40 | t/05_bigarray.t 41 | t/06_error.t 42 | t/07_locking.t 43 | t/08_deephash.t 44 | t/09_deeparray.t 45 | t/10_largekeys.t 46 | t/11_optimize.t 47 | t/12_clone.t 48 | t/13_setpack.t 49 | t/14_filter.t 50 | t/15_digest.t 51 | t/16_circular.t 52 | t/17_import.t 53 | t/18_export.t 54 | t/19_crossref.t 55 | t/20_tie.t 56 | t/21_tie_access.t 57 | t/22_internal_copy.t 58 | t/23_misc.t 59 | t/24_autobless.t 60 | t/25_tie_return_value.t 61 | t/26_scalar_ref.t 62 | t/27_filehandle.t 63 | t/28_index_sector.t 64 | t/29_largedata.t 65 | t/30_already_tied.t 66 | t/31_references.t 67 | t/32_dash_ell.t 68 | t/33_transactions.t 69 | t/34_transaction_arrays.t 70 | t/35_transaction_multiple.t 71 | t/38_data_sector_size.t 72 | t/39_singletons.t 73 | t/40_freespace.t 74 | t/41_transaction_multilevel.t 75 | t/42_transaction_indexsector.t 76 | t/43_transaction_maximum.t 77 | t/44_upgrade_db.t 78 | t/45_references.t 79 | t/46_blist_reindex.t 80 | t/47_odd_reference_behaviors.t 81 | t/48_autoexport_after_delete.t 82 | t/50_deletes.t 83 | t/52_memory_leak.t 84 | t/53_misc_transactions.t 85 | t/54_output_punct_vars.t 86 | t/55_recursion.t 87 | t/56_unicode.t 88 | t/57_old_db.t 89 | t/58_cache.t 90 | t/96_virtual_functions.t 91 | t/97_dump_file.t 92 | t/98_pod.t 93 | t/99_pod_coverage.t 94 | t/common.pm 95 | t/etc/db-0-983 96 | t/etc/db-0-99_04 97 | t/etc/db-1-0000 98 | t/etc/db-1-0003 99 | t/lib/DBM/Deep/Engine/Test.pm 100 | t/lib/DBM/Deep/Iterator/Test.pm 101 | t/lib/DBM/Deep/Storage/Test.pm 102 | etc/mysql_tables.sql 103 | etc/sqlite_tables.sql 104 | utils/lib/DBM/Deep/09830.pm 105 | utils/lib/DBM/Deep/10002.pm 106 | utils/upgrade_db.pl 107 | META.json 108 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector/File.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector::File; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use base qw( DBM::Deep::Sector ); 9 | 10 | use DBM::Deep::Sector::File::BucketList (); 11 | use DBM::Deep::Sector::File::Index (); 12 | use DBM::Deep::Sector::File::Null (); 13 | use DBM::Deep::Sector::File::Reference (); 14 | use DBM::Deep::Sector::File::Scalar (); 15 | 16 | my $STALE_SIZE = 2; 17 | 18 | sub base_size { 19 | my $self = shift; 20 | return $self->engine->SIG_SIZE + $STALE_SIZE; 21 | } 22 | 23 | sub free_meth { die "free_meth must be implemented in a child class" } 24 | 25 | sub free { 26 | my $self = shift; 27 | 28 | my $e = $self->engine; 29 | 30 | $e->storage->print_at( $self->offset, $e->SIG_FREE ); 31 | # Skip staleness counter 32 | $e->storage->print_at( $self->offset + $self->base_size, 33 | chr(0) x ($self->size - $self->base_size), 34 | ); 35 | 36 | my $free_meth = $self->free_meth; 37 | $e->$free_meth( $self->offset, $self->size ); 38 | 39 | return; 40 | } 41 | 42 | #=head2 load( $offset ) 43 | # 44 | #This will instantiate and return the sector object that represents the data 45 | #found at $offset. 46 | # 47 | #=cut 48 | 49 | sub load { 50 | my $self = shift; 51 | my ($engine, $offset) = @_; 52 | 53 | # Add a catch for offset of 0 or 1 54 | return if !$offset || $offset <= 1; 55 | 56 | my $type = $engine->storage->read_at( $offset, 1 ); 57 | return if $type eq chr(0); 58 | 59 | if ( $type eq $engine->SIG_ARRAY || $type eq $engine->SIG_HASH ) { 60 | return DBM::Deep::Sector::File::Reference->new({ 61 | engine => $engine, 62 | type => $type, 63 | offset => $offset, 64 | }); 65 | } 66 | # XXX Don't we need key_md5 here? 67 | elsif ( $type eq $engine->SIG_BLIST ) { 68 | return DBM::Deep::Sector::File::BucketList->new({ 69 | engine => $engine, 70 | type => $type, 71 | offset => $offset, 72 | }); 73 | } 74 | elsif ( $type eq $engine->SIG_INDEX ) { 75 | return DBM::Deep::Sector::File::Index->new({ 76 | engine => $engine, 77 | type => $type, 78 | offset => $offset, 79 | }); 80 | } 81 | elsif ( $type eq $engine->SIG_NULL ) { 82 | return DBM::Deep::Sector::File::Null->new({ 83 | engine => $engine, 84 | type => $type, 85 | offset => $offset, 86 | }); 87 | } 88 | elsif ( $type eq $engine->SIG_DATA || $type eq $engine->SIG_UNIDATA ) { 89 | return DBM::Deep::Sector::File::Scalar->new({ 90 | engine => $engine, 91 | type => $type, 92 | offset => $offset, 93 | }); 94 | } 95 | # This was deleted from under us, so just return and let the caller figure it out. 96 | elsif ( $type eq $engine->SIG_FREE ) { 97 | return; 98 | } 99 | 100 | DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" ); 101 | } 102 | 103 | 1; 104 | __END__ 105 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Iterator/File.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Iterator::File; 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use base qw( DBM::Deep::Iterator ); 7 | 8 | use DBM::Deep::Iterator::File::BucketList (); 9 | use DBM::Deep::Iterator::File::Index (); 10 | 11 | sub reset { $_[0]{breadcrumbs} = []; return } 12 | 13 | sub get_sector_iterator { 14 | my $self = shift; 15 | my ($loc) = @_; 16 | 17 | my $sector = $self->{engine}->load_sector( $loc ) 18 | or return; 19 | 20 | if ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) { 21 | return DBM::Deep::Iterator::File::Index->new({ 22 | iterator => $self, 23 | sector => $sector, 24 | }); 25 | } 26 | elsif ( $sector->isa( 'DBM::Deep::Sector::File::BucketList' ) ) { 27 | return DBM::Deep::Iterator::File::BucketList->new({ 28 | iterator => $self, 29 | sector => $sector, 30 | }); 31 | } 32 | 33 | DBM::Deep->_throw_error( "get_sector_iterator(): Why did $loc make a $sector?" ); 34 | } 35 | 36 | sub get_next_key { 37 | my $self = shift; 38 | my ($obj) = @_; 39 | 40 | my $crumbs = $self->{breadcrumbs}; 41 | my $e = $self->{engine}; 42 | 43 | unless ( @$crumbs ) { 44 | # This will be a Reference sector 45 | my $sector = $e->load_sector( $self->{base_offset} ) 46 | # If no sector is found, this must have been deleted from under us. 47 | or return; 48 | 49 | if ( $sector->staleness != $obj->_staleness ) { 50 | return; 51 | } 52 | 53 | my $loc = $sector->get_blist_loc 54 | or return; 55 | 56 | push @$crumbs, $self->get_sector_iterator( $loc ); 57 | } 58 | 59 | FIND_NEXT_KEY: { 60 | # We're at the end. 61 | unless ( @$crumbs ) { 62 | $self->reset; 63 | return; 64 | } 65 | 66 | my $iterator = $crumbs->[-1]; 67 | 68 | # This level is done. 69 | if ( $iterator->at_end ) { 70 | pop @$crumbs; 71 | redo FIND_NEXT_KEY; 72 | } 73 | 74 | if ( $iterator->isa( 'DBM::Deep::Iterator::File::Index' ) ) { 75 | # If we don't have any more, it will be caught at the 76 | # prior check. 77 | if ( my $next = $iterator->get_next_iterator ) { 78 | push @$crumbs, $next; 79 | } 80 | redo FIND_NEXT_KEY; 81 | } 82 | 83 | unless ( $iterator->isa( 'DBM::Deep::Iterator::File::BucketList' ) ) { 84 | DBM::Deep->_throw_error( 85 | "Should have a bucketlist iterator here - instead have $iterator" 86 | ); 87 | } 88 | 89 | # At this point, we have a BucketList iterator 90 | my $key = $iterator->get_next_key; 91 | if ( defined $key ) { 92 | return $key; 93 | } 94 | #XXX else { $iterator->set_to_end() } ? 95 | 96 | # We hit the end of the bucketlist iterator, so redo 97 | redo FIND_NEXT_KEY; 98 | } 99 | 100 | DBM::Deep->_throw_error( "get_next_key(): How did we get here?" ); 101 | } 102 | 103 | 1; 104 | __END__ 105 | -------------------------------------------------------------------------------- /t/13_setpack.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Config; 5 | use Test::More; 6 | use t::common qw( new_fh ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my ($default, $small, $medium, $large); 11 | 12 | { 13 | my ($fh, $filename) = new_fh(); 14 | my $db = DBM::Deep->new( 15 | file => $filename, 16 | autoflush => 1, 17 | ); 18 | $db->{key1} = "value1"; 19 | $db->{key2} = "value2"; 20 | $default = (stat($filename))[7]; 21 | } 22 | 23 | { 24 | my ($fh, $filename) = new_fh(); 25 | { 26 | my $db = DBM::Deep->new( 27 | file => $filename, 28 | autoflush => 1, 29 | pack_size => 'medium', 30 | ); 31 | 32 | $db->{key1} = "value1"; 33 | $db->{key2} = "value2"; 34 | $medium = (stat($filename))[7]; 35 | } 36 | 37 | # This tests the header to verify that the pack_size is really there 38 | { 39 | my $db = DBM::Deep->new( 40 | file => $filename, 41 | ); 42 | 43 | is( $db->{key1}, 'value1', 'Can read key1' ); 44 | is( $db->{key2}, 'value2', 'Can read key2' ); 45 | } 46 | 47 | cmp_ok( $medium, '==', $default, "The default is medium" ); 48 | } 49 | 50 | { 51 | my ($fh, $filename) = new_fh(); 52 | { 53 | my $db = DBM::Deep->new( 54 | file => $filename, 55 | autoflush => 1, 56 | pack_size => 'small', 57 | ); 58 | 59 | $db->{key1} = "value1"; 60 | $db->{key2} = "value2"; 61 | $small = (stat($filename))[7]; 62 | } 63 | 64 | # This tests the header to verify that the pack_size is really there 65 | { 66 | my $db = DBM::Deep->new( 67 | file => $filename, 68 | ); 69 | 70 | is( $db->{key1}, 'value1', 'Can read key1' ); 71 | is( $db->{key2}, 'value2', 'Can read key2' ); 72 | } 73 | 74 | cmp_ok( $medium, '>', $small, "medium is greater than small" ); 75 | } 76 | 77 | eval "pack('Q', 0);"; 78 | my $haveQ = !$@; 79 | 80 | SKIP: { 81 | skip "Largefile support is not compiled into $^X", 3 82 | unless $haveQ; 83 | 84 | my ($fh, $filename) = new_fh(); 85 | { 86 | my $db = DBM::Deep->new( 87 | file => $filename, 88 | autoflush => 1, 89 | pack_size => 'large', 90 | ); 91 | 92 | $db->{key1} = "value1"; 93 | $db->{key2} = "value2"; 94 | $large = (stat($filename))[7]; 95 | } 96 | 97 | # This tests the header to verify that the pack_size is really there 98 | { 99 | my $db = DBM::Deep->new( 100 | file => $filename, 101 | ); 102 | 103 | is( $db->{key1}, 'value1', 'Can read key1' ); 104 | is( $db->{key2}, 'value2', 'Can read key2' ); 105 | } 106 | cmp_ok( $medium, '<', $large, "medium is smaller than large" ); 107 | } 108 | 109 | #SKIP: { 110 | # skip "Largefile support is compiled into $^X", 3 111 | # if $haveQ; 112 | # 113 | # my ($fh, $filename) = new_fh(); 114 | # { 115 | # my $db = DBM::Deep->new( 116 | # file => $filename, 117 | # autoflush => 1, 118 | # pack_size => 'large', 119 | # ); 120 | # } 121 | # 122 | #} 123 | 124 | done_testing; 125 | -------------------------------------------------------------------------------- /t/42_transaction_indexsector.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | # This testfile is in sections because the goal is to verify the behavior 11 | # when a reindex occurs during an active transaction, both as a result of the 12 | # transaction's actions as well as the result of the HEAD's actions. In order 13 | # to keep this test quick, it's easier to restart and hit the known 14 | # reindexing at 17 keys vs. attempting to hit the second-level reindex which 15 | # can occur as early as 18 keys and as late as 4097 (256*16+1) keys. 16 | 17 | { 18 | my $dbm_factory = new_dbm( 19 | locking => 1, 20 | autoflush => 1, 21 | num_txns => 16, 22 | ); 23 | while ( my $dbm_maker = $dbm_factory->() ) { 24 | my $db1 = $dbm_maker->(); 25 | next unless $db1->supports( 'transactions' ); 26 | my $db2 = $dbm_maker->(); 27 | 28 | $db1->{x} = 'y'; 29 | is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" ); 30 | is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" ); 31 | 32 | $db1->begin_work; 33 | 34 | cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); 35 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 36 | 37 | # Add enough keys to force a reindex 38 | $db1->{"K$_"} = "V$_" for 1 .. 16; 39 | 40 | cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" ); 41 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 42 | 43 | $db1->rollback; 44 | 45 | cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); 46 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 47 | 48 | ok( !exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16; 49 | ok( !exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16; 50 | } 51 | } 52 | 53 | { 54 | my $dbm_factory = new_dbm( 55 | locking => 1, 56 | autoflush => 1, 57 | num_txns => 16, 58 | ); 59 | while ( my $dbm_maker = $dbm_factory->() ) { 60 | my $db1 = $dbm_maker->(); 61 | next unless $db1->supports( 'transactions' ); 62 | my $db2 = $dbm_maker->(); 63 | 64 | $db1->{x} = 'y'; 65 | is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" ); 66 | is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" ); 67 | 68 | $db1->begin_work; 69 | 70 | cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); 71 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 72 | 73 | # Add enough keys to force a reindex 74 | $db1->{"K$_"} = "V$_" for 1 .. 16; 75 | 76 | cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" ); 77 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 78 | 79 | $db1->commit; 80 | 81 | cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" ); 82 | cmp_bag( [ keys %$db2 ], ['x', (map { "K$_" } 1 .. 16)], "DB2 keys correct" ); 83 | 84 | ok( exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16; 85 | ok( exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16; 86 | } 87 | } 88 | 89 | done_testing; 90 | -------------------------------------------------------------------------------- /t/common.pm: -------------------------------------------------------------------------------- 1 | package # Hide from PAUSE 2 | t::common; 3 | 4 | use strict; 5 | use warnings FATAL => 'all'; 6 | 7 | use base 'Exporter'; 8 | our @EXPORT_OK = qw( 9 | new_dbm 10 | new_fh 11 | ); 12 | 13 | use File::Spec (); 14 | use File::Temp qw( tempfile tempdir ); 15 | use Fcntl qw( :flock ); 16 | 17 | my $parent = $ENV{WORK_DIR} || File::Spec->tmpdir; 18 | our $dir = tempdir( CLEANUP => 1, DIR => $parent ); 19 | 20 | sub new_fh { 21 | my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir, UNLINK => 1 ); 22 | 23 | # This is because tempfile() returns a flock'ed $fh on MacOSX. 24 | flock $fh, LOCK_UN; 25 | 26 | return ($fh, $filename); 27 | } 28 | 29 | sub new_dbm { 30 | my @args = @_; 31 | my ($fh, $filename) = new_fh(); 32 | 33 | my (@names, @reset_funcs, @extra_args); 34 | 35 | unless ( $ENV{NO_TEST_FILE} ) { 36 | push @names, 'File'; 37 | push @reset_funcs, undef; 38 | push @extra_args, [ 39 | file => $filename, 40 | ]; 41 | } 42 | 43 | if ( $ENV{TEST_SQLITE} ) { 44 | (undef, my $filename) = new_fh(); 45 | push @names, 'SQLite'; 46 | push @reset_funcs, sub { 47 | require 'DBI.pm'; 48 | my $dbh = DBI->connect( 49 | "dbi:SQLite:dbname=$filename", '', '', 50 | ); 51 | my $sql = do { 52 | my $filename = 'etc/sqlite_tables.sql'; 53 | open my $fh, '<', $filename 54 | or die "Cannot open '$filename' for reading: $!\n"; 55 | local $/; 56 | <$fh> 57 | }; 58 | foreach my $line ( split ';', $sql ) { 59 | $dbh->do( "$line" ) if $line =~ /\S/; 60 | } 61 | }; 62 | push @extra_args, [ 63 | dbi => { 64 | dsn => "dbi:SQLite:dbname=$filename", 65 | user => '', 66 | password => '', 67 | }, 68 | ]; 69 | } 70 | 71 | if ( $ENV{TEST_MYSQL_DSN} ) { 72 | push @names, 'MySQL'; 73 | push @reset_funcs, sub { 74 | require 'DBI.pm'; 75 | my $dbh = DBI->connect( 76 | $ENV{TEST_MYSQL_DSN}, 77 | $ENV{TEST_MYSQL_USER}, 78 | $ENV{TEST_MYSQL_PASS}, 79 | ); 80 | my $sql = do { 81 | my $filename = 'etc/mysql_tables.sql'; 82 | open my $fh, '<', $filename 83 | or die "Cannot open '$filename' for reading: $!\n"; 84 | local $/; 85 | <$fh> 86 | }; 87 | foreach my $line ( split ';', $sql ) { 88 | $dbh->do( "$line" ) if $line =~ /\S/; 89 | } 90 | }; 91 | push @extra_args, [ 92 | dbi => { 93 | dsn => $ENV{TEST_MYSQL_DSN}, 94 | user => $ENV{TEST_MYSQL_USER}, 95 | password => $ENV{TEST_MYSQL_PASS}, 96 | }, 97 | ]; 98 | } 99 | 100 | return sub { 101 | return unless @extra_args; 102 | my @these_args = @{ shift @extra_args }; 103 | if ( my $reset = shift @reset_funcs ) { 104 | $reset->(); 105 | } 106 | Test::More::diag( "Testing '@{[shift @names]}'\n" ) if $ENV{TEST_VERBOSE}; 107 | return sub { 108 | DBM::Deep->new( @these_args, @args, @_ ) 109 | }; 110 | }; 111 | } 112 | 113 | 1; 114 | __END__ 115 | -------------------------------------------------------------------------------- /t/11_optimize.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | 6 | plan skip_all => "Skipping the optimize tests on Win32/cygwin for now." 7 | if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ); 8 | 9 | use t::common qw( new_fh ); 10 | 11 | use_ok( 'DBM::Deep' ); 12 | 13 | my ($fh, $filename) = new_fh(); 14 | my $db = DBM::Deep->new( 15 | file => $filename, 16 | autoflush => 1, 17 | ); 18 | 19 | ## 20 | # create some unused space 21 | ## 22 | $db->{key1} = "value1"; 23 | $db->{key2} = "value2"; 24 | 25 | $db->{a} = {}; 26 | $db->{a}{b} = []; 27 | $db->{a}{c} = 'value2'; 28 | 29 | my $b = $db->{a}->{b}; 30 | $b->[0] = 1; 31 | $b->[1] = 2; 32 | $b->[2] = {}; 33 | $b->[2]->{c} = []; 34 | 35 | my $c = $b->[2]->{c}; 36 | $c->[0] = 'd'; 37 | $c->[1] = {}; 38 | $c->[1]->{e} = 'f'; 39 | 40 | undef $c; 41 | undef $b; 42 | 43 | delete $db->{key2}; 44 | delete $db->{a}{b}; 45 | 46 | ## 47 | # take byte count readings before, and after optimize 48 | ## 49 | my $before = (stat($filename))[7]; 50 | my $result = $db->optimize(); 51 | my $after = (stat($filename))[7]; 52 | 53 | ok( $result, "optimize succeeded" ); 54 | cmp_ok( $after, '<', $before, "file size has shrunk" ); # make sure file shrunk 55 | 56 | is( $db->{key1}, 'value1', "key1's value is still there after optimize" ); 57 | is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" ); 58 | 59 | $db->_get_self->_engine->storage->close( $db->_get_self ); 60 | 61 | ## 62 | # now for the tricky one -- try to store a new key while file is being 63 | # optimized and locked by another process. filehandle should be invalidated, 64 | # and automatically re-opened transparently. Cannot test on Win32, due to 65 | # problems with fork()ing, flock()ing, etc. Win32 very bad. 66 | ## 67 | 68 | SKIP: { 69 | skip "Fork tests skipped until fh/filename question solved.", 4; 70 | skip "Fork tests skipped on Win32", 4 71 | if $^O eq 'MSWin32' || $^O eq 'cygwin'; 72 | 73 | ## 74 | # first things first, get us about 1000 keys so the optimize() will take 75 | # at least a few seconds on any machine, and re-open db with locking 76 | ## 77 | for (1..1000) { $db->STORE( $_, $_ +1 ); } 78 | undef $db; 79 | 80 | ## 81 | # now, fork a process for the optimize() 82 | ## 83 | my $pid = fork(); 84 | 85 | unless ( $pid ) { 86 | # child fork 87 | 88 | # re-open db 89 | $db = DBM::Deep->new( 90 | file => $filename, 91 | autoflush => 1, 92 | locking => 1 93 | ); 94 | 95 | # optimize and exit 96 | $db->optimize(); 97 | 98 | exit( 0 ); 99 | } 100 | # parent fork 101 | ok( defined($pid), "fork was successful" ); # make sure fork was successful 102 | 103 | # re-open db 104 | $db = DBM::Deep->new( 105 | file => $filename, 106 | autoflush => 1, 107 | locking => 1 108 | ); 109 | 110 | # sleep for 1 second to make sure optimize() is running in the other fork 111 | sleep(1); 112 | 113 | # now, try to get a lock and store a key 114 | $db->{parentfork} = "hello"; 115 | 116 | # see if it was stored successfully 117 | is( $db->{parentfork}, "hello", "stored key while optimize took place" ); 118 | 119 | undef $db; 120 | $db = DBM::Deep->new( 121 | file => $filename, 122 | autoflush => 1, 123 | locking => 1 124 | ); 125 | 126 | # now check some existing values from before 127 | is( $db->{key1}, 'value1', "key1's value is still there after optimize" ); 128 | is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" ); 129 | } 130 | 131 | done_testing; 132 | -------------------------------------------------------------------------------- /t/16_circular.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use t::common qw( new_dbm ); 6 | 7 | use_ok( 'DBM::Deep' ); 8 | 9 | my $dbm_factory = new_dbm(); 10 | while ( my $dbm_maker = $dbm_factory->() ) { 11 | my $db = $dbm_maker->(); 12 | 13 | ## 14 | # put/get simple keys 15 | ## 16 | $db->{key1} = "value1"; 17 | $db->{key2} = "value2"; 18 | 19 | my @keys_1 = sort keys %$db; 20 | 21 | $db->{key3} = $db->{key1}; 22 | 23 | my @keys_2 = sort keys %$db; 24 | is( @keys_2 + 0, @keys_1 + 1, "Correct number of keys" ); 25 | is_deeply( 26 | [ @keys_1, 'key3' ], 27 | [ @keys_2 ], 28 | "Keys still match after circular reference is added", 29 | ); 30 | 31 | $db->{key4} = { 'foo' => 'bar' }; 32 | $db->{key5} = $db->{key4}; 33 | $db->{key6} = $db->{key5}; 34 | 35 | my @keys_3 = sort keys %$db; 36 | 37 | is( @keys_3 + 0, @keys_2 + 3, "Correct number of keys" ); 38 | is_deeply( 39 | [ @keys_2, 'key4', 'key5', 'key6', ], 40 | [ @keys_3 ], 41 | "Keys still match after circular reference is added (@keys_3)", 42 | ); 43 | 44 | ## 45 | # Insert circular reference 46 | ## 47 | $db->{circle} = $db; 48 | 49 | my @keys_4 = sort keys %$db; 50 | 51 | is( @keys_4 + 0, @keys_3 + 1, "Correct number of keys" ); 52 | is_deeply( 53 | [ 'circle', @keys_3 ], 54 | [ @keys_4 ], 55 | "Keys still match after circular reference is added", 56 | ); 57 | 58 | ## 59 | # Make sure keys exist in both places 60 | ## 61 | is( $db->{key1}, 'value1', "The value is there directly" ); 62 | is( $db->{circle}{key1}, 'value1', "The value is there in one loop of the circle" ); 63 | is( $db->{circle}{circle}{key1}, 'value1', "The value is there in two loops of the circle" ); 64 | is( $db->{circle}{circle}{circle}{key1}, 'value1', "The value is there in three loops of the circle" ); 65 | 66 | ## 67 | # Make sure changes are reflected in both places 68 | ## 69 | $db->{key1} = "another value"; 70 | 71 | isnt( $db->{key3}, 'another value', "Simple scalars are copied by value" ); 72 | 73 | is( $db->{key1}, 'another value', "The value is there directly" ); 74 | is( $db->{circle}{key1}, 'another value', "The value is there in one loop of the circle" ); 75 | is( $db->{circle}{circle}{key1}, 'another value', "The value is there in two loops of the circle" ); 76 | is( $db->{circle}{circle}{circle}{key1}, 'another value', "The value is there in three loops of the circle" ); 77 | 78 | $db->{circle}{circle}{circle}{circle}{key1} = "circles"; 79 | 80 | is( $db->{key1}, 'circles', "The value is there directly" ); 81 | is( $db->{circle}{key1}, 'circles', "The value is there in one loop of the circle" ); 82 | is( $db->{circle}{circle}{key1}, 'circles', "The value is there in two loops of the circle" ); 83 | is( $db->{circle}{circle}{circle}{key1}, 'circles', "The value is there in three loops of the circle" ); 84 | 85 | is( $db->{key4}{foo}, 'bar' ); 86 | is( $db->{key5}{foo}, 'bar' ); 87 | is( $db->{key6}{foo}, 'bar' ); 88 | 89 | $db->{key4}{foo2} = 'bar2'; 90 | is( $db->{key4}{foo2}, 'bar2' ); 91 | is( $db->{key5}{foo2}, 'bar2' ); 92 | is( $db->{key6}{foo2}, 'bar2' ); 93 | 94 | $db->{key4}{foo3} = 'bar3'; 95 | is( $db->{key4}{foo3}, 'bar3' ); 96 | is( $db->{key5}{foo3}, 'bar3' ); 97 | is( $db->{key6}{foo3}, 'bar3' ); 98 | 99 | $db->{key4}{foo4} = 'bar4'; 100 | is( $db->{key4}{foo4}, 'bar4' ); 101 | is( $db->{key5}{foo4}, 'bar4' ); 102 | is( $db->{key6}{foo4}, 'bar4' ); 103 | } 104 | done_testing; 105 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | use Module::Build 0.28; # for prepare_metadata 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | my $build = Module::Build->subclass( 7 | class => "Module::Build::Custom", 8 | code => ' 9 | sub ACTION_test { 10 | my $self = shift; 11 | if ( $self->notes(\'TEST_MYSQL_DSN\') ) { 12 | $ENV{$_} = $self->notes($_) for qw( 13 | TEST_MYSQL_DSN TEST_MYSQL_USER TEST_MYSQL_PASS 14 | ); 15 | } 16 | foreach my $name ( qw( LONG_TESTS TEST_SQLITE ) ) { 17 | $ENV{$name} = 1 if $self->notes( $name ); 18 | } 19 | 20 | $self->SUPER::ACTION_test( @_ ); 21 | } 22 | sub ACTION_dist { 23 | my $self = shift; 24 | my $v = $self->dist_version; 25 | system 26 | $^X, 27 | "-pi -le", 28 | q"$line = $. if ?VERSION?; " 29 | . q"$_ = q<" . $v . q"> if $line && $. == $line+2", 30 | "lib/DBM/Deep.pod"; 31 | $self->SUPER::ACTION_dist( @_ ); 32 | } 33 | ', 34 | )->new( 35 | module_name => 'DBM::Deep', 36 | license => 'perl', 37 | requires => { 38 | 'perl' => '5.008_004', 39 | 'Fcntl' => '0.01', 40 | 'Scalar::Util' => '1.14', 41 | 'Digest::MD5' => '1.00', 42 | }, 43 | build_requires => { 44 | 'File::Path' => '0.01', 45 | 'File::Temp' => '0.01', 46 | 'Pod::Usage' => '1.3', 47 | 'Test::Deep' => '0.095', 48 | 'Test::Warn' => '0.08', 49 | 'Test::More' => '0.88', # done_testing 50 | 'Test::Exception' => '0.21', 51 | }, 52 | create_makefile_pl => 'traditional', 53 | create_readme => 1, 54 | add_to_cleanup => [ 55 | 'META.yml', '*.bak', '*.gz', 'Makefile.PL', 'cover_db', 56 | ], 57 | test_files => 't/??_*.t', 58 | auto_features => { 59 | sqlite_engine => { 60 | description => 'DBI support via SQLite', 61 | requires => { 62 | 'DBI' => '1.5', 63 | 'DBD::SQLite' => '1.25', 64 | }, 65 | }, 66 | mysql_engine => { 67 | description => 'DBI support via MySQL', 68 | requires => { 69 | 'DBI' => '1.5', 70 | 'DBD::mysql' => '4.001', 71 | }, 72 | }, 73 | }, 74 | meta_add => { no_index => { directory => [ 'utils' ] } }, 75 | meta_merge => { 76 | resources => { 77 | repository => 'https://github.com/robkinyon/dbm-deep', 78 | } 79 | }, 80 | ); 81 | 82 | if ( $build->y_n( "Run the long-running tests", 'n' ) ) { 83 | $build->notes( 'LONG_TESTS' => 1 ); 84 | } 85 | 86 | if ( $build->features( 'sqlite_engine' ) ) { 87 | if ( $build->y_n( "Run the tests against the DBI engine via SQLite?", 'n' ) ) { 88 | $build->notes( 'TEST_SQLITE' => 1 ); 89 | } 90 | } 91 | 92 | if ( $build->features( 'mysql_engine' ) ) { 93 | if ( $build->y_n( "Run the tests against the DBI engine via MySQL?", 'n' ) ) { 94 | my ($dsn, $user, $pass) = ('') x 3; 95 | $dsn = $build->prompt( "\tWhat is the full DSN (for example 'dbi:mysql:test')" ); 96 | if ( $dsn ) { 97 | $user = $build->prompt( "\tWhat is the username?" ); 98 | if ( $user ) { 99 | $pass = $build->prompt( "\tWhat is the password?" ); 100 | } 101 | } 102 | 103 | $build->notes( 'TEST_MYSQL_DSN' => $dsn ); 104 | $build->notes( 'TEST_MYSQL_USER' => $user ); 105 | $build->notes( 'TEST_MYSQL_PASS' => $pass ); 106 | } 107 | } 108 | 109 | $build->create_build_script; 110 | -------------------------------------------------------------------------------- /t/27_filehandle.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_fh ); 7 | 8 | # Need to have an explicit plan in order for the sub-testing to work right. 9 | #XXX Figure out how to use subtests for that. 10 | my $pre_fork_tests = 14; 11 | plan tests => $pre_fork_tests + 2; 12 | 13 | use_ok( 'DBM::Deep' ); 14 | 15 | { 16 | my ($fh, $filename) = new_fh(); 17 | 18 | # Create the datafile to be used 19 | { 20 | my $db = DBM::Deep->new( $filename ); 21 | $db->{hash} = { foo => [ 'a' .. 'c' ] }; 22 | } 23 | 24 | { 25 | open(my $fh, '<', $filename) || die("Can't open '$filename' for reading: $!\n"); 26 | 27 | # test if we can open and read a db using its filehandle 28 | 29 | my $db; 30 | ok( ($db = DBM::Deep->new( fh => $fh )), "open db in filehandle" ); 31 | ok( $db->{hash}{foo}[1] eq 'b', "and get at stuff in the database" ); 32 | throws_ok { 33 | $db->{foo} = 1; 34 | } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle"; 35 | ok( !$db->exists( 'foo' ), "foo doesn't exist" ); 36 | 37 | throws_ok { 38 | delete $db->{foo}; 39 | } qr/Cannot write to a readonly filehandle/, "Can't delete from a read-only filehandle"; 40 | 41 | throws_ok { 42 | %$db = (); 43 | } qr/Cannot write to a readonly filehandle/, "Can't clear from a read-only filehandle"; 44 | 45 | SKIP: { 46 | skip( "No inode tests on Win32", 1 ) 47 | if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ); 48 | my $db_obj = $db->_get_self; 49 | ok( $db_obj->_engine->storage->{inode}, "The inode has been set" ); 50 | } 51 | 52 | close($fh); 53 | } 54 | } 55 | 56 | # now the same, but with an offset into the file. Use the database that's 57 | # embedded in the test for the DATA filehandle. First, find the database ... 58 | { 59 | my ($fh,$filename) = new_fh(); 60 | 61 | print $fh "#!$^X\n"; 62 | print $fh <<"__END_FH__"; 63 | my \$t = $pre_fork_tests; 64 | 65 | print "not " unless eval { require DBM::Deep }; 66 | print "ok ", ++\$t, " - use DBM::Deep\n"; 67 | 68 | my \$db = DBM::Deep->new({ 69 | fh => *DATA, 70 | }); 71 | print "not " unless \$db->{x} eq 'b'; 72 | print "ok ", ++\$t, " - and get at stuff in the database\n"; 73 | __END_FH__ 74 | 75 | # The exec below prevents END blocks from doing this. 76 | (my $esc_dir = $t::common::dir) =~ s/(.)/sprintf "\\x{%x}", ord $1/egg; 77 | print $fh <<__END_FH_AGAIN__; 78 | use File::Path 'rmtree'; 79 | rmtree "$esc_dir"; 80 | __END_FH_AGAIN__ 81 | 82 | print $fh "__DATA__\n"; 83 | close $fh; 84 | 85 | my $offset = do { 86 | open my $fh, '<', $filename; 87 | while(my $line = <$fh>) { 88 | last if($line =~ /^__DATA__/); 89 | } 90 | tell($fh); 91 | }; 92 | 93 | { 94 | my $db = DBM::Deep->new({ 95 | file => $filename, 96 | file_offset => $offset, 97 | #XXX For some reason, this is needed to make the test pass. Figure 98 | #XXX out why later. 99 | locking => 0, 100 | }); 101 | 102 | $db->{x} = 'b'; 103 | is( $db->{x}, 'b', 'and it was stored' ); 104 | } 105 | 106 | { 107 | open my $fh, '<', $filename; 108 | my $db = DBM::Deep->new({ 109 | fh => $fh, 110 | file_offset => $offset, 111 | }); 112 | 113 | is($db->{x}, 'b', "and get at stuff in the database"); 114 | 115 | ok( !$db->exists( 'foo' ), "foo doesn't exist yet" ); 116 | throws_ok { 117 | $db->{foo} = 1; 118 | } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle"; 119 | ok( !$db->exists( 'foo' ), "foo still doesn't exist" ); 120 | 121 | is( $db->{x}, 'b' ); 122 | } 123 | 124 | exec( "$^X -Iblib/lib $filename" ); 125 | } 126 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Hash.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Hash; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | no warnings 'recursion'; 8 | 9 | use base 'DBM::Deep'; 10 | 11 | sub _get_self { 12 | # See the note in Array.pm as to why this is commented out. 13 | # eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0] 14 | 15 | # During global destruction %{$_[0]} might get tied to undef, so we 16 | # need to check that case if tied returns false. 17 | tied %{$_[0]} or local *@, eval { exists $_[0]{_}; 1 } ? $_[0] : undef 18 | } 19 | 20 | sub _repr { return {} } 21 | 22 | sub TIEHASH { 23 | my $class = shift; 24 | my $args = $class->_get_args( @_ ); 25 | 26 | $args->{type} = $class->TYPE_HASH; 27 | 28 | return $class->_init($args); 29 | } 30 | 31 | sub FETCH { 32 | my $self = shift->_get_self; 33 | DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; 34 | my $key = ($self->_engine->storage->{filter_store_key}) 35 | ? $self->_engine->storage->{filter_store_key}->($_[0]) 36 | : $_[0]; 37 | 38 | return $self->SUPER::FETCH( $key, $_[0] ); 39 | } 40 | 41 | sub STORE { 42 | my $self = shift->_get_self; 43 | DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; 44 | my $key = ($self->_engine->storage->{filter_store_key}) 45 | ? $self->_engine->storage->{filter_store_key}->($_[0]) 46 | : $_[0]; 47 | my $value = $_[1]; 48 | 49 | return $self->SUPER::STORE( $key, $value, $_[0] ); 50 | } 51 | 52 | sub EXISTS { 53 | my $self = shift->_get_self; 54 | DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; 55 | my $key = ($self->_engine->storage->{filter_store_key}) 56 | ? $self->_engine->storage->{filter_store_key}->($_[0]) 57 | : $_[0]; 58 | 59 | return $self->SUPER::EXISTS( $key ); 60 | } 61 | 62 | sub DELETE { 63 | my $self = shift->_get_self; 64 | DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0]; 65 | my $key = ($self->_engine->storage->{filter_store_key}) 66 | ? $self->_engine->storage->{filter_store_key}->($_[0]) 67 | : $_[0]; 68 | 69 | return $self->SUPER::DELETE( $key, $_[0] ); 70 | } 71 | 72 | # Locate and return first key (in no particular order) 73 | sub FIRSTKEY { 74 | my $self = shift->_get_self; 75 | 76 | $self->lock_shared; 77 | 78 | my $result = $self->_engine->get_next_key( $self ); 79 | 80 | $self->unlock; 81 | 82 | return ($result && $self->_engine->storage->{filter_fetch_key}) 83 | ? $self->_engine->storage->{filter_fetch_key}->($result) 84 | : $result; 85 | } 86 | 87 | # Return next key (in no particular order), given previous one 88 | sub NEXTKEY { 89 | my $self = shift->_get_self; 90 | 91 | my $prev_key = ($self->_engine->storage->{filter_store_key}) 92 | ? $self->_engine->storage->{filter_store_key}->($_[0]) 93 | : $_[0]; 94 | 95 | $self->lock_shared; 96 | 97 | my $result = $self->_engine->get_next_key( $self, $prev_key ); 98 | 99 | $self->unlock; 100 | 101 | return ($result && $self->_engine->storage->{filter_fetch_key}) 102 | ? $self->_engine->storage->{filter_fetch_key}->($result) 103 | : $result; 104 | } 105 | 106 | sub first_key { (shift)->FIRSTKEY(@_) } 107 | sub next_key { (shift)->NEXTKEY(@_) } 108 | 109 | sub _clear { 110 | my $self = shift; 111 | 112 | while ( defined(my $key = $self->first_key) ) { 113 | do { 114 | $self->_engine->delete_key( $self, $key, $key ); 115 | } while defined($key = $self->next_key($key)); 116 | } 117 | 118 | return; 119 | } 120 | 121 | sub _copy_node { 122 | my $self = shift; 123 | my ($db_temp) = @_; 124 | 125 | my $key = $self->first_key(); 126 | while (defined $key) { 127 | my $value = $self->get($key); 128 | $self->_copy_value( \$db_temp->{$key}, $value ); 129 | $key = $self->next_key($key); 130 | } 131 | 132 | return 1; 133 | } 134 | 135 | 1; 136 | __END__ 137 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Storage/DBI.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Storage::DBI; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use base 'DBM::Deep::Storage'; 9 | 10 | use DBI; 11 | 12 | sub new { 13 | my $class = shift; 14 | my ($args) = @_; 15 | 16 | my $self = bless { 17 | autobless => 1, 18 | dbh => undef, 19 | dbi => undef, 20 | }, $class; 21 | 22 | # Grab the parameters we want to use 23 | foreach my $param ( keys %$self ) { 24 | next unless exists $args->{$param}; 25 | $self->{$param} = $args->{$param}; 26 | } 27 | 28 | if ( $self->{dbh} ) { 29 | $self->{driver} = lc $self->{dbh}->{Driver}->{Name}; 30 | } 31 | else { 32 | $self->open; 33 | } 34 | 35 | # Foreign keys are turned off by default in SQLite3 (for now) 36 | #q.v. http://search.cpan.org/~adamk/DBD-SQLite-1.27/lib/DBD/SQLite.pm#Foreign_Keys 37 | # for more info. 38 | if ( $self->driver eq 'sqlite' ) { 39 | $self->{dbh}->do( 'PRAGMA foreign_keys = ON' ); 40 | } 41 | 42 | return $self; 43 | } 44 | 45 | sub open { 46 | my $self = shift; 47 | 48 | return if $self->{dbh}; 49 | 50 | $self->{dbh} = DBI->connect( 51 | $self->{dbi}{dsn}, $self->{dbi}{username}, $self->{dbi}{password}, { 52 | AutoCommit => 1, 53 | PrintError => 0, 54 | RaiseError => 1, 55 | %{ $self->{dbi}{connect_args} || {} }, 56 | }, 57 | ) or die $DBI::error; 58 | 59 | # Should we use the same method as done in new() if passed a $dbh? 60 | (undef, $self->{driver}) = map defined($_) ? lc($_) : undef, DBI->parse_dsn( $self->{dbi}{dsn} ); 61 | 62 | return 1; 63 | } 64 | 65 | sub close { 66 | my $self = shift; 67 | $self->{dbh}->disconnect if $self->{dbh}; 68 | return 1; 69 | } 70 | 71 | sub DESTROY { 72 | my $self = shift; 73 | $self->close if ref $self; 74 | } 75 | 76 | # Is there a portable way of determining writability to a DBH? 77 | sub is_writable { 78 | my $self = shift; 79 | return 1; 80 | } 81 | 82 | sub lock_exclusive { 83 | my $self = shift; 84 | } 85 | 86 | sub lock_shared { 87 | my $self = shift; 88 | } 89 | 90 | sub unlock { 91 | my $self = shift; 92 | # $self->{dbh}->commit; 93 | } 94 | 95 | #sub begin_work { 96 | # my $self = shift; 97 | # $self->{dbh}->begin_work; 98 | #} 99 | # 100 | #sub commit { 101 | # my $self = shift; 102 | # $self->{dbh}->commit; 103 | #} 104 | # 105 | #sub rollback { 106 | # my $self = shift; 107 | # $self->{dbh}->rollback; 108 | #} 109 | 110 | sub read_from { 111 | my $self = shift; 112 | my ($table, $cond, @cols) = @_; 113 | 114 | $cond = { id => $cond } unless ref $cond; 115 | 116 | my @keys = keys %$cond; 117 | my $where = join ' AND ', map { "`$_` = ?" } @keys; 118 | 119 | return $self->{dbh}->selectall_arrayref( 120 | "SELECT `@{[join '`,`', @cols ]}` FROM $table WHERE $where", 121 | { Slice => {} }, @{$cond}{@keys}, 122 | ); 123 | } 124 | 125 | sub flush {} 126 | 127 | sub write_to { 128 | my $self = shift; 129 | my ($table, $id, %args) = @_; 130 | 131 | my @keys = keys %args; 132 | my $sql = 133 | "REPLACE INTO $table ( `id`, " 134 | . join( ',', map { "`$_`" } @keys ) 135 | . ") VALUES (" 136 | . join( ',', ('?') x (@keys + 1) ) 137 | . ")"; 138 | $self->{dbh}->do( $sql, undef, $id, @args{@keys} ); 139 | 140 | return $self->{dbh}->last_insert_id("", "", "", ""); 141 | } 142 | 143 | sub delete_from { 144 | my $self = shift; 145 | my ($table, $cond) = @_; 146 | 147 | $cond = { id => $cond } unless ref $cond; 148 | 149 | my @keys = keys %$cond; 150 | my $where = join ' AND ', map { "`$_` = ?" } @keys; 151 | 152 | $self->{dbh}->do( 153 | "DELETE FROM $table WHERE $where", undef, @{$cond}{@keys}, 154 | ); 155 | } 156 | 157 | sub driver { $_[0]{driver} } 158 | 159 | sub rand_function { 160 | my $self = shift; 161 | my $driver = $self->driver; 162 | 163 | $driver eq 'sqlite' and return 'random()'; 164 | $driver eq 'mysql' and return 'RAND()'; 165 | 166 | die "rand_function undefined for $driver\n"; 167 | } 168 | 169 | 1; 170 | __END__ 171 | -------------------------------------------------------------------------------- /t/41_transaction_multilevel.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | use Test::Deep; 4 | use t::common qw( new_dbm ); 5 | 6 | use_ok( 'DBM::Deep' ); 7 | 8 | my $dbm_factory = new_dbm( 9 | locking => 1, 10 | autoflush => 1, 11 | num_txns => 2, 12 | ); 13 | while ( my $dbm_maker = $dbm_factory->() ) { 14 | my $db1 = $dbm_maker->(); 15 | next unless $db1->supports('transactions'); 16 | my $db2 = $dbm_maker->(); 17 | 18 | $db1->{x} = { xy => { foo => 'y' } }; 19 | is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" ); 20 | is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" ); 21 | 22 | cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); 23 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 24 | 25 | cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" ); 26 | cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); 27 | 28 | cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" ); 29 | cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" ); 30 | 31 | $db1->begin_work; 32 | 33 | cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); 34 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 35 | 36 | cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" ); 37 | cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); 38 | 39 | cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" ); 40 | cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" ); 41 | 42 | is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" ); 43 | is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" ); 44 | 45 | $db1->{x} = { yz => { bar => 30 } }; 46 | ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" ); 47 | is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" ); 48 | 49 | cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" ); 50 | cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); 51 | 52 | $db1->rollback; 53 | 54 | cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); 55 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 56 | 57 | cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" ); 58 | cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); 59 | 60 | cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" ); 61 | cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" ); 62 | 63 | is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" ); 64 | is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" ); 65 | 66 | $db1->begin_work; 67 | 68 | cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); 69 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 70 | 71 | cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" ); 72 | cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); 73 | 74 | cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" ); 75 | cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" ); 76 | 77 | is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" ); 78 | is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" ); 79 | 80 | $db1->{x} = { yz => { bar => 30 } }; 81 | ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" ); 82 | is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X->YZ is Y" ); 83 | 84 | cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" ); 85 | cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" ); 86 | 87 | $db1->commit; 88 | 89 | cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" ); 90 | cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" ); 91 | 92 | cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" ); 93 | cmp_bag( [ keys %{$db2->{x}} ], [qw( yz )], "DB2->X keys correct" ); 94 | 95 | cmp_bag( [ keys %{$db1->{x}{yz}} ], [qw( bar )], "DB1->X->XY keys correct" ); 96 | cmp_bag( [ keys %{$db2->{x}{yz}} ], [qw( bar )], "DB2->X->XY keys correct" ); 97 | } 98 | 99 | done_testing; 100 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector/File/Scalar.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector::File::Scalar; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | no warnings 'recursion'; 8 | 9 | use base qw( DBM::Deep::Sector::File::Data ); 10 | 11 | my $STALE_SIZE = 2; 12 | 13 | # Please refer to the pack() documentation for further information 14 | my %StP = ( 15 | 1 => 'C', # Unsigned char value (no order needed as it's just one byte) 16 | 2 => 'n', # Unsigned short in "network" (big-endian) order 17 | 4 => 'N', # Unsigned long in "network" (big-endian) order 18 | 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent) 19 | ); 20 | 21 | sub free { 22 | my $self = shift; 23 | 24 | my $chain_loc = $self->chain_loc; 25 | 26 | $self->SUPER::free(); 27 | 28 | if ( $chain_loc ) { 29 | $self->engine->load_sector( $chain_loc )->free; 30 | } 31 | 32 | return; 33 | } 34 | 35 | sub _init { 36 | my $self = shift; 37 | 38 | my $engine = $self->engine; 39 | 40 | unless ( $self->offset ) { 41 | my $data_section = $self->size - $self->base_size - $engine->byte_size - 1; 42 | 43 | $self->{offset} = $engine->_request_data_sector( $self->size ); 44 | 45 | my $data = delete $self->{data}; 46 | my $utf8 = do { no warnings 'utf8'; $data !~ /^[\0-\xff]*\z/ }; 47 | if($utf8){ 48 | if($engine->{v} < 4) { 49 | DBM::Deep->_throw_error( 50 | "This database format version is too old for Unicode" 51 | ); 52 | } 53 | utf8::encode $data; 54 | $self->{type} = $engine->SIG_UNIDATA; 55 | } 56 | else { $self->{type} = $engine->SIG_DATA; } 57 | 58 | my $dlen = length $data; 59 | my $continue = 1; 60 | my $curr_offset = $self->offset; 61 | while ( $continue ) { 62 | 63 | my $next_offset = 0; 64 | 65 | my ($leftover, $this_len, $chunk); 66 | if ( $dlen > $data_section ) { 67 | $leftover = 0; 68 | $this_len = $data_section; 69 | $chunk = substr( $data, 0, $this_len ); 70 | 71 | $dlen -= $data_section; 72 | $next_offset = $engine->_request_data_sector( $self->size ); 73 | $data = substr( $data, $this_len ); 74 | } 75 | else { 76 | $leftover = $data_section - $dlen; 77 | $this_len = $dlen; 78 | $chunk = $data; 79 | 80 | $continue = 0; 81 | } 82 | 83 | $engine->storage->print_at( $curr_offset, $self->type ); # Sector type 84 | # Skip staleness 85 | $engine->storage->print_at( $curr_offset + $self->base_size, 86 | pack( $StP{$engine->byte_size}, $next_offset ), # Chain loc 87 | pack( $StP{1}, $this_len ), # Data length 88 | $chunk, # Data to be stored in this sector 89 | chr(0) x $leftover, # Zero-fill the rest 90 | ); 91 | 92 | $curr_offset = $next_offset; 93 | } 94 | 95 | return; 96 | } 97 | } 98 | 99 | sub data_length { 100 | my $self = shift; 101 | 102 | my $buffer = $self->engine->storage->read_at( 103 | $self->offset + $self->base_size + $self->engine->byte_size, 1 104 | ); 105 | 106 | return unpack( $StP{1}, $buffer ); 107 | } 108 | 109 | sub chain_loc { 110 | my $self = shift; 111 | return unpack( 112 | $StP{$self->engine->byte_size}, 113 | $self->engine->storage->read_at( 114 | $self->offset + $self->base_size, 115 | $self->engine->byte_size, 116 | ), 117 | ); 118 | } 119 | 120 | sub data { 121 | my $self = shift; 122 | my $engine = $self->engine; 123 | 124 | my $data; 125 | while ( 1 ) { 126 | my $chain_loc = $self->chain_loc; 127 | 128 | $data .= $engine->storage->read_at( 129 | $self->offset + $self->base_size + $engine->byte_size + 1, $self->data_length, 130 | ); 131 | 132 | last unless $chain_loc; 133 | 134 | $self = $engine->load_sector( $chain_loc ); 135 | } 136 | 137 | utf8::decode $data if $self->type eq $engine->SIG_UNIDATA; 138 | 139 | return $data; 140 | } 141 | 142 | 1; 143 | __END__ 144 | -------------------------------------------------------------------------------- /t/34_transaction_arrays.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $dbm_factory = new_dbm( 11 | locking => 1, 12 | autoflush => 1, 13 | num_txns => 16, 14 | type => DBM::Deep->TYPE_ARRAY, 15 | ); 16 | while ( my $dbm_maker = $dbm_factory->() ) { 17 | my $db1 = $dbm_maker->(); 18 | next unless $db1->supports( 'transactions' ); 19 | my $db2 = $dbm_maker->(); 20 | 21 | $db1->[0] = 'y'; 22 | is( $db1->[0], 'y', "Before transaction, DB1's 0 is Y" ); 23 | is( $db2->[0], 'y', "Before transaction, DB2's 0 is Y" ); 24 | 25 | $db1->begin_work; 26 | 27 | is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" ); 28 | is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" ); 29 | 30 | $db1->[0] = 'z'; 31 | is( $db1->[0], 'z', "Within DB1 transaction, DB1's 0 is Z" ); 32 | is( $db2->[0], 'y', "Within DB1 transaction, DB2's 0 is still Y" ); 33 | 34 | $db2->[1] = 'foo'; 35 | is( $db2->[1], 'foo', "DB2 set 1 within DB1's transaction, so DB2 can see it" ); 36 | ok( !exists $db1->[1], "Since 1 was added after the transaction began, DB1 doesn't see it." ); 37 | 38 | cmp_ok( scalar(@$db1), '==', 1, "DB1 has 1 element" ); 39 | cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" ); 40 | 41 | $db1->rollback; 42 | 43 | is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" ); 44 | is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" ); 45 | 46 | is( $db1->[1], 'foo', "After DB1 transaction is over, DB1 can see 1" ); 47 | is( $db2->[1], 'foo', "After DB1 transaction is over, DB2 can still see 1" ); 48 | 49 | cmp_ok( scalar(@$db1), '==', 2, "DB1 now has 2 elements" ); 50 | cmp_ok( scalar(@$db2), '==', 2, "DB2 still has 2 elements" ); 51 | 52 | $db1->begin_work; 53 | 54 | is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" ); 55 | is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" ); 56 | 57 | $db1->[2] = 'z'; 58 | is( $db1->[2], 'z', "Within DB1 transaction, DB1's 2 is Z" ); 59 | ok( !exists $db2->[2], "Within DB1 transaction, DB2 cannot see 2" ); 60 | 61 | cmp_ok( scalar(@$db1), '==', 3, "DB1 has 3 elements" ); 62 | cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" ); 63 | 64 | $db1->commit; 65 | 66 | is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" ); 67 | is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" ); 68 | 69 | is( $db1->[2], 'z', "After DB1 transaction is over, DB1 can still see 2" ); 70 | is( $db2->[2], 'z', "After DB1 transaction is over, DB2 can now see 2" ); 71 | 72 | cmp_ok( scalar(@$db1), '==', 3, "DB1 now has 2 elements" ); 73 | cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 2 elements" ); 74 | 75 | $db1->begin_work; 76 | 77 | push @$db1, 'foo'; 78 | unshift @$db1, 'bar'; 79 | 80 | cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" ); 81 | cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" ); 82 | 83 | is( $db1->[0], 'bar' ); 84 | is( $db1->[-1], 'foo' ); 85 | 86 | $db1->rollback; 87 | 88 | cmp_ok( scalar(@$db1), '==', 3, "DB1 is back to 3 elements" ); 89 | cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" ); 90 | 91 | $db1->begin_work; 92 | 93 | push @$db1, 'foo'; 94 | unshift @$db1, 'bar'; 95 | 96 | cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" ); 97 | cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" ); 98 | 99 | $db1->commit; 100 | 101 | cmp_ok( scalar(@$db1), '==', 5, "DB1 is still at 5 elements" ); 102 | cmp_ok( scalar(@$db2), '==', 5, "DB2 now has 5 elements" ); 103 | 104 | is( $db1->[0], 'bar' ); 105 | is( $db1->[-1], 'foo' ); 106 | 107 | is( $db2->[0], 'bar' ); 108 | is( $db2->[-1], 'foo' ); 109 | 110 | $db1->begin_work; 111 | 112 | @$db1 = (); # clear() 113 | 114 | cmp_ok( scalar(@$db1), '==', 0, "DB1 now has 0 elements" ); 115 | cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" ); 116 | 117 | $db1->rollback; 118 | 119 | cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" ); 120 | cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" ); 121 | } 122 | 123 | done_testing; 124 | -------------------------------------------------------------------------------- /t/96_virtual_functions.t: -------------------------------------------------------------------------------- 1 | #vim: ft=perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | use lib 't/lib'; 10 | 11 | use_ok( 'DBM::Deep' ); 12 | 13 | throws_ok { 14 | DBM::Deep->new({ _test => 1 }); 15 | } qr/lock_exclusive must be implemented in a child class/, 'Must define lock_exclusive in Storage'; 16 | 17 | { 18 | no strict 'refs'; 19 | *{"DBM::Deep::Storage::Test::lock_exclusive"} = sub { 1 }; 20 | } 21 | 22 | throws_ok { 23 | DBM::Deep->new({ _test => 1 }); 24 | } qr/setup must be implemented in a child class/, 'Must define setup in Engine'; 25 | 26 | { 27 | no strict 'refs'; 28 | *{"DBM::Deep::Engine::Test::setup"} = sub { 1 }; 29 | } 30 | 31 | throws_ok { 32 | DBM::Deep->new({ _test => 1 }); 33 | } qr/unlock must be implemented in a child class/, 'Must define unlock in Storage'; 34 | 35 | { 36 | no strict 'refs'; 37 | *{"DBM::Deep::Storage::Test::unlock"} = sub { 1 }; 38 | } 39 | 40 | throws_ok { 41 | DBM::Deep->new({ _test => 1 }); 42 | } qr/flush must be implemented in a child class/, 'Must define flush in Storage'; 43 | 44 | { 45 | no strict 'refs'; 46 | *{"DBM::Deep::Storage::Test::flush"} = sub { 1 }; 47 | } 48 | 49 | my $db; 50 | lives_ok { 51 | $db = DBM::Deep->new({ _test => 1 }); 52 | } "We finally have enough defined to instantiate"; 53 | 54 | throws_ok { 55 | $db->lock_shared; 56 | } qr/lock_shared must be implemented in a child class/, 'Must define lock_shared in Storage'; 57 | 58 | { 59 | no strict 'refs'; 60 | *{"DBM::Deep::Storage::Test::lock_shared"} = sub { 1 }; 61 | } 62 | 63 | lives_ok { 64 | $db->lock_shared; 65 | } 'We have lock_shared defined'; 66 | 67 | # Yes, this is ordered for good reason. Think about it. 68 | my @methods = ( 69 | 'begin_work' => [ 70 | Engine => 'begin_work', 71 | ], 72 | 'rollback' => [ 73 | Engine => 'rollback', 74 | ], 75 | 'commit' => [ 76 | Engine => 'commit', 77 | ], 78 | 'supports' => [ 79 | Engine => 'supports', 80 | ], 81 | 'store' => [ 82 | Storage => 'is_writable', 83 | Engine => 'write_value', 84 | ], 85 | 'fetch' => [ 86 | Engine => 'read_value', 87 | ], 88 | 'delete' => [ 89 | Engine => 'delete_key', 90 | ], 91 | 'exists' => [ 92 | Engine => 'key_exists', 93 | ], 94 | # Why is this one's error message bleeding through? 95 | 'clear' => [ 96 | Engine => 'clear', 97 | ], 98 | ); 99 | 100 | # Add the following: 101 | # in_txn 102 | 103 | # If only I could use natatime(). *sighs* 104 | while ( @methods ) { 105 | my ($entry, $requirements) = splice @methods, 0, 2; 106 | while ( @$requirements ) { 107 | my ($class, $child_method) = splice @$requirements, 0, 2; 108 | 109 | throws_ok { 110 | $db->$entry( 1 ); 111 | } qr/$child_method must be implemented in a child class/, 112 | "'$entry' requires '$child_method' to be defined in the '$class'"; 113 | 114 | { 115 | no strict 'refs'; 116 | *{"DBM::Deep::${class}::Test::${child_method}"} = sub { 1 }; 117 | } 118 | } 119 | 120 | lives_ok { 121 | $db->$entry( 1 ); 122 | } "Finally have enough for '$entry' to work"; 123 | } 124 | 125 | throws_ok { 126 | $db->_engine->sector_type; 127 | } qr/sector_type must be implemented in a child class/, 'Must define sector_type in Storage'; 128 | 129 | { 130 | no strict 'refs'; 131 | *{"DBM::Deep::Engine::Test::sector_type"} = sub { 'DBM::Deep::Iterator::Test' }; 132 | } 133 | 134 | lives_ok { 135 | $db->_engine->sector_type; 136 | } 'We have sector_type defined'; 137 | 138 | throws_ok { 139 | $db->first_key; 140 | } qr/iterator_class must be implemented in a child class/, 'Must define iterator_class in Iterator'; 141 | 142 | { 143 | no strict 'refs'; 144 | *{"DBM::Deep::Engine::Test::iterator_class"} = sub { 'DBM::Deep::Iterator::Test' }; 145 | } 146 | 147 | throws_ok { 148 | $db->first_key; 149 | } qr/reset must be implemented in a child class/, 'Must define reset in Iterator'; 150 | 151 | { 152 | no strict 'refs'; 153 | *{"DBM::Deep::Iterator::Test::reset"} = sub { 1 }; 154 | } 155 | 156 | throws_ok { 157 | $db->first_key; 158 | } qr/get_next_key must be implemented in a child class/, 'Must define get_next_key in Iterator'; 159 | 160 | { 161 | no strict 'refs'; 162 | *{"DBM::Deep::Iterator::Test::get_next_key"} = sub { 1 }; 163 | } 164 | 165 | lives_ok { 166 | $db->first_key; 167 | } 'Finally have enough for first_key to work.'; 168 | 169 | done_testing; 170 | -------------------------------------------------------------------------------- /t/35_transaction_multiple.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use t::common qw( new_dbm ); 7 | 8 | use_ok( 'DBM::Deep' ); 9 | 10 | my $dbm_factory = new_dbm( 11 | locking => 1, 12 | autoflush => 1, 13 | num_txns => 16, 14 | ); 15 | while ( my $dbm_maker = $dbm_factory->() ) { 16 | my $db1 = $dbm_maker->(); 17 | next unless $db1->supports( 'transactions' ); 18 | my $db2 = $dbm_maker->(); 19 | my $db3 = $dbm_maker->(); 20 | 21 | $db1->{foo} = 'bar'; 22 | is( $db1->{foo}, 'bar', "Before transaction, DB1's foo is bar" ); 23 | is( $db2->{foo}, 'bar', "Before transaction, DB2's foo is bar" ); 24 | is( $db3->{foo}, 'bar', "Before transaction, DB3's foo is bar" ); 25 | 26 | $db1->begin_work; 27 | 28 | is( $db1->{foo}, 'bar', "Before transaction work, DB1's foo is bar" ); 29 | is( $db2->{foo}, 'bar', "Before transaction work, DB2's foo is bar" ); 30 | is( $db3->{foo}, 'bar', "Before transaction work, DB3's foo is bar" ); 31 | 32 | $db1->{foo} = 'bar2'; 33 | 34 | is( $db1->{foo}, 'bar2', "After DB1 foo to bar2, DB1's foo is bar2" ); 35 | is( $db2->{foo}, 'bar', "After DB1 foo to bar2, DB2's foo is bar" ); 36 | is( $db3->{foo}, 'bar', "After DB1 foo to bar2, DB3's foo is bar" ); 37 | 38 | $db1->{bar} = 'foo'; 39 | 40 | ok( exists $db1->{bar}, "After DB1 set bar to foo, DB1's bar exists" ); 41 | ok( !exists $db2->{bar}, "After DB1 set bar to foo, DB2's bar doesn't exist" ); 42 | ok( !exists $db3->{bar}, "After DB1 set bar to foo, DB3's bar doesn't exist" ); 43 | 44 | $db2->begin_work; 45 | 46 | is( $db1->{foo}, 'bar2', "After DB2 transaction begin, DB1's foo is still bar2" ); 47 | is( $db2->{foo}, 'bar', "After DB2 transaction begin, DB2's foo is still bar" ); 48 | is( $db3->{foo}, 'bar', "After DB2 transaction begin, DB3's foo is still bar" ); 49 | 50 | ok( exists $db1->{bar}, "After DB2 transaction begin, DB1's bar exists" ); 51 | ok( !exists $db2->{bar}, "After DB2 transaction begin, DB2's bar doesn't exist" ); 52 | ok( !exists $db3->{bar}, "After DB2 transaction begin, DB3's bar doesn't exist" ); 53 | 54 | $db2->{foo} = 'bar333'; 55 | 56 | is( $db1->{foo}, 'bar2', "After DB2 foo to bar2, DB1's foo is bar2" ); 57 | is( $db2->{foo}, 'bar333', "After DB2 foo to bar2, DB2's foo is bar333" ); 58 | is( $db3->{foo}, 'bar', "After DB2 foo to bar2, DB3's foo is bar" ); 59 | 60 | $db2->{bar} = 'mybar'; 61 | 62 | ok( exists $db1->{bar}, "After DB2 set bar to mybar, DB1's bar exists" ); 63 | ok( exists $db2->{bar}, "After DB2 set bar to mybar, DB2's bar exists" ); 64 | ok( !exists $db3->{bar}, "After DB2 set bar to mybar, DB3's bar doesn't exist" ); 65 | 66 | is( $db1->{bar}, 'foo', "DB1's bar is still foo" ); 67 | is( $db2->{bar}, 'mybar', "DB2's bar is now mybar" ); 68 | 69 | $db2->{mykey} = 'myval'; 70 | 71 | ok( !exists $db1->{mykey}, "After DB2 set mykey to myval, DB1's mykey doesn't exist" ); 72 | ok( exists $db2->{mykey}, "After DB2 set mykey to myval, DB2's mykey exists" ); 73 | ok( !exists $db3->{mykey}, "After DB2 set mykey to myval, DB3's mykey doesn't exist" ); 74 | 75 | cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" ); 76 | cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" ); 77 | cmp_bag( [ keys %$db3 ], [qw( foo )], "DB3 keys correct" ); 78 | 79 | $db1->commit; 80 | 81 | is( $db1->{foo}, 'bar2', "After DB1 commit, DB1's foo is bar2" ); 82 | is( $db2->{foo}, 'bar333', "After DB1 commit, DB2's foo is bar333" ); 83 | is( $db3->{foo}, 'bar2', "After DB1 commit, DB3's foo is bar2" ); 84 | 85 | is( $db1->{bar}, 'foo', "DB1's bar is still foo" ); 86 | is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" ); 87 | is( $db3->{bar}, 'foo', "DB3's bar is now foo" ); 88 | 89 | cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" ); 90 | cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" ); 91 | cmp_bag( [ keys %$db3 ], [qw( foo bar )], "DB3 keys correct" ); 92 | 93 | $db2->commit; 94 | 95 | is( $db1->{foo}, 'bar333', "After DB2 commit, DB1's foo is bar333" ); 96 | is( $db2->{foo}, 'bar333', "After DB2 commit, DB2's foo is bar333" ); 97 | is( $db3->{foo}, 'bar333', "After DB2 commit, DB3's foo is bar333" ); 98 | 99 | is( $db1->{bar}, 'mybar', "DB1's bar is now mybar" ); 100 | is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" ); 101 | is( $db3->{bar}, 'mybar', "DB3's bar is now mybar" ); 102 | 103 | cmp_bag( [ keys %$db1 ], [qw( foo bar mykey )], "DB1 keys correct" ); 104 | cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" ); 105 | cmp_bag( [ keys %$db3 ], [qw( foo bar mykey )], "DB3 keys correct" ); 106 | } 107 | 108 | done_testing; 109 | -------------------------------------------------------------------------------- /t/17_import.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use Test::Exception; 7 | use t::common qw( new_dbm ); 8 | 9 | use_ok( 'DBM::Deep' ); 10 | 11 | # Failure cases to make sure that things are caught right. 12 | foreach my $type ( DBM::Deep->TYPE_HASH, DBM::Deep->TYPE_ARRAY ) { 13 | my $dbm_factory = new_dbm( type => $type ); 14 | while ( my $dbm_maker = $dbm_factory->() ) { 15 | my $db = $dbm_maker->(); 16 | 17 | # Load a scalar 18 | throws_ok { 19 | $db->import( 'foo' ); 20 | } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails"; 21 | 22 | # Load a ref of the wrong type 23 | # Load something with bad stuff in it 24 | my $x = 3; 25 | if ( $type eq 'A' ) { 26 | throws_ok { 27 | $db->import( { foo => 'bar' } ); 28 | } qr/Cannot import a hash into an array/, "Wrong type fails"; 29 | 30 | throws_ok { 31 | $db->import( [ \$x ] ); 32 | } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails"; 33 | } 34 | else { 35 | throws_ok { 36 | $db->import( [ 1 .. 3 ] ); 37 | } qr/Cannot import an array into a hash/, "Wrong type fails"; 38 | 39 | throws_ok { 40 | $db->import( { foo => \$x } ); 41 | } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails"; 42 | } 43 | } 44 | } 45 | 46 | my $dbm_factory = new_dbm( autobless => 1 ); 47 | while ( my $dbm_maker = $dbm_factory->() ) { 48 | my $db = $dbm_maker->(); 49 | 50 | ## 51 | # Create structure in memory 52 | ## 53 | my $struct = { 54 | key1 => "value1", 55 | key2 => "value2", 56 | array1 => [ "elem0", "elem1", "elem2" ], 57 | hash1 => { 58 | subkey1 => "subvalue1", 59 | subkey2 => "subvalue2", 60 | subkey3 => bless( { a => 'b' }, 'Foo' ), 61 | } 62 | }; 63 | 64 | $db->import( $struct ); 65 | 66 | cmp_deeply( 67 | $db, 68 | noclass({ 69 | key1 => 'value1', 70 | key2 => 'value2', 71 | array1 => [ 'elem0', 'elem1', 'elem2', ], 72 | hash1 => { 73 | subkey1 => "subvalue1", 74 | subkey2 => "subvalue2", 75 | subkey3 => useclass( bless { a => 'b' }, 'Foo' ), 76 | }, 77 | }), 78 | "Everything matches", 79 | ); 80 | 81 | $struct->{foo} = 'bar'; 82 | is( $struct->{foo}, 'bar', "\$struct has foo and it's 'bar'" ); 83 | ok( !exists $db->{foo}, "\$db doesn't have the 'foo' key, so \$struct is not tied" ); 84 | 85 | $struct->{hash1}->{foo} = 'bar'; 86 | is( $struct->{hash1}->{foo}, 'bar', "\$struct->{hash1} has foo and it's 'bar'" ); 87 | ok( !exists $db->{hash1}->{foo}, "\$db->{hash1} doesn't have the 'foo' key, so \$struct->{hash1} is not tied" ); 88 | } 89 | 90 | $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY ); 91 | while ( my $dbm_maker = $dbm_factory->() ) { 92 | my $db = $dbm_maker->(); 93 | 94 | my $struct = [ 95 | 1 .. 3, 96 | [ 2, 4, 6 ], 97 | bless( [], 'Bar' ), 98 | { foo => [ 2 .. 4 ] }, 99 | ]; 100 | 101 | $db->import( $struct ); 102 | 103 | cmp_deeply( 104 | $db, 105 | noclass([ 106 | 1 .. 3, 107 | [ 2, 4, 6 ], 108 | useclass( bless( [], 'Bar' ) ), 109 | { foo => [ 2 .. 4 ] }, 110 | ]), 111 | "Everything matches", 112 | ); 113 | 114 | push @$struct, 'bar'; 115 | is( $struct->[-1], 'bar', "\$struct has 'bar' at the end" ); 116 | ok( $db->[-1], "\$db doesn't have the 'bar' value at the end, so \$struct is not tied" ); 117 | } 118 | 119 | # Failure case to verify that rollback occurs 120 | $dbm_factory = new_dbm( autobless => 1 ); 121 | while ( my $dbm_maker = $dbm_factory->() ) { 122 | my $db = $dbm_maker->(); 123 | 124 | $db->{foo} = 'bar'; 125 | 126 | my $x; 127 | my $struct = { 128 | key1 => [ 129 | 2, \$x, 3, 130 | ], 131 | }; 132 | 133 | eval { 134 | $db->import( $struct ); 135 | }; 136 | like( $@, qr/Storage of references of type 'SCALAR' is not supported/, 'Error message correct' ); 137 | 138 | TODO: { 139 | local $TODO = "Importing cannot occur within a transaction yet."; 140 | cmp_deeply( 141 | $db, 142 | noclass({ 143 | foo => 'bar', 144 | }), 145 | "Everything matches", 146 | ); 147 | } 148 | } 149 | 150 | done_testing; 151 | 152 | __END__ 153 | 154 | Need to add tests for: 155 | - Failure case (have something tied or a glob or something like that) 156 | - Where we already have $db->{hash1} to make sure that it's not overwritten 157 | -------------------------------------------------------------------------------- /t/06_error.t: -------------------------------------------------------------------------------- 1 | 2 | $|++; 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | use Test::Warn; 9 | use t::common qw( new_fh ); 10 | 11 | use_ok( 'DBM::Deep' ); 12 | 13 | # test a corrupted file 14 | { 15 | my ($fh, $filename) = new_fh(); 16 | 17 | open FH, ">$filename"; 18 | print FH 'DPDB'; 19 | close FH; 20 | 21 | throws_ok { 22 | DBM::Deep->new( $filename ); 23 | } qr/DBM::Deep: Pre-1.00 file version found/, "Fail if there's a bad header"; 24 | } 25 | 26 | { 27 | my ($fh, $filename) = new_fh(); 28 | my %hash; 29 | tie %hash, 'DBM::Deep', $filename; 30 | undef %hash; 31 | 32 | my @array; 33 | throws_ok { 34 | tie @array, 'DBM::Deep', $filename; 35 | } qr/DBM::Deep: File type mismatch/, "Fail if we try and tie a hash file with an array"; 36 | 37 | throws_ok { 38 | DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY ) 39 | } qr/DBM::Deep: File type mismatch/, "Fail if we try and open a hash file with an array"; 40 | } 41 | 42 | { 43 | my ($fh, $filename) = new_fh(); 44 | my @array; 45 | tie @array, 'DBM::Deep', $filename; 46 | undef @array; 47 | 48 | my %hash; 49 | throws_ok { 50 | tie %hash, 'DBM::Deep', $filename; 51 | } qr/DBM::Deep: File type mismatch/, "Fail if we try and tie an array file with a hash"; 52 | 53 | throws_ok { 54 | DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_HASH ) 55 | } qr/DBM::Deep: File type mismatch/, "Fail if we try and open an array file with a hash"; 56 | } 57 | 58 | { 59 | my %floors = ( 60 | max_buckets => 16, 61 | num_txns => 1, 62 | data_sector_size => 32, 63 | ); 64 | 65 | while ( my ($attr, $floor) = each %floors ) { 66 | { 67 | my ($fh, $filename) = new_fh(); 68 | warning_like { 69 | my $db = DBM::Deep->new( 70 | file => $filename, 71 | $attr => undef, 72 | ); 73 | } qr{Floor of $attr is $floor\. Setting it to $floor from '\Q(undef)\E'}, 74 | "Warning for $attr => undef is correct"; 75 | } 76 | { 77 | my ($fh, $filename) = new_fh(); 78 | warning_like { 79 | my $db = DBM::Deep->new( 80 | file => $filename, 81 | $attr => '', 82 | ); 83 | } qr{Floor of $attr is $floor\. Setting it to $floor from ''}, 84 | "Warning for $attr => '' is correct"; 85 | } 86 | { 87 | my ($fh, $filename) = new_fh(); 88 | warning_like { 89 | my $db = DBM::Deep->new( 90 | file => $filename, 91 | $attr => 'abcd', 92 | ); 93 | } qr{Floor of $attr is $floor\. Setting it to $floor from 'abcd'}, 94 | "Warning for $attr => 'abcd' is correct"; 95 | } 96 | { 97 | my ($fh, $filename) = new_fh(); 98 | my $val = $floor - 1; 99 | warning_like { 100 | my $db = DBM::Deep->new( 101 | file => $filename, 102 | $attr => $val, 103 | ); 104 | } qr{Floor of $attr is $floor\. Setting it to $floor from '$val'}, 105 | "Warning for $attr => $val is correct"; 106 | } 107 | } 108 | 109 | my %ceilings = ( 110 | max_buckets => 256, 111 | num_txns => 255, 112 | data_sector_size => 256, 113 | ); 114 | 115 | while ( my ($attr, $ceiling) = each %ceilings ) { 116 | my ($fh, $filename) = new_fh(); 117 | warning_like { 118 | my $db = DBM::Deep->new( 119 | file => $filename, 120 | $attr => 1000, 121 | ); 122 | } qr{Ceiling of $attr is $ceiling\. Setting it to $ceiling from '1000'}, 123 | "Warning for $attr => 1000 is correct"; 124 | } 125 | } 126 | 127 | { 128 | throws_ok { 129 | DBM::Deep->new( 't/etc/db-0-983' ); 130 | } qr/DBM::Deep: Pre-1.00 file version found/, "Fail if opening a pre-1.00 file"; 131 | } 132 | 133 | { 134 | throws_ok { 135 | DBM::Deep->new( 't/etc/db-0-99_04' ); 136 | } qr/DBM::Deep: This file version is too old - 0\.99 - expected (?x: 137 | )1\.0003 to \d/, "Fail if opening a file version 1"; 138 | } 139 | 140 | { 141 | # Make sure we get the right file name in the error message. 142 | throws_ok { 143 | eval "#line 1 gneen\nDBM::Deep->new( 't/etc/db-0-99_04' )" 144 | or die $@ 145 | } qr/ at gneen line 1\b/, "File name in error message is correct"; 146 | } 147 | 148 | { 149 | # Too many transactions. 150 | my ($fh, $filename) = new_fh(); 151 | 152 | throws_ok { 153 | new DBM::Deep $filename =>-> begin_work; 154 | } qr/^DBM::Deep: Cannot allocate transaction ID at/, 155 | "Error when starting transaction in database with only 1 txn"; 156 | } 157 | 158 | done_testing; 159 | -------------------------------------------------------------------------------- /t/24_autobless.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | { 5 | package Foo; 6 | 7 | sub export { 'export' }; 8 | sub foo { 'foo' }; 9 | } 10 | 11 | use Test::More; 12 | use t::common qw( new_dbm ); 13 | 14 | use_ok( 'DBM::Deep' ); 15 | 16 | my $dbm_factory = new_dbm( autobless => 1 ); 17 | while ( my $dbm_maker = $dbm_factory->() ) { 18 | { 19 | my $db = $dbm_maker->(); 20 | 21 | my $obj = bless { 22 | a => 1, 23 | b => [ 1 .. 3 ], 24 | }, 'Foo'; 25 | 26 | $db->{blessed} = $obj; 27 | is( $db->{blessed}{a}, 1 ); 28 | is( $db->{blessed}{b}[0], 1 ); 29 | is( $db->{blessed}{b}[1], 2 ); 30 | is( $db->{blessed}{b}[2], 3 ); 31 | 32 | my $obj2 = bless [ 33 | { a => 'foo' }, 34 | 2, 35 | ], 'Foo'; 36 | $db->{blessed2} = $obj2; 37 | 38 | is( $db->{blessed2}[0]{a}, 'foo' ); 39 | is( $db->{blessed2}[1], '2' ); 40 | 41 | $db->{unblessed} = {}; 42 | $db->{unblessed}{a} = 1; 43 | $db->{unblessed}{b} = []; 44 | $db->{unblessed}{b}[0] = 1; 45 | $db->{unblessed}{b}[1] = 2; 46 | $db->{unblessed}{b}[2] = 3; 47 | 48 | is( $db->{unblessed}{a}, 1 ); 49 | is( $db->{unblessed}{b}[0], 1 ); 50 | is( $db->{unblessed}{b}[1], 2 ); 51 | is( $db->{unblessed}{b}[2], 3 ); 52 | 53 | $db->{blessed_long} = bless {}, 'a' x 1000; 54 | $db->_get_self->_engine->storage->close( $db->_get_self ); 55 | } 56 | 57 | { 58 | my $db = $dbm_maker->(); 59 | 60 | my $obj = $db->{blessed}; 61 | isa_ok( $obj, 'Foo' ); 62 | can_ok( $obj, 'export', 'foo' ); 63 | ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" ); 64 | 65 | is( $obj->{a}, 1 ); 66 | is( $obj->{b}[0], 1 ); 67 | is( $obj->{b}[1], 2 ); 68 | is( $obj->{b}[2], 3 ); 69 | 70 | my $obj2 = $db->{blessed2}; 71 | isa_ok( $obj2, 'Foo' ); 72 | can_ok( $obj2, 'export', 'foo' ); 73 | ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" ); 74 | 75 | is( $obj2->[0]{a}, 'foo' ); 76 | is( $obj2->[1], '2' ); 77 | 78 | is( $db->{unblessed}{a}, 1 ); 79 | is( $db->{unblessed}{b}[0], 1 ); 80 | is( $db->{unblessed}{b}[1], 2 ); 81 | is( $db->{unblessed}{b}[2], 3 ); 82 | 83 | $obj->{c} = 'new'; 84 | is( $db->{blessed}{c}, 'new' ); 85 | 86 | isa_ok( $db->{blessed_long}, 'a' x 1000 ); 87 | $db->_get_self->_engine->storage->close( $db->_get_self ); 88 | } 89 | 90 | { 91 | my $db = $dbm_maker->(); 92 | is( $db->{blessed}{c}, 'new' ); 93 | 94 | my $structure = $db->export(); 95 | use Data::Dumper;print Dumper $structure; 96 | 97 | my $obj = $structure->{blessed}; 98 | isa_ok( $obj, 'Foo' ); 99 | can_ok( $obj, 'export', 'foo' ); 100 | ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" ); 101 | 102 | is( $obj->{a}, 1 ); 103 | is( $obj->{b}[0], 1 ); 104 | is( $obj->{b}[1], 2 ); 105 | is( $obj->{b}[2], 3 ); 106 | 107 | my $obj2 = $structure->{blessed2}; 108 | isa_ok( $obj2, 'Foo' ); 109 | can_ok( $obj2, 'export', 'foo' ); 110 | ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" ); 111 | 112 | is( $obj2->[0]{a}, 'foo' ); 113 | is( $obj2->[1], '2' ); 114 | 115 | is( $structure->{unblessed}{a}, 1 ); 116 | is( $structure->{unblessed}{b}[0], 1 ); 117 | is( $structure->{unblessed}{b}[1], 2 ); 118 | is( $structure->{unblessed}{b}[2], 3 ); 119 | $db->_get_self->_engine->storage->close( $db->_get_self ); 120 | } 121 | 122 | { 123 | my $db = $dbm_maker->( autobless => 0 ); 124 | 125 | my $obj = $db->{blessed}; 126 | isa_ok( $obj, 'DBM::Deep' ); 127 | can_ok( $obj, 'export', 'STORE' ); 128 | ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" ); 129 | 130 | is( $obj->{a}, 1 ); 131 | is( $obj->{b}[0], 1 ); 132 | is( $obj->{b}[1], 2 ); 133 | is( $obj->{b}[2], 3 ); 134 | 135 | my $obj2 = $db->{blessed2}; 136 | isa_ok( $obj2, 'DBM::Deep' ); 137 | can_ok( $obj2, 'export', 'STORE' ); 138 | ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" ); 139 | 140 | is( $obj2->[0]{a}, 'foo' ); 141 | is( $obj2->[1], '2' ); 142 | 143 | is( $db->{unblessed}{a}, 1 ); 144 | is( $db->{unblessed}{b}[0], 1 ); 145 | is( $db->{unblessed}{b}[1], 2 ); 146 | is( $db->{unblessed}{b}[2], 3 ); 147 | $db->_get_self->_engine->storage->close( $db->_get_self ); 148 | } 149 | } 150 | 151 | $dbm_factory = new_dbm( autobless => 1 ); 152 | while ( my $dbm_maker = $dbm_factory->() ) { 153 | { 154 | my $db = $dbm_maker->(); 155 | my $obj = bless { 156 | a => 1, 157 | b => [ 1 .. 3 ], 158 | }, 'Foo'; 159 | 160 | $db->import( { blessed => $obj } ); 161 | } 162 | 163 | { 164 | my $db = $dbm_maker->(); 165 | 166 | my $blessed = $db->{blessed}; 167 | isa_ok( $blessed, 'Foo' ); 168 | is( $blessed->{a}, 1 ); 169 | } 170 | } 171 | 172 | # test blessing hash into short named class (Foo), then re-blessing into 173 | # longer named class (FooFoo) and replacing key in db file, then validating 174 | # content after that point in file to check for corruption. 175 | $dbm_factory = new_dbm( autobless => 1 ); 176 | while ( my $dbm_maker = $dbm_factory->() ) { 177 | my $db = $dbm_maker->(); 178 | 179 | my $obj = bless {}, 'Foo'; 180 | 181 | $db->{blessed} = $obj; 182 | $db->{after} = "hello"; 183 | 184 | my $obj2 = bless {}, 'FooFoo'; 185 | 186 | $db->{blessed} = $obj2; 187 | 188 | is( $db->{after}, "hello" ); 189 | } 190 | 191 | done_testing; 192 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Sector/DBI/Reference.pm: -------------------------------------------------------------------------------- 1 | package DBM::Deep::Sector::DBI::Reference; 2 | 3 | use 5.008_004; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use base 'DBM::Deep::Sector::DBI'; 9 | 10 | use Scalar::Util; 11 | 12 | sub table { 'refs' } 13 | 14 | sub _init { 15 | my $self = shift; 16 | 17 | my $e = $self->engine; 18 | 19 | unless ( $self->offset ) { 20 | my $classname = Scalar::Util::blessed( delete $self->{data} ); 21 | $self->{offset} = $self->engine->storage->write_to( 22 | refs => undef, 23 | ref_type => $self->type, 24 | classname => $classname, 25 | ); 26 | } 27 | else { 28 | my ($rows) = $self->engine->storage->read_from( 29 | refs => $self->offset, 30 | qw( ref_type ), 31 | ); 32 | 33 | $self->{type} = $rows->[0]{ref_type}; 34 | } 35 | 36 | return; 37 | } 38 | 39 | sub get_data_for { 40 | my $self = shift; 41 | my ($args) = @_; 42 | 43 | my ($rows) = $self->engine->storage->read_from( 44 | datas => { ref_id => $self->offset, key => $args->{key} }, 45 | qw( id ), 46 | ); 47 | 48 | return unless $rows->[0]{id}; 49 | 50 | $self->load( 51 | $self->engine, 52 | $rows->[0]{id}, 53 | 'datas', 54 | ); 55 | } 56 | 57 | sub write_data { 58 | my $self = shift; 59 | my ($args) = @_; 60 | 61 | if ( ( $args->{value}->type || 'S' ) eq 'S' ) { 62 | $args->{value}{offset} = $self->engine->storage->write_to( 63 | datas => $args->{value}{offset}, 64 | ref_id => $self->offset, 65 | data_type => 'S', 66 | key => $args->{key}, 67 | value => $args->{value}{data}, 68 | ); 69 | 70 | $args->{value}->reload; 71 | } 72 | else { 73 | # Write the Scalar of the Reference 74 | $self->engine->storage->write_to( 75 | datas => undef, 76 | ref_id => $self->offset, 77 | data_type => 'R', 78 | key => $args->{key}, 79 | value => $args->{value}{offset}, 80 | ); 81 | } 82 | } 83 | 84 | sub delete_key { 85 | my $self = shift; 86 | my ($args) = @_; 87 | 88 | my $old_value = $self->get_data_for({ 89 | key => $args->{key}, 90 | }); 91 | 92 | my $data; 93 | if ( $old_value ) { 94 | $data = $old_value->data({ export => 1 }); 95 | 96 | $self->engine->storage->delete_from( 97 | 'datas', 98 | { ref_id => $self->offset, 99 | key => $args->{key}, }, 100 | ); 101 | $old_value->free; 102 | } 103 | 104 | return $data; 105 | } 106 | 107 | sub get_classname { 108 | my $self = shift; 109 | my ($rows) = $self->engine->storage->read_from( 110 | 'refs', $self->offset, 111 | qw( classname ), 112 | ); 113 | return unless @$rows; 114 | return $rows->[0]{classname}; 115 | } 116 | 117 | # Look to hoist this method into a ::Reference trait 118 | sub data { 119 | my $self = shift; 120 | my ($args) = @_; 121 | $args ||= {}; 122 | 123 | my $engine = $self->engine; 124 | my $cache = $engine->cache; 125 | my $off = $self->offset; 126 | my $obj; 127 | if ( !defined $cache->{ $off } ) { 128 | $obj = DBM::Deep->new({ 129 | type => $self->type, 130 | base_offset => $self->offset, 131 | storage => $engine->storage, 132 | engine => $engine, 133 | }); 134 | 135 | $cache->{$off} = $obj; 136 | Scalar::Util::weaken($cache->{$off}); 137 | } 138 | else { 139 | $obj = $cache->{$off}; 140 | } 141 | 142 | # We're not exporting, so just return. 143 | unless ( $args->{export} ) { 144 | if ( $engine->storage->{autobless} ) { 145 | my $classname = $self->get_classname; 146 | if ( defined $classname ) { 147 | bless $obj, $classname; 148 | } 149 | } 150 | 151 | return $obj; 152 | } 153 | 154 | # We shouldn't export if this is still referred to. 155 | if ( $self->get_refcount > 1 ) { 156 | return $obj; 157 | } 158 | 159 | return $obj->export; 160 | } 161 | 162 | sub free { 163 | my $self = shift; 164 | 165 | # We're not ready to be removed yet. 166 | return if $self->decrement_refcount > 0; 167 | 168 | # Rebless the object into DBM::Deep::Null. 169 | # In external_refs mode, this will already have been removed from 170 | # the cache, so we can skip this. 171 | my $e = $self->engine; 172 | if(!$e->{external_refs}) { 173 | eval { %{ $e->cache->{ $self->offset } } = (); }; 174 | eval { @{ $e->cache->{ $self->offset } } = (); }; 175 | bless $e->cache->{ $self->offset }, 'DBM::Deep::Null'; 176 | delete $e->cache->{ $self->offset }; 177 | } 178 | 179 | $e->storage->delete_from( 180 | 'datas', { ref_id => $self->offset }, 181 | ); 182 | 183 | $e->storage->delete_from( 184 | 'datas', { value => $self->offset, data_type => 'R' }, 185 | ); 186 | 187 | $self->SUPER::free( @_ ); 188 | } 189 | 190 | sub increment_refcount { 191 | my $self = shift; 192 | my $refcount = $self->get_refcount; 193 | $refcount++; 194 | $self->write_refcount( $refcount ); 195 | return $refcount; 196 | } 197 | 198 | sub decrement_refcount { 199 | my $self = shift; 200 | my $refcount = $self->get_refcount; 201 | $refcount--; 202 | $self->write_refcount( $refcount ); 203 | return $refcount; 204 | } 205 | 206 | sub get_refcount { 207 | my $self = shift; 208 | my ($rows) = $self->engine->storage->read_from( 209 | 'refs', $self->offset, 210 | qw( refcount ), 211 | ); 212 | return $rows->[0]{refcount}; 213 | } 214 | 215 | sub write_refcount { 216 | my $self = shift; 217 | my ($num) = @_; 218 | $self->engine->storage->{dbh}->do( 219 | "UPDATE refs SET refcount = ? WHERE id = ?", undef, 220 | $num, $self->offset, 221 | ); 222 | } 223 | 224 | sub clear { 225 | my $self = shift; 226 | 227 | DBM::Deep->new({ 228 | type => $self->type, 229 | base_offset => $self->offset, 230 | storage => $self->engine->storage, 231 | engine => $self->engine, 232 | })->_clear; 233 | 234 | return; 235 | } 236 | 237 | 1; 238 | __END__ 239 | -------------------------------------------------------------------------------- /utils/upgrade_db.pl: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use 5.6.0; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use FindBin; 9 | use File::Spec (); 10 | use lib File::Spec->catdir( $FindBin::Bin, 'lib' ); 11 | 12 | # This is for the latest version. 13 | use lib File::Spec->catdir( $FindBin::Bin, '..', 'lib' ); 14 | 15 | use Getopt::Long qw( GetOptions ); 16 | use Pod::Usage 1.3; 17 | 18 | my %headerver_to_module = ( 19 | '0' => 'DBM::Deep::09830', 20 | '2' => 'DBM::Deep::10002', 21 | '3' => 'DBM::Deep', 22 | '4' => 'DBM::Deep', 23 | ); 24 | 25 | my %is_dev = ( 26 | '1' => 1, 27 | ); 28 | 29 | my %opts = ( 30 | man => 0, 31 | help => 0, 32 | version => '2', 33 | autobless => 1, 34 | ); 35 | GetOptions( \%opts, 36 | 'input=s', 'output=s', 'version:s', 'autobless:i', 37 | 'help|?', 'man', 38 | ) || pod2man(2); 39 | pod2usage(1) if $opts{help}; 40 | pod2usage(-exitstatus => 0, -verbose => 2) if $opts{man}; 41 | 42 | pod2usage(-msg => "Missing required parameters.", verbose => 1) 43 | unless $opts{input} && $opts{output}; 44 | 45 | if ( $opts{input} eq $opts{output} ) { 46 | _exit( "Cannot use the same filename for both input and output." ); 47 | } 48 | 49 | unless ( -f $opts{input} ) { 50 | _exit( "'$opts{input}' is not a file." ); 51 | } 52 | 53 | my %db; 54 | { 55 | my $ver = _read_file_header( $opts{input} ); 56 | if ( $is_dev{ $ver } ) { 57 | _exit( "'$opts{input}' is a dev release and not supported." ); 58 | } 59 | 60 | my $mod = $headerver_to_module{ $ver }; 61 | eval "use $mod;"; 62 | if ( $@ ) { 63 | _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" ); 64 | } 65 | $db{input} = $mod->new({ 66 | file => $opts{input}, 67 | locking => 1, 68 | autobless => $opts{autobless}, 69 | }); 70 | $db{input}->lock; 71 | } 72 | 73 | { 74 | my $ver = $opts{version}; 75 | if ( $ver =~ /^2(?:\.|\z)/ ) { 76 | $ver = 4; 77 | } 78 | elsif ( $ver =~ /^1\.001[0-4]/ ) { 79 | $ver = 3; 80 | } 81 | elsif ( $ver =~ /^1\.000[3-9]/ ) { 82 | $ver = 3; 83 | } 84 | elsif ( $ver eq '1.00' || $ver eq '1.000' || $ver =~ /^1\.000[0-2]/ ) { 85 | $ver = 2; 86 | } 87 | elsif ( $ver =~ /^0\.99/ ) { 88 | $ver = 1; 89 | } 90 | elsif ( $ver =~ /^0\.9[1-8]/ ) { 91 | $ver = 0; 92 | } 93 | else { 94 | _exit( "'$ver' is an unrecognized version." ); 95 | } 96 | 97 | if ( $is_dev{ $ver } ) { 98 | _exit( "-version '$opts{version}' is a dev release and not supported." ); 99 | } 100 | 101 | # First thing is to destroy the file, in case it's an incompatible version. 102 | unlink $opts{output}; 103 | 104 | my $mod = $headerver_to_module{ $ver }; 105 | eval "use $mod;"; 106 | if ( $@ ) { 107 | _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" ); 108 | } 109 | $db{output} = $mod->new({ 110 | file => $opts{output}, 111 | locking => 1, 112 | autobless => $opts{autobless}, 113 | }); 114 | $db{output}->lock; 115 | 116 | # Hack to write a version 3 file: 117 | if($ver == 3) { 118 | my $engine = $db{output}->_engine; 119 | $engine->{v} = 3; 120 | $engine->storage->print_at( 5, pack('N',3) ); 121 | } 122 | } 123 | 124 | # Do the actual conversion. This is the code that compress uses. 125 | $db{input}->_copy_node( $db{output} ); 126 | undef $db{output}; 127 | 128 | ################################################################################ 129 | 130 | sub _read_file_header { 131 | my ($file) = @_; 132 | 133 | open my $fh, '<', $file 134 | or _exit( "Cannot open '$file' for reading: $!" ); 135 | 136 | my $buffer = _read_buffer( $fh, 9 ); 137 | _exit( "'$file' is not a DBM::Deep file." ) 138 | unless length $buffer == 9; 139 | 140 | my ($file_sig, $header_sig, $header_ver) = unpack( 'A4 A N', $buffer ); 141 | 142 | # SIG_FILE == 'DPDB' 143 | _exit( "'$file' is not a DBM::Deep file." ) 144 | unless $file_sig eq 'DPDB'; 145 | 146 | # SIG_HEADER == 'h' - this means that this is a pre-1.0 file 147 | return 0 unless ($header_sig eq 'h'); 148 | 149 | return $header_ver; 150 | } 151 | 152 | sub _read_buffer { 153 | my ($fh, $len) = @_; 154 | my $buffer; 155 | read( $fh, $buffer, $len ); 156 | return $buffer; 157 | } 158 | 159 | sub _exit { 160 | my ($msg) = @_; 161 | pod2usage( -verbose => 0, -msg => $msg ); 162 | } 163 | 164 | __END__ 165 | 166 | =head1 NAME 167 | 168 | upgrade_db.pl 169 | 170 | =head1 SYNOPSIS 171 | 172 | upgrade_db.pl -input -output 173 | 174 | =head1 DESCRIPTION 175 | 176 | This will attempt to upgrade DB files from one version of DBM::Deep to 177 | another. The version of the input file is detected from the file header. The 178 | version of the output file defaults to the version of the distro in this file, 179 | but can be set, if desired. 180 | 181 | =head1 OPTIONS 182 | 183 | =over 4 184 | 185 | =item B<-input> (required) 186 | 187 | This is the name of original DB file. 188 | 189 | =item B<-output> (required) 190 | 191 | This is the name of target output DB file. 192 | 193 | =item B<-version> 194 | 195 | Optionally, you can specify the version of L for the output file. 196 | This can either be an upgrade or a downgrade. The minimum version supported is 197 | 0.91. 198 | 199 | If the version is the same as the input file, this acts like a compressed copy 200 | of the database. 201 | 202 | =item B<-autobless> 203 | 204 | In pre-1.0000 versions, autoblessing was an optional setting defaulting to 205 | false. Autobless in upgrade_db.pl defaults to true. 206 | 207 | =item B<-help> 208 | 209 | Prints a brief help message, then exits. 210 | 211 | =item B<-man> 212 | 213 | Prints a much longer message, then exits; 214 | 215 | =back 216 | 217 | =head1 CAVEATS 218 | 219 | The following are known issues with this converter. 220 | 221 | =over 4 222 | 223 | =item * Diskspace requirements 224 | 225 | This will require about twice the diskspace of the input file. 226 | 227 | =item * Feature support 228 | 229 | Not all versions support the same features. In particular, internal references 230 | were supported in 0.983, removed in 1.000, and re-added in 1.0003. There is no 231 | detection of this by upgrade_db.pl. 232 | 233 | =back 234 | 235 | =head1 MAINTAINER(S) 236 | 237 | Rob Kinyon, L 238 | 239 | Originally written by Rob Kinyon, L 240 | 241 | =head1 LICENSE 242 | 243 | Copyright (c) 2007 Rob Kinyon. All Rights Reserved. 244 | This is free software, you may use it and distribute it under the 245 | same terms as Perl itself. 246 | 247 | =cut 248 | -------------------------------------------------------------------------------- /t/44_upgrade_db.t: -------------------------------------------------------------------------------- 1 | $|++; 2 | use strict; 3 | use Test::More; 4 | 5 | plan skip_all => "upgrade_db.pl doesn't actually do anything correct."; 6 | 7 | # Add skips here 8 | BEGIN { 9 | plan skip_all => "Skipping the upgrade_db.pl tests on Win32/cygwin for now." 10 | if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ); 11 | 12 | plan skip_all => "Skipping the upgrade_db.pl tests on *bsd for now." 13 | if ( $^O =~ /bsd/i ); 14 | 15 | my @failures; 16 | eval "use Pod::Usage 1.3;"; push @failures, 'Pod::Usage' if $@; 17 | eval "use FileHandle::Fmode;"; push @failures, 'FileHandle::Fmode' if $@; 18 | if ( @failures ) { 19 | my $missing = join ',', @failures; 20 | plan skip_all => "'$missing' must be installed to run these tests"; 21 | } 22 | } 23 | 24 | plan tests => 351; 25 | 26 | use t::common qw( new_fh ); 27 | use File::Spec; 28 | use Test::Deep; 29 | 30 | my $PROG = File::Spec->catfile( qw( utils upgrade_db.pl ) ); 31 | 32 | my $short = get_pod( $PROG, 0 ); 33 | my $long = get_pod( $PROG, 1 ); 34 | 35 | is( run_prog( $PROG ), "Missing required parameters.\n$long", "Failed no params" ); 36 | is( run_prog( $PROG, '-input foo' ), "Missing required parameters.\n$long", "Failed only -input" ); 37 | is( run_prog( $PROG, '-output foo' ), "Missing required parameters.\n$long", "Failed only -output" ); 38 | is( 39 | run_prog( $PROG, '-input foo', '-output foo' ), 40 | "Cannot use the same filename for both input and output.\n$short", 41 | "Failed same name", 42 | ); 43 | 44 | is( 45 | run_prog( $PROG, '-input foo', '-output bar' ), 46 | "'foo' is not a file.\n$short", 47 | "Failed input does not exist", 48 | ); 49 | 50 | my (undef, $input_filename) = new_fh(); 51 | my (undef, $output_filename) = new_fh(); 52 | 53 | is( 54 | run_prog( $PROG, "-input $input_filename", "-output $output_filename" ), 55 | "'$input_filename' is not a DBM::Deep file.\n$short", 56 | "Input is not a DBM::Deep file", 57 | ); 58 | 59 | unlink $input_filename;unlink $output_filename; 60 | 61 | # All files are of the form: 62 | # $db->{foo} = [ 1 .. 3 ]; 63 | 64 | my @input_files = ( 65 | '0-983', 66 | '0-99_04', 67 | '1-0000', 68 | '1-0003', 69 | ); 70 | 71 | my @output_versions = ( 72 | '0.91', '0.92', '0.93', '0.94', '0.95', '0.96', '0.97', '0.98', 73 | '0.981', '0.982', '0.983', 74 | '0.99_01', '0.99_02', '0.99_03', '0.99_04', 75 | '1.00', '1.000', '1.0000', '1.0001', '1.0002', 76 | '1.0003', '1.0004', '1.0005', '1.0006', '1.0007', '1.0008', '1.0009', '1.0010', 77 | '1.0011', '1.0012', '1.0013', '1.0014', '2.0000' 78 | ); 79 | 80 | foreach my $input_filename ( 81 | map { 82 | File::Spec->catfile( qw( t etc ), "db-$_" ) 83 | } @input_files 84 | ) { 85 | # chmod it writable because old DBM::Deep versions don't handle readonly 86 | # files correctly. This is fixed in DBM::Deep 1.0000 87 | chmod 0600, $input_filename; 88 | 89 | foreach my $v ( @output_versions ) { 90 | my (undef, $output_filename) = new_fh(); 91 | 92 | my $output = run_prog( 93 | $PROG, 94 | "-input $input_filename", 95 | "-output $output_filename", 96 | "-version $v", 97 | ); 98 | 99 | #warn "Testing $input_filename against $v\n"; 100 | 101 | # Clone was removed as a requirement in 1.0006 102 | if ( $output =~ /Can\'t locate Clone\.pm in \@INC/ ) { 103 | ok( 1 ); 104 | unless ( $input_filename =~ /_/ || $v =~ /_/ ) { 105 | ok( 1 ); ok( 1 ); 106 | } 107 | next; 108 | } 109 | 110 | if ( $input_filename =~ /_/ ) { 111 | is( 112 | $output, "'$input_filename' is a dev release and not supported.\n$short", 113 | "Input file is a dev release - not supported", 114 | ); 115 | 116 | next; 117 | } 118 | 119 | if ( $v =~ /_/ ) { 120 | is( 121 | $output, "-version '$v' is a dev release and not supported.\n$short", 122 | "Output version is a dev release - not supported", 123 | ); 124 | 125 | next; 126 | } 127 | 128 | # Now, read the output file with the right version. 129 | ok( !$output, "A successful run produces no output" ); 130 | die "'$input_filename' -> '$v' : $output\n" if $output; 131 | 132 | my $db; 133 | my $db_version; 134 | if ( $v =~ /^2(?:\.|\z)/ ) { 135 | push @INC, 'lib'; 136 | eval "use DBM::Deep 1.9999"; die $@ if $@; 137 | $db = DBM::Deep->new( $output_filename ); 138 | $db_version = 2; 139 | } 140 | elsif( $v =~ /^1\.001[0-4]/ || $v =~ /^1\.000[3-9]/ ) { 141 | push @INC, 'lib'; 142 | eval "use DBM::Deep $v"; die $@ if $@; 143 | $db = DBM::Deep->new( $output_filename ); 144 | $db_version = '1.0003'; 145 | } 146 | elsif ( $v =~ /^1\.000?[0-2]?/ ) { 147 | push @INC, File::Spec->catdir( 'utils', 'lib' ); 148 | eval "use DBM::Deep::10002"; 149 | $db = DBM::Deep::10002->new( $output_filename ); 150 | } 151 | elsif ( $v =~ /^0/ ) { 152 | push @INC, File::Spec->catdir( 'utils', 'lib' ); 153 | eval "use DBM::Deep::09830"; 154 | $db = DBM::Deep::09830->new( $output_filename ); 155 | } 156 | else { 157 | die "How did we get here?!\n"; 158 | } 159 | 160 | ok( $db, "Writing to version $v made a file" ); 161 | 162 | cmp_deeply( 163 | $db->export, 164 | { foo => [ 1 .. 3 ] }, 165 | "We can read the output file", 166 | ); 167 | 168 | if($db_version) { 169 | is $db->db_version, $db_version, "db_version is $db_version"; 170 | } 171 | } 172 | } 173 | 174 | ################################################################################ 175 | 176 | #XXX This needs to be made OS-portable 177 | sub run_prog { 178 | open( my $fh, '-|', "$^X @_ 2>&1" ) 179 | or die "Cannot launch '@_' as a piped filehandle: $!\n"; 180 | return join '', <$fh>; 181 | } 182 | 183 | # In 5.8, we could use in-memory filehandles and have done: 184 | # open( my $fh, '>', \my $pod ) or die "Cannot open in-memory filehandle: $!\n"; 185 | # ... 186 | # return $pod; 187 | # However, DBM::Deep requires 5.6, so this set of contortions will have to do. 188 | sub get_pod { 189 | my ($p,$v) = @_; 190 | 191 | my ($fh, $fn) = new_fh(); 192 | close $fh; 193 | 194 | open $fh, '>', $fn; 195 | pod2usage({ 196 | -input => $p, 197 | -output => $fh, 198 | -verbose => $v, 199 | -exitval => 'NOEXIT', 200 | }); 201 | close $fh; 202 | 203 | open $fh, '<', $fn; 204 | return join '', <$fh>; 205 | } 206 | -------------------------------------------------------------------------------- /t/02_hash.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | use t::common qw( new_dbm ); 7 | use Scalar::Util qw( reftype ); 8 | 9 | use_ok( 'DBM::Deep' ); 10 | 11 | my $dbm_factory = new_dbm(); 12 | while ( my $dbm_maker = $dbm_factory->() ) { 13 | my $db = $dbm_maker->(); 14 | 15 | ## 16 | # put/get key 17 | ## 18 | $db->{key1} = "value1"; 19 | is( $db->get("key1"), "value1", "get() works with hash assignment" ); 20 | is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" ); 21 | is( $db->{key1}, "value1", "... and hash-access also works" ); 22 | 23 | $db->put("key2", undef); 24 | is( $db->get("key2"), undef, "get() works with put()" ); 25 | is( $db->fetch("key2"), undef, "... fetch() works with put()" ); 26 | is( $db->{key2}, undef, "... and hash-access also works" ); 27 | 28 | $db->store( "0", "value3" ); 29 | is( $db->get("0"), "value3", "get() works with store()" ); 30 | is( $db->fetch("0"), "value3", "... fetch() works with put()" ); 31 | is( $db->{0}, 'value3', "... and hash-access also works" ); 32 | 33 | # Verify that the keyval pairs are still correct. 34 | is( $db->{key1}, "value1", "Key1 is still correct" ); 35 | is( $db->{key2}, undef, "Key2 is still correct" ); 36 | is( $db->{0}, 'value3', "Key3 is still correct" ); 37 | 38 | ok( $db->exists("key1"), "exists() function works" ); 39 | ok( exists $db->{key2}, "exists() works against tied hash" ); 40 | 41 | ok( !exists $db->{key4}, "exists() function works for keys that aren't there" ); 42 | is( $db->{key4}, undef, "Nonexistent key4 is undef" ); 43 | ok( !exists $db->{key4}, "Simply reading key4 does not autovivify" ); 44 | 45 | # Keys will be done via an iterator that keeps a breadcrumb trail of the last 46 | # key it provided. There will also be an "edit revision number" on the 47 | # reference so that resetting the iterator can be done. 48 | # 49 | # Q: How do we make sure that the iterator is unique? Is it supposed to be? 50 | 51 | ## 52 | # count keys 53 | ## 54 | is( scalar keys %$db, 3, "keys() works against tied hash" ); 55 | 56 | ## 57 | # step through keys 58 | ## 59 | my $temphash = {}; 60 | while ( my ($key, $value) = each %$db ) { 61 | $temphash->{$key} = $value; 62 | } 63 | 64 | is( $temphash->{key1}, 'value1', "First key copied successfully using tied interface" ); 65 | is( $temphash->{key2}, undef, "Second key copied successfully" ); 66 | is( $temphash->{0}, 'value3', "Third key copied successfully" ); 67 | 68 | $temphash = {}; 69 | my $key = $db->first_key(); 70 | while (defined $key) { 71 | $temphash->{$key} = $db->get($key); 72 | $key = $db->next_key($key); 73 | } 74 | 75 | is( $temphash->{key1}, 'value1', "First key copied successfully using OO interface" ); 76 | is( $temphash->{key2}, undef, "Second key copied successfully" ); 77 | is( $temphash->{0}, 'value3', "Third key copied successfully" ); 78 | 79 | ## 80 | # delete keys 81 | ## 82 | is( delete $db->{key2}, undef, "delete through tied inteface works" ); 83 | is( $db->delete("key1"), 'value1', "delete through OO inteface works" ); 84 | is( $db->{0}, 'value3', "The other key is still there" ); 85 | ok( !exists $db->{key1}, "key1 doesn't exist" ); 86 | ok( !exists $db->{key2}, "key2 doesn't exist" ); 87 | 88 | is( scalar keys %$db, 1, "After deleting two keys, 1 remains" ); 89 | 90 | ## 91 | # delete all keys 92 | ## 93 | ok( $db->clear(), "clear() returns true" ); 94 | 95 | is( scalar keys %$db, 0, "After clear(), everything is removed" ); 96 | 97 | ## 98 | # replace key 99 | ## 100 | $db->put("key1", "value1"); 101 | is( $db->get("key1"), "value1", "Assignment still works" ); 102 | 103 | $db->put("key1", "value2"); 104 | is( $db->get("key1"), "value2", "... and replacement works" ); 105 | 106 | $db->put("key1", "value222222222222222222222222"); 107 | is( $db->get("key1"), "value222222222222222222222222", "We set a value before closing the file" ); 108 | 109 | ## 110 | # Make sure DB still works after closing / opening 111 | ## 112 | undef $db; 113 | $db = $dbm_maker->(); 114 | is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" ); 115 | 116 | ## 117 | # Make sure keys are still fetchable after replacing values 118 | # with smaller ones (bug found by John Cardenas, DBM::Deep 0.93) 119 | ## 120 | $db->clear(); 121 | $db->put("key1", "long value here"); 122 | $db->put("key2", "longer value here"); 123 | 124 | $db->put("key1", "short value"); 125 | $db->put("key2", "shorter v"); 126 | 127 | my $first_key = $db->first_key(); 128 | my $next_key = $db->next_key($first_key); 129 | 130 | ok( 131 | (($first_key eq "key1") || ($first_key eq "key2")) && 132 | (($next_key eq "key1") || ($next_key eq "key2")) && 133 | ($first_key ne $next_key) 134 | ,"keys() still works if you replace long values with shorter ones" 135 | ); 136 | 137 | # Test autovivification 138 | $db->{unknown}{bar} = 1; 139 | ok( $db->{unknown}, 'Autovivified hash exists' ); 140 | is( reftype($db->{unknown}), 'HASH', "... and it's a HASH" ); 141 | cmp_ok( $db->{unknown}{bar}, '==', 1, 'And the value stored is there' ); 142 | 143 | # Test failures 144 | throws_ok { 145 | $db->fetch(); 146 | } qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key"; 147 | 148 | throws_ok { 149 | $db->fetch(undef); 150 | } qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key"; 151 | 152 | throws_ok { 153 | $db->store(); 154 | } qr/Cannot use an undefined hash key/, "STORE fails on an undefined key"; 155 | 156 | throws_ok { 157 | $db->store(undef, undef); 158 | } qr/Cannot use an undefined hash key/, "STORE fails on an undefined key"; 159 | 160 | throws_ok { 161 | $db->delete(); 162 | } qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key"; 163 | 164 | throws_ok { 165 | $db->delete(undef); 166 | } qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key"; 167 | 168 | throws_ok { 169 | $db->exists(); 170 | } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key"; 171 | 172 | throws_ok { 173 | $db->exists(undef); 174 | } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key"; 175 | } 176 | 177 | { 178 | # RT# 50541 (reported by Peter Scott) 179 | # clear() leaves one key unless there's only one 180 | my $dbm_factory = new_dbm(); 181 | while ( my $dbm_maker = $dbm_factory->() ) { 182 | my $db = $dbm_maker->(); 183 | 184 | $db->{block} = { }; 185 | $db->{critical} = { }; 186 | $db->{minor} = { }; 187 | 188 | cmp_ok( scalar(keys( %$db )), '==', 3, "Have 3 keys" ); 189 | 190 | $db->clear; 191 | 192 | cmp_ok( scalar(keys( %$db )), '==', 0, "clear clears everything" ); 193 | } 194 | } 195 | 196 | done_testing; 197 | -------------------------------------------------------------------------------- /lib/DBM/Deep/Cookbook.pod: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | DBM::Deep::Cookbook - Cookbook for DBM::Deep 4 | 5 | =head1 DESCRIPTION 6 | 7 | This is the Cookbook for L. It contains useful tips and tricks, 8 | plus some examples of how to do common tasks. 9 | 10 | =head1 RECIPES 11 | 12 | =head2 Unicode data 13 | 14 | If possible, it is highly recommended that you upgrade your database to 15 | version 2 (using the F script in the CPAN 16 | distribution), in order to use Unicode. 17 | 18 | If your databases are still shared by perl installations with older 19 | DBM::Deep versions, you can use filters to encode strings on the fly: 20 | 21 | my $db = DBM::Deep->new( ... ); 22 | my $encode_sub = sub { my $s = shift; utf8::encode($s); $s }; 23 | my $decode_sub = sub { my $s = shift; utf8::decode($s); $s }; 24 | $db->set_filter( 'store_value' => $encode_sub ); 25 | $db->set_filter( 'fetch_value' => $decode_sub ); 26 | $db->set_filter( 'store_key' => $encode_sub ); 27 | $db->set_filter( 'fetch_key' => $decode_sub ); 28 | 29 | A previous version of this cookbook recommended using 30 | C_fh, ":utf8">, but that is I a good idea, as it 31 | could easily corrupt the database. 32 | 33 | =head2 Real-time Encryption Example 34 | 35 | B: This is just an example of how to write a filter. This most 36 | definitely should B be taken as a proper way to write a filter that does 37 | encryption. (Furthermore, it fails to take Unicode into account.) 38 | 39 | Here is a working example that uses the I module to 40 | do real-time encryption / decryption of keys & values with DBM::Deep Filters. 41 | Please visit L for more 42 | on I. You'll also need the I module. 43 | 44 | use DBM::Deep; 45 | use Crypt::Blowfish; 46 | use Crypt::CBC; 47 | 48 | my $cipher = Crypt::CBC->new({ 49 | 'key' => 'my secret key', 50 | 'cipher' => 'Blowfish', 51 | 'iv' => '$KJh#(}q', 52 | 'regenerate_key' => 0, 53 | 'padding' => 'space', 54 | 'prepend_iv' => 0 55 | }); 56 | 57 | my $db = DBM::Deep->new( 58 | file => "foo-encrypt.db", 59 | filter_store_key => \&my_encrypt, 60 | filter_store_value => \&my_encrypt, 61 | filter_fetch_key => \&my_decrypt, 62 | filter_fetch_value => \&my_decrypt, 63 | ); 64 | 65 | $db->{key1} = "value1"; 66 | $db->{key2} = "value2"; 67 | print "key1: " . $db->{key1} . "\n"; 68 | print "key2: " . $db->{key2} . "\n"; 69 | 70 | undef $db; 71 | exit; 72 | 73 | sub my_encrypt { 74 | return $cipher->encrypt( $_[0] ); 75 | } 76 | sub my_decrypt { 77 | return $cipher->decrypt( $_[0] ); 78 | } 79 | 80 | =head2 Real-time Compression Example 81 | 82 | Here is a working example that uses the I module to do real-time 83 | compression / decompression of keys & values with DBM::Deep Filters. 84 | Please visit L for 85 | more on I. 86 | 87 | use DBM::Deep; 88 | use Compress::Zlib; 89 | 90 | my $db = DBM::Deep->new( 91 | file => "foo-compress.db", 92 | filter_store_key => \&my_compress, 93 | filter_store_value => \&my_compress, 94 | filter_fetch_key => \&my_decompress, 95 | filter_fetch_value => \&my_decompress, 96 | ); 97 | 98 | $db->{key1} = "value1"; 99 | $db->{key2} = "value2"; 100 | print "key1: " . $db->{key1} . "\n"; 101 | print "key2: " . $db->{key2} . "\n"; 102 | 103 | undef $db; 104 | exit; 105 | 106 | sub my_compress { 107 | my $s = shift; 108 | utf8::encode($s); 109 | return Compress::Zlib::memGzip( $s ) ; 110 | } 111 | sub my_decompress { 112 | my $s = Compress::Zlib::memGunzip( shift ) ; 113 | utf8::decode($s); 114 | return $s; 115 | } 116 | 117 | B Filtering of keys only applies to hashes. Array "keys" are 118 | actually numerical index numbers, and are not filtered. 119 | 120 | =head1 Custom Digest Algorithm 121 | 122 | DBM::Deep by default uses the I (MD5) algorithm for hashing 123 | keys. However you can override this, and use another algorithm (such as SHA-256) 124 | or even write your own. But please note that DBM::Deep currently expects zero 125 | collisions, so your algorithm has to be I, so to speak. Collision 126 | detection may be introduced in a later version. 127 | 128 | You can specify a custom digest algorithm by passing it into the parameter 129 | list for new(), passing a reference to a subroutine as the 'digest' parameter, 130 | and the length of the algorithm's hashes (in bytes) as the 'hash_size' 131 | parameter. Here is a working example that uses a 256-bit hash from the 132 | I module. Please see 133 | L for more information. 134 | 135 | The value passed to your digest function will be encoded as UTF-8 if the 136 | database is in version 2 format or higher. 137 | 138 | use DBM::Deep; 139 | use Digest::SHA256; 140 | 141 | my $context = Digest::SHA256::new(256); 142 | 143 | my $db = DBM::Deep->new( 144 | filename => "foo-sha.db", 145 | digest => \&my_digest, 146 | hash_size => 32, 147 | ); 148 | 149 | $db->{key1} = "value1"; 150 | $db->{key2} = "value2"; 151 | print "key1: " . $db->{key1} . "\n"; 152 | print "key2: " . $db->{key2} . "\n"; 153 | 154 | undef $db; 155 | exit; 156 | 157 | sub my_digest { 158 | return substr( $context->hash($_[0]), 0, 32 ); 159 | } 160 | 161 | B Your returned digest strings must be B the number 162 | of bytes you specify in the hash_size parameter (in this case 32). Undefined 163 | behavior will occur otherwise. 164 | 165 | B If you do choose to use a custom digest algorithm, you must set it 166 | every time you access this file. Otherwise, the default (MD5) will be used. 167 | 168 | =head1 PERFORMANCE 169 | 170 | Because DBM::Deep is a conncurrent datastore, every change is flushed to disk 171 | immediately and every read goes to disk. This means that DBM::Deep functions 172 | at the speed of disk (generally 10-20ms) vs. the speed of RAM (generally 173 | 50-70ns), or at least 150-200x slower than the comparable in-memory 174 | datastructure in Perl. 175 | 176 | There are several techniques you can use to speed up how DBM::Deep functions. 177 | 178 | =over 4 179 | 180 | =item * Put it on a ramdisk 181 | 182 | The easiest and quickest mechanism to making DBM::Deep run faster is to create 183 | a ramdisk and locate the DBM::Deep file there. Doing this as an option may 184 | become a feature of DBM::Deep, assuming there is a good ramdisk wrapper on CPAN. 185 | 186 | =item * Work at the tightest level possible 187 | 188 | It is much faster to assign the level of your db that you are working with to 189 | an intermediate variable than to re-look it up every time. Thus 190 | 191 | # BAD 192 | while ( my ($k, $v) = each %{$db->{foo}{bar}{baz}} ) { 193 | ... 194 | } 195 | 196 | # GOOD 197 | my $x = $db->{foo}{bar}{baz}; 198 | while ( my ($k, $v) = each %$x ) { 199 | ... 200 | } 201 | 202 | =item * Make your file as tight as possible 203 | 204 | If you know that you are not going to use more than 65K in your database, 205 | consider using the C 'small'> option. This will instruct 206 | DBM::Deep to use 16bit addresses, meaning that the seek times will be less. 207 | 208 | =back 209 | 210 | =head1 SEE ALSO 211 | 212 | L, L, L, 213 | L, L 214 | 215 | =cut 216 | -------------------------------------------------------------------------------- /t/39_singletons.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use t::common qw( new_dbm new_fh ); 7 | 8 | sub is_undef { 9 | ok(!defined $_[0] || ref $_[0] eq 'DBM::Deep::Null', $_[1]) 10 | } 11 | 12 | use_ok( 'DBM::Deep' ); 13 | 14 | my $dbm_factory = new_dbm( 15 | locking => 1, 16 | autoflush => 1, 17 | ); 18 | while ( my $dbm_maker = $dbm_factory->() ) { 19 | my $db = $dbm_maker->(); 20 | 21 | SKIP: { 22 | skip "This engine doesn't support singletons", 8 23 | unless $db->supports( 'singletons' ); 24 | 25 | $db->{a} = 1; 26 | $db->{foo} = { a => 'b' }; 27 | my $x = $db->{foo}; 28 | my $y = $db->{foo}; 29 | 30 | is( $x, $y, "The references are the same" ); 31 | 32 | delete $db->{foo}; 33 | is_undef( $x, "After deleting the DB location, external references are also undef (\$x)" ); 34 | is_undef( $y, "After deleting the DB location, external references are also undef (\$y)" ); 35 | is( eval { $x + 0 }, undef, "DBM::Deep::Null can be added to." ); 36 | is( eval { $y + 0 }, undef, "DBM::Deep::Null can be added to." ); 37 | is_undef( $db->{foo}, "The {foo} location is also undef." ); 38 | 39 | # These shenanigans work to get another hashref 40 | # into the same data location as $db->{foo} was. 41 | $db->{foo} = {}; 42 | delete $db->{foo}; 43 | $db->{foo} = {}; 44 | $db->{bar} = {}; 45 | 46 | is_undef( $x, "After re-assigning to {foo}, external references to old values are still undef (\$x)" ); 47 | is_undef( $y, "After re-assigning to {foo}, external references to old values are still undef (\$y)" ); 48 | 49 | my($w,$line); 50 | my $file = __FILE__; 51 | local $SIG{__WARN__} = sub { $w = $_[0] }; 52 | eval { 53 | $line = __LINE__; $db->{stext} = $x; 54 | }; 55 | is $@, "Assignment of stale reference at $file line $line.\n", 56 | 'assigning a stale reference to the DB dies w/FATAL warnings'; 57 | { 58 | no warnings FATAL => "all"; 59 | use warnings 'uninitialized'; # non-FATAL 60 | $db->{stext} = $x; $line = __LINE__; 61 | is $w, "Assignment of stale reference at $file line $line.\n", 62 | 'assigning a stale reference back to the DB warns'; 63 | } 64 | { 65 | no warnings 'uninitialized'; 66 | $w = undef; 67 | $db->{stext} = $x; 68 | is $w, undef, 69 | 'stale ref assignment warnings can be suppressed'; 70 | } 71 | 72 | eval { $line = __LINE__+1; 73 | () = $x->{stit}; 74 | }; 75 | like $@, 76 | qr/^Can't use a stale reference as a HASH at \Q$file\E line(?x: 77 | ) $line\.?\n\z/, 78 | 'Using a stale reference as a hash dies'; 79 | eval { $line = __LINE__+1; 80 | () = $x->[28]; 81 | }; 82 | like $@, 83 | qr/^Can't use a stale reference as an ARRAY at \Q$file\E line(?x: 84 | ) $line\.?\n\z/, 85 | 'Using a stale reference as an array dies'; 86 | } 87 | } 88 | 89 | { 90 | my $null = bless {}, 'DBM::Deep::Null'; 91 | cmp_ok $null, 'eq', undef, 'DBM::Deep::Null compares equal to undef'; 92 | cmp_ok $null, '==', undef, 'DBM::Deep::Null compares ==ual to undef'; 93 | } 94 | 95 | SKIP: { 96 | skip "What do we do with external references and txns?", 2; 97 | 98 | my $dbm_factory = new_dbm( 99 | locking => 1, 100 | autoflush => 1, 101 | num_txns => 2, 102 | ); 103 | while ( my $dbm_maker = $dbm_factory->() ) { 104 | my $db = $dbm_maker->(); 105 | 106 | $db->{foo} = { a => 'b' }; 107 | my $x = $db->{foo}; 108 | 109 | $db->begin_work; 110 | 111 | $db->{foo} = { c => 'd' }; 112 | my $y = $db->{foo}; 113 | 114 | # XXX What should happen here with $x and $y? 115 | is( $x, $y ); 116 | is( $x->{c}, 'd' ); 117 | 118 | $db->rollback; 119 | } 120 | } 121 | 122 | $dbm_factory = new_dbm( 123 | locking => 1, 124 | autoflush => 1, 125 | external_refs => 1, 126 | ); 127 | while ( my $dbm_maker = $dbm_factory->() ) { 128 | my $db = $dbm_maker->(); 129 | 130 | SKIP: { 131 | # Should this feature rely on singleton support? (This question is cur- 132 | # ently irrelevant, as all back ends support it.) 133 | # skip "This engine doesn't support singletons", 8 134 | # unless $db->supports( 'singletons' ); 135 | 136 | $db->{a} = 1; 137 | $db->{foo} = { a => 'b' }; 138 | my $x = $db->{foo}; 139 | my $y = $db->{foo}; 140 | my $x_str = "$x"; 141 | 142 | is( $x, $y, "The references are the same in e_r mode" ); 143 | 144 | delete $db->{foo}; 145 | is( 146 | $x, $x_str, 147 | 'After deletion, external refs still stringify the same way ($x)' 148 | ); 149 | is( 150 | $y, $x_str, 151 | 'After deletion, external refs still stringify the same way ($y)' 152 | ); 153 | is $x->{a}, 'b', 'external refs still point to live data'; 154 | undef $x; 155 | is $y->{a}, 'b', 156 | 'ext refs are still live after other ext refs have gone'; 157 | is( $db->{foo}, undef, "The ref in the DB was actually deleted." ); 158 | 159 | # These shenanigans work to get another hashref 160 | # into the same data location as $db->{foo} was. 161 | # Or they would if external_refs mode were off. 162 | $db->{foo} = {}; 163 | delete $db->{foo}; 164 | $db->{foo} = {}; 165 | $db->{bar} = {}; 166 | 167 | is( $y->{a}, 'b', 168 | "After re-assigning to the DB loc, external refs styll live" ); 169 | 170 | $db->{stext} = $y; 171 | undef $y; 172 | is $db->{stext}{a}, 'b', 173 | 'assigning a zombie hash to the DB wholly revives it'; 174 | 175 | 176 | # Now we must redo all those tests with arrays 177 | $db->{foo} = [ 'swew','squor' ]; 178 | $x = $db->{foo}; 179 | $y = $db->{foo}; 180 | $x_str = "$x"; 181 | 182 | is( $x, $y, "The references are the same in e_r mode (arrays)" ); 183 | 184 | delete $db->{foo}; 185 | is( 186 | $x, $x_str, 187 | 'After deletion, ext ary refs still stringify the same way ($x)' 188 | ); 189 | is( 190 | $y, $x_str, 191 | 'After deletion, ext ary refs still stringify the same way ($y)' 192 | ); 193 | is $x->[0], 'swew', 'external ary refs still point to live data'; 194 | undef $x; 195 | is $y->[0], 'swew', 196 | 'ext ary refs are still live after other ext refs have gone'; 197 | is( 198 | $db->{foo}, undef, 199 | "The ary ref in the DB was actually deleted." 200 | ); 201 | 202 | # These shenanigans work to get another ref 203 | # into the same data location as $db->{foo} was. 204 | # Or they would if external_refs mode were off. 205 | $db->{foo} = []; 206 | delete $db->{foo}; 207 | $db->{foo} = []; 208 | $db->{bar} = []; 209 | 210 | is( $y->[1], 'squor', 211 | "After re-assigning to the DB loc, ext ary refs styll live" ); 212 | 213 | $db->{stext} = $y; 214 | undef $y; 215 | is $db->{stext}[1], 'squor', 216 | 'assigning a zombie array to the DB wholly revives it'; 217 | 218 | } 219 | } 220 | 221 | # Make sure that global destruction triggers the freeing of externally ref- 222 | # erenced aggregates. 223 | { 224 | my ($fh, $filename) = new_fh(); 225 | (my $esc_filename = $filename) =~ s/([\\'])/\\$1/g; 226 | system $^X, '-Mblib', 227 | # We must use package variables here, to avoid freeing them before 228 | # global destruction. 229 | '-e use DBM::Deep;', 230 | "-e tie %db, 'DBM::Deep', file => '$esc_filename', external_refs => 1;", 231 | '-e $db{foo} = ["hello"];', 232 | '-e $db{bar} = {"olleh"=>1};', 233 | '-e $a = $db{foo};', 234 | '-e $b = $db{bar};', 235 | '-e delete $db{foo};', 236 | '-e delete $db{bar};', 237 | ; 238 | # And in case a future version does not write over freed sectors: 239 | system $^X, '-Mblib', 240 | '-e use DBM::Deep;', 241 | "-e tie %db, 'DBM::Deep', file => '$esc_filename', external_refs => 1;", 242 | '-e $db{foo} = ["goodybpe", 1,2,3,5,56];', 243 | ; 244 | local $/; 245 | my $db = <$fh>; 246 | unlike $db, qr/hello/, 247 | 'global destruction frees externally referenced arrays'; 248 | unlike $db, qr/olleh/, 249 | 'global destruction frees externally referenced hashes'; 250 | } 251 | 252 | done_testing; 253 | --------------------------------------------------------------------------------