-use Module::Build 0.28; # prepare_metadata
+use Module::Build 0.28; # for prepare_metadata
use strict;
+use warnings FATAL => 'all';
my $build = Module::Build->subclass(
- class => 'Any::Thing',
+ class => "Module::Build::Custom",
code => '
sub prepare_metadata {
my $node = shift->SUPER::prepare_metadata(@_);
$_->{version} = $ver for values %{$node->{provides}};
$node;
}
- ',
+
+ sub ACTION_test {
+ my $self = shift;
+ if ( $self->notes(\'TEST_MYSQL_DSN\') ) {
+ $ENV{$_} = $self->notes($_) for qw(
+ TEST_MYSQL_DSN TEST_MYSQL_USER TEST_MYSQL_PASS
+ );
+ }
+ foreach my $name ( qw( LONG_TESTS TEST_SQLITE ) ) {
+ $ENV{$name} = 1 if $self->notes( $name );
+ }
+
+ $self->SUPER::ACTION_test( @_ );
+ }
+ ',
)->new(
module_name => 'DBM::Deep',
license => 'perl',
'File::Path' => '0.01',
'File::Temp' => '0.01',
'Pod::Usage' => '1.3',
+ 'Test::More' => '0.88',
'Test::Deep' => '0.095',
'Test::Warn' => '0.08',
'Test::More' => '0.88', # done_testing
'META.yml', '*.bak', '*.gz', 'Makefile.PL', 'cover_db',
],
test_files => 't/??_*.t',
+ auto_features => {
+ sqlite_engine => {
+ description => 'DBI support via SQLite',
+ requires => {
+ 'DBI' => '1.5',
+ 'DBD::SQLite' => '1.25',
+ },
+ },
+ mysql_engine => {
+ description => 'DBI support via MySQL',
+ requires => {
+ 'DBI' => '1.5',
+ 'DBD::mysql' => '4.001',
+ },
+ },
+ },
);
+if ( $build->y_n( "Run the long-running tests", 'n' ) ) {
+ $build->notes( 'LONG_TESTS' => 1 );
+}
+
+if ( $build->features( 'sqlite_engine' ) ) {
+ if ( $build->y_n( "Run the tests against the DBI engine via SQLite?", 'n' ) ) {
+ $build->notes( 'TEST_SQLITE' => 1 );
+ }
+}
+
+if ( $build->features( 'mysql_engine' ) ) {
+ if ( $build->y_n( "Run the tests against the DBI engine via MySQL?", 'n' ) ) {
+ my ($dsn, $user, $pass) = ('') x 3;
+ $dsn = $build->prompt( "\tWhat is the full DSN (for example 'dbi:mysql:test')" );
+ if ( $dsn ) {
+ $user = $build->prompt( "\tWhat is the username?" );
+ if ( $user ) {
+ $pass = $build->prompt( "\tWhat is the password?" );
+ }
+ }
+
+ $build->notes( 'TEST_MYSQL_DSN' => $dsn );
+ $build->notes( 'TEST_MYSQL_USER' => $user );
+ $build->notes( 'TEST_MYSQL_PASS' => $pass );
+ }
+}
+
$build->create_build_script;
-Revision history for DBM::Deep.
+Revision history for DBM::Deep (ordered by revision number).
+
+1.0020 Feb 16 22:00:00 2010 EST
+ (This version is compatible with 1.0016)
+ - Fixed t/43_transaction_maximum.t so that it doesn't error out on systems
+ which cannot fork > 255 children at one time.
+ - Improved code coverage
+ - Added t/96_virtual_functions.t which helps describe what actually
+ needs to be overridden in a new plugin.
+
+
+1.0019_003 Feb 16 22:00:00 2010 EST
+ (This is the third developer release for 1.0020.)
+ (This version is compatible with 1.0016)
+ - Fixed problem where "./Build test" wouldn't actually -do- anything.
+ - (No-one apparently tried to install this till Steven Lembark. Thanks!)
+ - Fixed speed regression with keys in the File backend.
+ - Introduced in 1.0019_002 to fix #50541
+ - Thanks, SPROUT!
+ - (RT #53575) Recursion failure in STORE (Thanks, SPROUT)
+ - Merged the rest of the fixes from 1.0015 and 1.0016
+ - Thanks to our new co-maintainer, SPROUT! :)
+ - Had to turn off singleton support in the File backend because the caching
+ was causing havoc with transactions. Turning on fatal warnings does give
+ apparently important information.
+ - Oh - forgot to mention that fatal warnings are now on in all files.
+
+1.0019_002 Jan 05 22:30:00 2010 EST
+ (This is the second developer release for 1.0020.)
+ (This version is compatible with 1.0014)
+ - Fixed bug where attempting to store a value tied to something other than
+ DBM::Deep would leave the file flocked.
+ - Added support for DBD::SQLite
+ - Build.PL has been extended to support sqlite vs. mysql
+ - Storage::DBI now detects between the two DBDs
+ - (RT #51888) Applied POD patch (Thanks, FWIE!)
+ - (RT #44981) Added VERSION to ::Array, ::Engine, and ::Hash
+ - Removed extraneous slashes from POD links (Thanks ilmari!)
+ - (RT #50541) Fixed bug in clear() for hashes in the File backend.
+ - This has caused a regression in speed for clear() when clearing
+ large hashes using running with the File backend. ->clear() (on my
+ machine) now takes ( N / 40 ) ** (1.66) seconds. So, clearing 4000
+ keys (as is the test in t/03_bighash.t) would take ~2070 seconds.
+ - (RT #40782) Fixed bug when handling a key of '0' (Thanks Sterling!)
+ - (RT #48031) Fixed bug with localized $, (Thanks, SPROUT!)
+
+1.0019_001 Dec 31 22:00:00 2009 EST
+ (This is the first developer release for 1.0020.)
+ (This version is compatible with 1.0014)
+ - DBM::Deep has been refactored to allow for multiple engines. There are two
+ engines built so far:
+ - File (the original engine)
+ - DBI (an engine based on DBI)
+ - The DBI engine has only been tested on MySQL and isn't transactional.
+ - InnoDB sucks horribly. When run in a sufficient isolation mode, it
+ creates deadlocks.
+ - A custom Build.PL has been written to allow for running tests under
+ CPAN.pm against the various engines.
+ - This also allows running the long tests under CPAN.pm
+ - This has meant a ton of refactoring. Hopefullly, this refactoring will
+ allow finding some of the niggly bugs more easily. Those tests have not
+ been enabled yet. That's the next developer release.
+ - Hopefully, this multi-engine support will allow deprecation of the file
+ format in the future.
+
+1.0016 Feb 05 22:10:00 2010 PST
+ - (This version is compatible with 1.0015)
+ - New caveat in the docs explaining stale references (RT#42129)
+ - All included modules now have the same version in META.yml, so
+ the CPAN shell will no longer try to downgrade.
+ - Fixed bug in clear() for hashes (RT#50541)
+
+1.0015 Jan 25 22:05:00 2010 PST
+ - (This version is compatible with 1.0014)
+ - Fix deep recursion errors (RT#53575)
+ - Avoid leaving temp files lying around (RT#32462)
+ - (RT #48031) Fixed bug with localized $, (Thanks, SPROUT!)
1.0016 Feb 05 22:10:00 2010 PST
- (This version is compatible with 1.0015)
lib/DBM/Deep/Array.pm
lib/DBM/Deep/Cookbook.pod
lib/DBM/Deep/Engine.pm
-lib/DBM/Deep/Engine/Sector.pm
-lib/DBM/Deep/Engine/Sector/BucketList.pm
-lib/DBM/Deep/Engine/Sector/Data.pm
-lib/DBM/Deep/Engine/Sector/Index.pm
-lib/DBM/Deep/Engine/Sector/Null.pm
-lib/DBM/Deep/Engine/Sector/Reference.pm
-lib/DBM/Deep/Engine/Sector/Scalar.pm
-lib/DBM/Deep/File.pm
+lib/DBM/Deep/Engine/DBI.pm
+lib/DBM/Deep/Engine/File.pm
lib/DBM/Deep/Hash.pm
lib/DBM/Deep/Internals.pod
lib/DBM/Deep/Iterator.pm
-lib/DBM/Deep/Iterator/BucketList.pm
-lib/DBM/Deep/Iterator/Index.pm
+lib/DBM/Deep/Iterator/DBI.pm
+lib/DBM/Deep/Iterator/File.pm
+lib/DBM/Deep/Iterator/File/BucketList.pm
+lib/DBM/Deep/Iterator/File/Index.pm
lib/DBM/Deep/Null.pm
+lib/DBM/Deep/Sector.pm
+lib/DBM/Deep/Sector/DBI.pm
+lib/DBM/Deep/Sector/DBI/Reference.pm
+lib/DBM/Deep/Sector/DBI/Scalar.pm
+lib/DBM/Deep/Sector/File.pm
+lib/DBM/Deep/Sector/File/BucketList.pm
+lib/DBM/Deep/Sector/File/Data.pm
+lib/DBM/Deep/Sector/File/Index.pm
+lib/DBM/Deep/Sector/File/Null.pm
+lib/DBM/Deep/Sector/File/Reference.pm
+lib/DBM/Deep/Sector/File/Scalar.pm
+lib/DBM/Deep/Storage.pm
+lib/DBM/Deep/Storage/DBI.pm
+lib/DBM/Deep/Storage/File.pm
Makefile.PL
MANIFEST
META.yml
t/52_memory_leak.t
t/53_misc_transactions.t
t/54_output_punct_vars.t
+t/55_recursion.t
+t/96_virtual_functions.t
t/97_dump_file.t
t/98_pod.t
t/99_pod_coverage.t
t/etc/db-0-99_04
t/etc/db-1-0000
t/etc/db-1-0003
+etc/mysql_tables.sql
+etc/sqlite_tables.sql
utils/lib/DBM/Deep/09830.pm
utils/lib/DBM/Deep/10002.pm
utils/upgrade_db.pl
^__MACOSX
^articles
^t_attic
+^.gitignore
--- /dev/null
+* clear() should use the Engine to clear. In the File backend, this would mean
+ that Sector::File::Reference should have a function similar to get_bucket_list
+ that iterates and deletes as appropriate.
+* Does the cache work with reblessing?
--- /dev/null
+DROP TABLE IF EXISTS datas;
+DROP TABLE IF EXISTS refs;
+
+CREATE TABLE refs (
+ id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY
+ ,ref_type ENUM( 'H', 'A' ) NOT NULL DEFAULT 'H'
+ ,refcount BIGINT UNSIGNED NOT NULL DEFAULT 1
+ ,classname LONGTEXT
+) ENGINE=MyISAM;
+
+CREATE TABLE datas (
+ id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY
+ ,ref_id BIGINT UNSIGNED NOT NULL
+ ,data_type ENUM( 'S', 'R' ) DEFAULT 'S'
+ ,`key` LONGTEXT NOT NULL
+ ,value LONGTEXT
+ ,FOREIGN KEY (ref_id) REFERENCES refs (id)
+ ON DELETE CASCADE ON UPDATE CASCADE
+ ,UNIQUE INDEX (ref_id, `key` (700) )
+) ENGINE=MyISAM;
--- /dev/null
+#!/usr/bin/perl
+
+use DBM::Deep;
+use Data::Dumper;
+
+my $hash = new DBM::Deep(
+ 'dbi' => {
+ 'dsn' => 'DBI:mysql:database=perl;host=localhost',
+ 'user' => 'perl',
+ 'password' => '2A7Qcmh5CBQvLGUu',
+ },
+ 'id' => 20,
+);
+
+print Dumper(
+ $hash,
+ $hash->id(),
+);
+
+my $array = new DBM::Deep(
+ 'dbi' => {
+ 'dsn' => 'DBI:mysql:database=perl;host=localhost',
+ 'user' => 'perl',
+ 'password' => '2A7Qcmh5CBQvLGUu',
+ },
+ 'type' => DBM::Deep->TYPE_ARRAY,
+ 'id' => 21,
+);
+
+print Dumper(
+ $array,
+ $array->id(),
+);
+
--- /dev/null
+DROP TABLE IF EXISTS datas;
+DROP TABLE IF EXISTS refs;
+
+CREATE TABLE refs (
+ id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT
+ ,ref_type STRING NOT NULL DEFAULT 'H'
+ ,refcount INTEGER NOT NULL DEFAULT 1
+ ,classname STRING
+);
+
+CREATE TABLE datas (
+ id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT
+ ,ref_id INTEGER NOT NULL
+ ,data_type STRING DEFAULT 'S'
+ ,`key` STRING NOT NULL
+ ,value STRING
+ ,FOREIGN KEY (ref_id) REFERENCES refs (id)
+ ON DELETE CASCADE ON UPDATE CASCADE
+ ,UNIQUE (ref_id, `key` )
+);
use warnings FATAL => 'all';
no warnings 'recursion';
-our $VERSION = q(1.0016);
+our $VERSION = q(1.0020);
-use Data::Dumper ();
use Scalar::Util ();
-use DBM::Deep::Engine;
-use DBM::Deep::File;
-
use overload
'""' => sub { overload::StrVal( $_[0] ) },
fallback => 1;
use constant DEBUG => 0;
-##
-# Setup constants for users to pass to new()
-##
+use DBM::Deep::Engine;
+
sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH }
sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY }
return $args;
}
+# Class constructor method for Perl OO interface.
+# Calls tie() and returns blessed reference to tied hash or array,
+# providing a hybrid OO/tie interface.
sub new {
- ##
- # Class constructor method for Perl OO interface.
- # Calls tie() and returns blessed reference to tied hash or array,
- # providing a hybrid OO/tie interface.
- ##
my $class = shift;
my $args = $class->_get_args( @_ );
-
- ##
- # Check if we want a tied hash or array.
- ##
my $self;
+
if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
$class = 'DBM::Deep::Array';
require DBM::Deep::Array;
engine => undef,
}, $class;
- $args->{engine} = DBM::Deep::Engine->new( { %{$args}, obj => $self } )
- unless exists $args->{engine};
+ unless ( exists $args->{engine} ) {
+ my $class =
+ exists $args->{dbi} ? 'DBM::Deep::Engine::DBI' :
+ exists $args->{_test} ? 'DBM::Deep::Engine::Test' :
+ 'DBM::Deep::Engine::File' ;
+
+ eval "use $class"; die $@ if $@;
+ $args->{engine} = $class->new({
+ %{$args},
+ obj => $self,
+ });
+ }
# Grab the parameters we want to use
foreach my $param ( keys %$self ) {
}
eval {
- local $SIG{'__DIE__'};
+ local $SIG{'__DIE__'};
- $self->lock_exclusive;
- $self->_engine->setup_fh( $self );
- $self->unlock;
+ $self->lock_exclusive;
+ $self->_engine->setup( $self );
+ $self->unlock;
}; if ( $@ ) {
- my $e = $@;
- eval { local $SIG{'__DIE__'}; $self->unlock; };
- die $e;
+ my $e = $@;
+ eval { local $SIG{'__DIE__'}; $self->unlock; };
+ die $e;
}
return $self;
return $self->_engine->lock_exclusive( $self, @_ );
}
*lock = \&lock_exclusive;
+
sub lock_shared {
my $self = shift->_get_self;
+ # cluck() the problem with cached File objects.
+ unless ( $self->_engine ) {
+ require Carp;
+ require Data::Dumper;
+ Carp::cluck( Data::Dumper->Dump( [$self], ['self'] ) );
+ }
return $self->_engine->lock_shared( $self, @_ );
}
${$spot} = $value;
}
else {
- # This assumes hash or array only. This is a bad assumption moving forward.
- # -RobK, 2008-05-27
my $r = Scalar::Util::reftype( $value );
my $tied;
if ( $r eq 'ARRAY' ) {
$tied = tied(@$value);
}
- else {
+ elsif ( $r eq 'HASH' ) {
$tied = tied(%$value);
}
+ else {
+ __PACKAGE__->_throw_error( "Unknown type for '$value'" );
+ }
- if ( eval { local $SIG{__DIE__}; $tied->isa( 'DBM::Deep' ) } ) {
+ if ( eval { local $SIG{'__DIE__'}; $tied->isa( __PACKAGE__ ) } ) {
${$spot} = $tied->_repr;
$tied->_copy_node( ${$spot} );
}
}
my $c = Scalar::Util::blessed( $value );
- if ( defined $c && !$c->isa( 'DBM::Deep') ) {
+ if ( defined $c && !$c->isa( __PACKAGE__ ) ) {
${$spot} = bless ${$spot}, $c
}
}
return 1;
}
-#sub _copy_node {
-# die "Must be implemented in a child class\n";
-#}
-#
-#sub _repr {
-# die "Must be implemented in a child class\n";
-#}
-
sub export {
- ##
- # Recursively export into standard Perl hashes and arrays.
- ##
my $self = shift->_get_self;
my $temp = $self->_repr;
return $r if 'HASH' eq $r;
return $r if 'ARRAY' eq $r;
- DBM::Deep->_throw_error(
+ __PACKAGE__->_throw_error(
"Storage of references of type '$r' is not supported."
);
}
sub import {
- # Perl calls import() on use -- ignore
- return if !ref $_[0];
+ return if !ref $_[0]; # Perl calls import() on use -- ignore
my $self = shift->_get_self;
my ($struct) = @_;
my $type = $self->_check_legality( $struct );
if ( !$type ) {
- DBM::Deep->_throw_error( "Cannot import a scalar" );
+ __PACKAGE__->_throw_error( "Cannot import a scalar" );
}
if ( substr( $type, 0, 1 ) ne $self->_type ) {
- DBM::Deep->_throw_error(
+ __PACKAGE__->_throw_error(
"Cannot import " . ('HASH' eq $type ? 'a hash' : 'an array')
. " into " . ('HASH' eq $type ? 'an array' : 'a hash')
);
#XXX Need to keep track of who has a fh to this file in order to
#XXX close them all prior to optimize on Win32/cygwin
+# Rebuild entire database into new file, then move
+# it back on top of original.
sub optimize {
- ##
- # Rebuild entire database into new file, then move
- # it back on top of original.
- ##
my $self = shift->_get_self;
+ # Optimizing is only something we need to do when we're working with our
+ # own file format. Otherwise, let the other guy do the optimizations.
+ return unless $self->_engine->isa( 'DBM::Deep::Engine::File' );
+
#XXX Need to create a new test for this
# if ($self->_engine->storage->{links} > 1) {
# $self->_throw_error("Cannot optimize: reference count is greater than 1");
#XXX Should we use tempfile() here instead of a hard-coded name?
my $temp_filename = $self->_engine->storage->{file} . '.tmp';
- my $db_temp = DBM::Deep->new(
+ my $db_temp = __PACKAGE__->new(
file => $temp_filename,
type => $self->_type,
$self->lock_exclusive;
$self->_engine->clear_cache;
$self->_copy_node( $db_temp );
+ $self->unlock;
$db_temp->_engine->storage->close;
undef $db_temp;
$self->_engine->storage->open;
$self->lock_exclusive;
- $self->_engine->setup_fh( $self );
+ $self->_engine->setup( $self );
$self->unlock;
return 1;
}
sub clone {
- ##
- # Make copy of object and return
- ##
my $self = shift->_get_self;
- return DBM::Deep->new(
+ return __PACKAGE__->new(
type => $self->_type,
base_offset => $self->_base_offset,
staleness => $self->_staleness,
);
}
+sub supports {
+ my $self = shift->_get_self;
+ return $self->_engine->supports( @_ );
+}
+
#XXX Migrate this to the engine, where it really belongs and go through some
# API - stop poking in the innards of someone else..
{
sub begin_work {
my $self = shift->_get_self;
$self->lock_exclusive;
- my $rv = eval { $self->_engine->begin_work( $self, @_ ) };
+ my $rv = eval {
+ local $SIG{'__DIE__'};
+ $self->_engine->begin_work( $self, @_ );
+ };
my $e = $@;
$self->unlock;
die $e if $e;
sub rollback {
my $self = shift->_get_self;
+
$self->lock_exclusive;
- my $rv = eval { $self->_engine->rollback( $self, @_ ) };
+ my $rv = eval {
+ local $SIG{'__DIE__'};
+ $self->_engine->rollback( $self, @_ );
+ };
my $e = $@;
$self->unlock;
die $e if $e;
sub commit {
my $self = shift->_get_self;
$self->lock_exclusive;
- my $rv = eval { $self->_engine->commit( $self, @_ ) };
+ my $rv = eval {
+ local $SIG{'__DIE__'};
+ $self->_engine->commit( $self, @_ );
+ };
my $e = $@;
$self->unlock;
die $e if $e;
return $rv;
}
-##
# Accessor methods
-##
-
sub _engine {
my $self = $_[0]->_get_self;
return $self->{engine};
return $self->{staleness};
}
-##
# Utility methods
-##
-
sub _throw_error {
my $n = 0;
while( 1 ) {
}
}
+# Store single hash key/value or array element in database.
sub STORE {
- ##
- # Store single hash key/value or array element in database.
- ##
my $self = shift->_get_self;
my ($key, $value) = @_;
warn "STORE($self, '$key', '@{[defined$value?$value:'undef']}')\n" if DEBUG;
$value = $self->_engine->storage->{filter_store_value}->( $value );
}
- my $x = $self->_engine->write_value( $self, $key, $value);
+ eval {
+ local $SIG{'__DIE__'};
+ $self->_engine->write_value( $self, $key, $value );
+ }; if ( my $e = $@ ) {
+ $self->unlock;
+ die $e;
+ }
$self->unlock;
return 1;
}
+# Fetch single value or element given plain key or array index
sub FETCH {
- ##
- # Fetch single value or element given plain key or array index
- ##
my $self = shift->_get_self;
my ($key) = @_;
warn "FETCH($self, '$key')\n" if DEBUG;
$self->lock_shared;
- my $result = $self->_engine->read_value( $self, $key);
+ my $result = $self->_engine->read_value( $self, $key );
$self->unlock;
: $result;
}
+# Delete single key/value pair or element given plain key or array index
sub DELETE {
- ##
- # Delete single key/value pair or element given plain key or array index
- ##
my $self = shift->_get_self;
my ($key) = @_;
warn "DELETE($self, '$key')\n" if DEBUG;
return $value;
}
+# Check if a single key or element exists given plain key or array index
sub EXISTS {
- ##
- # Check if a single key or element exists given plain key or array index
- ##
my $self = shift->_get_self;
my ($key) = @_;
warn "EXISTS($self, '$key')\n" if DEBUG;
return $result;
}
+# Clear all keys from hash, or all elements from array.
sub CLEAR {
- ##
- # Clear all keys from hash, or all elements from array.
- ##
my $self = shift->_get_self;
warn "CLEAR($self)\n" if DEBUG;
}
$self->lock_exclusive;
-
- # Dispatch to the specific clearing functionality.
- $engine->clear($self);
+ eval {
+ local $SIG{'__DIE__'};
+ $engine->clear( $self );
+ };
+ my $e = $@;
+ warn "$e\n" if $e && DEBUG;
$self->unlock;
+ die $e if $e;
+
return 1;
}
-##
# Public method aliases
-##
-sub put { (shift)->STORE( @_ ) }
-sub store { (shift)->STORE( @_ ) }
-sub get { (shift)->FETCH( @_ ) }
-sub fetch { (shift)->FETCH( @_ ) }
+sub put { (shift)->STORE( @_ ) }
+sub get { (shift)->FETCH( @_ ) }
+sub store { (shift)->STORE( @_ ) }
+sub fetch { (shift)->FETCH( @_ ) }
sub delete { (shift)->DELETE( @_ ) }
sub exists { (shift)->EXISTS( @_ ) }
-sub clear { (shift)->CLEAR( @_ ) }
+sub clear { (shift)->CLEAR( @_ ) }
sub _dump_file {shift->_get_self->_engine->_dump_file;}
=head1 VERSION DIFFERENCES
+B<NOTE>: 1.0020 introduces different engines which are backed by different types
+of storage. There is the original storage (called 'File') and a database storage
+(called 'DBI'). q.v. L</PLUGINS> for more information.
+
B<NOTE>: 1.0000 has significant file format differences from prior versions.
THere is a backwards-compatibility layer at C<utils/upgrade_db.pl>. Files
created by 1.0000 or higher are B<NOT> compatible with scripts using prior
versions.
+=head1 PLUGINS
+
+DBM::Deep is a wrapper around different storage engines. These are:
+
+=head2 File
+
+This is the traditional storage engine, storing the data to a custom file
+format. The parameters accepted are:
+
+=over 4
+
+=item * file
+
+Filename of the DB file to link the handle to. You can pass a full absolute
+filesystem path, partial path, or a plain filename if the file is in the
+current working directory. This is a required parameter (though q.v. fh).
+
+=item * fh
+
+If you want, you can pass in the fh instead of the file. This is most useful for
+doing something like:
+
+ my $db = DBM::Deep->new( { fh => \*DATA } );
+
+You are responsible for making sure that the fh has been opened appropriately
+for your needs. If you open it read-only and attempt to write, an exception will
+be thrown. If you open it write-only or append-only, an exception will be thrown
+immediately as DBM::Deep needs to read from the fh.
+
+=item * file_offset
+
+This is the offset within the file that the DBM::Deep db starts. Most of the
+time, you will not need to set this. However, it's there if you want it.
+
+If you pass in fh and do not set this, it will be set appropriately.
+
+=item * locking
+
+Specifies whether locking is to be enabled. DBM::Deep uses Perl's flock()
+function to lock the database in exclusive mode for writes, and shared mode
+for reads. Pass any true value to enable. This affects the base DB handle
+I<and any child hashes or arrays> that use the same DB file. This is an
+optional parameter, and defaults to 1 (enabled). See L</LOCKING> below for
+more.
+
+=back
+
+=head2 DBI
+
+This is a storage engine that stores the data in a relational database. Funnily
+enough, this engine doesn't work with transactions (yet) as InnoDB doesn't do
+what DBM::Deep needs it to do.
+
+The parameters accepted are:
+
+=over 4
+
+=item * dbh
+
+This is a DBH that's already been opened with L<DBI/connect>.
+
+=item * dbi
+
+This is a hashref containing:
+
+=over 4
+
+=item * dsn
+
+=item * username
+
+=item * password
+
+=item * connect_args
+
+=back
+
+Theses correspond to the 4 parameters L<DBI/connect> takes.
+
+=back
+
+B<NOTE>: This has only been tested with MySQL (with disappointing results). I
+plan on extending this to work with SQLite and PostgreSQL in the next release.
+Oracle, Sybase, and other engines will come later.
+
+=head2 Planned engines
+
+There are plans to extend this functionality to (at least) the following:
+
+=over 4
+
+=item * BDB (and other hash engines like memcached)
+
+=item * NoSQL engines (such as Tokyo Cabinet)
+
+=item * DBIx::Class (and other ORMs)
+
+=back
+
=head1 SETUP
Construction can be done OO-style (which is the recommended way), or using
This opens a new database handle, mapped to the file "foo.db". If this
file does not exist, it will automatically be created. DB files are
opened in "r+" (read/write) mode, and the type of object returned is a
-hash, unless otherwise specified (see L<OPTIONS> below).
+hash, unless otherwise specified (see L</OPTIONS> below).
You can pass a number of options to the constructor to specify things like
locking, autoflush, etc. This is done by passing an inline hash (or hashref):
Notice that the filename is now specified I<inside> the hash with
the "file" parameter, as opposed to being the sole argument to the
constructor. This is required if any options are specified.
-See L<OPTIONS> below for the complete list.
+See L</OPTIONS> below for the complete list.
You can also start with an array instead of a hash. For this, you must
specify the C<type> parameter:
my $db = tie @array, "DBM::Deep", "bar.db";
As with the OO constructor, you can replace the DB filename parameter with
-a hash containing one or more options (see L<OPTIONS> just below for the
+a hash containing one or more options (see L</OPTIONS> just below for the
complete list).
tie %hash, "DBM::Deep", {
=over
-=item * file
-
-Filename of the DB file to link the handle to. You can pass a full absolute
-filesystem path, partial path, or a plain filename if the file is in the
-current working directory. This is a required parameter (though q.v. fh).
-
-=item * fh
-
-If you want, you can pass in the fh instead of the file. This is most useful for doing
-something like:
-
- my $db = DBM::Deep->new( { fh => \*DATA } );
-
-You are responsible for making sure that the fh has been opened appropriately for your
-needs. If you open it read-only and attempt to write, an exception will be thrown. If you
-open it write-only or append-only, an exception will be thrown immediately as DBM::Deep
-needs to read from the fh.
-
-=item * file_offset
-
-This is the offset within the file that the DBM::Deep db starts. Most of the time, you will
-not need to set this. However, it's there if you want it.
-
-If you pass in fh and do not set this, it will be set appropriately.
-
=item * type
This parameter specifies what type of object to create, a hash or array. Use
=over 4
-=item * C<DBM::Deep-E<gt>TYPE_HASH>
+=item * C<<DBM::Deep->TYPE_HASH>>
-=item * C<DBM::Deep-E<gt>TYPE_ARRAY>.
+=item * C<<DBM::Deep->TYPE_ARRAY>>
=back
This only takes effect when beginning a new file. This is an optional
-parameter, and defaults to C<DBM::Deep-E<gt>TYPE_HASH>.
-
-=item * locking
-
-Specifies whether locking is to be enabled. DBM::Deep uses Perl's flock()
-function to lock the database in exclusive mode for writes, and shared mode
-for reads. Pass any true value to enable. This affects the base DB handle
-I<and any child hashes or arrays> that use the same DB file. This is an
-optional parameter, and defaults to 1 (enabled). See L<LOCKING> below for
-more.
+parameter, and defaults to C<<DBM::Deep->TYPE_HASH>>.
=item * autoflush
syntax. Because all DBM::Deep objects are I<tied> to hashes or arrays, you can
treat them as such. DBM::Deep will intercept all reads/writes and direct them
to the right place -- the DB file. This has nothing to do with the
-L<TIE CONSTRUCTION> section above. This simply tells you how to use DBM::Deep
+L</TIE CONSTRUCTION> section above. This simply tells you how to use DBM::Deep
using regular hashes and arrays, rather than calling functions like C<get()>
and C<put()> (although those work too). It is entirely up to you how to want
to access your databases.
This causes an infinite loop, because for each iteration, Perl is calling
FETCH() on the $db handle, resulting in a "new" hash for foo every time, so
it effectively keeps returning the first key over and over again. Instead,
-assign a temporary variable to C<$db->{foo}>, then pass that to each().
+assign a temporary variable to C<<$db->{foo}>>, then pass that to each().
=head2 Arrays
As with hashes, you can treat any DBM::Deep object like a normal Perl array
reference. This includes inserting, removing and manipulating elements,
and the C<push()>, C<pop()>, C<shift()>, C<unshift()> and C<splice()> functions.
-The object must have first been created using type C<DBM::Deep-E<gt>TYPE_ARRAY>,
+The object must have first been created using type C<<DBM::Deep->TYPE_ARRAY>>,
or simply be a nested array reference inside a hash. Example:
my $db = DBM::Deep->new(
push @$db, "bar", "baz";
unshift @$db, "bah";
- my $last_elem = pop @$db; # baz
- my $first_elem = shift @$db; # bah
- my $second_elem = $db->[1]; # bar
+ my $last_elem = pop @$db; # baz
+ my $first_elem = shift @$db; # bah
+ my $second_elem = $db->[1]; # bar
my $num_elements = scalar @$db;
This will compress the datafile so that it takes up as little space as possible.
There is a freespace manager so that when space is freed up, it is used before
-extending the size of the datafile. But, that freespace just sits in the datafile
-unless C<optimize()> is called.
+extending the size of the datafile. But, that freespace just sits in the
+datafile unless C<optimize()> is called.
=item * import()
These are the transactional functions. L</TRANSACTIONS> for more information.
+=item * supports( $option )
+
+This returns a boolean depending on if this instance of DBM::Dep supports
+that feature. C<$option> can be one of:
+
+=over 4
+
+=item * transactions
+
+=back
+
=back
=head2 Hashes
Fetches the first element in the array, deletes it, then shifts all the
remaining elements over to take up the space. Returns the element value. This
-method is not recommended with large arrays -- see L<LARGE ARRAYS> below for
+method is not recommended with large arrays -- see L</LARGE ARRAYS> below for
details.
my $elem = $db->shift();
Performs exactly like Perl's built-in function of the same name. See L<perldoc
-f splice> for usage -- it is too complicated to document here. This method is
-not recommended with large arrays -- see L<LARGE ARRAYS> below for details.
+not recommended with large arrays -- see L</LARGE ARRAYS> below for details.
=back
=head1 LOCKING
Enable or disable automatic file locking by passing a boolean value to the
-C<locking> parameter when constructing your DBM::Deep object (see L<SETUP>
+C<locking> parameter when constructing your DBM::Deep object (see L</SETUP>
above).
my $db = DBM::Deep->new(
This causes DBM::Deep to C<flock()> the underlying filehandle with exclusive
mode for writes, and shared mode for reads. This is required if you have
multiple processes accessing the same database file, to avoid file corruption.
-Please note that C<flock()> does NOT work for files over NFS. See L<DB OVER
+Please note that C<flock()> does NOT work for files over NFS. See L</DB OVER
NFS> below for more.
=head2 Explicit Locking
by specifying the 'pack_size' parameter when constructing the file.
DBM::Deep->new(
- filename => $filename,
+ file => $filename,
pack_size => 'large',
);
instead of 32-bit longs. After setting these values your DB files have a
theoretical maximum size of 16 XB (exabytes).
-You can also use C<pack_size =E<gt> 'small'> in order to use 16-bit file
+You can also use C<<pack_size => 'small'>> in order to use 16-bit file
offsets.
B<Note:> Changing these values will B<NOT> work for existing database files.
=head1 TODO
The following are items that are planned to be added in future releases. These
-are separate from the L<CAVEATS, ISSUES & BUGS> below.
+are separate from the L</CAVEATS, ISSUES & BUGS> below.
=head2 Sub-Transactions
=head2 External references and transactions
-If you do C<my $x = $db-E<gt>{foo};>, then start a transaction, $x will be
+If you do C<<my $x = $db->{foo};>>, then start a transaction, $x will be
referencing the database from outside the transaction. A fix for this (and other
issues with how external references into the database) is being looked into. This
is the skipped set of tests in t/39_singletons.t and a related issue is the focus
using C<lockf()> to lock your files, but your mileage may vary there as well.
From what I understand, there is no real way to do it. However, if you need
access to the underlying filehandle in DBM::Deep for using some other kind of
-locking scheme like C<lockf()>, see the L<LOW-LEVEL ACCESS> section above.
+locking scheme like C<lockf()>, see the L</LOW-LEVEL ACCESS> section above.
=head2 Copying Objects
my $copy = $db->clone();
-B<Note>: Since clone() here is cloning the object, not the database location, any
-modifications to either $db or $copy will be visible to both.
+B<Note>: Since clone() here is cloning the object, not the database location,
+any modifications to either $db or $copy will be visible to both.
+
+=head2 Stale References
+
+If you take a reference to an array or hash from the database, it is tied
+to the database itself. This means that if the datum in question is subsequentl
+an invalid location and unpredictable things will happen if you try to use
+it.
+
+So a seemingly innocuous piece of code like this:
+
+ my %hash = %{ $db->{some_hash} };
+
+can fail if another process deletes or clobbers C<< $db->{some_hash} >>
+while the data are being extracted, since S<C<%{ ... }>> is not atomic.
+(This actually happened.) The solution is to lock the database before
+reading the data:
+
+ $db->lock_exclusive;
+ my %hash = %{ $db->{some_hash} };
+ $db->unlock;
=head2 Large Arrays
L<Devel::Cover> is used to test the code coverage of the tests. Below is the
L<Devel::Cover> report on this distribution's test suite.
- ------------------------------------------ ------ ------ ------ ------ ------
- File stmt bran cond sub total
- ------------------------------------------ ------ ------ ------ ------ ------
- blib/lib/DBM/Deep.pm 97.2 90.9 83.3 100.0 95.4
- blib/lib/DBM/Deep/Array.pm 100.0 95.7 100.0 100.0 99.0
- blib/lib/DBM/Deep/Engine.pm 95.6 84.7 81.6 98.4 92.5
- blib/lib/DBM/Deep/File.pm 97.2 81.6 66.7 100.0 91.9
- blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0
- Total 96.7 87.5 82.2 99.2 94.1
- ------------------------------------------ ------ ------ ------ ------ ------
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ File stmt bran cond sub pod time total
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ blib/lib/DBM/Deep.pm 100.0 89.1 82.9 100.0 100.0 32.5 98.1
+ blib/lib/DBM/Deep/Array.pm 100.0 94.4 100.0 100.0 100.0 5.2 98.8
+ blib/lib/DBM/Deep/Engine.pm 100.0 92.9 100.0 100.0 100.0 7.4 100.0
+ ...ib/DBM/Deep/Engine/DBI.pm 95.0 73.1 100.0 100.0 100.0 1.5 90.4
+ ...b/DBM/Deep/Engine/File.pm 92.3 78.5 88.9 100.0 100.0 4.9 90.3
+ blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0 3.8 100.0
+ .../lib/DBM/Deep/Iterator.pm 100.0 n/a n/a 100.0 100.0 0.0 100.0
+ .../DBM/Deep/Iterator/DBI.pm 100.0 100.0 n/a 100.0 100.0 1.2 100.0
+ ...DBM/Deep/Iterator/File.pm 92.5 84.6 n/a 100.0 66.7 0.6 90.0
+ ...erator/File/BucketList.pm 100.0 75.0 n/a 100.0 66.7 0.4 93.8
+ ...ep/Iterator/File/Index.pm 100.0 100.0 n/a 100.0 100.0 0.2 100.0
+ blib/lib/DBM/Deep/Null.pm 87.5 n/a n/a 75.0 n/a 0.0 83.3
+ blib/lib/DBM/Deep/Sector.pm 91.7 n/a n/a 83.3 0.0 6.7 74.4
+ ...ib/DBM/Deep/Sector/DBI.pm 96.8 83.3 n/a 100.0 0.0 1.0 89.8
+ ...p/Sector/DBI/Reference.pm 100.0 95.5 100.0 100.0 0.0 2.2 91.2
+ ...Deep/Sector/DBI/Scalar.pm 100.0 100.0 n/a 100.0 0.0 1.1 92.9
+ ...b/DBM/Deep/Sector/File.pm 96.0 87.5 100.0 92.3 25.0 2.2 91.0
+ ...Sector/File/BucketList.pm 98.2 85.7 83.3 100.0 0.0 3.3 89.4
+ .../Deep/Sector/File/Data.pm 100.0 n/a n/a 100.0 0.0 0.1 90.9
+ ...Deep/Sector/File/Index.pm 100.0 80.0 33.3 100.0 0.0 0.8 83.1
+ .../Deep/Sector/File/Null.pm 100.0 100.0 n/a 100.0 0.0 0.0 91.7
+ .../Sector/File/Reference.pm 100.0 90.0 80.0 100.0 0.0 1.4 91.5
+ ...eep/Sector/File/Scalar.pm 98.4 87.5 n/a 100.0 0.0 0.8 91.9
+ blib/lib/DBM/Deep/Storage.pm 100.0 n/a n/a 100.0 100.0 0.0 100.0
+ ...b/DBM/Deep/Storage/DBI.pm 97.3 70.8 n/a 100.0 38.5 6.7 87.0
+ .../DBM/Deep/Storage/File.pm 96.6 77.1 80.0 95.7 100.0 16.0 91.8
+ Total 99.3 85.2 84.9 99.8 63.3 100.0 97.6
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
=head1 MORE INFORMATION
or send email to L<DBM-Deep@googlegroups.com>. You can also visit #dbm-deep on
irc.perl.org
-The source code repository is at L<http://svn.perl.org/modules/DBM-Deep>
+The source code repository is at L<http://github.com/robkinyon/dbm-deep>
=head1 MAINTAINERS
use 5.006_000;
use strict;
-use warnings;
+use warnings FATAL => 'all';
no warnings 'recursion';
# This is to allow DBM::Deep::Array to handle negative indices on
return $rv;
}
-# Now that we have a real Reference sector, we should store arrayzize there. However,
-# arraysize needs to be transactionally-aware, so a simple location to store it isn't
-# going to work.
+# Now that we have a real Reference sector, we should store arrayzize there.
+# However, arraysize needs to be transactionally-aware, so a simple location to
+# store it isn't going to work.
sub FETCHSIZE {
my $self = shift->_get_self;
# We don't need to populate it, yet.
# It will be useful, though, when we split out HASH and ARRAY
-sub EXTEND {
- ##
- # Perl will call EXTEND() when the array is likely to grow.
- # We don't care, but include it because it gets called at times.
- ##
-}
+# Perl will call EXTEND() when the array is likely to grow.
+# We don't care, but include it because it gets called at times.
+sub EXTEND {}
sub _copy_node {
my $self = shift;
return;
}
-##
-# Public method aliases
-##
-sub length { (shift)->FETCHSIZE(@_) }
-sub pop { (shift)->POP(@_) }
-sub push { (shift)->PUSH(@_) }
-sub unshift { (shift)->UNSHIFT(@_) }
-sub splice { (shift)->SPLICE(@_) }
+sub length { (shift)->FETCHSIZE(@_) }
+sub pop { (shift)->POP(@_) }
+sub push { (shift)->PUSH(@_) }
+sub unshift { (shift)->UNSHIFT(@_) }
+sub splice { (shift)->SPLICE(@_) }
# This must be last otherwise we have to qualify all other calls to shift
# as calls to CORE::shift
use warnings FATAL => 'all';
no warnings 'recursion';
-# Never import symbols into our namespace. We are a class, not a library.
-# -RobK, 2008-05-27
-use Scalar::Util ();
-
-#use Data::Dumper ();
+use DBM::Deep::Iterator ();
# File-wide notes:
# * Every method in here assumes that the storage has been appropriately
# mutex. But, it's the caller's responsability to make sure that this has
# been done.
-# Setup file and tag signatures. These should never change.
-sub SIG_FILE () { 'DPDB' }
-sub SIG_HEADER () { 'h' }
-sub SIG_HASH () { 'H' }
-sub SIG_ARRAY () { 'A' }
-sub SIG_NULL () { 'N' }
-sub SIG_DATA () { 'D' }
-sub SIG_INDEX () { 'I' }
-sub SIG_BLIST () { 'B' }
-sub SIG_FREE () { 'F' }
-sub SIG_SIZE () { 1 }
-
-use DBM::Deep::Iterator ();
-use DBM::Deep::Engine::Sector::Data ();
-use DBM::Deep::Engine::Sector::BucketList ();
-use DBM::Deep::Engine::Sector::Index ();
-use DBM::Deep::Engine::Sector::Null ();
-use DBM::Deep::Engine::Sector::Reference ();
-use DBM::Deep::Engine::Sector::Scalar ();
-use DBM::Deep::Null ();
-
-my $STALE_SIZE = 2;
-
-# Please refer to the pack() documentation for further information
-my %StP = (
- 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
- 2 => 'n', # Unsigned short in "network" (big-endian) order
- 4 => 'N', # Unsigned long in "network" (big-endian) order
- 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
-);
+sub SIG_HASH () { 'H' }
+sub SIG_ARRAY () { 'A' }
=head1 NAME
=head1 PURPOSE
-This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level
-mapping between the L<DBM::Deep/> objects and the storage medium.
+This is an internal-use-only object for L<DBM::Deep>. It mediates the low-level
+mapping between the L<DBM::Deep> objects and the storage medium.
The purpose of this documentation is to provide low-level documentation for
developers. It is B<not> intended to be used by the general public. This
=item * get_next_key
-=item * clear
+=item * setup
-=item * setup_fh
+=item * clear
=item * begin_work
=head2 STALENESS
-If another process uses a transaction slot and writes stuff to it, then terminates,
-the data that process wrote it still within the file. In order to address this,
-there is also a transaction staleness counter associated within every write.
-Each time a transaction is started, that process increments that transaction's
-staleness counter. If, when it reads a value, the staleness counters aren't
-identical, DBM::Deep will consider the value on disk to be stale and discard it.
+If another process uses a transaction slot and writes stuff to it, then
+terminates, the data that process wrote it still within the file. In order to
+address this, there is also a transaction staleness counter associated within
+every write. Each time a transaction is started, that process increments that
+transaction's staleness counter. If, when it reads a value, the staleness
+counters aren't identical, DBM::Deep will consider the value on disk to be stale
+and discard it.
=head2 DURABILITY
The fourth leg of ACID is Durability, the guarantee that when a commit returns,
the data will be there the next time you read from it. This should be regardless
-of any crashes or powerdowns in between the commit and subsequent read. DBM::Deep
-does provide that guarantee; once the commit returns, all of the data has been
-transferred from the transaction shadow to the HEAD. The issue arises with partial
-commits - a commit that is interrupted in some fashion. In keeping with DBM::Deep's
-"tradition" of very light error-checking and non-existent error-handling, there is
-no way to recover from a partial commit. (This is probably a failure in Consistency
-as well as Durability.)
-
-Other DBMSes use transaction logs (a separate file, generally) to achieve Durability.
-As DBM::Deep is a single-file, we would have to do something similar to what SQLite
-and BDB do in terms of committing using synchonized writes. To do this, we would have
-to use a much higher RAM footprint and some serious programming that make my head
-hurts just to think about it.
+of any crashes or powerdowns in between the commit and subsequent read.
+DBM::Deep does provide that guarantee; once the commit returns, all of the data
+has been transferred from the transaction shadow to the HEAD. The issue arises
+with partial commits - a commit that is interrupted in some fashion. In keeping
+with DBM::Deep's "tradition" of very light error-checking and non-existent
+error-handling, there is no way to recover from a partial commit. (This is
+probably a failure in Consistency as well as Durability.)
-=head1 EXTERNAL METHODS
-
-=head2 new()
-
-This takes a set of args. These args are described in the documentation for
-L<DBM::Deep/new>.
+Other DBMSes use transaction logs (a separate file, generally) to achieve
+Durability. As DBM::Deep is a single-file, we would have to do something
+similar to what SQLite and BDB do in terms of committing using synchonized
+writes. To do this, we would have to use a much higher RAM footprint and some
+serious programming that make my head hurts just to think about it.
=cut
-sub new {
- my $class = shift;
- my ($args) = @_;
-
- $args->{storage} = DBM::Deep::File->new( $args )
- unless exists $args->{storage};
-
- my $self = bless {
- byte_size => 4,
-
- digest => undef,
- hash_size => 16, # In bytes
- hash_chars => 256, # Number of chars the algorithm uses per byte
- max_buckets => 16,
- num_txns => 1, # The HEAD
- trans_id => 0, # Default to the HEAD
-
- data_sector_size => 64, # Size in bytes of each data sector
-
- entries => {}, # This is the list of entries for transactions
- storage => undef,
- }, $class;
-
- # Never allow byte_size to be set directly.
- delete $args->{byte_size};
- if ( defined $args->{pack_size} ) {
- if ( lc $args->{pack_size} eq 'small' ) {
- $args->{byte_size} = 2;
- }
- elsif ( lc $args->{pack_size} eq 'medium' ) {
- $args->{byte_size} = 4;
- }
- elsif ( lc $args->{pack_size} eq 'large' ) {
- $args->{byte_size} = 8;
- }
- else {
- DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
- }
- }
-
- # Grab the parameters we want to use
- foreach my $param ( keys %$self ) {
- next unless exists $args->{$param};
- $self->{$param} = $args->{$param};
- }
-
- my %validations = (
- max_buckets => { floor => 16, ceil => 256 },
- num_txns => { floor => 1, ceil => 255 },
- data_sector_size => { floor => 32, ceil => 256 },
- );
-
- while ( my ($attr, $c) = each %validations ) {
- if ( !defined $self->{$attr}
- || !length $self->{$attr}
- || $self->{$attr} =~ /\D/
- || $self->{$attr} < $c->{floor}
- ) {
- $self->{$attr} = '(undef)' if !defined $self->{$attr};
- warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
- $self->{$attr} = $c->{floor};
- }
- elsif ( $self->{$attr} > $c->{ceil} ) {
- warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
- $self->{$attr} = $c->{ceil};
- }
- }
-
- if ( !$self->{digest} ) {
- require Digest::MD5;
- $self->{digest} = \&Digest::MD5::md5;
- }
-
- return $self;
-}
+=head1 METHODS
=head2 read_value( $obj, $key )
=cut
-sub read_value {
- my $self = shift;
- my ($obj, $key) = @_;
-
- # This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
- or return;
-
- if ( $sector->staleness != $obj->_staleness ) {
- return;
- }
-
- my $key_md5 = $self->_apply_digest( $key );
-
- my $value_sector = $sector->get_data_for({
- key_md5 => $key_md5,
- allow_head => 1,
- });
-
- unless ( $value_sector ) {
- $value_sector = DBM::Deep::Engine::Sector::Null->new({
- engine => $self,
- data => undef,
- });
-
- $sector->write_data({
- key_md5 => $key_md5,
- key => $key,
- value => $value_sector,
- });
- }
-
- return $value_sector->data;
-}
+sub read_value { die "read_value must be implemented in a child class" }
=head2 get_classname( $obj )
-This takes an object that provides _base_offset() and returns the classname (if any)
-associated with it.
+This takes an object that provides _base_offset() and returns the classname (if
+any) associated with it.
It delegates to Sector::Reference::get_classname() for the heavy lifting.
=cut
-sub get_classname {
- my $self = shift;
- my ($obj) = @_;
-
- # This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
- or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
-
- if ( $sector->staleness != $obj->_staleness ) {
- return;
- }
-
- return $sector->get_classname;
-}
+sub get_classname { die "get_classname must be implemented in a child class" }
=head2 make_reference( $obj, $old_key, $new_key )
This takes an object that provides _base_offset() and two strings. The
strings correspond to the old key and new key, respectively. This operation
-is equivalent to (given C<< $db->{foo} = []; >>) C<< $db->{bar} = $db->{foo}; >>.
+is equivalent to (given C<< $db->{foo} = []; >>) C<< $db->{bar} = $db->{foo} >>.
This returns nothing.
=cut
-sub make_reference {
- my $self = shift;
- my ($obj, $old_key, $new_key) = @_;
-
- # This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
- or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
-
- if ( $sector->staleness != $obj->_staleness ) {
- return;
- }
-
- my $old_md5 = $self->_apply_digest( $old_key );
-
- my $value_sector = $sector->get_data_for({
- key_md5 => $old_md5,
- allow_head => 1,
- });
-
- unless ( $value_sector ) {
- $value_sector = DBM::Deep::Engine::Sector::Null->new({
- engine => $self,
- data => undef,
- });
-
- $sector->write_data({
- key_md5 => $old_md5,
- key => $old_key,
- value => $value_sector,
- });
- }
-
- if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
- $sector->write_data({
- key => $new_key,
- key_md5 => $self->_apply_digest( $new_key ),
- value => $value_sector,
- });
- $value_sector->increment_refcount;
- }
- else {
- $sector->write_data({
- key => $new_key,
- key_md5 => $self->_apply_digest( $new_key ),
- value => $value_sector->clone,
- });
- }
-
- return;
-}
+sub make_reference { die "make_reference must be implemented in a child class" }
=head2 key_exists( $obj, $key )
=cut
-sub key_exists {
- my $self = shift;
- my ($obj, $key) = @_;
-
- # This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
- or return '';
-
- if ( $sector->staleness != $obj->_staleness ) {
- return '';
- }
-
- my $data = $sector->get_data_for({
- key_md5 => $self->_apply_digest( $key ),
- allow_head => 1,
- });
-
- # exists() returns 1 or '' for true/false.
- return $data ? 1 : '';
-}
+sub key_exists { die "key_exists must be implemented in a child class" }
=head2 delete_key( $obj, $key )
=cut
-sub delete_key {
- my $self = shift;
- my ($obj, $key) = @_;
-
- my $sector = $self->_load_sector( $obj->_base_offset )
- or return;
-
- if ( $sector->staleness != $obj->_staleness ) {
- return;
- }
-
- return $sector->delete_key({
- key_md5 => $self->_apply_digest( $key ),
- allow_head => 0,
- });
-}
+sub delete_key { die "delete_key must be implemented in a child class" }
=head2 write_value( $obj, $key, $value )
This takes an object that provides _base_offset(), a string for the
-key, and a value. This value can be anything storable within L<DBM::Deep/>.
+key, and a value. This value can be anything storable within L<DBM::Deep>.
This returns 1 upon success.
=cut
-sub write_value {
- my $self = shift;
- my ($obj, $key, $value) = @_;
-
- my $r = Scalar::Util::reftype( $value ) || '';
- {
- last if $r eq '';
- last if $r eq 'HASH';
- last if $r eq 'ARRAY';
-
- DBM::Deep->_throw_error(
- "Storage of references of type '$r' is not supported."
- );
- }
-
- # This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
- or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
-
- if ( $sector->staleness != $obj->_staleness ) {
- DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
- }
-
- my ($class, $type);
- if ( !defined $value ) {
- $class = 'DBM::Deep::Engine::Sector::Null';
- }
- elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
- my $tmpvar;
- if ( $r eq 'ARRAY' ) {
- $tmpvar = tied @$value;
- } elsif ( $r eq 'HASH' ) {
- $tmpvar = tied %$value;
- }
-
- if ( $tmpvar ) {
- my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
-
- unless ( $is_dbm_deep ) {
- DBM::Deep->_throw_error( "Cannot store something that is tied." );
- }
-
- unless ( $tmpvar->_engine->storage == $self->storage ) {
- DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
- }
-
- # First, verify if we're storing the same thing to this spot. If we are, then
- # this should be a no-op. -EJS, 2008-05-19
- my $loc = $sector->get_data_location_for({
- key_md5 => $self->_apply_digest( $key ),
- allow_head => 1,
- });
-
- if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
- return 1;
- }
-
- #XXX Can this use $loc?
- my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
- $sector->write_data({
- key => $key,
- key_md5 => $self->_apply_digest( $key ),
- value => $value_sector,
- });
- $value_sector->increment_refcount;
-
- return 1;
- }
-
- $class = 'DBM::Deep::Engine::Sector::Reference';
- $type = substr( $r, 0, 1 );
- }
- else {
- if ( tied($value) ) {
- DBM::Deep->_throw_error( "Cannot store something that is tied." );
- }
- $class = 'DBM::Deep::Engine::Sector::Scalar';
- }
-
- # Create this after loading the reference sector in case something bad happens.
- # This way, we won't allocate value sector(s) needlessly.
- my $value_sector = $class->new({
- engine => $self,
- data => $value,
- type => $type,
- });
-
- $sector->write_data({
- key => $key,
- key_md5 => $self->_apply_digest( $key ),
- value => $value_sector,
- });
-
- # This code is to make sure we write all the values in the $value to the disk
- # and to make sure all changes to $value after the assignment are reflected
- # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
- # NOTE - simply tying $value won't perform a STORE on each value. Hence, the
- # copy to a temp value.
- if ( $r eq 'ARRAY' ) {
- my @temp = @$value;
- tie @$value, 'DBM::Deep', {
- base_offset => $value_sector->offset,
- staleness => $value_sector->staleness,
- storage => $self->storage,
- engine => $self,
- };
- @$value = @temp;
- bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
- }
- elsif ( $r eq 'HASH' ) {
- my %temp = %$value;
- tie %$value, 'DBM::Deep', {
- base_offset => $value_sector->offset,
- staleness => $value_sector->staleness,
- storage => $self->storage,
- engine => $self,
- };
-
- %$value = %temp;
- bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
- }
-
- return 1;
-}
-
-=head2 get_next_key( $obj, $prev_key )
-
-This takes an object that provides _base_offset() and an optional string
-representing the prior key returned via a prior invocation of this method.
-
-This method delegates to C<< DBM::Deep::Iterator->get_next_key() >>.
-
-=cut
-
-# XXX Add staleness here
-sub get_next_key {
- my $self = shift;
- my ($obj, $prev_key) = @_;
-
- # XXX Need to add logic about resetting the iterator if any key in the reference has changed
- unless ( defined $prev_key ) {
- $obj->{iterator} = DBM::Deep::Iterator->new({
- base_offset => $obj->_base_offset,
- engine => $self,
- });
- }
-
- return $obj->{iterator}->get_next_key( $obj );
-}
-
-=head2 clear( $obj )
-
-This takes an object that provides _base_offset() and deletes all its
-elements, returning nothing.
-
-=cut
-
-sub clear {
- my $self = shift;
- my $obj = shift;
-
- my $sector = $self->_load_sector( $obj->_base_offset )
- or return;
-
- if ( $sector->staleness != $obj->_staleness ) {
- return;
- }
-
- $sector->clear;
- return;
-}
+sub write_value { die "write_value must be implemented in a child class" }
-=head2 setup_fh( $obj )
+=head2 setup( $obj )
This takes an object that provides _base_offset(). It will do everything needed
in order to properly initialize all values for necessary functioning. If this is
=cut
-sub setup_fh {
- my $self = shift;
- my ($obj) = @_;
-
- # We're opening the file.
- unless ( $obj->_base_offset ) {
- my $bytes_read = $self->_read_file_header;
-
- # Creating a new file
- unless ( $bytes_read ) {
- $self->_write_file_header;
-
- # 1) Create Array/Hash entry
- my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
- engine => $self,
- type => $obj->_type,
- });
- $obj->{base_offset} = $initial_reference->offset;
- $obj->{staleness} = $initial_reference->staleness;
-
- $self->storage->flush;
- }
- # Reading from an existing file
- else {
- $obj->{base_offset} = $bytes_read;
- my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
- engine => $self,
- offset => $obj->_base_offset,
- });
- unless ( $initial_reference ) {
- DBM::Deep->_throw_error("Corrupted file, no master index record");
- }
-
- unless ($obj->_type eq $initial_reference->type) {
- DBM::Deep->_throw_error("File type mismatch");
- }
-
- $obj->{staleness} = $initial_reference->staleness;
- }
- }
-
- $self->storage->set_inode;
-
- return 1;
-}
+sub setup { die "setup must be implemented in a child class" }
=head2 begin_work( $obj )
=cut
-sub begin_work {
- my $self = shift;
- my ($obj) = @_;
-
- if ( $self->trans_id ) {
- DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
- }
-
- my @slots = $self->read_txn_slots;
- my $found;
- for my $i ( 0 .. $#slots ) {
- next if $slots[$i];
-
- $slots[$i] = 1;
- $self->set_trans_id( $i + 1 );
- $found = 1;
- last;
- }
- unless ( $found ) {
- DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
- }
- $self->write_txn_slots( @slots );
-
- if ( !$self->trans_id ) {
- DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
- }
-
- return;
-}
+sub begin_work { die "begin_work must be implemented in a child class" }
=head2 rollback( $obj )
=cut
-sub rollback {
- my $self = shift;
- my ($obj) = @_;
-
- if ( !$self->trans_id ) {
- DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
- }
-
- # Each entry is the file location for a bucket that has a modification for
- # this transaction. The entries need to be expunged.
- foreach my $entry (@{ $self->get_entries } ) {
- # Remove the entry here
- my $read_loc = $entry
- + $self->hash_size
- + $self->byte_size
- + $self->byte_size
- + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
-
- my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
- $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
- $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
-
- if ( $data_loc > 1 ) {
- $self->_load_sector( $data_loc )->free;
- }
- }
-
- $self->clear_entries;
-
- my @slots = $self->read_txn_slots;
- $slots[$self->trans_id-1] = 0;
- $self->write_txn_slots( @slots );
- $self->inc_txn_staleness_counter( $self->trans_id );
- $self->set_trans_id( 0 );
-
- return 1;
-}
+sub rollback { die "rollback must be implemented in a child class" }
=head2 commit( $obj )
=cut
-sub commit {
- my $self = shift;
- my ($obj) = @_;
+sub commit { die "commit must be implemented in a child class" }
- if ( !$self->trans_id ) {
- DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
- }
+=head2 get_next_key( $obj, $prev_key )
- foreach my $entry (@{ $self->get_entries } ) {
- # Overwrite the entry in head with the entry in trans_id
- my $base = $entry
- + $self->hash_size
- + $self->byte_size;
-
- my $head_loc = $self->storage->read_at( $base, $self->byte_size );
- $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
-
- my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
- my $trans_loc = $self->storage->read_at(
- $spot, $self->byte_size,
- );
-
- $self->storage->print_at( $base, $trans_loc );
- $self->storage->print_at(
- $spot,
- pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
- );
-
- if ( $head_loc > 1 ) {
- $self->_load_sector( $head_loc )->free;
- }
- }
+This takes an object that provides _base_offset() and an optional string
+representing the prior key returned via a prior invocation of this method.
- $self->clear_entries;
+This method delegates to C<< DBM::Deep::Iterator->get_next_key() >>.
- my @slots = $self->read_txn_slots;
- $slots[$self->trans_id-1] = 0;
- $self->write_txn_slots( @slots );
- $self->inc_txn_staleness_counter( $self->trans_id );
- $self->set_trans_id( 0 );
+=cut
- return 1;
+# XXX Add staleness here
+sub get_next_key {
+ my $self = shift;
+ my ($obj, $prev_key) = @_;
+
+ # XXX Need to add logic about resetting the iterator if any key in the
+ # reference has changed
+ unless ( defined $prev_key ) {
+ eval "use " . $self->iterator_class; die $@ if $@;
+ $obj->{iterator} = $self->iterator_class->new({
+ base_offset => $obj->_base_offset,
+ engine => $self,
+ });
+ }
+
+ return $obj->{iterator}->get_next_key( $obj );
}
=head2 lock_exclusive()
=head2 unlock()
This takes an object that provides _base_offset(). It will guarantee that
-the storage has released all locks taken.
+the storage has released the most recently-taken lock.
This returns nothing.
=head1 INTERNAL METHODS
-The following methods are internal-use-only to DBM::Deep::Engine.
-
-=cut
-
-=head2 read_txn_slots()
-
-This takes no arguments.
-
-This will return an array with a 1 or 0 in each slot. Each spot represents one
-available transaction. If the slot is 1, that transaction is taken. If it is 0,
-the transaction is available.
+The following methods are internal-use-only to DBM::Deep::Engine and its
+child classes.
=cut
-sub read_txn_slots {
- my $self = shift;
- my $bl = $self->txn_bitfield_len;
- my $num_bits = $bl * 8;
- return split '', unpack( 'b'.$num_bits,
- $self->storage->read_at(
- $self->trans_loc, $bl,
- )
- );
-}
-
-=head2 write_txn_slots( @slots )
-
-This takes an array of 1's and 0's. This array represents the transaction slots
-returned by L</read_txn_slots()>. In other words, the following is true:
-
- @x = read_txn_slots( write_txn_slots( @x ) );
-
-(With the obviously missing object referents added back in.)
-
-=cut
-
-sub write_txn_slots {
- my $self = shift;
- my $num_bits = $self->txn_bitfield_len * 8;
- $self->storage->print_at( $self->trans_loc,
- pack( 'b'.$num_bits, join('', @_) ),
- );
-}
-
-=head2 get_running_txn_ids()
-
-This takes no arguments.
-
-This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
-
-=cut
-
-sub get_running_txn_ids {
- my $self = shift;
- my @transactions = $self->read_txn_slots;
- my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
-}
-
-=head2 get_txn_staleness_counter( $trans_id )
-
-This will return the staleness counter for the given transaction ID. Please see
-L</TRANSACTION STALENESS> for more information.
-
-=cut
-
-sub get_txn_staleness_counter {
- my $self = shift;
- my ($trans_id) = @_;
-
- # Hardcode staleness of 0 for the HEAD
- return 0 unless $trans_id;
-
- return unpack( $StP{$STALE_SIZE},
- $self->storage->read_at(
- $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
- $STALE_SIZE,
- )
- );
-}
-
-=head2 inc_txn_staleness_counter( $trans_id )
-
-This will increment the staleness counter for the given transaction ID. Please see
-L</TRANSACTION STALENESS> for more information.
-
-=cut
-
-sub inc_txn_staleness_counter {
- my $self = shift;
- my ($trans_id) = @_;
-
- # Hardcode staleness of 0 for the HEAD
- return 0 unless $trans_id;
-
- $self->storage->print_at(
- $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
- pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
- );
-}
-
-=head2 get_entries()
-
-This takes no arguments.
-
-This returns a list of all the sectors that have been modified by this transaction.
-
-=cut
-
-sub get_entries {
- my $self = shift;
- return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
-}
-
-=head2 add_entry( $trans_id, $location )
-
-This takes a transaction ID and a file location and marks the sector at that location
-as having been modified by the transaction identified by $trans_id.
-
-This returns nothing.
-
-B<NOTE>: Unlike all the other _entries() methods, there are several cases where
-C<< $trans_id != $self->trans_id >> for this method.
-
-=cut
-
-sub add_entry {
- my $self = shift;
- my ($trans_id, $loc) = @_;
-
- $self->{entries}{$trans_id} ||= {};
- $self->{entries}{$trans_id}{$loc} = undef;
-}
-
-=head2 reindex_entry( $old_loc, $new_loc )
-
-This takes two locations (old and new, respectively). If a location that has been
-modified by this transaction is subsequently reindexed due to a bucketlist
-overflowing, then the entries hash needs to be made aware of this change.
-
-This returns nothing.
-
-=cut
-
-sub reindex_entry {
- my $self = shift;
- my ($old_loc, $new_loc) = @_;
-
- TRANS:
- while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
- if ( exists $locs->{$old_loc} ) {
- delete $locs->{$old_loc};
- $locs->{$new_loc} = undef;
- next TRANS;
- }
- }
-}
-
-=head2 clear_entries()
+=head2 flush()
-This takes no arguments. It will clear the entries list for the running transaction.
+This takes no arguments. It will do everything necessary to flush all things to
+disk. This is usually called during unlock() and setup().
This returns nothing.
=cut
-sub clear_entries {
- my $self = shift;
- delete $self->{entries}{$self->trans_id};
-}
-
-=head2 _write_file_header()
-
-This writes the file header for a new file. This will write the various settings
-that set how the file is interpreted.
-
-=head2 _read_file_header()
-
-This reads the file header from an existing file. This will read the various
-settings that set how the file is interpreted.
-
-=cut
-
-{
- my $header_fixed = length( SIG_FILE ) + 1 + 4 + 4;
- my $this_file_version = 3;
-
- sub _write_file_header {
- my $self = shift;
-
- my $nt = $self->num_txns;
- my $bl = $self->txn_bitfield_len;
-
- my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
-
- my $loc = $self->storage->request_space( $header_fixed + $header_var );
-
- $self->storage->print_at( $loc,
- SIG_FILE,
- SIG_HEADER,
- pack('N', $this_file_version), # At this point, we're at 9 bytes
- pack('N', $header_var), # header size
- # --- Above is $header_fixed. Below is $header_var
- pack('C', $self->byte_size),
-
- # These shenanigans are to allow a 256 within a C
- pack('C', $self->max_buckets - 1),
- pack('C', $self->data_sector_size - 1),
-
- pack('C', $nt),
- pack('C' . $bl, 0 ), # Transaction activeness bitfield
- pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
- pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
- pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
- pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
- );
-
- #XXX Set these less fragilely
- $self->set_trans_loc( $header_fixed + 4 );
- $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
-
- return;
- }
-
- sub _read_file_header {
- my $self = shift;
-
- my $buffer = $self->storage->read_at( 0, $header_fixed );
- return unless length($buffer);
-
- my ($file_signature, $sig_header, $file_version, $size) = unpack(
- 'A4 A N N', $buffer
- );
-
- unless ( $file_signature eq SIG_FILE ) {
- $self->storage->close;
- DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
- }
-
- unless ( $sig_header eq SIG_HEADER ) {
- $self->storage->close;
- DBM::Deep->_throw_error( "Pre-1.00 file version found" );
- }
-
- unless ( $file_version == $this_file_version ) {
- $self->storage->close;
- DBM::Deep->_throw_error(
- "Wrong file version found - " . $file_version .
- " - expected " . $this_file_version
- );
- }
-
- my $buffer2 = $self->storage->read_at( undef, $size );
- my @values = unpack( 'C C C C', $buffer2 );
-
- if ( @values != 4 || grep { !defined } @values ) {
- $self->storage->close;
- DBM::Deep->_throw_error("Corrupted file - bad header");
- }
-
- #XXX Add warnings if values weren't set right
- @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
-
- # These shenangians are to allow a 256 within a C
- $self->{max_buckets} += 1;
- $self->{data_sector_size} += 1;
-
- my $bl = $self->txn_bitfield_len;
-
- my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
- unless ( $size == $header_var ) {
- $self->storage->close;
- DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
- }
-
- $self->set_trans_loc( $header_fixed + scalar(@values) );
- $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
-
- return length($buffer) + length($buffer2);
- }
-}
-
-=head2 _load_sector( $offset )
-
-This will instantiate and return the sector object that represents the data found
-at $offset.
-
-=cut
-
-sub _load_sector {
+sub flush {
my $self = shift;
- my ($offset) = @_;
-
- # Add a catch for offset of 0 or 1
- return if !$offset || $offset <= 1;
- my $type = $self->storage->read_at( $offset, 1 );
- return if $type eq chr(0);
-
- if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
- return DBM::Deep::Engine::Sector::Reference->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- # XXX Don't we need key_md5 here?
- elsif ( $type eq $self->SIG_BLIST ) {
- return DBM::Deep::Engine::Sector::BucketList->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- elsif ( $type eq $self->SIG_INDEX ) {
- return DBM::Deep::Engine::Sector::Index->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- elsif ( $type eq $self->SIG_NULL ) {
- return DBM::Deep::Engine::Sector::Null->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- elsif ( $type eq $self->SIG_DATA ) {
- return DBM::Deep::Engine::Sector::Scalar->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- # This was deleted from under us, so just return and let the caller figure it out.
- elsif ( $type eq $self->SIG_FREE ) {
- return;
- }
-
- DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
-}
-
-=head2 _apply_digest( @stuff )
-
-This will apply the digest methd (default to Digest::MD5::md5) to the arguments
-passed in and return the result.
-
-=cut
+ # Why do we need to have the storage flush? Shouldn't autoflush take care of
+ # things? -RobK, 2008-06-26
+ $self->storage->flush;
-sub _apply_digest {
- my $self = shift;
- return $self->{digest}->(@_);
+ return;
}
-=head2 _add_free_blist_sector( $offset, $size )
-
-=head2 _add_free_data_sector( $offset, $size )
-
-=head2 _add_free_index_sector( $offset, $size )
+=head2 load_sector( $loc )
-These methods are all wrappers around _add_free_sector(), providing the proper
-chain offset ($multiple) for the sector type.
+This takes an id/location/offset and loads the sector based on the engine's
+defined sector type.
=cut
-sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
-sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
-sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
-
-=head2 _add_free_sector( $multiple, $offset, $size )
-
-_add_free_sector() takes the offset into the chains location, the offset of the
-sector, and the size of that sector. It will mark the sector as a free sector
-and put it into the list of sectors that are free of this type for use later.
-
-This returns nothing.
-
-B<NOTE>: $size is unused?
-
-=cut
-
-sub _add_free_sector {
- my $self = shift;
- my ($multiple, $offset, $size) = @_;
-
- my $chains_offset = $multiple * $self->byte_size;
-
- my $storage = $self->storage;
-
- # Increment staleness.
- # XXX Can this increment+modulo be done by "&= 0x1" ?
- my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + SIG_SIZE, $STALE_SIZE ) );
- $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
- $storage->print_at( $offset + SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
-
- my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
+sub load_sector { $_[0]->sector_type->load( @_ ) }
- $storage->print_at( $self->chains_loc + $chains_offset,
- pack( $StP{$self->byte_size}, $offset ),
- );
-
- # Record the old head in the new sector after the signature and staleness counter
- $storage->print_at( $offset + SIG_SIZE + $STALE_SIZE, $old_head );
-}
-
-=head2 _request_blist_sector( $size )
-
-=head2 _request_data_sector( $size )
-
-=head2 _request_index_sector( $size )
+=head2 clear( $obj )
-These methods are all wrappers around _request_sector(), providing the proper
-chain offset ($multiple) for the sector type.
+This takes an object that provides _base_offset() and deletes all its
+elements, returning nothing.
=cut
-sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
-sub _request_data_sector { shift->_request_sector( 1, @_ ) }
-sub _request_index_sector { shift->_request_sector( 2, @_ ) }
-
-=head2 _request_sector( $multiple $size )
+sub clear { die "clear must be implemented in a child class" }
-This takes the offset into the chains location and the size of that sector.
+=head2 cache / clear_cache
-This returns the object with the sector. If there is an available free sector of
-that type, then it will be reused. If there isn't one, then a new one will be
-allocated.
+This is the cache of loaded Reference sectors.
=cut
-sub _request_sector {
- my $self = shift;
- my ($multiple, $size) = @_;
-
- my $chains_offset = $multiple * $self->byte_size;
-
- my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
- my $loc = unpack( $StP{$self->byte_size}, $old_head );
-
- # We don't have any free sectors of the right size, so allocate a new one.
- unless ( $loc ) {
- my $offset = $self->storage->request_space( $size );
+sub cache { $_[0]{cache} ||= {} }
+sub clear_cache { %{$_[0]->cache} = () }
- # Zero out the new sector. This also guarantees correct increases
- # in the filesize.
- $self->storage->print_at( $offset, chr(0) x $size );
+=head2 supports( $option )
- return $offset;
- }
+This returns a boolean depending on if this instance of DBM::Dep supports
+that feature. C<$option> can be one of:
- # Read the new head after the signature and the staleness counter
- my $new_head = $self->storage->read_at( $loc + SIG_SIZE + $STALE_SIZE, $self->byte_size );
- $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
- $self->storage->print_at(
- $loc + SIG_SIZE + $STALE_SIZE,
- pack( $StP{$self->byte_size}, 0 ),
- );
+=over 4
- return $loc;
-}
+=item * transactions
-=head2 flush()
+=item * singletons
-This takes no arguments. It will do everything necessary to flush all things to
-disk. This is usually called during unlock() and setup_fh().
+=back
-This returns nothing.
+Any other value will return false.
=cut
-sub flush {
- my $self = shift;
-
- # Why do we need to have the storage flush? Shouldn't autoflush take care of things?
- # -RobK, 2008-06-26
- $self->storage->flush;
-}
+sub supports { die "supports must be implemented in a child class" }
-=head2 ACCESSORS
+=head1 ACCESSORS
The following are readonly attributes.
=item * storage
-=item * byte_size
-
-=item * hash_size
-
-=item * hash_chars
-
-=item * num_txns
-
-=item * max_buckets
-
-=item * blank_md5
-
-=item * data_sector_size
+=item * sector_type
-=item * txn_bitfield_len
+=item * iterator_class
=back
=cut
-sub storage { $_[0]{storage} }
-sub byte_size { $_[0]{byte_size} }
-sub hash_size { $_[0]{hash_size} }
-sub hash_chars { $_[0]{hash_chars} }
-sub num_txns { $_[0]{num_txns} }
-sub max_buckets { $_[0]{max_buckets} }
-sub blank_md5 { chr(0) x $_[0]->hash_size }
-sub data_sector_size { $_[0]{data_sector_size} }
-
-# This is a calculated value
-sub txn_bitfield_len {
- my $self = shift;
- unless ( exists $self->{txn_bitfield_len} ) {
- my $temp = ($self->num_txns) / 8;
- if ( $temp > int( $temp ) ) {
- $temp = int( $temp ) + 1;
- }
- $self->{txn_bitfield_len} = $temp;
- }
- return $self->{txn_bitfield_len};
-}
-
-=pod
-
-The following are read/write attributes.
-
-=over 4
-
-=item * trans_id / set_trans_id( $new_id )
-
-=item * trans_loc / set_trans_loc( $new_loc )
-
-=item * chains_loc / set_chains_loc( $new_loc )
-
-=back
-
-=cut
-
-sub trans_id { $_[0]{trans_id} }
-sub set_trans_id { $_[0]{trans_id} = $_[1] }
-
-sub trans_loc { $_[0]{trans_loc} }
-sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
-
-sub chains_loc { $_[0]{chains_loc} }
-sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
-
-sub cache { $_[0]{cache} ||= {} }
-sub clear_cache { %{$_[0]->cache} = () }
+sub storage { $_[0]{storage} }
-=head2 _dump_file()
+sub sector_type { die "sector_type must be implemented in a child class" }
+sub iterator_class { die "iterator_class must be implemented in a child class" }
-This method takes no arguments. It's used to print out a textual representation of the DBM::Deep
-DB file. It assumes the file is not-corrupted.
-
-=cut
-
-sub _dump_file {
+# This code is to make sure we write all the values in the $value to the
+# disk and to make sure all changes to $value after the assignment are
+# reflected on disk. This may be counter-intuitive at first, but it is
+# correct dwimmery.
+# NOTE - simply tying $value won't perform a STORE on each value. Hence,
+# the copy to a temp value.
+sub _descend {
my $self = shift;
+ my ($value, $value_sector) = @_;
+ my $r = Scalar::Util::reftype( $value ) || '';
- # Read the header
- my $spot = $self->_read_file_header();
-
- my %types = (
- 0 => 'B',
- 1 => 'D',
- 2 => 'I',
- );
-
- my %sizes = (
- 'D' => $self->data_sector_size,
- 'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
- 'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
- );
-
- my $return = "";
-
- # Header values
- $return .= "NumTxns: " . $self->num_txns . $/;
-
- # Read the free sector chains
- my %sectors;
- foreach my $multiple ( 0 .. 2 ) {
- $return .= "Chains($types{$multiple}):";
- my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
- while ( 1 ) {
- my $loc = unpack(
- $StP{$self->byte_size},
- $self->storage->read_at( $old_loc, $self->byte_size ),
- );
-
- # We're now out of free sectors of this kind.
- unless ( $loc ) {
- last;
- }
-
- $sectors{ $types{$multiple} }{ $loc } = undef;
- $old_loc = $loc + SIG_SIZE + $STALE_SIZE;
- $return .= " $loc";
- }
- $return .= $/;
+ if ( $r eq 'ARRAY' ) {
+ my @temp = @$value;
+ tie @$value, 'DBM::Deep', {
+ base_offset => $value_sector->offset,
+ staleness => $value_sector->staleness,
+ storage => $self->storage,
+ engine => $self,
+ };
+ @$value = @temp;
+ bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
}
-
- SECTOR:
- while ( $spot < $self->storage->{end} ) {
- # Read each sector in order.
- my $sector = $self->_load_sector( $spot );
- if ( !$sector ) {
- # Find it in the free-sectors that were found already
- foreach my $type ( keys %sectors ) {
- if ( exists $sectors{$type}{$spot} ) {
- my $size = $sizes{$type};
- $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
- $spot += $size;
- next SECTOR;
- }
- }
-
- die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
- }
- else {
- $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
- if ( $sector->type eq 'D' ) {
- $return .= ' ' . $sector->data;
- }
- elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
- $return .= ' REF: ' . $sector->get_refcount;
- }
- elsif ( $sector->type eq 'B' ) {
- foreach my $bucket ( $sector->chopped_up ) {
- $return .= "\n ";
- $return .= sprintf "%08d", unpack($StP{$self->byte_size},
- substr( $bucket->[-1], $self->hash_size, $self->byte_size),
- );
- my $l = unpack( $StP{$self->byte_size},
- substr( $bucket->[-1],
- $self->hash_size + $self->byte_size,
- $self->byte_size,
- ),
- );
- $return .= sprintf " %08d", $l;
- foreach my $txn ( 0 .. $self->num_txns - 2 ) {
- my $l = unpack( $StP{$self->byte_size},
- substr( $bucket->[-1],
- $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
- $self->byte_size,
- ),
- );
- $return .= sprintf " %08d", $l;
- }
- }
- }
- $return .= $/;
-
- $spot += $sector->size;
- }
+ elsif ( $r eq 'HASH' ) {
+ my %temp = %$value;
+ tie %$value, 'DBM::Deep', {
+ base_offset => $value_sector->offset,
+ staleness => $value_sector->staleness,
+ storage => $self->storage,
+ engine => $self,
+ };
+ %$value = %temp;
+ bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
}
- return $return;
+ return;
}
1;
--- /dev/null
+package DBM::Deep::Engine::DBI;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+no warnings 'recursion';
+
+use base 'DBM::Deep::Engine';
+
+use DBM::Deep::Sector::DBI ();
+use DBM::Deep::Storage::DBI ();
+
+sub sector_type { 'DBM::Deep::Sector::DBI' }
+sub iterator_class { 'DBM::Deep::Iterator::DBI' }
+
+sub new {
+ my $class = shift;
+ my ($args) = @_;
+
+ $args->{storage} = DBM::Deep::Storage::DBI->new( $args )
+ unless exists $args->{storage};
+
+ my $self = bless {
+ storage => undef,
+ }, $class;
+
+ # Grab the parameters we want to use
+ foreach my $param ( keys %$self ) {
+ next unless exists $args->{$param};
+ $self->{$param} = $args->{$param};
+ }
+
+ return $self;
+}
+
+sub setup {
+ my $self = shift;
+ my ($obj) = @_;
+
+ # Default the id to 1. This means that we will be creating a row if there
+ # isn't one. The assumption is that the row_id=1 cannot never be deleted. I
+ # don't know if this is a good assumption.
+ $obj->{base_offset} ||= 1;
+
+ my ($rows) = $self->storage->read_from(
+ refs => $obj->_base_offset,
+ qw( ref_type ),
+ );
+
+ # We don't have a row yet.
+ unless ( @$rows ) {
+ $self->storage->write_to(
+ refs => $obj->_base_offset,
+ ref_type => $obj->_type,
+ );
+ }
+
+ my $sector = DBM::Deep::Sector::DBI::Reference->new({
+ engine => $self,
+ offset => $obj->_base_offset,
+ });
+}
+
+sub read_value {
+ my $self = shift;
+ my ($obj, $key) = @_;
+
+ my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+ or return;
+
+# if ( $sector->staleness != $obj->_staleness ) {
+# return;
+# }
+
+# my $key_md5 = $self->_apply_digest( $key );
+
+ my $value_sector = $sector->get_data_for({
+ key => $key,
+# key_md5 => $key_md5,
+ allow_head => 1,
+ });
+
+ unless ( $value_sector ) {
+ $value_sector = DBM::Deep::Sector::DBI::Scalar->new({
+ engine => $self,
+ data => undef,
+ data_type => 'S',
+ });
+
+ $sector->write_data({
+# key_md5 => $key_md5,
+ key => $key,
+ value => $value_sector,
+ });
+ }
+
+ return $value_sector->data;
+}
+
+sub get_classname {
+ my $self = shift;
+ my ($obj) = @_;
+
+ my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+ or return;
+
+ return $sector->get_classname;
+}
+
+sub make_reference {
+ my $self = shift;
+ my ($obj, $old_key, $new_key) = @_;
+
+ my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+ or return;
+
+# if ( $sector->staleness != $obj->_staleness ) {
+# return;
+# }
+
+ my $value_sector = $sector->get_data_for({
+ key => $old_key,
+ allow_head => 1,
+ });
+
+ unless ( $value_sector ) {
+ $value_sector = DBM::Deep::Sector::DBI::Scalar->new({
+ engine => $self,
+ data => undef,
+ });
+
+ $sector->write_data({
+ key => $old_key,
+ value => $value_sector,
+ });
+ }
+
+ if ( $value_sector->isa( 'DBM::Deep::Sector::DBI::Reference' ) ) {
+ $sector->write_data({
+ key => $new_key,
+ value => $value_sector,
+ });
+ $value_sector->increment_refcount;
+ }
+ else {
+ $sector->write_data({
+ key => $new_key,
+ value => $value_sector->clone,
+ });
+ }
+
+ return;
+}
+
+# exists returns '', not undefined.
+sub key_exists {
+ my $self = shift;
+ my ($obj, $key) = @_;
+
+ my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+ or return '';
+
+# if ( $sector->staleness != $obj->_staleness ) {
+# return '';
+# }
+
+ my $data = $sector->get_data_for({
+# key_md5 => $self->_apply_digest( $key ),
+ key => $key,
+ allow_head => 1,
+ });
+
+ # exists() returns 1 or '' for true/false.
+ return $data ? 1 : '';
+}
+
+sub delete_key {
+ my $self = shift;
+ my ($obj, $key) = @_;
+
+ my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+ or return '';
+
+# if ( $sector->staleness != $obj->_staleness ) {
+# return '';
+# }
+
+ return $sector->delete_key({
+# key_md5 => $self->_apply_digest( $key ),
+ key => $key,
+ allow_head => 0,
+ });
+}
+
+sub write_value {
+ my $self = shift;
+ my ($obj, $key, $value) = @_;
+
+ my $r = Scalar::Util::reftype( $value ) || '';
+ {
+ last if $r eq '';
+ last if $r eq 'HASH';
+ last if $r eq 'ARRAY';
+
+ DBM::Deep->_throw_error(
+ "Storage of references of type '$r' is not supported."
+ );
+ }
+
+ # Load the reference entry
+ # Determine if the row was deleted under us
+ #
+
+ my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+ or die "Cannot load sector at '@{[$obj->_base_offset]}'\n";;
+
+ my ($type, $class);
+ if ( $r eq 'ARRAY' || $r eq 'HASH' ) {
+ my $tmpvar;
+ if ( $r eq 'ARRAY' ) {
+ $tmpvar = tied @$value;
+ } elsif ( $r eq 'HASH' ) {
+ $tmpvar = tied %$value;
+ }
+
+ if ( $tmpvar ) {
+ my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
+
+ unless ( $is_dbm_deep ) {
+ DBM::Deep->_throw_error( "Cannot store something that is tied." );
+ }
+
+ unless ( $tmpvar->_engine->storage == $self->storage ) {
+ DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
+ }
+
+ # Load $tmpvar's sector
+
+ # First, verify if we're storing the same thing to this spot. If we
+ # are, then this should be a no-op. -EJS, 2008-05-19
+
+ # See whether or not we are storing ourselves to ourself.
+ # Write the sector as data in this reference (keyed by $key)
+ my $value_sector = $self->load_sector( $tmpvar->_base_offset, 'refs' );
+ $sector->write_data({
+ key => $key,
+# key_md5 => $self->_apply_digest( $key ),
+ value => $value_sector,
+ });
+ $value_sector->increment_refcount;
+
+ return 1;
+ }
+
+ $type = substr( $r, 0, 1 );
+ $class = 'DBM::Deep::Sector::DBI::Reference';
+ }
+ else {
+ if ( tied($value) ) {
+ DBM::Deep->_throw_error( "Cannot store something that is tied." );
+ }
+
+ $class = 'DBM::Deep::Sector::DBI::Scalar';
+ $type = 'S';
+ }
+
+ # Create this after loading the reference sector in case something bad
+ # happens. This way, we won't allocate value sector(s) needlessly.
+ my $value_sector = $class->new({
+ engine => $self,
+ data => $value,
+ type => $type,
+ });
+
+ $sector->write_data({
+ key => $key,
+# key_md5 => $self->_apply_digest( $key ),
+ value => $value_sector,
+ });
+
+ $self->_descend( $value, $value_sector );
+
+ return 1;
+}
+
+#sub begin_work {
+# my $self = shift;
+# die "Transactions are not supported by this engine"
+# unless $self->supports('transactions');
+#
+# if ( $self->in_txn ) {
+# DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
+# }
+#
+# $self->storage->begin_work;
+#
+# $self->in_txn( 1 );
+#
+# return 1;
+#}
+#
+#sub rollback {
+# my $self = shift;
+# die "Transactions are not supported by this engine"
+# unless $self->supports('transactions');
+#
+# if ( !$self->in_txn ) {
+# DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
+# }
+#
+# $self->storage->rollback;
+#
+# $self->in_txn( 0 );
+#
+# return 1;
+#}
+#
+#sub commit {
+# my $self = shift;
+# die "Transactions are not supported by this engine"
+# unless $self->supports('transactions');
+#
+# if ( !$self->in_txn ) {
+# DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
+# }
+#
+# $self->storage->commit;
+#
+# $self->in_txn( 0 );
+#
+# return 1;
+#}
+#
+#sub in_txn {
+# my $self = shift;
+# $self->{in_txn} = shift if @_;
+# $self->{in_txn};
+#}
+
+sub supports {
+ my $self = shift;
+ my ($feature) = @_;
+
+ return if $feature eq 'transactions';
+ return 1 if $feature eq 'singletons';
+ return;
+}
+
+sub clear {
+ my $self = shift;
+ my $obj = shift;
+
+ my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
+ or return;
+
+ $sector->clear;
+
+ return;
+}
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Engine::File;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+no warnings 'recursion';
+
+use base qw( DBM::Deep::Engine );
+
+use Scalar::Util ();
+
+use DBM::Deep::Null ();
+use DBM::Deep::Sector::File ();
+use DBM::Deep::Storage::File ();
+
+sub sector_type { 'DBM::Deep::Sector::File' }
+sub iterator_class { 'DBM::Deep::Iterator::File' }
+
+my $STALE_SIZE = 2;
+
+# Setup file and tag signatures. These should never change.
+sub SIG_FILE () { 'DPDB' }
+sub SIG_HEADER () { 'h' }
+sub SIG_NULL () { 'N' }
+sub SIG_DATA () { 'D' }
+sub SIG_INDEX () { 'I' }
+sub SIG_BLIST () { 'B' }
+sub SIG_FREE () { 'F' }
+sub SIG_SIZE () { 1 }
+# SIG_HASH and SIG_ARRAY are defined in DBM::Deep::Engine
+
+# Please refer to the pack() documentation for further information
+my %StP = (
+ 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
+ 2 => 'n', # Unsigned short in "network" (big-endian) order
+ 4 => 'N', # Unsigned long in "network" (big-endian) order
+ 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
+);
+
+=head1 NAME
+
+DBM::Deep::Engine::File
+
+=head1 PURPOSE
+
+This is the engine for use with L<DBM::Deep::Storage::File>.
+
+=head1 EXTERNAL METHODS
+
+=head2 new()
+
+This takes a set of args. These args are described in the documentation for
+L<DBM::Deep/new>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my ($args) = @_;
+
+ $args->{storage} = DBM::Deep::Storage::File->new( $args )
+ unless exists $args->{storage};
+
+ my $self = bless {
+ byte_size => 4,
+
+ digest => undef,
+ hash_size => 16, # In bytes
+ hash_chars => 256, # Number of chars the algorithm uses per byte
+ max_buckets => 16,
+ num_txns => 1, # The HEAD
+ trans_id => 0, # Default to the HEAD
+
+ data_sector_size => 64, # Size in bytes of each data sector
+
+ entries => {}, # This is the list of entries for transactions
+ storage => undef,
+ }, $class;
+
+ # Never allow byte_size to be set directly.
+ delete $args->{byte_size};
+ if ( defined $args->{pack_size} ) {
+ if ( lc $args->{pack_size} eq 'small' ) {
+ $args->{byte_size} = 2;
+ }
+ elsif ( lc $args->{pack_size} eq 'medium' ) {
+ $args->{byte_size} = 4;
+ }
+ elsif ( lc $args->{pack_size} eq 'large' ) {
+ $args->{byte_size} = 8;
+ }
+ else {
+ DBM::Deep->_throw_error( "Unknown pack_size value: '$args->{pack_size}'" );
+ }
+ }
+
+ # Grab the parameters we want to use
+ foreach my $param ( keys %$self ) {
+ next unless exists $args->{$param};
+ $self->{$param} = $args->{$param};
+ }
+
+ my %validations = (
+ max_buckets => { floor => 16, ceil => 256 },
+ num_txns => { floor => 1, ceil => 255 },
+ data_sector_size => { floor => 32, ceil => 256 },
+ );
+
+ while ( my ($attr, $c) = each %validations ) {
+ if ( !defined $self->{$attr}
+ || !length $self->{$attr}
+ || $self->{$attr} =~ /\D/
+ || $self->{$attr} < $c->{floor}
+ ) {
+ $self->{$attr} = '(undef)' if !defined $self->{$attr};
+ warn "Floor of $attr is $c->{floor}. Setting it to $c->{floor} from '$self->{$attr}'\n";
+ $self->{$attr} = $c->{floor};
+ }
+ elsif ( $self->{$attr} > $c->{ceil} ) {
+ warn "Ceiling of $attr is $c->{ceil}. Setting it to $c->{ceil} from '$self->{$attr}'\n";
+ $self->{$attr} = $c->{ceil};
+ }
+ }
+
+ if ( !$self->{digest} ) {
+ require Digest::MD5;
+ $self->{digest} = \&Digest::MD5::md5;
+ }
+
+ return $self;
+}
+
+sub read_value {
+ my $self = shift;
+ my ($obj, $key) = @_;
+
+ # This will be a Reference sector
+ my $sector = $self->load_sector( $obj->_base_offset )
+ or return;
+
+ if ( $sector->staleness != $obj->_staleness ) {
+ return;
+ }
+
+ my $key_md5 = $self->_apply_digest( $key );
+
+ my $value_sector = $sector->get_data_for({
+ key_md5 => $key_md5,
+ allow_head => 1,
+ });
+
+ unless ( $value_sector ) {
+ $value_sector = DBM::Deep::Sector::File::Null->new({
+ engine => $self,
+ data => undef,
+ });
+
+ $sector->write_data({
+ key_md5 => $key_md5,
+ key => $key,
+ value => $value_sector,
+ });
+ }
+
+ return $value_sector->data;
+}
+
+sub get_classname {
+ my $self = shift;
+ my ($obj) = @_;
+
+ # This will be a Reference sector
+ my $sector = $self->load_sector( $obj->_base_offset )
+ or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
+
+ if ( $sector->staleness != $obj->_staleness ) {
+ return;
+ }
+
+ return $sector->get_classname;
+}
+
+sub make_reference {
+ my $self = shift;
+ my ($obj, $old_key, $new_key) = @_;
+
+ # This will be a Reference sector
+ my $sector = $self->load_sector( $obj->_base_offset )
+ or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
+
+ if ( $sector->staleness != $obj->_staleness ) {
+ return;
+ }
+
+ my $old_md5 = $self->_apply_digest( $old_key );
+
+ my $value_sector = $sector->get_data_for({
+ key_md5 => $old_md5,
+ allow_head => 1,
+ });
+
+ unless ( $value_sector ) {
+ $value_sector = DBM::Deep::Sector::File::Null->new({
+ engine => $self,
+ data => undef,
+ });
+
+ $sector->write_data({
+ key_md5 => $old_md5,
+ key => $old_key,
+ value => $value_sector,
+ });
+ }
+
+ if ( $value_sector->isa( 'DBM::Deep::Sector::File::Reference' ) ) {
+ $sector->write_data({
+ key => $new_key,
+ key_md5 => $self->_apply_digest( $new_key ),
+ value => $value_sector,
+ });
+ $value_sector->increment_refcount;
+ }
+ else {
+ $sector->write_data({
+ key => $new_key,
+ key_md5 => $self->_apply_digest( $new_key ),
+ value => $value_sector->clone,
+ });
+ }
+
+ return;
+}
+
+# exists returns '', not undefined.
+sub key_exists {
+ my $self = shift;
+ my ($obj, $key) = @_;
+
+ # This will be a Reference sector
+ my $sector = $self->load_sector( $obj->_base_offset )
+ or return '';
+
+ if ( $sector->staleness != $obj->_staleness ) {
+ return '';
+ }
+
+ my $data = $sector->get_data_for({
+ key_md5 => $self->_apply_digest( $key ),
+ allow_head => 1,
+ });
+
+ # exists() returns 1 or '' for true/false.
+ return $data ? 1 : '';
+}
+
+sub delete_key {
+ my $self = shift;
+ my ($obj, $key) = @_;
+
+ my $sector = $self->load_sector( $obj->_base_offset )
+ or return;
+
+ if ( $sector->staleness != $obj->_staleness ) {
+ return;
+ }
+
+ return $sector->delete_key({
+ key_md5 => $self->_apply_digest( $key ),
+ allow_head => 0,
+ });
+}
+
+sub write_value {
+ my $self = shift;
+ my ($obj, $key, $value) = @_;
+
+ my $r = Scalar::Util::reftype( $value ) || '';
+ {
+ last if $r eq '';
+ last if $r eq 'HASH';
+ last if $r eq 'ARRAY';
+
+ DBM::Deep->_throw_error(
+ "Storage of references of type '$r' is not supported."
+ );
+ }
+
+ # This will be a Reference sector
+ my $sector = $self->load_sector( $obj->_base_offset )
+ or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
+
+ if ( $sector->staleness != $obj->_staleness ) {
+ DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
+ }
+
+ my ($class, $type);
+ if ( !defined $value ) {
+ $class = 'DBM::Deep::Sector::File::Null';
+ }
+ elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
+ my $tmpvar;
+ if ( $r eq 'ARRAY' ) {
+ $tmpvar = tied @$value;
+ } elsif ( $r eq 'HASH' ) {
+ $tmpvar = tied %$value;
+ }
+
+ if ( $tmpvar ) {
+ my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
+
+ unless ( $is_dbm_deep ) {
+ DBM::Deep->_throw_error( "Cannot store something that is tied." );
+ }
+
+ unless ( $tmpvar->_engine->storage == $self->storage ) {
+ DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
+ }
+
+ # First, verify if we're storing the same thing to this spot. If we
+ # are, then this should be a no-op. -EJS, 2008-05-19
+ my $loc = $sector->get_data_location_for({
+ key_md5 => $self->_apply_digest( $key ),
+ allow_head => 1,
+ });
+
+ if ( defined($loc) && $loc == $tmpvar->_base_offset ) {
+ return 1;
+ }
+
+ #XXX Can this use $loc?
+ my $value_sector = $self->load_sector( $tmpvar->_base_offset );
+ $sector->write_data({
+ key => $key,
+ key_md5 => $self->_apply_digest( $key ),
+ value => $value_sector,
+ });
+ $value_sector->increment_refcount;
+
+ return 1;
+ }
+
+ $class = 'DBM::Deep::Sector::File::Reference';
+ $type = substr( $r, 0, 1 );
+ }
+ else {
+ if ( tied($value) ) {
+ DBM::Deep->_throw_error( "Cannot store something that is tied." );
+ }
+ $class = 'DBM::Deep::Sector::File::Scalar';
+ }
+
+ # Create this after loading the reference sector in case something bad
+ # happens. This way, we won't allocate value sector(s) needlessly.
+ my $value_sector = $class->new({
+ engine => $self,
+ data => $value,
+ type => $type,
+ });
+
+ $sector->write_data({
+ key => $key,
+ key_md5 => $self->_apply_digest( $key ),
+ value => $value_sector,
+ });
+
+ $self->_descend( $value, $value_sector );
+
+ return 1;
+}
+
+sub setup {
+ my $self = shift;
+ my ($obj) = @_;
+
+ # We're opening the file.
+ unless ( $obj->_base_offset ) {
+ my $bytes_read = $self->_read_file_header;
+
+ # Creating a new file
+ unless ( $bytes_read ) {
+ $self->_write_file_header;
+
+ # 1) Create Array/Hash entry
+ my $initial_reference = DBM::Deep::Sector::File::Reference->new({
+ engine => $self,
+ type => $obj->_type,
+ });
+ $obj->{base_offset} = $initial_reference->offset;
+ $obj->{staleness} = $initial_reference->staleness;
+
+ $self->storage->flush;
+ }
+ # Reading from an existing file
+ else {
+ $obj->{base_offset} = $bytes_read;
+ my $initial_reference = DBM::Deep::Sector::File::Reference->new({
+ engine => $self,
+ offset => $obj->_base_offset,
+ });
+ unless ( $initial_reference ) {
+ DBM::Deep->_throw_error("Corrupted file, no master index record");
+ }
+
+ unless ($obj->_type eq $initial_reference->type) {
+ DBM::Deep->_throw_error("File type mismatch");
+ }
+
+ $obj->{staleness} = $initial_reference->staleness;
+ }
+ }
+
+ $self->storage->set_inode;
+
+ return 1;
+}
+
+sub begin_work {
+ my $self = shift;
+ my ($obj) = @_;
+
+ if ( $self->trans_id ) {
+ DBM::Deep->_throw_error( "Cannot begin_work within an active transaction" );
+ }
+
+ my @slots = $self->read_txn_slots;
+ my $found;
+ for my $i ( 0 .. $#slots ) {
+ next if $slots[$i];
+
+ $slots[$i] = 1;
+ $self->set_trans_id( $i + 1 );
+ $found = 1;
+ last;
+ }
+ unless ( $found ) {
+ DBM::Deep->_throw_error( "Cannot allocate transaction ID" );
+ }
+ $self->write_txn_slots( @slots );
+
+ if ( !$self->trans_id ) {
+ DBM::Deep->_throw_error( "Cannot begin_work - no available transactions" );
+ }
+
+ return;
+}
+
+sub rollback {
+ my $self = shift;
+ my ($obj) = @_;
+
+ if ( !$self->trans_id ) {
+ DBM::Deep->_throw_error( "Cannot rollback without an active transaction" );
+ }
+
+ # Each entry is the file location for a bucket that has a modification for
+ # this transaction. The entries need to be expunged.
+ foreach my $entry (@{ $self->get_entries } ) {
+ # Remove the entry here
+ my $read_loc = $entry
+ + $self->hash_size
+ + $self->byte_size
+ + $self->byte_size
+ + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
+
+ my $data_loc = $self->storage->read_at( $read_loc, $self->byte_size );
+ $data_loc = unpack( $StP{$self->byte_size}, $data_loc );
+ $self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
+
+ if ( $data_loc > 1 ) {
+ $self->load_sector( $data_loc )->free;
+ }
+ }
+
+ $self->clear_entries;
+
+ my @slots = $self->read_txn_slots;
+ $slots[$self->trans_id-1] = 0;
+ $self->write_txn_slots( @slots );
+ $self->inc_txn_staleness_counter( $self->trans_id );
+ $self->set_trans_id( 0 );
+
+ return 1;
+}
+
+sub commit {
+ my $self = shift;
+ my ($obj) = @_;
+
+ if ( !$self->trans_id ) {
+ DBM::Deep->_throw_error( "Cannot commit without an active transaction" );
+ }
+
+ foreach my $entry (@{ $self->get_entries } ) {
+ # Overwrite the entry in head with the entry in trans_id
+ my $base = $entry
+ + $self->hash_size
+ + $self->byte_size;
+
+ my $head_loc = $self->storage->read_at( $base, $self->byte_size );
+ $head_loc = unpack( $StP{$self->byte_size}, $head_loc );
+
+ my $spot = $base + $self->byte_size + ($self->trans_id - 1) * ( $self->byte_size + $STALE_SIZE );
+ my $trans_loc = $self->storage->read_at(
+ $spot, $self->byte_size,
+ );
+
+ $self->storage->print_at( $base, $trans_loc );
+ $self->storage->print_at(
+ $spot,
+ pack( $StP{$self->byte_size} . ' ' . $StP{$STALE_SIZE}, (0) x 2 ),
+ );
+
+ if ( $head_loc > 1 ) {
+ $self->load_sector( $head_loc )->free;
+ }
+ }
+
+ $self->clear_entries;
+
+ my @slots = $self->read_txn_slots;
+ $slots[$self->trans_id-1] = 0;
+ $self->write_txn_slots( @slots );
+ $self->inc_txn_staleness_counter( $self->trans_id );
+ $self->set_trans_id( 0 );
+
+ return 1;
+}
+
+=head1 INTERNAL METHODS
+
+The following methods are internal-use-only to DBM::Deep::Engine::File.
+
+=cut
+
+=head2 read_txn_slots()
+
+This takes no arguments.
+
+This will return an array with a 1 or 0 in each slot. Each spot represents one
+available transaction. If the slot is 1, that transaction is taken. If it is 0,
+the transaction is available.
+
+=cut
+
+sub read_txn_slots {
+ my $self = shift;
+ my $bl = $self->txn_bitfield_len;
+ my $num_bits = $bl * 8;
+ return split '', unpack( 'b'.$num_bits,
+ $self->storage->read_at(
+ $self->trans_loc, $bl,
+ )
+ );
+}
+
+=head2 write_txn_slots( @slots )
+
+This takes an array of 1's and 0's. This array represents the transaction slots
+returned by L</read_txn_slots()>. In other words, the following is true:
+
+ @x = read_txn_slots( write_txn_slots( @x ) );
+
+(With the obviously missing object referents added back in.)
+
+=cut
+
+sub write_txn_slots {
+ my $self = shift;
+ my $num_bits = $self->txn_bitfield_len * 8;
+ $self->storage->print_at( $self->trans_loc,
+ pack( 'b'.$num_bits, join('', @_) ),
+ );
+}
+
+=head2 get_running_txn_ids()
+
+This takes no arguments.
+
+This will return an array of taken transaction IDs. This wraps L</read_txn_slots()>.
+
+=cut
+
+sub get_running_txn_ids {
+ my $self = shift;
+ my @transactions = $self->read_txn_slots;
+ my @trans_ids = map { $_+1 } grep { $transactions[$_] } 0 .. $#transactions;
+}
+
+=head2 get_txn_staleness_counter( $trans_id )
+
+This will return the staleness counter for the given transaction ID. Please see
+L</TRANSACTION STALENESS> for more information.
+
+=cut
+
+sub get_txn_staleness_counter {
+ my $self = shift;
+ my ($trans_id) = @_;
+
+ # Hardcode staleness of 0 for the HEAD
+ return 0 unless $trans_id;
+
+ return unpack( $StP{$STALE_SIZE},
+ $self->storage->read_at(
+ $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
+ $STALE_SIZE,
+ )
+ );
+}
+
+=head2 inc_txn_staleness_counter( $trans_id )
+
+This will increment the staleness counter for the given transaction ID. Please see
+L</TRANSACTION STALENESS> for more information.
+
+=cut
+
+sub inc_txn_staleness_counter {
+ my $self = shift;
+ my ($trans_id) = @_;
+
+ # Hardcode staleness of 0 for the HEAD
+ return 0 unless $trans_id;
+
+ $self->storage->print_at(
+ $self->trans_loc + $self->txn_bitfield_len + $STALE_SIZE * ($trans_id - 1),
+ pack( $StP{$STALE_SIZE}, $self->get_txn_staleness_counter( $trans_id ) + 1 ),
+ );
+}
+
+=head2 get_entries()
+
+This takes no arguments.
+
+This returns a list of all the sectors that have been modified by this transaction.
+
+=cut
+
+sub get_entries {
+ my $self = shift;
+ return [ keys %{ $self->{entries}{$self->trans_id} ||= {} } ];
+}
+
+=head2 add_entry( $trans_id, $location )
+
+This takes a transaction ID and a file location and marks the sector at that
+location as having been modified by the transaction identified by $trans_id.
+
+This returns nothing.
+
+B<NOTE>: Unlike all the other _entries() methods, there are several cases where
+C<< $trans_id != $self->trans_id >> for this method.
+
+=cut
+
+sub add_entry {
+ my $self = shift;
+ my ($trans_id, $loc) = @_;
+
+ $self->{entries}{$trans_id} ||= {};
+ $self->{entries}{$trans_id}{$loc} = undef;
+}
+
+=head2 reindex_entry( $old_loc, $new_loc )
+
+This takes two locations (old and new, respectively). If a location that has
+been modified by this transaction is subsequently reindexed due to a bucketlist
+overflowing, then the entries hash needs to be made aware of this change.
+
+This returns nothing.
+
+=cut
+
+sub reindex_entry {
+ my $self = shift;
+ my ($old_loc, $new_loc) = @_;
+
+ TRANS:
+ while ( my ($trans_id, $locs) = each %{ $self->{entries} } ) {
+ if ( exists $locs->{$old_loc} ) {
+ delete $locs->{$old_loc};
+ $locs->{$new_loc} = undef;
+ next TRANS;
+ }
+ }
+}
+
+=head2 clear_entries()
+
+This takes no arguments. It will clear the entries list for the running
+transaction.
+
+This returns nothing.
+
+=cut
+
+sub clear_entries {
+ my $self = shift;
+ delete $self->{entries}{$self->trans_id};
+}
+
+=head2 _write_file_header()
+
+This writes the file header for a new file. This will write the various settings
+that set how the file is interpreted.
+
+=head2 _read_file_header()
+
+This reads the file header from an existing file. This will read the various
+settings that set how the file is interpreted.
+
+=cut
+
+{
+ my $header_fixed = length( __PACKAGE__->SIG_FILE ) + 1 + 4 + 4;
+ my $this_file_version = 3;
+
+ sub _write_file_header {
+ my $self = shift;
+
+ my $nt = $self->num_txns;
+ my $bl = $self->txn_bitfield_len;
+
+ my $header_var = 1 + 1 + 1 + 1 + $bl + $STALE_SIZE * ($nt - 1) + 3 * $self->byte_size;
+
+ my $loc = $self->storage->request_space( $header_fixed + $header_var );
+
+ $self->storage->print_at( $loc,
+ $self->SIG_FILE,
+ $self->SIG_HEADER,
+ pack('N', $this_file_version), # At this point, we're at 9 bytes
+ pack('N', $header_var), # header size
+ # --- Above is $header_fixed. Below is $header_var
+ pack('C', $self->byte_size),
+
+ # These shenanigans are to allow a 256 within a C
+ pack('C', $self->max_buckets - 1),
+ pack('C', $self->data_sector_size - 1),
+
+ pack('C', $nt),
+ pack('C' . $bl, 0 ), # Transaction activeness bitfield
+ pack($StP{$STALE_SIZE}.($nt-1), 0 x ($nt-1) ), # Transaction staleness counters
+ pack($StP{$self->byte_size}, 0), # Start of free chain (blist size)
+ pack($StP{$self->byte_size}, 0), # Start of free chain (data size)
+ pack($StP{$self->byte_size}, 0), # Start of free chain (index size)
+ );
+
+ #XXX Set these less fragilely
+ $self->set_trans_loc( $header_fixed + 4 );
+ $self->set_chains_loc( $header_fixed + 4 + $bl + $STALE_SIZE * ($nt-1) );
+
+ return;
+ }
+
+ sub _read_file_header {
+ my $self = shift;
+
+ my $buffer = $self->storage->read_at( 0, $header_fixed );
+ return unless length($buffer);
+
+ my ($file_signature, $sig_header, $file_version, $size) = unpack(
+ 'A4 A N N', $buffer
+ );
+
+ unless ( $file_signature eq $self->SIG_FILE ) {
+ $self->storage->close;
+ DBM::Deep->_throw_error( "Signature not found -- file is not a Deep DB" );
+ }
+
+ unless ( $sig_header eq $self->SIG_HEADER ) {
+ $self->storage->close;
+ DBM::Deep->_throw_error( "Pre-1.00 file version found" );
+ }
+
+ unless ( $file_version == $this_file_version ) {
+ $self->storage->close;
+ DBM::Deep->_throw_error(
+ "Wrong file version found - " . $file_version .
+ " - expected " . $this_file_version
+ );
+ }
+
+ my $buffer2 = $self->storage->read_at( undef, $size );
+ my @values = unpack( 'C C C C', $buffer2 );
+
+ if ( @values != 4 || grep { !defined } @values ) {
+ $self->storage->close;
+ DBM::Deep->_throw_error("Corrupted file - bad header");
+ }
+
+ #XXX Add warnings if values weren't set right
+ @{$self}{qw(byte_size max_buckets data_sector_size num_txns)} = @values;
+
+ # These shenangians are to allow a 256 within a C
+ $self->{max_buckets} += 1;
+ $self->{data_sector_size} += 1;
+
+ my $bl = $self->txn_bitfield_len;
+
+ my $header_var = scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) + 3 * $self->byte_size;
+ unless ( $size == $header_var ) {
+ $self->storage->close;
+ DBM::Deep->_throw_error( "Unexpected size found ($size <-> $header_var)." );
+ }
+
+ $self->set_trans_loc( $header_fixed + scalar(@values) );
+ $self->set_chains_loc( $header_fixed + scalar(@values) + $bl + $STALE_SIZE * ($self->num_txns - 1) );
+
+ return length($buffer) + length($buffer2);
+ }
+}
+
+=head2 _apply_digest( @stuff )
+
+This will apply the digest methd (default to Digest::MD5::md5) to the arguments
+passed in and return the result.
+
+=cut
+
+sub _apply_digest {
+ my $self = shift;
+ return $self->{digest}->(@_);
+}
+
+=head2 _add_free_blist_sector( $offset, $size )
+
+=head2 _add_free_data_sector( $offset, $size )
+
+=head2 _add_free_index_sector( $offset, $size )
+
+These methods are all wrappers around _add_free_sector(), providing the proper
+chain offset ($multiple) for the sector type.
+
+=cut
+
+sub _add_free_blist_sector { shift->_add_free_sector( 0, @_ ) }
+sub _add_free_data_sector { shift->_add_free_sector( 1, @_ ) }
+sub _add_free_index_sector { shift->_add_free_sector( 2, @_ ) }
+
+=head2 _add_free_sector( $multiple, $offset, $size )
+
+_add_free_sector() takes the offset into the chains location, the offset of the
+sector, and the size of that sector. It will mark the sector as a free sector
+and put it into the list of sectors that are free of this type for use later.
+
+This returns nothing.
+
+B<NOTE>: $size is unused?
+
+=cut
+
+sub _add_free_sector {
+ my $self = shift;
+ my ($multiple, $offset, $size) = @_;
+
+ my $chains_offset = $multiple * $self->byte_size;
+
+ my $storage = $self->storage;
+
+ # Increment staleness.
+ # XXX Can this increment+modulo be done by "&= 0x1" ?
+ my $staleness = unpack( $StP{$STALE_SIZE}, $storage->read_at( $offset + $self->SIG_SIZE, $STALE_SIZE ) );
+ $staleness = ($staleness + 1 ) % ( 2 ** ( 8 * $STALE_SIZE ) );
+ $storage->print_at( $offset + $self->SIG_SIZE, pack( $StP{$STALE_SIZE}, $staleness ) );
+
+ my $old_head = $storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
+
+ $storage->print_at( $self->chains_loc + $chains_offset,
+ pack( $StP{$self->byte_size}, $offset ),
+ );
+
+ # Record the old head in the new sector after the signature and staleness counter
+ $storage->print_at( $offset + $self->SIG_SIZE + $STALE_SIZE, $old_head );
+}
+
+=head2 _request_blist_sector( $size )
+
+=head2 _request_data_sector( $size )
+
+=head2 _request_index_sector( $size )
+
+These methods are all wrappers around _request_sector(), providing the proper
+chain offset ($multiple) for the sector type.
+
+=cut
+
+sub _request_blist_sector { shift->_request_sector( 0, @_ ) }
+sub _request_data_sector { shift->_request_sector( 1, @_ ) }
+sub _request_index_sector { shift->_request_sector( 2, @_ ) }
+
+=head2 _request_sector( $multiple $size )
+
+This takes the offset into the chains location and the size of that sector.
+
+This returns the object with the sector. If there is an available free sector of
+that type, then it will be reused. If there isn't one, then a new one will be
+allocated.
+
+=cut
+
+sub _request_sector {
+ my $self = shift;
+ my ($multiple, $size) = @_;
+
+ my $chains_offset = $multiple * $self->byte_size;
+
+ my $old_head = $self->storage->read_at( $self->chains_loc + $chains_offset, $self->byte_size );
+ my $loc = unpack( $StP{$self->byte_size}, $old_head );
+
+ # We don't have any free sectors of the right size, so allocate a new one.
+ unless ( $loc ) {
+ my $offset = $self->storage->request_space( $size );
+
+ # Zero out the new sector. This also guarantees correct increases
+ # in the filesize.
+ $self->storage->print_at( $offset, chr(0) x $size );
+
+ return $offset;
+ }
+
+ # Read the new head after the signature and the staleness counter
+ my $new_head = $self->storage->read_at( $loc + $self->SIG_SIZE + $STALE_SIZE, $self->byte_size );
+ $self->storage->print_at( $self->chains_loc + $chains_offset, $new_head );
+ $self->storage->print_at(
+ $loc + $self->SIG_SIZE + $STALE_SIZE,
+ pack( $StP{$self->byte_size}, 0 ),
+ );
+
+ return $loc;
+}
+
+=head2 ACCESSORS
+
+The following are readonly attributes.
+
+=over 4
+
+=item * byte_size
+
+=item * hash_size
+
+=item * hash_chars
+
+=item * num_txns
+
+=item * max_buckets
+
+=item * blank_md5
+
+=item * data_sector_size
+
+=item * txn_bitfield_len
+
+=back
+
+=cut
+
+sub byte_size { $_[0]{byte_size} }
+sub hash_size { $_[0]{hash_size} }
+sub hash_chars { $_[0]{hash_chars} }
+sub num_txns { $_[0]{num_txns} }
+sub max_buckets { $_[0]{max_buckets} }
+sub blank_md5 { chr(0) x $_[0]->hash_size }
+sub data_sector_size { $_[0]{data_sector_size} }
+
+# This is a calculated value
+sub txn_bitfield_len {
+ my $self = shift;
+ unless ( exists $self->{txn_bitfield_len} ) {
+ my $temp = ($self->num_txns) / 8;
+ if ( $temp > int( $temp ) ) {
+ $temp = int( $temp ) + 1;
+ }
+ $self->{txn_bitfield_len} = $temp;
+ }
+ return $self->{txn_bitfield_len};
+}
+
+=pod
+
+The following are read/write attributes.
+
+=over 4
+
+=item * trans_id / set_trans_id( $new_id )
+
+=item * trans_loc / set_trans_loc( $new_loc )
+
+=item * chains_loc / set_chains_loc( $new_loc )
+
+=back
+
+=cut
+
+sub trans_id { $_[0]{trans_id} }
+sub set_trans_id { $_[0]{trans_id} = $_[1] }
+
+sub trans_loc { $_[0]{trans_loc} }
+sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
+
+sub chains_loc { $_[0]{chains_loc} }
+sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
+
+sub supports {
+ shift;
+ my ($feature) = @_;
+
+ return 1 if $feature eq 'transactions';
+ return if $feature eq 'singletones';
+ return;
+}
+
+sub clear {
+ my $self = shift;
+ my $obj = shift;
+
+ my $sector = $self->load_sector( $obj->_base_offset )
+ or return;
+
+ return unless $sector->staleness == $obj->_staleness;
+
+ $sector->clear;
+
+ return;
+}
+
+=head2 _dump_file()
+
+This method takes no arguments. It's used to print out a textual representation
+of the DBM::Deep DB file. It assumes the file is not-corrupted.
+
+=cut
+
+sub _dump_file {
+ my $self = shift;
+
+ # Read the header
+ my $spot = $self->_read_file_header();
+
+ my %types = (
+ 0 => 'B',
+ 1 => 'D',
+ 2 => 'I',
+ );
+
+ my %sizes = (
+ 'D' => $self->data_sector_size,
+ 'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
+ 'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
+ );
+
+ my $return = "";
+
+ # Header values
+ $return .= "NumTxns: " . $self->num_txns . $/;
+
+ # Read the free sector chains
+ my %sectors;
+ foreach my $multiple ( 0 .. 2 ) {
+ $return .= "Chains($types{$multiple}):";
+ my $old_loc = $self->chains_loc + $multiple * $self->byte_size;
+ while ( 1 ) {
+ my $loc = unpack(
+ $StP{$self->byte_size},
+ $self->storage->read_at( $old_loc, $self->byte_size ),
+ );
+
+ # We're now out of free sectors of this kind.
+ unless ( $loc ) {
+ last;
+ }
+
+ $sectors{ $types{$multiple} }{ $loc } = undef;
+ $old_loc = $loc + $self->SIG_SIZE + $STALE_SIZE;
+ $return .= " $loc";
+ }
+ $return .= $/;
+ }
+
+ SECTOR:
+ while ( $spot < $self->storage->{end} ) {
+ # Read each sector in order.
+ my $sector = $self->load_sector( $spot );
+ if ( !$sector ) {
+ # Find it in the free-sectors that were found already
+ foreach my $type ( keys %sectors ) {
+ if ( exists $sectors{$type}{$spot} ) {
+ my $size = $sizes{$type};
+ $return .= sprintf "%08d: %s %04d\n", $spot, 'F' . $type, $size;
+ $spot += $size;
+ next SECTOR;
+ }
+ }
+
+ die "********\n$return\nDidn't find free sector for $spot in chains\n********\n";
+ }
+ else {
+ $return .= sprintf "%08d: %s %04d", $spot, $sector->type, $sector->size;
+ if ( $sector->type eq 'D' ) {
+ $return .= ' ' . $sector->data;
+ }
+ elsif ( $sector->type eq 'A' || $sector->type eq 'H' ) {
+ $return .= ' REF: ' . $sector->get_refcount;
+ }
+ elsif ( $sector->type eq 'B' ) {
+ foreach my $bucket ( $sector->chopped_up ) {
+ $return .= "\n ";
+ $return .= sprintf "%08d", unpack($StP{$self->byte_size},
+ substr( $bucket->[-1], $self->hash_size, $self->byte_size),
+ );
+ my $l = unpack( $StP{$self->byte_size},
+ substr( $bucket->[-1],
+ $self->hash_size + $self->byte_size,
+ $self->byte_size,
+ ),
+ );
+ $return .= sprintf " %08d", $l;
+ foreach my $txn ( 0 .. $self->num_txns - 2 ) {
+ my $l = unpack( $StP{$self->byte_size},
+ substr( $bucket->[-1],
+ $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
+ $self->byte_size,
+ ),
+ );
+ $return .= sprintf " %08d", $l;
+ }
+ }
+ }
+ $return .= $/;
+
+ $spot += $sector->size;
+ }
+ }
+
+ return $return;
+}
+
+1;
+__END__
+++ /dev/null
-package DBM::Deep::Engine::Sector;
-
-use 5.006_000;
-
-use strict;
-use warnings FATAL => 'all';
-
-my $STALE_SIZE = 2;
-
-# Please refer to the pack() documentation for further information
-my %StP = (
- 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
- 2 => 'n', # Unsigned short in "network" (big-endian) order
- 4 => 'N', # Unsigned long in "network" (big-endian) order
- 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
-);
-
-sub new {
- my $self = bless $_[1], $_[0];
- Scalar::Util::weaken( $self->{engine} );
- $self->_init;
- return $self;
-}
-
-#sub _init {}
-#sub clone { DBM::Deep->_throw_error( "Must be implemented in the child class" ); }
-
-sub engine { $_[0]{engine} }
-sub offset { $_[0]{offset} }
-sub type { $_[0]{type} }
-
-sub base_size {
- my $self = shift;
- return $self->engine->SIG_SIZE + $STALE_SIZE;
-}
-
-sub free {
- my $self = shift;
-
- my $e = $self->engine;
-
- $e->storage->print_at( $self->offset, $e->SIG_FREE );
- # Skip staleness counter
- $e->storage->print_at( $self->offset + $self->base_size,
- chr(0) x ($self->size - $self->base_size),
- );
-
- my $free_meth = $self->free_meth;
- $e->$free_meth( $self->offset, $self->size );
-
- return;
-}
-
-1;
-__END__
+++ /dev/null
-package DBM::Deep::Engine::Sector::Data;
-
-use 5.006_000;
-
-use strict;
-use warnings FATAL => 'all';
-
-use base qw( DBM::Deep::Engine::Sector );
-
-# This is in bytes
-sub size { $_[0]{engine}->data_sector_size }
-sub free_meth { return '_add_free_data_sector' }
-
-sub clone {
- my $self = shift;
- return ref($self)->new({
- engine => $self->engine,
- type => $self->type,
- data => $self->data,
- });
-}
-
-1;
-__END__
sub _repr { return {} }
sub TIEHASH {
- ##
- # Tied hash constructor method, called by Perl's tie() function.
- ##
my $class = shift;
my $args = $class->_get_args( @_ );
return $self->SUPER::DELETE( $key, $_[0] );
}
+# Locate and return first key (in no particular order)
sub FIRSTKEY {
- ##
- # Locate and return first key (in no particular order)
- ##
my $self = shift->_get_self;
$self->lock_shared;
: $result;
}
+# Return next key (in no particular order), given previous one
sub NEXTKEY {
- ##
- # Return next key (in no particular order), given previous one
- ##
my $self = shift->_get_self;
my $prev_key = ($self->_engine->storage->{filter_store_key})
: $result;
}
-##
-# Public method aliases
-##
sub first_key { (shift)->FIRSTKEY(@_) }
-sub next_key { (shift)->NEXTKEY(@_) }
+sub next_key { (shift)->NEXTKEY(@_) }
sub _clear {
my $self = shift;
DBM::Deep::Internals
-=head1 DESCRIPTION
+=head1 OUT OF DATE
+
+This document is out-of-date. It describes an intermediate file format used
+during the development from 0.983 to 1.0000. It will be rewritten soon.
-B<NOTE>: This document is out-of-date. It describes an intermediate file
-format used during the development from 0.983 to 1.0000. It will be rewritten
-soon.
+=head1 DESCRIPTION
This is a document describing the internal workings of L<DBM::Deep>. It is
not necessary to read this document if you only intend to be a user. This
use strict;
use warnings FATAL => 'all';
-use DBM::Deep::Iterator::BucketList ();
-use DBM::Deep::Iterator::Index ();
-
=head1 NAME
DBM::Deep::Iterator
=head1 PURPOSE
-This is an internal-use-only object for L<DBM::Deep/>. It is the iterator
+This is an internal-use-only object for L<DBM::Deep>. It is the iterator
for FIRSTKEY() and NEXTKEY().
=head1 OVERVIEW
=over 4
-=item * engine (of type L<DBM::Deep::Engine/>
+=item * engine (of type L<DBM::Deep::Engine>
=item * base_offset (the base_offset of the invoking DBM::Deep object)
my ($args) = @_;
my $self = bless {
- breadcrumbs => [],
engine => $args->{engine},
base_offset => $args->{base_offset},
}, $class;
Scalar::Util::weaken( $self->{engine} );
+ $self->reset;
+
return $self;
}
=cut
-sub reset { $_[0]{breadcrumbs} = [] }
-
-=head2 get_sector_iterator( $loc )
-
-This takes a location. It will load the sector for $loc, then instantiate the right
-iteartor type for it.
-
-This returns the sector iterator.
-
-=cut
-
-sub get_sector_iterator {
- my $self = shift;
- my ($loc) = @_;
-
- my $sector = $self->{engine}->_load_sector( $loc )
- or return;
-
- if ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) {
- return DBM::Deep::Iterator::Index->new({
- iterator => $self,
- sector => $sector,
- });
- }
- elsif ( $sector->isa( 'DBM::Deep::Engine::Sector::BucketList' ) ) {
- return DBM::Deep::Iterator::BucketList->new({
- iterator => $self,
- sector => $sector,
- });
- }
-
- DBM::Deep->_throw_error( "get_sector_iterator(): Why did $loc make a $sector?" );
-}
+sub reset { die "reset must be implemented in a child class" }
=head2 get_next_key( $obj )
=cut
-sub get_next_key {
- my $self = shift;
- my ($obj) = @_;
-
- my $crumbs = $self->{breadcrumbs};
- my $e = $self->{engine};
-
- unless ( @$crumbs ) {
- # This will be a Reference sector
- my $sector = $e->_load_sector( $self->{base_offset} )
- # If no sector is found, thist must have been deleted from under us.
- or return;
-
- if ( $sector->staleness != $obj->_staleness ) {
- return;
- }
-
- my $loc = $sector->get_blist_loc
- or return;
-
- push @$crumbs, $self->get_sector_iterator( $loc );
- }
-
- FIND_NEXT_KEY: {
- # We're at the end.
- unless ( @$crumbs ) {
- $self->reset;
- return;
- }
-
- my $iterator = $crumbs->[-1];
-
- # This level is done.
- if ( $iterator->at_end ) {
- pop @$crumbs;
- redo FIND_NEXT_KEY;
- }
-
- if ( $iterator->isa( 'DBM::Deep::Iterator::Index' ) ) {
- # If we don't have any more, it will be caught at the
- # prior check.
- if ( my $next = $iterator->get_next_iterator ) {
- push @$crumbs, $next;
- }
- redo FIND_NEXT_KEY;
- }
-
- unless ( $iterator->isa( 'DBM::Deep::Iterator::BucketList' ) ) {
- DBM::Deep->_throw_error(
- "Should have a bucketlist iterator here - instead have $iterator"
- );
- }
-
- # At this point, we have a BucketList iterator
- my $key = $iterator->get_next_key;
- if ( defined $key ) {
- return $key;
- }
- #XXX else { $iterator->set_to_end() } ?
-
- # We hit the end of the bucketlist iterator, so redo
- redo FIND_NEXT_KEY;
- }
-
- DBM::Deep->_throw_error( "get_next_key(): How did we get here?" );
-}
+sub get_next_key { die "get_next_key must be implemented in a child class" }
1;
__END__
--- /dev/null
+package DBM::Deep::Iterator::DBI;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Iterator );
+
+sub reset {
+ my $self = shift;
+
+ eval { $self->{sth}->finish; };
+ delete $self->{sth};
+
+ return;
+}
+
+sub get_next_key {
+ my $self = shift;
+ my ($obj) = @_;
+
+ unless ( exists $self->{sth} ) {
+ # For mysql, this needs to be RAND()
+ # For sqlite, this needs to be random()
+ my $storage = $self->{engine}->storage;
+ $self->{sth} = $storage->{dbh}->prepare(
+ "SELECT `key` FROM datas WHERE ref_id = ? ORDER BY "
+ . $storage->rand_function,
+ );
+ $self->{sth}->execute( $self->{base_offset} );
+ }
+
+ my ($key) = $self->{sth}->fetchrow_array;
+ return $key;
+}
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Iterator::File;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Iterator );
+
+use DBM::Deep::Iterator::File::BucketList ();
+use DBM::Deep::Iterator::File::Index ();
+
+sub reset { $_[0]{breadcrumbs} = []; return }
+
+sub get_sector_iterator {
+ my $self = shift;
+ my ($loc) = @_;
+
+ my $sector = $self->{engine}->load_sector( $loc )
+ or return;
+
+ if ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
+ return DBM::Deep::Iterator::File::Index->new({
+ iterator => $self,
+ sector => $sector,
+ });
+ }
+ elsif ( $sector->isa( 'DBM::Deep::Sector::File::BucketList' ) ) {
+ return DBM::Deep::Iterator::File::BucketList->new({
+ iterator => $self,
+ sector => $sector,
+ });
+ }
+
+ DBM::Deep->_throw_error( "get_sector_iterator(): Why did $loc make a $sector?" );
+}
+
+sub get_next_key {
+ my $self = shift;
+ my ($obj) = @_;
+
+ my $crumbs = $self->{breadcrumbs};
+ my $e = $self->{engine};
+
+ unless ( @$crumbs ) {
+ # This will be a Reference sector
+ my $sector = $e->load_sector( $self->{base_offset} )
+ # If no sector is found, this must have been deleted from under us.
+ or return;
+
+ if ( $sector->staleness != $obj->_staleness ) {
+ return;
+ }
+
+ my $loc = $sector->get_blist_loc
+ or return;
+
+ push @$crumbs, $self->get_sector_iterator( $loc );
+ }
+
+ FIND_NEXT_KEY: {
+ # We're at the end.
+ unless ( @$crumbs ) {
+ $self->reset;
+ return;
+ }
+
+ my $iterator = $crumbs->[-1];
+
+ # This level is done.
+ if ( $iterator->at_end ) {
+ pop @$crumbs;
+ redo FIND_NEXT_KEY;
+ }
+
+ if ( $iterator->isa( 'DBM::Deep::Iterator::File::Index' ) ) {
+ # If we don't have any more, it will be caught at the
+ # prior check.
+ if ( my $next = $iterator->get_next_iterator ) {
+ push @$crumbs, $next;
+ }
+ redo FIND_NEXT_KEY;
+ }
+
+ unless ( $iterator->isa( 'DBM::Deep::Iterator::File::BucketList' ) ) {
+ DBM::Deep->_throw_error(
+ "Should have a bucketlist iterator here - instead have $iterator"
+ );
+ }
+
+ # At this point, we have a BucketList iterator
+ my $key = $iterator->get_next_key;
+ if ( defined $key ) {
+ return $key;
+ }
+ #XXX else { $iterator->set_to_end() } ?
+
+ # We hit the end of the bucketlist iterator, so redo
+ redo FIND_NEXT_KEY;
+ }
+
+ DBM::Deep->_throw_error( "get_next_key(): How did we get here?" );
+}
+
+1;
+__END__
-package DBM::Deep::Iterator::BucketList;
+package DBM::Deep::Iterator::File::BucketList;
use 5.006_000;
=head1 PURPOSE
-This is an internal-use-only object for L<DBM::Deep/>. It acts as the mediator
-between the L<DBM::Deep::Iterator/> object and a L<DBM::Deep::Engine::Sector::BucketList/>
+This is an internal-use-only object for L<DBM::Deep>. It acts as the mediator
+between the L<DBM::Deep::Iterator> object and a L<DBM::Deep::Engine::Sector::BucketList>
sector.
=head1 OVERVIEW
This object, despite the implied class hiearchy, does B<NOT> inherit from
-L<DBM::Deep::Iterator/>. Instead, it delegates to it, essentially acting as a
+L<DBM::Deep::Iterator>. Instead, it delegates to it, essentially acting as a
facade over it. L<DBM::Deep::Iterator/get_next_key> will instantiate one of
these objects as needed to handle an BucketList sector.
=over 4
-=item * iterator (of type L<DBM::Deep::Iterator/>
+=item * iterator (of type L<DBM::Deep::Iterator>
-=item * sector (of type L<DBM::Deep::Engine::Sector::BucketList/>
+=item * sector (of type L<DBM::Deep::Engine::Sector::BucketList>
=back
-package DBM::Deep::Iterator::Index;
+package DBM::Deep::Iterator::File::Index;
use 5.006_000;
=head1 PURPOSE
-This is an internal-use-only object for L<DBM::Deep/>. It acts as the mediator
-between the L<DBM::Deep::Iterator/> object and a L<DBM::Deep::Engine::Sector::Index/>
+This is an internal-use-only object for L<DBM::Deep>. It acts as the mediator
+between the L<DBM::Deep::Iterator> object and a L<DBM::Deep::Engine::Sector::Index>
sector.
=head1 OVERVIEW
This object, despite the implied class hiearchy, does B<NOT> inherit from
-L<DBM::Deep::Iterator/>. Instead, it delegates to it, essentially acting as a
+L<DBM::Deep::Iterator>. Instead, it delegates to it, essentially acting as a
facade over it. L<DBM::Deep::Iterator/get_next_key> will instantiate one of
these objects as needed to handle an Index sector.
=over 4
-=item * iterator (of type L<DBM::Deep::Iterator/>
+=item * iterator (of type L<DBM::Deep::Iterator>
-=item * sector (of type L<DBM::Deep::Engine::Sector::Index/>
+=item * sector (of type L<DBM::Deep::Engine::Sector::Index>
=back
-# This was copied from MARCEL's Class::Null. However, I couldn't use it because
-# I need an undef value, not an implementation of the Null Class pattern.
package DBM::Deep::Null;
use 5.006_000;
=head1 PURPOSE
-This is an internal-use-only object for L<DBM::Deep/>. It acts as a NULL object
-in the same vein as MARCEL's L<Class::Null/>. I couldn't use L<Class::Null/>
+This is an internal-use-only object for L<DBM::Deep>. It acts as a NULL object
+in the same vein as MARCEL's L<Class::Null>. I couldn't use L<Class::Null>
because DBM::Deep needed an object that always evaluated as undef, not an
implementation of the Null Class pattern.
use overload
'bool' => sub { undef },
'""' => sub { undef },
- '0+' => sub { undef },
+ '0+' => sub { 0 },
fallback => 1,
nomethod => 'AUTOLOAD';
--- /dev/null
+package DBM::Deep::Sector;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Scalar::Util ();
+
+sub new {
+ my $self = bless $_[1], $_[0];
+ Scalar::Util::weaken( $self->{engine} );
+ $self->_init;
+ return $self;
+}
+
+sub _init {}
+
+sub clone {
+ my $self = shift;
+ return ref($self)->new({
+ engine => $self->engine,
+ type => $self->type,
+ data => $self->data,
+ });
+}
+
+
+sub engine { $_[0]{engine} }
+sub offset { $_[0]{offset} }
+sub type { $_[0]{type} }
+sub staleness { $_[0]{staleness} }
+
+sub load { die "load must be implemented in a child class" }
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Sector::DBI;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Sector );
+
+use DBM::Deep::Sector::DBI::Reference ();
+use DBM::Deep::Sector::DBI::Scalar ();
+
+sub free {
+ my $self = shift;
+
+ $self->engine->storage->delete_from(
+ $self->table, $self->offset,
+ );
+}
+
+sub reload {
+ my $self = shift;
+ $self->_init;
+}
+
+sub load {
+ my $self = shift;
+ my ($engine, $offset, $type) = @_;
+
+ if ( $type eq 'refs' ) {
+ return DBM::Deep::Sector::DBI::Reference->new({
+ engine => $engine,
+ offset => $offset,
+ });
+ }
+ elsif ( $type eq 'datas' ) {
+ my $sector = DBM::Deep::Sector::DBI::Scalar->new({
+ engine => $engine,
+ offset => $offset,
+ });
+
+ if ( $sector->{data_type} eq 'R' ) {
+ return $self->load(
+ $engine, $sector->{value}, 'refs',
+ );
+ }
+
+ return $sector;
+ }
+
+ DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
+}
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Sector::DBI::Reference;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base 'DBM::Deep::Sector::DBI';
+
+sub table { 'refs' }
+
+sub _init {
+ my $self = shift;
+
+ my $e = $self->engine;
+
+ unless ( $self->offset ) {
+ my $classname = Scalar::Util::blessed( delete $self->{data} );
+ $self->{offset} = $self->engine->storage->write_to(
+ refs => undef,
+ ref_type => $self->type,
+ classname => $classname,
+ );
+ }
+ else {
+ my ($rows) = $self->engine->storage->read_from(
+ refs => $self->offset,
+ qw( ref_type ),
+ );
+
+ $self->{type} = $rows->[0]{ref_type};
+ }
+
+ return;
+}
+
+sub get_data_for {
+ my $self = shift;
+ my ($args) = @_;
+
+ my ($rows) = $self->engine->storage->read_from(
+ datas => { ref_id => $self->offset, key => $args->{key} },
+ qw( id ),
+ );
+
+ return unless $rows->[0]{id};
+
+ $self->load(
+ $self->engine,
+ $rows->[0]{id},
+ 'datas',
+ );
+}
+
+sub write_data {
+ my $self = shift;
+ my ($args) = @_;
+
+ if ( ( $args->{value}->type || 'S' ) eq 'S' ) {
+ $args->{value}{offset} = $self->engine->storage->write_to(
+ datas => $args->{value}{offset},
+ ref_id => $self->offset,
+ data_type => 'S',
+ key => $args->{key},
+ value => $args->{value}{data},
+ );
+
+ $args->{value}->reload;
+ }
+ else {
+ # Write the Scalar of the Reference
+ $self->engine->storage->write_to(
+ datas => undef,
+ ref_id => $self->offset,
+ data_type => 'R',
+ key => $args->{key},
+ value => $args->{value}{offset},
+ );
+ }
+}
+
+sub delete_key {
+ my $self = shift;
+ my ($args) = @_;
+
+ my $old_value = $self->get_data_for({
+ key => $args->{key},
+ });
+
+ my $data;
+ if ( $old_value ) {
+ $data = $old_value->data({ export => 1 });
+ $old_value->free;
+ }
+
+ return $data;
+}
+
+sub get_classname {
+ my $self = shift;
+ my ($rows) = $self->engine->storage->read_from(
+ 'refs', $self->offset,
+ qw( classname ),
+ );
+ return unless @$rows;
+ return $rows->[0]{classname};
+}
+
+# Look to hoist this method into a ::Reference trait
+sub data {
+ my $self = shift;
+ my ($args) = @_;
+ $args ||= {};
+
+ my $engine = $self->engine;
+ if ( !exists $engine->cache->{ $self->offset } ) {
+ my $obj = DBM::Deep->new({
+ type => $self->type,
+ base_offset => $self->offset,
+ storage => $engine->storage,
+ engine => $engine,
+ });
+
+ $engine->cache->{$self->offset} = $obj;
+ }
+ my $obj = $engine->cache->{$self->offset};
+
+ # We're not exporting, so just return.
+ unless ( $args->{export} ) {
+ if ( $engine->storage->{autobless} ) {
+ my $classname = $self->get_classname;
+ if ( defined $classname ) {
+ bless $obj, $classname;
+ }
+ }
+
+ return $obj;
+ }
+
+ # We shouldn't export if this is still referred to.
+ if ( $self->get_refcount > 1 ) {
+ return $obj;
+ }
+
+ return $obj->export;
+}
+
+sub free {
+ my $self = shift;
+
+ # We're not ready to be removed yet.
+ return if $self->decrement_refcount > 0;
+
+ # Rebless the object into DBM::Deep::Null.
+ eval { %{ $self->engine->cache->{ $self->offset } } = (); };
+ eval { @{ $self->engine->cache->{ $self->offset } } = (); };
+ bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
+ delete $self->engine->cache->{ $self->offset };
+
+ $self->engine->storage->delete_from(
+ 'datas', { ref_id => $self->offset },
+ );
+
+ $self->engine->storage->delete_from(
+ 'datas', { value => $self->offset, data_type => 'R' },
+ );
+
+ $self->SUPER::free( @_ );
+}
+
+sub increment_refcount {
+ my $self = shift;
+ my $refcount = $self->get_refcount;
+ $refcount++;
+ $self->write_refcount( $refcount );
+ return $refcount;
+}
+
+sub decrement_refcount {
+ my $self = shift;
+ my $refcount = $self->get_refcount;
+ $refcount--;
+ $self->write_refcount( $refcount );
+ return $refcount;
+}
+
+sub get_refcount {
+ my $self = shift;
+ my ($rows) = $self->engine->storage->read_from(
+ 'refs', $self->offset,
+ qw( refcount ),
+ );
+ return $rows->[0]{refcount};
+}
+
+sub write_refcount {
+ my $self = shift;
+ my ($num) = @_;
+ $self->engine->storage->{dbh}->do(
+ "UPDATE refs SET refcount = ? WHERE id = ?", undef,
+ $num, $self->offset,
+ );
+}
+
+sub clear {
+ my $self = shift;
+
+ DBM::Deep->new({
+ type => $self->type,
+ base_offset => $self->offset,
+ storage => $self->engine->storage,
+ engine => $self->engine,
+ })->_clear;
+
+ return;
+}
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Sector::DBI::Scalar;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Sector::DBI );
+
+sub table { 'datas' }
+
+sub _init {
+ my $self = shift;
+
+ if ( $self->offset ) {
+ my ($rows) = $self->engine->storage->read_from(
+ datas => $self->offset,
+ qw( id data_type key value ),
+ );
+
+ $self->{$_} = $rows->[0]{$_} for qw( data_type key value );
+ }
+
+ return;
+}
+
+sub data {
+ my $self = shift;
+ $self->{value};
+}
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Sector::File;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Sector );
+
+use DBM::Deep::Sector::File::BucketList ();
+use DBM::Deep::Sector::File::Index ();
+use DBM::Deep::Sector::File::Null ();
+use DBM::Deep::Sector::File::Reference ();
+use DBM::Deep::Sector::File::Scalar ();
+
+my $STALE_SIZE = 2;
+
+sub base_size {
+ my $self = shift;
+ return $self->engine->SIG_SIZE + $STALE_SIZE;
+}
+
+sub free_meth { die "free_meth must be implemented in a child class" }
+
+sub free {
+ my $self = shift;
+
+ my $e = $self->engine;
+
+ $e->storage->print_at( $self->offset, $e->SIG_FREE );
+ # Skip staleness counter
+ $e->storage->print_at( $self->offset + $self->base_size,
+ chr(0) x ($self->size - $self->base_size),
+ );
+
+ my $free_meth = $self->free_meth;
+ $e->$free_meth( $self->offset, $self->size );
+
+ return;
+}
+
+=head2 load( $offset )
+
+This will instantiate and return the sector object that represents the data
+found at $offset.
+
+=cut
+
+sub load {
+ my $self = shift;
+ my ($engine, $offset) = @_;
+
+ # Add a catch for offset of 0 or 1
+ return if !$offset || $offset <= 1;
+
+ my $type = $engine->storage->read_at( $offset, 1 );
+ return if $type eq chr(0);
+
+ if ( $type eq $engine->SIG_ARRAY || $type eq $engine->SIG_HASH ) {
+ return DBM::Deep::Sector::File::Reference->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ # XXX Don't we need key_md5 here?
+ elsif ( $type eq $engine->SIG_BLIST ) {
+ return DBM::Deep::Sector::File::BucketList->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ elsif ( $type eq $engine->SIG_INDEX ) {
+ return DBM::Deep::Sector::File::Index->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ elsif ( $type eq $engine->SIG_NULL ) {
+ return DBM::Deep::Sector::File::Null->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ elsif ( $type eq $engine->SIG_DATA ) {
+ return DBM::Deep::Sector::File::Scalar->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ # This was deleted from under us, so just return and let the caller figure it out.
+ elsif ( $type eq $engine->SIG_FREE ) {
+ return;
+ }
+
+ DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
+}
+
+1;
+__END__
-package DBM::Deep::Engine::Sector::BucketList;
+package DBM::Deep::Sector::File::BucketList;
use 5.006_000;
use strict;
use warnings FATAL => 'all';
-use base qw( DBM::Deep::Engine::Sector );
+use base qw( DBM::Deep::Sector::File );
my $STALE_SIZE = 2;
return $self;
}
-sub clear {
+sub wipe {
my $self = shift;
$self->engine->storage->print_at( $self->offset + $self->base_size,
chr(0) x ($self->size - $self->base_size), # Zero-fill the data
return $self->{size};
}
-sub free_meth { return '_add_free_blist_sector' }
+sub free_meth { '_add_free_blist_sector' }
sub free {
my $self = shift;
# Delete the keysector
my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size, $e->byte_size ) );
- my $s = $e->_load_sector( $l ); $s->free if $s;
+ my $s = $e->load_sector( $l ); $s->free if $s;
# Delete the HEAD sector
$l = unpack( $StP{$e->byte_size},
$e->byte_size,
),
);
- $s = $e->_load_sector( $l ); $s->free if $s;
+ $s = $e->load_sector( $l ); $s->free if $s;
foreach my $txn ( 0 .. $e->num_txns - 2 ) {
my $l = unpack( $StP{$e->byte_size},
$e->byte_size,
),
);
- my $s = $e->_load_sector( $l ); $s->free if $s;
+ my $s = $e->load_sector( $l ); $s->free if $s;
}
}
$engine->add_entry( $args->{trans_id}, $spot );
unless ($self->{found}) {
- my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({
+ my $key_sector = DBM::Deep::Sector::File::Scalar->new({
engine => $engine,
data => $args->{key},
});
$key_sector->free;
- my $data_sector = $self->engine->_load_sector( $location );
+ my $data_sector = $self->engine->load_sector( $location );
my $data = $data_sector->data({ export => 1 });
$data_sector->free;
my $location = $self->get_data_location_for({
allow_head => $args->{allow_head},
});
- return $self->engine->_load_sector( $location );
+ return $self->engine->load_sector( $location );
}
sub get_key_for {
$location = unpack( $StP{$self->engine->byte_size}, $location );
DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location;
- return $self->engine->_load_sector( $location );
+ return $self->engine->load_sector( $location );
}
1;
--- /dev/null
+package DBM::Deep::Sector::File::Data;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Sector::File );
+
+# This is in bytes
+sub size { $_[0]{engine}->data_sector_size }
+sub free_meth { return '_add_free_data_sector' }
+
+1;
+__END__
-package DBM::Deep::Engine::Sector::Index;
+package DBM::Deep::Sector::File::Index;
-use base qw( DBM::Deep::Engine::Sector );
+use base qw( DBM::Deep::Sector::File );
my $STALE_SIZE = 2;
for my $i ( 0 .. $e->hash_chars - 1 ) {
my $l = $self->get_entry( $i ) or next;
- $e->_load_sector( $l )->free;
+ $e->load_sector( $l )->free;
}
$self->SUPER::free();
-package DBM::Deep::Engine::Sector::Null;
+package DBM::Deep::Sector::File::Null;
use 5.006_000;
use strict;
use warnings FATAL => 'all';
-use base qw( DBM::Deep::Engine::Sector::Data );
+use base qw( DBM::Deep::Sector::File::Data );
my $STALE_SIZE = 2;
-package DBM::Deep::Engine::Sector::Reference;
+package DBM::Deep::Sector::File::Reference;
use 5.006_000;
use strict;
use warnings FATAL => 'all';
-use base qw( DBM::Deep::Engine::Sector::Data );
+use base qw( DBM::Deep::Sector::File::Data );
my $STALE_SIZE = 2;
my $class_offset = 0;
if ( defined $classname ) {
- my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
+ my $class_sector = DBM::Deep::Sector::File::Scalar->new({
engine => $e,
data => $classname,
});
return;
}
-sub staleness { $_[0]{staleness} }
-
sub get_data_location_for {
my $self = shift;
my ($args) = @_;
my $location = $self->get_data_location_for( $args )
or return;
- return $self->engine->_load_sector( $location );
+ return $self->engine->load_sector( $location );
}
sub write_data {
my $location = $blist->get_data_location_for({
allow_head => 0,
});
- my $old_value = $location && $self->engine->_load_sector( $location );
+ my $old_value = $location && $self->engine->load_sector( $location );
my @trans_ids = $self->engine->get_running_txn_ids;
- # If we're the HEAD and there are running txns, then we need to clone this value to the other
- # transactions to preserve Isolation.
+ # If we're the HEAD and there are running txns, then we need to clone this
+ # value to the other transactions to preserve Isolation.
if ( $self->engine->trans_id == 0 ) {
if ( @trans_ids ) {
foreach my $other_trans_id ( @trans_ids ) {
$blist->mark_deleted( $args );
if ( $old_value ) {
+ #XXX Is this export => 1 actually doing anything?
$data = $old_value->data({ export => 1 });
$old_value->free;
}
return $data;
}
-sub clear {
+sub write_blist_loc {
my $self = shift;
-
- my $blist_loc = $self->get_blist_loc or return;
+ my ($loc) = @_;
my $engine = $self->engine;
-
- if($engine->get_running_txn_ids) {
- # ~~~ Temporary; the code below this block needs to be modified to
- # take transactions into account.
- $self->data->_clear;
- return;
- }
-
- my $sector = $engine->_load_sector( $blist_loc )
- or DBM::Deep->_throw_error(
- "Cannot read sector at $blist_loc in clear()"
- );
-
- # Set blist offset to 0
$engine->storage->print_at( $self->offset + $self->base_size,
- pack( $StP{$engine->byte_size}, 0 ),
+ pack( $StP{$engine->byte_size}, $loc ),
);
-
- # Free the blist
- $sector->free;
-
- return;
}
sub get_blist_loc {
unless ( $blist_loc ) {
return unless $args->{create};
- my $blist = DBM::Deep::Engine::Sector::BucketList->new({
+ my $blist = DBM::Deep::Sector::File::BucketList->new({
engine => $engine,
key_md5 => $args->{key_md5},
});
- $engine->storage->print_at( $self->offset + $self->base_size,
- pack( $StP{$engine->byte_size}, $blist->offset ),
- );
+ $self->write_blist_loc( $blist->offset );
+# $engine->storage->print_at( $self->offset + $self->base_size,
+# pack( $StP{$engine->byte_size}, $blist->offset ),
+# );
return $blist;
}
- my $sector = $engine->_load_sector( $blist_loc )
+ my $sector = $engine->load_sector( $blist_loc )
or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
my $i = 0;
my $last_sector = undef;
- while ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) {
+ while ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
$blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
$last_sector = $sector;
if ( $blist_loc ) {
- $sector = $engine->_load_sector( $blist_loc )
+ $sector = $engine->load_sector( $blist_loc )
or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
}
else {
DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
unless $last_sector;
- my $blist = DBM::Deep::Engine::Sector::BucketList->new({
+ my $blist = DBM::Deep::Sector::File::BucketList->new({
engine => $engine,
key_md5 => $args->{key_md5},
});
if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
my $redo;
- my $new_index = DBM::Deep::Engine::Sector::Index->new({
+ my $new_index = DBM::Deep::Sector::File::Index->new({
engine => $engine,
});
# XXX This is inefficient
my $blist = $blist_cache{$idx}
- ||= DBM::Deep::Engine::Sector::BucketList->new({
+ ||= DBM::Deep::Sector::File::BucketList->new({
engine => $engine,
});
++$i, ++$redo;
} else {
my $blist = $blist_cache{$idx}
- ||= DBM::Deep::Engine::Sector::BucketList->new({
+ ||= DBM::Deep::Sector::File::BucketList->new({
engine => $engine,
});
$blist->write_md5({
key => $args->{key},
key_md5 => $args->{key_md5},
- value => DBM::Deep::Engine::Sector::Null->new({
+ value => DBM::Deep::Sector::File::Null->new({
engine => $engine,
data => undef,
}),
});
}
-# my $blist = $blist_cache{$idx}
-# ||= DBM::Deep::Engine::Sector::BucketList->new({
-# engine => $engine,
-# });
-#
-# $new_index->set_entry( $idx => $blist->offset );
-#
-# #XXX THIS IS HACKY!
-# $blist->find_md5( $args->{key_md5} );
-# $blist->write_md5({
-# key => $args->{key},
-# key_md5 => $args->{key_md5},
-# value => DBM::Deep::Engine::Sector::Null->new({
-# engine => $engine,
-# data => undef,
-# }),
-# });
}
if ( $last_sector ) {
);
}
- $sector->clear;
+ $sector->wipe;
$sector->free;
if ( $redo ) {
return unless $class_offset;
- return $self->engine->_load_sector( $class_offset )->data;
+ return $self->engine->load_sector( $class_offset )->data;
}
+# Look to hoist this method into a ::Reference trait
sub data {
my $self = shift;
my ($args) = @_;
$args ||= {};
- my $obj;
- unless ( $obj = $self->engine->cache->{ $self->offset } ) {
- $obj = DBM::Deep->new({
+ my $engine = $self->engine;
+# if ( !exists $engine->cache->{ $self->offset }{ $engine->trans_id } ) {
+ my $obj = DBM::Deep->new({
type => $self->type,
base_offset => $self->offset,
staleness => $self->staleness,
- storage => $self->engine->storage,
- engine => $self->engine,
+ storage => $engine->storage,
+ engine => $engine,
});
- if ( $self->engine->storage->{autobless} ) {
+# $engine->cache->{$self->offset}{ $engine->trans_id } = $obj;
+# }
+# my $obj = $engine->cache->{$self->offset}{ $engine->trans_id };
+
+ # We're not exporting, so just return.
+ unless ( $args->{export} ) {
+ if ( $engine->storage->{autobless} ) {
my $classname = $self->get_classname;
if ( defined $classname ) {
bless $obj, $classname;
}
}
- $self->engine->cache->{$self->offset} = $obj;
- }
-
- # We're not exporting, so just return.
- unless ( $args->{export} ) {
return $obj;
}
my $self = shift;
# We're not ready to be removed yet.
- if ( $self->decrement_refcount > 0 ) {
- return;
- }
+ return if $self->decrement_refcount > 0;
+
+ my $e = $self->engine;
# Rebless the object into DBM::Deep::Null.
- eval { %{ $self->engine->cache->{ $self->offset } } = (); };
- eval { @{ $self->engine->cache->{ $self->offset } } = (); };
- bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
- delete $self->engine->cache->{ $self->offset };
+# eval { %{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); };
+# eval { @{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); };
+# bless $e->cache->{ $self->offset }{ $e->trans_id }, 'DBM::Deep::Null';
+# delete $e->cache->{ $self->offset }{ $e->trans_id };
my $blist_loc = $self->get_blist_loc;
- $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
+ $e->load_sector( $blist_loc )->free if $blist_loc;
my $class_loc = $self->get_class_offset;
- $self->engine->_load_sector( $class_loc )->free if $class_loc;
+ $e->load_sector( $class_loc )->free if $class_loc;
$self->SUPER::free();
}
);
}
+sub clear {
+ my $self = shift;
+
+ my $blist_loc = $self->get_blist_loc or return;
+
+ my $engine = $self->engine;
+
+ # This won't work with autoblessed items.
+ if ($engine->get_running_txn_ids) {
+ # ~~~ Temporary; the code below this block needs to be modified to
+ # take transactions into account.
+ $self->data->_get_self->_clear;
+ return;
+ }
+
+ my $sector = $engine->load_sector( $blist_loc )
+ or DBM::Deep->_throw_error(
+ "Cannot read sector at $blist_loc in clear()"
+ );
+
+ # Set blist offset to 0
+ $engine->storage->print_at( $self->offset + $self->base_size,
+ pack( $StP{$engine->byte_size}, 0 ),
+ );
+
+ # Free the blist
+ $sector->free;
+
+ return;
+}
+
1;
__END__
-package DBM::Deep::Engine::Sector::Scalar;
+package DBM::Deep::Sector::File::Scalar;
use 5.006_000;
use warnings FATAL => 'all';
no warnings 'recursion';
-use base qw( DBM::Deep::Engine::Sector::Data );
+use base qw( DBM::Deep::Sector::File::Data );
my $STALE_SIZE = 2;
$self->SUPER::free();
if ( $chain_loc ) {
- $self->engine->_load_sector( $chain_loc )->free;
+ $self->engine->load_sector( $chain_loc )->free;
}
return;
sub data {
my $self = shift;
-# my ($args) = @_;
-# $args ||= {};
my $data;
while ( 1 ) {
last unless $chain_loc;
- $self = $self->engine->_load_sector( $chain_loc );
+ $self = $self->engine->load_sector( $chain_loc );
}
return $data;
--- /dev/null
+package DBM::Deep::Storage;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+=head2 flush()
+
+This flushes the filehandle. This takes no parameters and returns nothing.
+
+=cut
+
+sub flush { die "flush must be implemented in a child class" }
+
+=head2 is_writable()
+
+This takes no parameters. It returns a boolean saying if this filehandle is
+writable.
+
+Taken from L<http://www.perlmonks.org/?node_id=691054/>.
+
+=cut
+
+sub is_writable { die "is_writable must be implemented in a child class" }
+
+=head1 LOCKING
+
+This is where the actual locking of the storage medium is performed.
+Nested locking is supported.
+
+B<NOTE>: It is unclear what will happen if a read lock is taken, then
+a write lock is taken as a nested lock, then the write lock is released.
+
+Currently, the only locking method supported is flock(1). This is a
+whole-file lock. In the future, more granular locking may be supported.
+The API for that is unclear right now.
+
+The following methods manage the locking status. In all cases, they take
+a L<DBM::Deep> object and returns nothing.
+
+=over 4
+
+=item * lock_exclusive( $obj )
+
+Take a lock usable for writing.
+
+=item * lock_shared( $obj )
+
+Take a lock usable for reading.
+
+=item * unlock( $obj )
+
+Releases the last lock taken. If this is the outermost lock, then the
+object is actually unlocked.
+
+=back
+
+=cut
+
+sub lock_exclusive { die "lock_exclusive must be implemented in a child class" }
+sub lock_shared { die "lock_shared must be implemented in a child class" }
+sub unlock { die "unlock must be implemented in a child class" }
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Storage::DBI;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base 'DBM::Deep::Storage';
+
+use DBI;
+
+sub new {
+ my $class = shift;
+ my ($args) = @_;
+
+ my $self = bless {
+ autobless => 1,
+ dbh => undef,
+ dbi => undef,
+ }, $class;
+
+ # Grab the parameters we want to use
+ foreach my $param ( keys %$self ) {
+ next unless exists $args->{$param};
+ $self->{$param} = $args->{$param};
+ }
+
+ if ( $self->{dbh} ) {
+ $self->{driver} = lc $self->{dbh}->{Driver}->{Name};
+ }
+ else {
+ $self->open;
+ }
+
+ # Foreign keys are turned off by default in SQLite3 (for now)
+ #q.v. http://search.cpan.org/~adamk/DBD-SQLite-1.27/lib/DBD/SQLite.pm#Foreign_Keys
+ # for more info.
+ if ( $self->driver eq 'sqlite' ) {
+ $self->{dbh}->do( 'PRAGMA foreign_keys = ON' );
+ }
+
+ return $self;
+}
+
+sub open {
+ my $self = shift;
+
+ return if $self->{dbh};
+
+ $self->{dbh} = DBI->connect(
+ $self->{dbi}{dsn}, $self->{dbi}{username}, $self->{dbi}{password}, {
+ AutoCommit => 1,
+ PrintError => 0,
+ RaiseError => 1,
+ %{ $self->{dbi}{connect_args} || {} },
+ },
+ ) or die $DBI::error;
+
+ # Should we use the same method as done in new() if passed a $dbh?
+ (undef, $self->{driver}) = map lc, DBI->parse_dsn( $self->{dbi}{dsn} );
+
+ return 1;
+}
+
+sub close {
+ my $self = shift;
+ $self->{dbh}->disconnect if $self->{dbh};
+ return 1;
+}
+
+sub DESTROY {
+ my $self = shift;
+ $self->close if ref $self;
+}
+
+# Is there a portable way of determining writability to a DBH?
+sub is_writable {
+ my $self = shift;
+ return 1;
+}
+
+sub lock_exclusive {
+ my $self = shift;
+}
+
+sub lock_shared {
+ my $self = shift;
+}
+
+sub unlock {
+ my $self = shift;
+# $self->{dbh}->commit;
+}
+
+#sub begin_work {
+# my $self = shift;
+# $self->{dbh}->begin_work;
+#}
+#
+#sub commit {
+# my $self = shift;
+# $self->{dbh}->commit;
+#}
+#
+#sub rollback {
+# my $self = shift;
+# $self->{dbh}->rollback;
+#}
+
+sub read_from {
+ my $self = shift;
+ my ($table, $cond, @cols) = @_;
+
+ $cond = { id => $cond } unless ref $cond;
+
+ my @keys = keys %$cond;
+ my $where = join ' AND ', map { "`$_` = ?" } @keys;
+
+ return $self->{dbh}->selectall_arrayref(
+ "SELECT `@{[join '`,`', @cols ]}` FROM $table WHERE $where",
+ { Slice => {} }, @{$cond}{@keys},
+ );
+}
+
+sub flush {}
+
+sub write_to {
+ my $self = shift;
+ my ($table, $id, %args) = @_;
+
+ my @keys = keys %args;
+ my $sql =
+ "REPLACE INTO $table ( `id`, "
+ . join( ',', map { "`$_`" } @keys )
+ . ") VALUES ("
+ . join( ',', ('?') x (@keys + 1) )
+ . ")";
+ $self->{dbh}->do( $sql, undef, $id, @args{@keys} );
+
+ return $self->{dbh}->last_insert_id("", "", "", "");
+}
+
+sub delete_from {
+ my $self = shift;
+ my ($table, $cond) = @_;
+
+ $cond = { id => $cond } unless ref $cond;
+
+ my @keys = keys %$cond;
+ my $where = join ' AND ', map { "`$_` = ?" } @keys;
+
+ $self->{dbh}->do(
+ "DELETE FROM $table WHERE $where", undef, @{$cond}{@keys},
+ );
+}
+
+sub driver { $_[0]{driver} }
+
+sub rand_function {
+ my $self = shift;
+ my $driver = $self->driver;
+ if ( $driver eq 'sqlite' ) {
+ return 'random()';
+ }
+ elsif ( $driver eq 'mysql' ) {
+ return 'RAND()';
+ }
+
+ die "rand_function undefined for $driver\n";
+}
+
+1;
+__END__
-package DBM::Deep::File;
+package DBM::Deep::Storage::File;
use 5.006_000;
use constant DEBUG => 0;
+use base 'DBM::Deep::Storage';
+
=head1 NAME
-DBM::Deep::File
+DBM::Deep::Storage::File
=head1 PURPOSE
-This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level
+This is an internal-use-only object for L<DBM::Deep>. It mediates the low-level
interaction with the storage mechanism.
Currently, the only storage mechanism supported is the file system.
=head1 OVERVIEW
-This class provides an abstraction to the storage mechanism so that the Engine (the
-only class that uses this class) doesn't have to worry about that.
+This class provides an abstraction to the storage mechanism so that the Engine
+(the only class that uses this class) doesn't have to worry about that.
=head1 METHODS
=cut
+# TODO: What happens if we ->open when we already have a $fh?
sub open {
my $self = shift;
This will return the size of the DB. If file_offset is set, this will take that into account.
+B<NOTE>: This function isn't used internally anywhere.
+
=cut
sub size {
This will set the inode value of the underlying file object.
-This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be needed outside
-this object.
+This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be
+needed outside this object.
There is no return value.
This takes an optional offset and some data to print.
-C< $offset >, if defined, will be used to seek into the file. If file_offset is set, it will be used
-as the zero location. If it is undefined, no seeking will occur. Then, C< @data > will be printed to
-the current location.
+C< $offset >, if defined, will be used to seek into the file. If file_offset is
+set, it will be used as the zero location. If it is undefined, no seeking will
+occur. Then, C< @data > will be printed to the current location.
There is no return value.
This takes an optional offset and a length.
-C< $offset >, if defined, will be used to seek into the file. If file_offset is set, it will be used
-as the zero location. If it is undefined, no seeking will occur. Then, C< $length > bytes will be
-read from the current location.
+C< $offset >, if defined, will be used to seek into the file. If file_offset is
+set, it will be used as the zero location. If it is undefined, no seeking will
+occur. Then, C< $length > bytes will be read from the current location.
The data read will be returned.
=head2 DESTROY
-When the ::File object goes out of scope, it will be closed.
+When the ::Storage::File object goes out of scope, it will be closed.
=cut
return $loc;
}
-=head2 flush()
-
-This flushes the filehandle. This takes no parameters and returns nothing.
-
-=cut
-
-sub flush {
- my $self = shift;
-
- # Flush the filehandle
- my $old_fh = select $self->{fh};
- my $old_af = $|; $| = 1; $| = $old_af;
- select $old_fh;
-
- return 1;
-}
-
-=head2 is_writable()
-
-This takes no parameters. It returns a boolean saying if this filehandle is
-writable.
-
-Taken from L<http://www.perlmonks.org/?node_id=691054/>.
-
-=cut
-
-sub is_writable {
- my $self = shift;
-
- my $fh = $self->{fh};
- return unless defined $fh;
- return unless defined fileno $fh;
- local $\ = ''; # just in case
- no warnings; # temporarily disable warnings
- local $^W; # temporarily disable warnings
- return print $fh '';
-}
-
=head2 copy_stats( $target_filename )
This will take the stats for the current filehandle and apply them to
chmod( $perms, $temp_filename );
}
-=head1 LOCKING
-
-This is where the actual locking of the storage medium is performed.
-Nested locking is supported.
-
-B<NOTE>: It is unclear what will happen if a read lock is taken, then
-a write lock is taken as a nested lock, then the write lock is released.
-
-Currently, the only locking method supported is flock(1). This is a
-whole-file lock. In the future, more granular locking may be supported.
-The API for that is unclear right now.
-
-The following methods manage the locking status. In all cases, they take
-a L<DBM::Deep/> object and returns nothing.
-
-=over 4
-
-=item * lock_exclusive( $obj )
-
-Take a lock usable for writing.
-
-=item * lock_shared( $obj )
-
-Take a lock usable for reading.
+sub flush {
+ my $self = shift;
-=item * unlock( $obj )
+ # Flush the filehandle
+ my $old_fh = select $self->{fh};
+ my $old_af = $|; $| = 1; $| = $old_af;
+ select $old_fh;
-Releases the last lock taken. If this is the outermost lock, then the
-object is actually unlocked.
+ return 1;
+}
-=back
+sub is_writable {
+ my $self = shift;
-=cut
+ my $fh = $self->{fh};
+ return unless defined $fh;
+ return unless defined fileno $fh;
+ local $\ = ''; # just in case
+ no warnings; # temporarily disable warnings
+ local $^W; # temporarily disable warnings
+ return print $fh '';
+}
sub lock_exclusive {
my $self = shift;
$self->open;
#XXX This needs work
- $obj->{engine}->setup_fh( $obj );
+ $obj->{engine}->setup( $obj );
flock($self->{fh}, $type); # re-lock
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 3;
+use warnings FATAL => 'all';
+
+use Test::More;
use t::common qw( new_fh );
my $db = eval {
local $SIG{__DIE__};
DBM::Deep->new( $filename );
-};
-if ( $@ ) {
+}; if ( $@ ) {
diag "ERROR: $@";
Test::More->builder->BAIL_OUT( "Opening a new file fails." );
}
ok(1, "We can successfully open a file!" );
$db->{foo} = 'bar';
+is( $db->{foo}, 'bar', 'We can write and read.' );
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 53;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
+use Scalar::Util qw( reftype );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
-);
-
-##
-# put/get key
-##
-$db->{key1} = "value1";
-is( $db->get("key1"), "value1", "get() works with hash assignment" );
-is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" );
-is( $db->{key1}, "value1", "... and hash-access also works" );
-
-$db->put("key2", undef);
-is( $db->get("key2"), undef, "get() works with put()" );
-is( $db->fetch("key2"), undef, "... fetch() works with put()" );
-is( $db->{key2}, undef, "... and hash-access also works" );
-
-$db->store( "0", "value3" );
-is( $db->get("0"), "value3", "get() works with store()" );
-is( $db->fetch("0"), "value3", "... fetch() works with put()" );
-is( $db->{0}, 'value3', "... and hash-access also works" );
-
-# Verify that the keyval pairs are still correct.
-is( $db->{key1}, "value1", "Key1 is still correct" );
-is( $db->{key2}, undef, "Key2 is still correct" );
-is( $db->{0}, 'value3', "Key3 is still correct" );
-
-ok( $db->exists("key1"), "exists() function works" );
-ok( exists $db->{key2}, "exists() works against tied hash" );
-
-ok( !exists $db->{key4}, "exists() function works for keys that aren't there" );
-is( $db->{key4}, undef, "Autovivified key4" );
-ok( exists $db->{key4}, "Autovivified key4 now exists" );
-
-delete $db->{key4};
-ok( !exists $db->{key4}, "And key4 doesn't exists anymore" );
-
-# Keys will be done via an iterator that keeps a breadcrumb trail of the last
-# key it provided. There will also be an "edit revision number" on the
-# reference so that resetting the iterator can be done.
-#
-# Q: How do we make sure that the iterator is unique? Is it supposed to be?
-
-##
-# count keys
-##
-is( scalar keys %$db, 3, "keys() works against tied hash" );
-
-##
-# step through keys
-##
-my $temphash = {};
-while ( my ($key, $value) = each %$db ) {
- $temphash->{$key} = $value;
-}
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # put/get key
+ ##
+ $db->{key1} = "value1";
+ is( $db->get("key1"), "value1", "get() works with hash assignment" );
+ is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" );
+ is( $db->{key1}, "value1", "... and hash-access also works" );
+
+ $db->put("key2", undef);
+ is( $db->get("key2"), undef, "get() works with put()" );
+ is( $db->fetch("key2"), undef, "... fetch() works with put()" );
+ is( $db->{key2}, undef, "... and hash-access also works" );
+
+ $db->store( "0", "value3" );
+ is( $db->get("0"), "value3", "get() works with store()" );
+ is( $db->fetch("0"), "value3", "... fetch() works with put()" );
+ is( $db->{0}, 'value3', "... and hash-access also works" );
+
+ # Verify that the keyval pairs are still correct.
+ is( $db->{key1}, "value1", "Key1 is still correct" );
+ is( $db->{key2}, undef, "Key2 is still correct" );
+ is( $db->{0}, 'value3', "Key3 is still correct" );
+
+ ok( $db->exists("key1"), "exists() function works" );
+ ok( exists $db->{key2}, "exists() works against tied hash" );
+
+ ok( !exists $db->{key4}, "exists() function works for keys that aren't there" );
+ is( $db->{key4}, undef, "Autovivified key4" );
+ ok( exists $db->{key4}, "Autovivified key4 now exists" );
+
+ delete $db->{key4};
+ ok( !exists $db->{key4}, "And key4 doesn't exists anymore" );
+
+ # Keys will be done via an iterator that keeps a breadcrumb trail of the last
+ # key it provided. There will also be an "edit revision number" on the
+ # reference so that resetting the iterator can be done.
+ #
+ # Q: How do we make sure that the iterator is unique? Is it supposed to be?
+
+ ##
+ # count keys
+ ##
+ is( scalar keys %$db, 3, "keys() works against tied hash" );
+
+ ##
+ # step through keys
+ ##
+ my $temphash = {};
+ while ( my ($key, $value) = each %$db ) {
+ $temphash->{$key} = $value;
+ }
-is( $temphash->{key1}, 'value1', "First key copied successfully using tied interface" );
-is( $temphash->{key2}, undef, "Second key copied successfully" );
-is( $temphash->{0}, 'value3', "Third key copied successfully" );
+ is( $temphash->{key1}, 'value1', "First key copied successfully using tied interface" );
+ is( $temphash->{key2}, undef, "Second key copied successfully" );
+ is( $temphash->{0}, 'value3', "Third key copied successfully" );
-$temphash = {};
-my $key = $db->first_key();
-while (defined $key) {
- $temphash->{$key} = $db->get($key);
- $key = $db->next_key($key);
-}
-
-is( $temphash->{key1}, 'value1', "First key copied successfully using OO interface" );
-is( $temphash->{key2}, undef, "Second key copied successfully" );
-is( $temphash->{0}, 'value3', "Third key copied successfully" );
-
-##
-# delete keys
-##
-is( delete $db->{key2}, undef, "delete through tied inteface works" );
-is( $db->delete("key1"), 'value1', "delete through OO inteface works" );
-is( $db->{0}, 'value3', "The other key is still there" );
-ok( !exists $db->{key1}, "key1 doesn't exist" );
-ok( !exists $db->{key2}, "key2 doesn't exist" );
-
-is( scalar keys %$db, 1, "After deleting two keys, 1 remains" );
-
-##
-# delete all keys
-##
-ok( $db->clear(), "clear() returns true" );
-
-is( scalar keys %$db, 0, "After clear(), everything is removed" );
-
-##
-# replace key
-##
-$db->put("key1", "value1");
-is( $db->get("key1"), "value1", "Assignment still works" );
-
-$db->put("key1", "value2");
-is( $db->get("key1"), "value2", "... and replacement works" );
-
-$db->put("key1", "value222222222222222222222222");
-is( $db->get("key1"), "value222222222222222222222222", "We set a value before closing the file" );
-
-##
-# Make sure DB still works after closing / opening
-##
-undef $db;
-open $fh, '+<', $filename;
-$db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
-);
-is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" );
-
-##
-# Make sure keys are still fetchable after replacing values
-# with smaller ones (bug found by John Cardenas, DBM::Deep 0.93)
-##
-$db->clear();
-$db->put("key1", "long value here");
-$db->put("key2", "longer value here");
-
-$db->put("key1", "short value");
-$db->put("key2", "shorter v");
-
-my $first_key = $db->first_key();
-my $next_key = $db->next_key($first_key);
-
-ok(
- (($first_key eq "key1") || ($first_key eq "key2")) &&
- (($next_key eq "key1") || ($next_key eq "key2")) &&
- ($first_key ne $next_key)
- ,"keys() still works if you replace long values with shorter ones"
-);
-
-# Make sure we do not trigger a deep recursion warning [RT #53575]
-{
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( file => $filename, fh => $fh, );
- my $h = {};
- my $tmp = $h;
- for(1..100) {
- %$tmp = ("" => {});
- $tmp = $$tmp{""};
+ $temphash = {};
+ my $key = $db->first_key();
+ while (defined $key) {
+ $temphash->{$key} = $db->get($key);
+ $key = $db->next_key($key);
}
- ok eval {
- $db->{""} = $h;
- }, 'deep recursion in hash assignment' or diag $@;
- is $w, undef, 'no warnings with deep recursion in hash assignment';
-}
-# Test autovivification
-$db->{unknown}{bar} = 1;
-ok( $db->{unknown}, 'Autovivified hash exists' );
-cmp_ok( $db->{unknown}{bar}, '==', 1, 'And the value stored is there' );
+ is( $temphash->{key1}, 'value1', "First key copied successfully using OO interface" );
+ is( $temphash->{key2}, undef, "Second key copied successfully" );
+ is( $temphash->{0}, 'value3', "Third key copied successfully" );
+
+ ##
+ # delete keys
+ ##
+ is( delete $db->{key2}, undef, "delete through tied inteface works" );
+ is( $db->delete("key1"), 'value1', "delete through OO inteface works" );
+ is( $db->{0}, 'value3', "The other key is still there" );
+ ok( !exists $db->{key1}, "key1 doesn't exist" );
+ ok( !exists $db->{key2}, "key2 doesn't exist" );
+
+ is( scalar keys %$db, 1, "After deleting two keys, 1 remains" );
+
+ ##
+ # delete all keys
+ ##
+ ok( $db->clear(), "clear() returns true" );
+
+ is( scalar keys %$db, 0, "After clear(), everything is removed" );
+
+ ##
+ # replace key
+ ##
+ $db->put("key1", "value1");
+ is( $db->get("key1"), "value1", "Assignment still works" );
+
+ $db->put("key1", "value2");
+ is( $db->get("key1"), "value2", "... and replacement works" );
+
+ $db->put("key1", "value222222222222222222222222");
+ is( $db->get("key1"), "value222222222222222222222222", "We set a value before closing the file" );
+
+ ##
+ # Make sure DB still works after closing / opening
+ ##
+ undef $db;
+ $db = $dbm_maker->();
+ is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" );
+
+ ##
+ # Make sure keys are still fetchable after replacing values
+ # with smaller ones (bug found by John Cardenas, DBM::Deep 0.93)
+ ##
+ $db->clear();
+ $db->put("key1", "long value here");
+ $db->put("key2", "longer value here");
+
+ $db->put("key1", "short value");
+ $db->put("key2", "shorter v");
+
+ my $first_key = $db->first_key();
+ my $next_key = $db->next_key($first_key);
+
+ ok(
+ (($first_key eq "key1") || ($first_key eq "key2")) &&
+ (($next_key eq "key1") || ($next_key eq "key2")) &&
+ ($first_key ne $next_key)
+ ,"keys() still works if you replace long values with shorter ones"
+ );
+
+ # Test autovivification
+ $db->{unknown}{bar} = 1;
+ ok( $db->{unknown}, 'Autovivified hash exists' );
+ is( reftype($db->{unknown}), 'HASH', "... and it's a HASH" );
+ cmp_ok( $db->{unknown}{bar}, '==', 1, 'And the value stored is there' );
-# Test failures
-throws_ok {
- $db->fetch();
-} qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key";
+ # Test failures
+ throws_ok {
+ $db->fetch();
+ } qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key";
-throws_ok {
- $db->fetch(undef);
-} qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key";
+ throws_ok {
+ $db->fetch(undef);
+ } qr/Cannot use an undefined hash key/, "FETCH fails on an undefined key";
-throws_ok {
- $db->store();
-} qr/Cannot use an undefined hash key/, "STORE fails on an undefined key";
+ throws_ok {
+ $db->store();
+ } qr/Cannot use an undefined hash key/, "STORE fails on an undefined key";
-throws_ok {
- $db->store(undef, undef);
-} qr/Cannot use an undefined hash key/, "STORE fails on an undefined key";
+ throws_ok {
+ $db->store(undef, undef);
+ } qr/Cannot use an undefined hash key/, "STORE fails on an undefined key";
-throws_ok {
- $db->delete();
-} qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key";
+ throws_ok {
+ $db->delete();
+ } qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key";
-throws_ok {
- $db->delete(undef);
-} qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key";
+ throws_ok {
+ $db->delete(undef);
+ } qr/Cannot use an undefined hash key/, "DELETE fails on an undefined key";
-throws_ok {
- $db->exists();
-} qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
+ throws_ok {
+ $db->exists();
+ } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
-throws_ok {
- $db->exists(undef);
-} qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
+ throws_ok {
+ $db->exists(undef);
+ } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
+}
{
# RT# 50541 (reported by Peter Scott)
# clear() leaves one key unless there's only one
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- $db->{block} = { };
- $db->{critical} = { };
- $db->{minor} = { };
+ $db->{block} = { };
+ $db->{critical} = { };
+ $db->{minor} = { };
- cmp_ok( scalar(keys( %$db )), '==', 3, "Have 3 keys" );
+ cmp_ok( scalar(keys( %$db )), '==', 3, "Have 3 keys" );
- $db->clear;
+ $db->clear;
- cmp_ok( scalar(keys( %$db )), '==', 0, "clear clears everything" );
+ cmp_ok( scalar(keys( %$db )), '==', 0, "clear clears everything" );
+ }
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests"
unless $ENV{LONG_TESTS};
use Test::Deep;
-use t::common qw( new_fh );
-
-plan tests => 9;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-diag "This test can take up to a minute to run. Please be patient.";
-
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_HASH,
-);
-
-$db->{foo} = {};
-my $foo = $db->{foo};
-
-##
-# put/get many keys
-##
-my $max_keys = 4000;
-
-for ( 0 .. $max_keys ) {
- $foo->put( "hello $_" => "there " . $_ * 2 );
-}
-
-my $count = -1;
-for ( 0 .. $max_keys ) {
- $count = $_;
- unless ( $foo->get( "hello $_" ) eq "there " . $_ * 2 ) {
- last;
- };
+diag "This test can take up to several minutes to run. Please be patient.";
+
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_HASH );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ $db->{foo} = {};
+ my $foo = $db->{foo};
+
+ ##
+ # put/get many keys
+ ##
+ my $max_keys = 4000;
+
+ for ( 0 .. $max_keys ) {
+ $foo->put( "hello $_" => "there " . $_ * 2 );
+ }
+
+ my $count = -1;
+ for ( 0 .. $max_keys ) {
+ $count = $_;
+ unless ( $foo->get( "hello $_" ) eq "there " . $_ * 2 ) {
+ last;
+ };
+ }
+ is( $count, $max_keys, "We read $count keys" );
+
+ my @keys = sort keys %$foo;
+ cmp_ok( scalar(@keys), '==', $max_keys + 1, "Number of keys is correct" );
+ my @control = sort map { "hello $_" } 0 .. $max_keys;
+ cmp_deeply( \@keys, \@control, "Correct keys are there" );
+
+ ok( !exists $foo->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" );
+ is( $foo->{does_not_exist}, undef, "autovivification works on large hashes" );
+ ok( exists $foo->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" );
+ cmp_ok( scalar(keys %$foo), '==', $max_keys + 2, "Number of keys after autovivify is correct" );
+
+ $db->clear;
+ cmp_ok( scalar(keys %$db), '==', 0, "Number of keys after clear() is correct" );
}
-is( $count, $max_keys, "We read $count keys" );
-
-my @keys = sort keys %$foo;
-cmp_ok( scalar(@keys), '==', $max_keys + 1, "Number of keys is correct" );
-my @control = sort map { "hello $_" } 0 .. $max_keys;
-cmp_deeply( \@keys, \@control, "Correct keys are there" );
-
-ok( !exists $foo->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" );
-is( $foo->{does_not_exist}, undef, "autovivification works on large hashes" );
-ok( exists $foo->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" );
-cmp_ok( scalar(keys %$foo), '==', $max_keys + 2, "Number of keys after autovivify is correct" );
-$db->clear;
-cmp_ok( scalar(keys %$db), '==', 0, "Number of keys after clear() is correct" );
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 130;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- type => DBM::Deep->TYPE_ARRAY
-);
-
-##
-# basic put/get/push
-##
-$db->[0] = "elem1";
-$db->push( "elem2" );
-$db->put(2, "elem3");
-$db->store(3, "elem4");
-$db->unshift("elem0");
-
-is( $db->[0], 'elem0', "Array get for shift works" );
-is( $db->[1], 'elem1', "Array get for array set works" );
-is( $db->[2], 'elem2', "Array get for push() works" );
-is( $db->[3], 'elem3', "Array get for put() works" );
-is( $db->[4], 'elem4', "Array get for store() works" );
-
-is( $db->get(0), 'elem0', "get() for shift() works" );
-is( $db->get(1), 'elem1', "get() for array set works" );
-is( $db->get(2), 'elem2', "get() for push() works" );
-is( $db->get(3), 'elem3', "get() for put() works" );
-is( $db->get(4), 'elem4', "get() for store() works" );
-
-is( $db->fetch(0), 'elem0', "fetch() for shift() works" );
-is( $db->fetch(1), 'elem1', "fetch() for array set works" );
-is( $db->fetch(2), 'elem2', "fetch() for push() works" );
-is( $db->fetch(3), 'elem3', "fetch() for put() works" );
-is( $db->fetch(4), 'elem4', "fetch() for store() works" );
-
-is( $db->length, 5, "... and we have five elements" );
-
-is( $db->[-1], $db->[4], "-1st index is 4th index" );
-is( $db->[-2], $db->[3], "-2nd index is 3rd index" );
-is( $db->[-3], $db->[2], "-3rd index is 2nd index" );
-is( $db->[-4], $db->[1], "-4th index is 1st index" );
-is( $db->[-5], $db->[0], "-5th index is 0th index" );
-
-# This is for Perls older than 5.8.0 because of is()'s prototype
-{ my $v = $db->[-6]; is( $v, undef, "-6th index is undef" ); }
-
-is( $db->length, 5, "... and we have five elements after abortive -6 index lookup" );
-
-$db->[-1] = 'elem4.1';
-is( $db->[-1], 'elem4.1' );
-is( $db->[4], 'elem4.1' );
-is( $db->get(4), 'elem4.1' );
-is( $db->fetch(4), 'elem4.1' );
-
-throws_ok {
- $db->[-6] = 'whoops!';
-} qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown";
-
-my $popped = $db->pop;
-is( $db->length, 4, "... and we have four after popping" );
-is( $db->[0], 'elem0', "0th element still there after popping" );
-is( $db->[1], 'elem1', "1st element still there after popping" );
-is( $db->[2], 'elem2', "2nd element still there after popping" );
-is( $db->[3], 'elem3', "3rd element still there after popping" );
-is( $popped, 'elem4.1', "Popped value is correct" );
-
-my $shifted = $db->shift;
-is( $db->length, 3, "... and we have three after shifting" );
-is( $db->[0], 'elem1', "0th element still there after shifting" );
-is( $db->[1], 'elem2', "1st element still there after shifting" );
-is( $db->[2], 'elem3', "2nd element still there after shifting" );
-is( $db->[3], undef, "There is no third element now" );
-is( $shifted, 'elem0', "Shifted value is correct" );
-
-##
-# delete
-##
-my $deleted = $db->delete(0);
-is( $db->length, 3, "... and we still have three after deleting" );
-is( $db->[0], undef, "0th element now undef" );
-is( $db->[1], 'elem2', "1st element still there after deleting" );
-is( $db->[2], 'elem3', "2nd element still there after deleting" );
-is( $deleted, 'elem1', "Deleted value is correct" );
-
-is( $db->delete(99), undef, 'delete on an element not in the array returns undef' );
-is( $db->length, 3, "... and we still have three after a delete on an out-of-range index" );
-
-is( delete $db->[99], undef, 'DELETE on an element not in the array returns undef' );
-is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range index" );
-
-is( $db->delete(-99), undef, 'delete on an element (neg) not in the array returns undef' );
-is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
-
-is( delete $db->[-99], undef, 'DELETE on an element (neg) not in the array returns undef' );
-is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
-
-$deleted = $db->delete(-2);
-is( $db->length, 3, "... and we still have three after deleting" );
-is( $db->[0], undef, "0th element still undef" );
-is( $db->[1], undef, "1st element now undef" );
-is( $db->[2], 'elem3', "2nd element still there after deleting" );
-is( $deleted, 'elem2', "Deleted value is correct" );
-
-$db->[1] = 'elem2';
-
-##
-# exists
-##
-ok( $db->exists(1), "The 1st value exists" );
-ok( $db->exists(0), "The 0th value doesn't exist" );
-ok( !$db->exists(22), "The 22nd value doesn't exists" );
-ok( $db->exists(-1), "The -1st value does exists" );
-ok( !$db->exists(-22), "The -22nd value doesn't exists" );
-
-##
-# clear
-##
-ok( $db->clear(), "clear() returns true if the file was ever non-empty" );
-is( $db->length(), 0, "After clear(), no more elements" );
-
-is( $db->pop, undef, "pop on an empty array returns undef" );
-is( $db->length(), 0, "After pop() on empty array, length is still 0" );
-
-is( $db->shift, undef, "shift on an empty array returns undef" );
-is( $db->length(), 0, "After shift() on empty array, length is still 0" );
-
-is( $db->unshift( 1, 2, 3 ), 3, "unshift returns the number of elements in the array" );
-is( $db->unshift( 1, 2, 3 ), 6, "unshift returns the number of elements in the array" );
-is( $db->push( 1, 2, 3 ), 9, "push returns the number of elements in the array" );
-
-is( $db->length(), 9, "After unshift and push on empty array, length is now 9" );
-
-$db->clear;
-
-##
-# multi-push
-##
-$db->push( 'elem first', "elem middle", "elem last" );
-is( $db->length, 3, "3-element push results in three elements" );
-is($db->[0], "elem first", "First element is 'elem first'");
-is($db->[1], "elem middle", "Second element is 'elem middle'");
-is($db->[2], "elem last", "Third element is 'elem last'");
-
-##
-# splice with length 1
-##
-my @returned = $db->splice( 1, 1, "middle A", "middle B" );
-is( scalar(@returned), 1, "One element was removed" );
-is( $returned[0], 'elem middle', "... and it was correctly removed" );
-is($db->length(), 4);
-is($db->[0], "elem first");
-is($db->[1], "middle A");
-is($db->[2], "middle B");
-is($db->[3], "elem last");
-
-##
-# splice with length of 0
-##
-@returned = $db->splice( -1, 0, "middle C" );
-is( scalar(@returned), 0, "No elements were removed" );
-is($db->length(), 5);
-is($db->[0], "elem first");
-is($db->[1], "middle A");
-is($db->[2], "middle B");
-is($db->[3], "middle C");
-is($db->[4], "elem last");
-
-##
-# splice with length of 3
-##
-my $returned = $db->splice( 1, 3, "middle ABC" );
-is( $returned, 'middle C', "Just the last element was returned" );
-is($db->length(), 3);
-is($db->[0], "elem first");
-is($db->[1], "middle ABC");
-is($db->[2], "elem last");
-
-@returned = $db->splice( 1 );
-is($db->length(), 1);
-is($db->[0], "elem first");
-is($returned[0], "middle ABC");
-is($returned[1], "elem last");
-
-$db->push( @returned );
-
-@returned = $db->splice( 1, -1 );
-is($db->length(), 2);
-is($db->[0], "elem first");
-is($db->[1], "elem last");
-is($returned[0], "middle ABC");
-
-@returned = $db->splice;
-is( $db->length, 0 );
-is( $returned[0], "elem first" );
-is( $returned[1], "elem last" );
-
-$db->[0] = [ 1 .. 3 ];
-$db->[1] = { a => 'foo' };
-is( $db->[0]->length, 3, "Reuse of same space with array successful" );
-is( $db->[1]->fetch('a'), 'foo', "Reuse of same space with hash successful" );
-
-# Test autovivification
-$db->[9999]{bar} = 1;
-ok( $db->[9999] );
-cmp_ok( $db->[9999]{bar}, '==', 1 );
-
-# Test failures
-throws_ok {
- $db->fetch( 'foo' );
-} qr/Cannot use 'foo' as an array index/, "FETCH fails on an illegal key";
-
-throws_ok {
- $db->fetch();
-} qr/Cannot use an undefined array index/, "FETCH fails on an undefined key";
-
-throws_ok {
- $db->store( 'foo', 'bar' );
-} qr/Cannot use 'foo' as an array index/, "STORE fails on an illegal key";
-
-throws_ok {
- $db->store();
-} qr/Cannot use an undefined array index/, "STORE fails on an undefined key";
-
-throws_ok {
- $db->delete( 'foo' );
-} qr/Cannot use 'foo' as an array index/, "DELETE fails on an illegal key";
-
-throws_ok {
- $db->delete();
-} qr/Cannot use an undefined array index/, "DELETE fails on an undefined key";
-
-throws_ok {
- $db->exists( 'foo' );
-} qr/Cannot use 'foo' as an array index/, "EXISTS fails on an illegal key";
-
-throws_ok {
- $db->exists();
-} qr/Cannot use an undefined array index/, "EXISTS fails on an undefined key";
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # basic put/get/push
+ ##
+ $db->[0] = "elem1";
+ $db->push( "elem2" );
+ $db->put(2, "elem3");
+ $db->store(3, "elem4");
+ $db->unshift("elem0");
+
+ is( $db->[0], 'elem0', "Array get for shift works" );
+ is( $db->[1], 'elem1', "Array get for array set works" );
+ is( $db->[2], 'elem2', "Array get for push() works" );
+ is( $db->[3], 'elem3', "Array get for put() works" );
+ is( $db->[4], 'elem4', "Array get for store() works" );
+
+ is( $db->get(0), 'elem0', "get() for shift() works" );
+ is( $db->get(1), 'elem1', "get() for array set works" );
+ is( $db->get(2), 'elem2', "get() for push() works" );
+ is( $db->get(3), 'elem3', "get() for put() works" );
+ is( $db->get(4), 'elem4', "get() for store() works" );
+
+ is( $db->fetch(0), 'elem0', "fetch() for shift() works" );
+ is( $db->fetch(1), 'elem1', "fetch() for array set works" );
+ is( $db->fetch(2), 'elem2', "fetch() for push() works" );
+ is( $db->fetch(3), 'elem3', "fetch() for put() works" );
+ is( $db->fetch(4), 'elem4', "fetch() for store() works" );
+
+ is( $db->length, 5, "... and we have five elements" );
+
+ is( $db->[-1], $db->[4], "-1st index is 4th index" );
+ is( $db->[-2], $db->[3], "-2nd index is 3rd index" );
+ is( $db->[-3], $db->[2], "-3rd index is 2nd index" );
+ is( $db->[-4], $db->[1], "-4th index is 1st index" );
+ is( $db->[-5], $db->[0], "-5th index is 0th index" );
+
+ # This is for Perls older than 5.8.0 because of is()'s prototype
+ { my $v = $db->[-6]; is( $v, undef, "-6th index is undef" ); }
+
+ is( $db->length, 5, "... and we have five elements after abortive -6 index lookup" );
+
+ $db->[-1] = 'elem4.1';
+ is( $db->[-1], 'elem4.1' );
+ is( $db->[4], 'elem4.1' );
+ is( $db->get(4), 'elem4.1' );
+ is( $db->fetch(4), 'elem4.1' );
+
+ throws_ok {
+ $db->[-6] = 'whoops!';
+ } qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown";
+
+ my $popped = $db->pop;
+ is( $db->length, 4, "... and we have four after popping" );
+ is( $db->[0], 'elem0', "0th element still there after popping" );
+ is( $db->[1], 'elem1', "1st element still there after popping" );
+ is( $db->[2], 'elem2', "2nd element still there after popping" );
+ is( $db->[3], 'elem3', "3rd element still there after popping" );
+ is( $popped, 'elem4.1', "Popped value is correct" );
+
+ my $shifted = $db->shift;
+ is( $db->length, 3, "... and we have three after shifting" );
+ is( $db->[0], 'elem1', "0th element still there after shifting" );
+ is( $db->[1], 'elem2', "1st element still there after shifting" );
+ is( $db->[2], 'elem3', "2nd element still there after shifting" );
+ is( $db->[3], undef, "There is no third element now" );
+ is( $shifted, 'elem0', "Shifted value is correct" );
+
+ ##
+ # delete
+ ##
+ my $deleted = $db->delete(0);
+ is( $db->length, 3, "... and we still have three after deleting" );
+ is( $db->[0], undef, "0th element now undef" );
+ is( $db->[1], 'elem2', "1st element still there after deleting" );
+ is( $db->[2], 'elem3', "2nd element still there after deleting" );
+ is( $deleted, 'elem1', "Deleted value is correct" );
+
+ is( $db->delete(99), undef, 'delete on an element not in the array returns undef' );
+ is( $db->length, 3, "... and we still have three after a delete on an out-of-range index" );
+
+ is( delete $db->[99], undef, 'DELETE on an element not in the array returns undef' );
+ is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range index" );
+
+ is( $db->delete(-99), undef, 'delete on an element (neg) not in the array returns undef' );
+ is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
+
+ is( delete $db->[-99], undef, 'DELETE on an element (neg) not in the array returns undef' );
+ is( $db->length, 3, "... and we still have three after a DELETE on an out-of-range negative index" );
+
+ $deleted = $db->delete(-2);
+ is( $db->length, 3, "... and we still have three after deleting" );
+ is( $db->[0], undef, "0th element still undef" );
+ is( $db->[1], undef, "1st element now undef" );
+ is( $db->[2], 'elem3', "2nd element still there after deleting" );
+ is( $deleted, 'elem2', "Deleted value is correct" );
+
+ $db->[1] = 'elem2';
+
+ ##
+ # exists
+ ##
+ ok( $db->exists(1), "The 1st value exists" );
+ ok( $db->exists(0), "The 0th value doesn't exist" );
+ ok( !$db->exists(22), "The 22nd value doesn't exists" );
+ ok( $db->exists(-1), "The -1st value does exists" );
+ ok( !$db->exists(-22), "The -22nd value doesn't exists" );
+
+ ##
+ # clear
+ ##
+ ok( $db->clear(), "clear() returns true if the file was ever non-empty" );
+ is( $db->length(), 0, "After clear(), no more elements" );
+
+ is( $db->pop, undef, "pop on an empty array returns undef" );
+ is( $db->length(), 0, "After pop() on empty array, length is still 0" );
+
+ is( $db->shift, undef, "shift on an empty array returns undef" );
+ is( $db->length(), 0, "After shift() on empty array, length is still 0" );
+
+ is( $db->unshift( 1, 2, 3 ), 3, "unshift returns the number of elements in the array" );
+ is( $db->unshift( 1, 2, 3 ), 6, "unshift returns the number of elements in the array" );
+ is( $db->push( 1, 2, 3 ), 9, "push returns the number of elements in the array" );
+
+ is( $db->length(), 9, "After unshift and push on empty array, length is now 9" );
+
+ $db->clear;
+
+ ##
+ # multi-push
+ ##
+ $db->push( 'elem first', "elem middle", "elem last" );
+ is( $db->length, 3, "3-element push results in three elements" );
+ is($db->[0], "elem first", "First element is 'elem first'");
+ is($db->[1], "elem middle", "Second element is 'elem middle'");
+ is($db->[2], "elem last", "Third element is 'elem last'");
+
+ ##
+ # splice with length 1
+ ##
+ my @returned = $db->splice( 1, 1, "middle A", "middle B" );
+ is( scalar(@returned), 1, "One element was removed" );
+ is( $returned[0], 'elem middle', "... and it was correctly removed" );
+ is($db->length(), 4);
+ is($db->[0], "elem first");
+ is($db->[1], "middle A");
+ is($db->[2], "middle B");
+ is($db->[3], "elem last");
+
+ ##
+ # splice with length of 0
+ ##
+ @returned = $db->splice( -1, 0, "middle C" );
+ is( scalar(@returned), 0, "No elements were removed" );
+ is($db->length(), 5);
+ is($db->[0], "elem first");
+ is($db->[1], "middle A");
+ is($db->[2], "middle B");
+ is($db->[3], "middle C");
+ is($db->[4], "elem last");
+
+ ##
+ # splice with length of 3
+ ##
+ my $returned = $db->splice( 1, 3, "middle ABC" );
+ is( $returned, 'middle C', "Just the last element was returned" );
+ is($db->length(), 3);
+ is($db->[0], "elem first");
+ is($db->[1], "middle ABC");
+ is($db->[2], "elem last");
+
+ @returned = $db->splice( 1 );
+ is($db->length(), 1);
+ is($db->[0], "elem first");
+ is($returned[0], "middle ABC");
+ is($returned[1], "elem last");
+
+ $db->push( @returned );
+
+ @returned = $db->splice( 1, -1 );
+ is($db->length(), 2);
+ is($db->[0], "elem first");
+ is($db->[1], "elem last");
+ is($returned[0], "middle ABC");
+
+ @returned = $db->splice;
+ is( $db->length, 0 );
+ is( $returned[0], "elem first" );
+ is( $returned[1], "elem last" );
+
+ $db->[0] = [ 1 .. 3 ];
+ $db->[1] = { a => 'foo' };
+ is( $db->[0]->length, 3, "Reuse of same space with array successful" );
+ is( $db->[1]->fetch('a'), 'foo', "Reuse of same space with hash successful" );
+
+ # Test autovivification
+ $db->[9999]{bar} = 1;
+ ok( $db->[9999] );
+ cmp_ok( $db->[9999]{bar}, '==', 1 );
+
+ # Test failures
+ throws_ok {
+ $db->fetch( 'foo' );
+ } qr/Cannot use 'foo' as an array index/, "FETCH fails on an illegal key";
+
+ throws_ok {
+ $db->fetch();
+ } qr/Cannot use an undefined array index/, "FETCH fails on an undefined key";
+
+ throws_ok {
+ $db->store( 'foo', 'bar' );
+ } qr/Cannot use 'foo' as an array index/, "STORE fails on an illegal key";
+
+ throws_ok {
+ $db->store();
+ } qr/Cannot use an undefined array index/, "STORE fails on an undefined key";
+
+ throws_ok {
+ $db->delete( 'foo' );
+ } qr/Cannot use 'foo' as an array index/, "DELETE fails on an illegal key";
+
+ throws_ok {
+ $db->delete();
+ } qr/Cannot use an undefined array index/, "DELETE fails on an undefined key";
+
+ throws_ok {
+ $db->exists( 'foo' );
+ } qr/Cannot use 'foo' as an array index/, "EXISTS fails on an illegal key";
+
+ throws_ok {
+ $db->exists();
+ } qr/Cannot use an undefined array index/, "EXISTS fails on an undefined key";
+}
# Bug reported by Mike Schilli
# Also, RT #29583 reported by HANENKAMP
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- type => DBM::Deep->TYPE_ARRAY
- );
+$dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
push @{$db}, 3, { foo => 1 };
lives_ok {
is( $db->[5]{foo}, 1, "Right hashref there" );
}
+done_testing;
+__END__
{ # Make sure we do not trigger a deep recursion warning [RT #53575]
my $w;
local $SIG{__WARN__} = sub { $w = shift };
}, 'deep recursion in array assignment' or diag $@;
is $w, undef, 'no warnings with deep recursion in array assignment';
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests"
unless $ENV{LONG_TESTS};
-plan tests => 4;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-diag "This test can take up to a minute to run. Please be patient.";
-
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_ARRAY,
-);
-
-##
-# put/get many keys
-##
-my $max_keys = 4000;
-
-for ( 0 .. $max_keys ) {
- $db->put( $_ => $_ * 2 );
-}
-
-my $count = -1;
-for ( 0 .. $max_keys ) {
- $count = $_;
- unless ( $db->get( $_ ) == $_ * 2 ) {
- last;
- };
+diag "This test can take up to several minutes to run. Please be patient.";
+
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # put/get many keys
+ ##
+ my $max_keys = 4000;
+
+ for ( 0 .. $max_keys ) {
+ $db->put( $_ => $_ * 2 );
+ }
+
+ my $count = -1;
+ for ( 0 .. $max_keys ) {
+ $count = $_;
+ unless ( $db->get( $_ ) == $_ * 2 ) {
+ last;
+ };
+ }
+ is( $count, $max_keys, "We read $count keys" );
+
+ cmp_ok( scalar(@$db), '==', $max_keys + 1, "Number of elements is correct" );
+ $db->clear;
+ cmp_ok( scalar(@$db), '==', 0, "Number of elements after clear() is correct" );
}
-is( $count, $max_keys, "We read $count keys" );
-cmp_ok( scalar(@$db), '==', $max_keys + 1, "Number of elements is correct" );
-$db->clear;
-cmp_ok( scalar(@$db), '==', 0, "Number of elements after clear() is correct" );
+done_testing;
-##
-# DBM::Deep Test
-##
+
$|++;
use strict;
-use Test::More tests => 23;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use Test::Warn;
use t::common qw( new_fh );
DBM::Deep->new( 't/etc/db-0-99_04' );
} qr/DBM::Deep: Wrong file version found - 1 - expected 3/, "Fail if opening a file version 1";
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 5;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- locking => 1,
-);
-
-lives_ok {
- $db->unlock;
-} "Can call unlock on an unlocked DB.";
-
-##
-# basic put/get
-##
-$db->{key1} = "value1";
-is( $db->{key1}, "value1", "key1 is set" );
-
-$db->{key2} = [ 1 .. 3 ];
-is( $db->{key2}[1], 2, "The value is set properly" );
-
-##
-# explicit lock
-##
-$db->lock_exclusive;
-$db->{key1} = "value2";
-$db->unlock();
-is( $db->{key1}, "value2", "key1 is overridden" );
+my $dbm_factory = new_dbm( locking => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ lives_ok {
+ $db->unlock;
+ } "Can call unlock on an unlocked DB.";
+
+ ##
+ # basic put/get
+ ##
+ $db->{key1} = "value1";
+ is( $db->{key1}, "value1", "key1 is set" );
+
+ $db->{key2} = [ 1 .. 3 ];
+ is( $db->{key2}[1], 2, "The value is set properly" );
+
+ ##
+ # explicit lock
+ ##
+ $db->lock_exclusive;
+ $db->{key1} = "value2";
+ $db->unlock();
+ is( $db->{key1}, "value2", "key1 is overridden" );
+}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests"
unless $ENV{LONG_TESTS};
-plan tests => 5;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
-diag "This test can take up to a minute to run. Please be patient.";
+diag "This test can take up to several minutes to run. Please be patient.";
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-
-my $max_levels = 1000;
-
-{
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- type => DBM::Deep->TYPE_HASH,
- );
-
- ##
- # basic deep hash
- ##
- $db->{company} = {};
- $db->{company}->{name} = "My Co.";
- $db->{company}->{employees} = {};
- $db->{company}->{employees}->{"Henry Higgins"} = {};
- $db->{company}->{employees}->{"Henry Higgins"}->{salary} = 90000;
-
- is( $db->{company}->{name}, "My Co.", "Set and retrieved a second-level value" );
- is( $db->{company}->{employees}->{"Henry Higgins"}->{salary}, 90000, "Set and retrieved a fourth-level value" );
-
- ##
- # super deep hash
- ##
- $db->{base_level} = {};
- my $temp_db = $db->{base_level};
-
- for my $k ( 0 .. $max_levels ) {
- $temp_db->{"level$k"} = {};
- $temp_db = $temp_db->{"level$k"};
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_HASH );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $max_levels = 1000;
+
+ {
+ my $db = $dbm_maker->();
+
+ ##
+ # basic deep hash
+ ##
+ $db->{company} = {};
+ $db->{company}->{name} = "My Co.";
+ $db->{company}->{employees} = {};
+ $db->{company}->{employees}->{"Henry Higgins"} = {};
+ $db->{company}->{employees}->{"Henry Higgins"}->{salary} = 90000;
+
+ is( $db->{company}->{name}, "My Co.", "Set and retrieved a second-level value" );
+ is( $db->{company}->{employees}->{"Henry Higgins"}->{salary}, 90000, "Set and retrieved a fourth-level value" );
+
+ ##
+ # super deep hash
+ ##
+ $db->{base_level} = {};
+ my $temp_db = $db->{base_level};
+
+ for my $k ( 0 .. $max_levels ) {
+ $temp_db->{"level$k"} = {};
+ $temp_db = $temp_db->{"level$k"};
+ }
+ $temp_db->{deepkey} = "deepvalue";
}
- $temp_db->{deepkey} = "deepvalue";
-}
-{
- open $fh, '+<', $filename;
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- type => DBM::Deep->TYPE_HASH,
- );
-
- my $cur_level = -1;
- my $temp_db = $db->{base_level};
- for my $k ( 0 .. $max_levels ) {
- $cur_level = $k;
- $temp_db = $temp_db->{"level$k"};
- eval { $temp_db->isa( 'DBM::Deep' ) } or last;
+ {
+ my $db = $dbm_maker->();
+
+ my $cur_level = -1;
+ my $temp_db = $db->{base_level};
+ for my $k ( 0 .. $max_levels ) {
+ $cur_level = $k;
+ $temp_db = $temp_db->{"level$k"};
+ eval { $temp_db->isa( 'DBM::Deep' ) } or last;
+ }
+ is( $cur_level, $max_levels, "We read all the way down to level $cur_level" );
+ is( $temp_db->{deepkey}, "deepvalue", "And we retrieved the value at the bottom of the ocean" );
}
- is( $cur_level, $max_levels, "We read all the way down to level $cur_level" );
- is( $temp_db->{deepkey}, "deepvalue", "And we retrieved the value at the bottom of the ocean" );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "You must set \$ENV{LONG_TESTS} to run the long tests"
unless $ENV{LONG_TESTS};
-plan tests => 3;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
-diag "This test can take up to a minute to run. Please be patient.";
+diag "This test can take up to several minutes to run. Please be patient.";
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-
-my $max_levels = 1000;
+my $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $max_levels = 1000;
-{
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- type => DBM::Deep->TYPE_ARRAY,
- );
+ {
+ my $db = $dbm_maker->();
- $db->[0] = [];
- my $temp_db = $db->[0];
- for my $k ( 0 .. $max_levels ) {
- $temp_db->[$k] = [];
- $temp_db = $temp_db->[$k];
+ $db->[0] = [];
+ my $temp_db = $db->[0];
+ for my $k ( 0 .. $max_levels ) {
+ $temp_db->[$k] = [];
+ $temp_db = $temp_db->[$k];
+ }
+ $temp_db->[0] = "deepvalue";
}
- $temp_db->[0] = "deepvalue";
-}
-{
- open $fh, '+<', $filename;
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- type => DBM::Deep->TYPE_ARRAY,
- );
-
- my $cur_level = -1;
- my $temp_db = $db->[0];
- for my $k ( 0 .. $max_levels ) {
- $cur_level = $k;
- $temp_db = $temp_db->[$k];
- eval { $temp_db->isa( 'DBM::Deep' ) } or last;
+ {
+ my $db = $dbm_maker->();
+
+ my $cur_level = -1;
+ my $temp_db = $db->[0];
+ for my $k ( 0 .. $max_levels ) {
+ $cur_level = $k;
+ $temp_db = $temp_db->[$k];
+ eval { $temp_db->isa( 'DBM::Deep' ) } or last;
+ }
+ is( $cur_level, $max_levels, "We read all the way down to level $cur_level" );
+ is( $temp_db->[0], "deepvalue", "And we retrieved the value at the bottom of the ocean" );
}
- is( $cur_level, $max_levels, "We read all the way down to level $cur_level" );
- is( $temp_db->[0], "deepvalue", "And we retrieved the value at the bottom of the ocean" );
}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 14;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
+
+use Test::More;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
-);
-
-##
-# large keys
-##
-my $key1 = "Now is the time for all good men to come to the aid of their country." x 100;
-my $key2 = "The quick brown fox jumped over the lazy, sleeping dog." x 1000;
-my $key3 = "Lorem dolor ipsum latinum suckum causum Ium cannotum rememberum squatum." x 1000;
-
-$db->put($key1, "value1");
-$db->store($key2, "value2");
-$db->{$key3} = "value3";
-
-is( $db->{$key1}, 'value1', "Hash retrieval of put()" );
-is( $db->{$key2}, 'value2', "Hash retrieval of store()" );
-is( $db->{$key3}, 'value3', "Hash retrieval of hashstore" );
-is( $db->get($key1), 'value1', "get() retrieval of put()" );
-is( $db->get($key2), 'value2', "get() retrieval of store()" );
-is( $db->get($key3), 'value3', "get() retrieval of hashstore" );
-is( $db->fetch($key1), 'value1', "fetch() retrieval of put()" );
-is( $db->fetch($key2), 'value2', "fetch() retrieval of store()" );
-is( $db->fetch($key3), 'value3', "fetch() retrieval of hashstore" );
-
-my $test_key = $db->first_key();
-ok(
- ($test_key eq $key1) ||
- ($test_key eq $key2) ||
- ($test_key eq $key3)
-);
-
-$test_key = $db->next_key($test_key);
-ok(
- ($test_key eq $key1) ||
- ($test_key eq $key2) ||
- ($test_key eq $key3)
-);
-
-$test_key = $db->next_key($test_key);
-ok(
- ($test_key eq $key1) ||
- ($test_key eq $key2) ||
- ($test_key eq $key3)
-);
-
-$test_key = $db->next_key($test_key);
-ok( !$test_key );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # large keys
+ ##
+ my $key1 = "Now is the time for all good men to come to the aid of their country." x 100;
+ my $key2 = "The quick brown fox jumped over the lazy, sleeping dog." x 1000;
+ my $key3 = "Lorem dolor ipsum latinum suckum causum Ium cannotum rememberum squatum." x 1000;
+
+ $db->put($key1, "value1");
+ $db->store($key2, "value2");
+ $db->{$key3} = "value3";
+
+ is( $db->{$key1}, 'value1', "Hash retrieval of put()" );
+ is( $db->{$key2}, 'value2', "Hash retrieval of store()" );
+ is( $db->{$key3}, 'value3', "Hash retrieval of hashstore" );
+ is( $db->get($key1), 'value1', "get() retrieval of put()" );
+ is( $db->get($key2), 'value2', "get() retrieval of store()" );
+ is( $db->get($key3), 'value3', "get() retrieval of hashstore" );
+ is( $db->fetch($key1), 'value1', "fetch() retrieval of put()" );
+ is( $db->fetch($key2), 'value2', "fetch() retrieval of store()" );
+ is( $db->fetch($key3), 'value3', "fetch() retrieval of hashstore" );
+
+ my $test_key = $db->first_key();
+ ok(
+ ($test_key eq $key1) ||
+ ($test_key eq $key2) ||
+ ($test_key eq $key3),
+ "First key found",
+ );
+
+ $test_key = $db->next_key($test_key);
+ ok(
+ ($test_key eq $key1) ||
+ ($test_key eq $key2) ||
+ ($test_key eq $key3),
+ "Second key found",
+ );
+
+ $test_key = $db->next_key($test_key);
+ ok(
+ ($test_key eq $key1) ||
+ ($test_key eq $key2) ||
+ ($test_key eq $key3),
+ "Third key found",
+ );
+
+ $test_key = $db->next_key($test_key);
+ ok( !$test_key, "No fourth key" );
+}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
plan skip_all => "Skipping the optimize tests on Win32/cygwin for now."
if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
-plan tests => 9;
-
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
my $after = (stat($filename))[7];
ok( $result, "optimize succeeded" );
-ok( $after < $before, "file size has shrunk" ); # make sure file shrunk
+cmp_ok( $after, '<', $before, "file size has shrunk" ); # make sure file shrunk
is( $db->{key1}, 'value1', "key1's value is still there after optimize" );
is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" );
is( $db->{key1}, 'value1', "key1's value is still there after optimize" );
is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 14;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
-use_ok( 'DBM::Deep' );
+use Test::More;
+use t::common qw( new_dbm );
-my ($fh, $filename) = new_fh();
+use_ok( 'DBM::Deep' );
-{
- my $clone;
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
{
- my $db = DBM::Deep->new(
- file => $filename,
- );
+ my $clone;
- $db->{key1} = "value1";
+ {
+ my $db = $dbm_maker->();
- ##
- # clone db handle, make sure both are usable
- ##
- $clone = $db->clone();
+ $db->{key1} = "value1";
- is($clone->{key1}, "value1");
+ ##
+ # clone db handle, make sure both are usable
+ ##
+ $clone = $db->clone();
- $clone->{key2} = "value2";
- $db->{key3} = "value3";
+ is($clone->{key1}, "value1");
- is($db->{key1}, "value1");
- is($db->{key2}, "value2");
- is($db->{key3}, "value3");
+ $clone->{key2} = "value2";
+ $db->{key3} = "value3";
+
+ is($db->{key1}, "value1");
+ is($db->{key2}, "value2");
+ is($db->{key3}, "value3");
+
+ is($clone->{key1}, "value1");
+ is($clone->{key2}, "value2");
+ is($clone->{key3}, "value3");
+ }
is($clone->{key1}, "value1");
is($clone->{key2}, "value2");
is($clone->{key3}, "value3");
}
- is($clone->{key1}, "value1");
- is($clone->{key2}, "value2");
- is($clone->{key3}, "value3");
-}
-
-{
- my $db = DBM::Deep->new(
- file => $filename,
- );
+ {
+ my $db = $dbm_maker->();
- is($db->{key1}, "value1");
- is($db->{key2}, "value2");
- is($db->{key3}, "value3");
+ is($db->{key1}, "value1");
+ is($db->{key2}, "value2");
+ is($db->{key3}, "value3");
+ }
}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
+use warnings FATAL => 'all';
+
use Config;
-use Test::More tests => 10;
+use Test::More;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
# }
#
#}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 21;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
-);
+sub my_filter_store_key { return 'MYFILTER' . $_[0]; }
+sub my_filter_store_value { return 'MYFILTER' . $_[0]; }
-ok( !$db->set_filter( 'floober', sub {} ), "floober isn't a value filter key" );
+sub my_filter_fetch_key { $_[0] =~ s/^MYFILTER//; return $_[0]; }
+sub my_filter_fetch_value { $_[0] =~ s/^MYFILTER//; return $_[0]; }
-##
-# First try store filters only (values will be unfiltered)
-##
-ok( $db->set_filter( 'store_key', \&my_filter_store_key ), "set the store_key filter" );
-ok( $db->set_filter( 'store_value', \&my_filter_store_value ), "set the store_value filter" );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-$db->{key1} = "value1";
-$db->{key2} = "value2";
+ ok( !$db->set_filter( 'floober', sub {} ), "floober isn't a value filter key" );
-is($db->{key1}, "MYFILTERvalue1", "The value for key1 was filtered correctly" );
-is($db->{key2}, "MYFILTERvalue2", "The value for key2 was filtered correctly" );
+ ##
+ # First try store filters only (values will be unfiltered)
+ ##
+ ok( $db->set_filter( 'store_key', \&my_filter_store_key ), "set the store_key filter" );
+ ok( $db->set_filter( 'store_value', \&my_filter_store_value ), "set the store_value filter" );
-##
-# Now try fetch filters as well
-##
-ok( $db->set_filter( 'fetch_key', \&my_filter_fetch_key ), "Set the fetch_key filter" );
-ok( $db->set_filter( 'fetch_value', \&my_filter_fetch_value), "Set the fetch_value filter" );
+ $db->{key1} = "value1";
+ $db->{key2} = "value2";
-is($db->{key1}, "value1", "Fetchfilters worked right");
-is($db->{key2}, "value2", "Fetchfilters worked right");
+ is($db->{key1}, "MYFILTERvalue1", "The value for key1 was filtered correctly" );
+ is($db->{key2}, "MYFILTERvalue2", "The value for key2 was filtered correctly" );
-##
-# Try fetching keys as well as values
-##
-cmp_bag( [ keys %$db ], [qw( key1 key2 )], "DB keys correct" );
+ ##
+ # Now try fetch filters as well
+ ##
+ ok( $db->set_filter( 'fetch_key', \&my_filter_fetch_key ), "Set the fetch_key filter" );
+ ok( $db->set_filter( 'fetch_value', \&my_filter_fetch_value), "Set the fetch_value filter" );
-# Exists and delete tests
-ok( exists $db->{key1}, "Key1 exists" );
-ok( exists $db->{key2}, "Key2 exists" );
+ is($db->{key1}, "value1", "Fetchfilters worked right");
+ is($db->{key2}, "value2", "Fetchfilters worked right");
-is( delete $db->{key1}, 'value1', "Delete returns the right value" );
+ ##
+ # Try fetching keys as well as values
+ ##
+ cmp_bag( [ keys %$db ], [qw( key1 key2 )], "DB keys correct" );
-ok( !exists $db->{key1}, "Key1 no longer exists" );
-ok( exists $db->{key2}, "Key2 exists" );
+ # Exists and delete tests
+ ok( exists $db->{key1}, "Key1 exists" );
+ ok( exists $db->{key2}, "Key2 exists" );
-##
-# Now clear all filters, and make sure all is unfiltered
-##
-ok( $db->filter_store_key( undef ), "Unset store_key filter" );
-ok( $db->filter_store_value( undef ), "Unset store_value filter" );
-ok( $db->filter_fetch_key( undef ), "Unset fetch_key filter" );
-ok( $db->filter_fetch_value( undef ), "Unset fetch_value filter" );
+ is( delete $db->{key1}, 'value1', "Delete returns the right value" );
-is( $db->{MYFILTERkey2}, "MYFILTERvalue2", "We get the right unfiltered value" );
+ ok( !exists $db->{key1}, "Key1 no longer exists" );
+ ok( exists $db->{key2}, "Key2 exists" );
-sub my_filter_store_key { return 'MYFILTER' . $_[0]; }
-sub my_filter_store_value { return 'MYFILTER' . $_[0]; }
+ ##
+ # Now clear all filters, and make sure all is unfiltered
+ ##
+ ok( $db->filter_store_key( undef ), "Unset store_key filter" );
+ ok( $db->filter_store_value( undef ), "Unset store_value filter" );
+ ok( $db->filter_fetch_key( undef ), "Unset fetch_key filter" );
+ ok( $db->filter_fetch_value( undef ), "Unset fetch_value filter" );
-sub my_filter_fetch_key { $_[0] =~ s/^MYFILTER//; return $_[0]; }
-sub my_filter_fetch_value { $_[0] =~ s/^MYFILTER//; return $_[0]; }
+ is( $db->{MYFILTERkey2}, "MYFILTERvalue2", "We get the right unfiltered value" );
+}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 14;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
-use_ok( 'DBM::Deep' );
+use Test::More;
+use t::common qw( new_dbm );
-my ($fh, $filename) = new_fh();
+use_ok( 'DBM::Deep' );
my $salt = 38473827;
-my $db = new DBM::Deep(
- file => $filename,
- digest => \&my_digest,
- hash_size => 8,
-);
-
-##
-# put/get key
-##
-$db->{key1} = "value1";
-ok( $db->{key1} eq "value1" );
-
-$db->put("key2", "value2");
-ok( $db->get("key2") eq "value2" );
-
-##
-# key exists
-##
-ok( $db->exists("key1") );
-ok( exists $db->{key2} );
-
-##
-# count keys
-##
-ok( scalar keys %$db == 2 );
-
-##
-# step through keys
-##
-my $temphash = {};
-while ( my ($key, $value) = each %$db ) {
- $temphash->{$key} = $value;
+# Warning: This digest function is for testing ONLY.
+# It is NOT intended for actual use. If you do so, I will laugh at you.
+sub my_digest {
+ my $key = shift;
+ my $num = $salt;
+
+ for (my $k=0; $k<length($key); $k++) {
+ $num += ord( substr($key, $k, 1) );
+ }
+
+ return sprintf("%00000008d", $num);
}
-ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") );
+my $dbm_factory = new_dbm( digest => \&my_digest, hash_size => 8 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-$temphash = {};
-my $key = $db->first_key();
-while ($key) {
- $temphash->{$key} = $db->get($key);
- $key = $db->next_key($key);
-}
+ ##
+ # put/get key
+ ##
+ $db->{key1} = "value1";
+ ok( $db->{key1} eq "value1" );
-ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") );
+ $db->put("key2", "value2");
+ ok( $db->get("key2") eq "value2" );
-##
-# delete keys
-##
-ok( delete $db->{key1} );
-ok( $db->delete("key2") );
+ ##
+ # key exists
+ ##
+ ok( $db->exists("key1") );
+ ok( exists $db->{key2} );
-ok( scalar keys %$db == 0 );
+ ##
+ # count keys
+ ##
+ ok( scalar keys %$db == 2 );
-##
-# delete all keys
-##
-$db->put("another", "value");
-$db->clear();
+ ##
+ # step through keys
+ ##
+ my $temphash = {};
+ while ( my ($key, $value) = each %$db ) {
+ $temphash->{$key} = $value;
+ }
-ok( scalar keys %$db == 0 );
+ ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") );
-##
-# replace key
-##
-$db->put("key1", "value1");
-$db->put("key1", "value2");
+ $temphash = {};
+ my $key = $db->first_key();
+ while ($key) {
+ $temphash->{$key} = $db->get($key);
+ $key = $db->next_key($key);
+ }
-ok( $db->get("key1") eq "value2" );
+ ok( ($temphash->{key1} eq "value1") && ($temphash->{key2} eq "value2") );
-$db->put("key1", "value222222222222222222222222");
+ ##
+ # delete keys
+ ##
+ ok( delete $db->{key1} );
+ ok( $db->delete("key2") );
-ok( $db->get("key1") eq "value222222222222222222222222" );
+ ok( scalar keys %$db == 0 );
-sub my_digest {
- ##
- # Warning: This digest function is for testing ONLY
- # It is NOT intended for actual use
- ##
- my $key = shift;
- my $num = $salt;
-
- for (my $k=0; $k<length($key); $k++) {
- $num += ord( substr($key, $k, 1) );
- }
-
- return sprintf("%00000008d", $num);
+ ##
+ # delete all keys
+ ##
+ $db->put("another", "value");
+ $db->clear();
+
+ ok( scalar keys %$db == 0 );
+
+ ##
+ # replace key
+ ##
+ $db->put("key1", "value1");
+ $db->put("key1", "value2");
+
+ ok( $db->get("key1") eq "value2" );
+
+ $db->put("key1", "value222222222222222222222222");
+
+ ok( $db->get("key1") eq "value222222222222222222222222" );
}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 32;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
-use_ok( 'DBM::Deep' );
+use Test::More;
+use t::common qw( new_dbm );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( file => $filename, fh => $fh, );
-
-##
-# put/get simple keys
-##
-$db->{key1} = "value1";
-$db->{key2} = "value2";
-
-my @keys_1 = sort keys %$db;
-
-$db->{key3} = $db->{key1};
-
-my @keys_2 = sort keys %$db;
-is( @keys_2 + 0, @keys_1 + 1, "Correct number of keys" );
-is_deeply(
- [ @keys_1, 'key3' ],
- [ @keys_2 ],
- "Keys still match after circular reference is added",
-);
-
-$db->{key4} = { 'foo' => 'bar' };
-$db->{key5} = $db->{key4};
-$db->{key6} = $db->{key5};
-
-my @keys_3 = sort keys %$db;
-
-is( @keys_3 + 0, @keys_2 + 3, "Correct number of keys" );
-is_deeply(
- [ @keys_2, 'key4', 'key5', 'key6', ],
- [ @keys_3 ],
- "Keys still match after circular reference is added (@keys_3)",
-);
-
-##
-# Insert circular reference
-##
-$db->{circle} = $db;
-
-my @keys_4 = sort keys %$db;
-
-is( @keys_4 + 0, @keys_3 + 1, "Correct number of keys" );
-is_deeply(
- [ 'circle', @keys_3 ],
- [ @keys_4 ],
- "Keys still match after circular reference is added",
-);
-
-##
-# Make sure keys exist in both places
-##
-is( $db->{key1}, 'value1', "The value is there directly" );
-is( $db->{circle}{key1}, 'value1', "The value is there in one loop of the circle" );
-is( $db->{circle}{circle}{key1}, 'value1', "The value is there in two loops of the circle" );
-is( $db->{circle}{circle}{circle}{key1}, 'value1', "The value is there in three loops of the circle" );
-
-##
-# Make sure changes are reflected in both places
-##
-$db->{key1} = "another value";
-
-isnt( $db->{key3}, 'another value', "Simple scalars are copied by value" );
-
-is( $db->{key1}, 'another value', "The value is there directly" );
-is( $db->{circle}{key1}, 'another value', "The value is there in one loop of the circle" );
-is( $db->{circle}{circle}{key1}, 'another value', "The value is there in two loops of the circle" );
-is( $db->{circle}{circle}{circle}{key1}, 'another value', "The value is there in three loops of the circle" );
-
-$db->{circle}{circle}{circle}{circle}{key1} = "circles";
-
-is( $db->{key1}, 'circles', "The value is there directly" );
-is( $db->{circle}{key1}, 'circles', "The value is there in one loop of the circle" );
-is( $db->{circle}{circle}{key1}, 'circles', "The value is there in two loops of the circle" );
-is( $db->{circle}{circle}{circle}{key1}, 'circles', "The value is there in three loops of the circle" );
-
-is( $db->{key4}{foo}, 'bar' );
-is( $db->{key5}{foo}, 'bar' );
-is( $db->{key6}{foo}, 'bar' );
-
-$db->{key4}{foo2} = 'bar2';
-is( $db->{key4}{foo2}, 'bar2' );
-is( $db->{key5}{foo2}, 'bar2' );
-is( $db->{key6}{foo2}, 'bar2' );
-
-$db->{key4}{foo3} = 'bar3';
-is( $db->{key4}{foo3}, 'bar3' );
-is( $db->{key5}{foo3}, 'bar3' );
-is( $db->{key6}{foo3}, 'bar3' );
-
-$db->{key4}{foo4} = 'bar4';
-is( $db->{key4}{foo4}, 'bar4' );
-is( $db->{key5}{foo4}, 'bar4' );
-is( $db->{key6}{foo4}, 'bar4' );
+use_ok( 'DBM::Deep' );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # put/get simple keys
+ ##
+ $db->{key1} = "value1";
+ $db->{key2} = "value2";
+
+ my @keys_1 = sort keys %$db;
+
+ $db->{key3} = $db->{key1};
+
+ my @keys_2 = sort keys %$db;
+ is( @keys_2 + 0, @keys_1 + 1, "Correct number of keys" );
+ is_deeply(
+ [ @keys_1, 'key3' ],
+ [ @keys_2 ],
+ "Keys still match after circular reference is added",
+ );
+
+ $db->{key4} = { 'foo' => 'bar' };
+ $db->{key5} = $db->{key4};
+ $db->{key6} = $db->{key5};
+
+ my @keys_3 = sort keys %$db;
+
+ is( @keys_3 + 0, @keys_2 + 3, "Correct number of keys" );
+ is_deeply(
+ [ @keys_2, 'key4', 'key5', 'key6', ],
+ [ @keys_3 ],
+ "Keys still match after circular reference is added (@keys_3)",
+ );
+
+ ##
+ # Insert circular reference
+ ##
+ $db->{circle} = $db;
+
+ my @keys_4 = sort keys %$db;
+
+ is( @keys_4 + 0, @keys_3 + 1, "Correct number of keys" );
+ is_deeply(
+ [ 'circle', @keys_3 ],
+ [ @keys_4 ],
+ "Keys still match after circular reference is added",
+ );
+
+ ##
+ # Make sure keys exist in both places
+ ##
+ is( $db->{key1}, 'value1', "The value is there directly" );
+ is( $db->{circle}{key1}, 'value1', "The value is there in one loop of the circle" );
+ is( $db->{circle}{circle}{key1}, 'value1', "The value is there in two loops of the circle" );
+ is( $db->{circle}{circle}{circle}{key1}, 'value1', "The value is there in three loops of the circle" );
+
+ ##
+ # Make sure changes are reflected in both places
+ ##
+ $db->{key1} = "another value";
+
+ isnt( $db->{key3}, 'another value', "Simple scalars are copied by value" );
+
+ is( $db->{key1}, 'another value', "The value is there directly" );
+ is( $db->{circle}{key1}, 'another value', "The value is there in one loop of the circle" );
+ is( $db->{circle}{circle}{key1}, 'another value', "The value is there in two loops of the circle" );
+ is( $db->{circle}{circle}{circle}{key1}, 'another value', "The value is there in three loops of the circle" );
+
+ $db->{circle}{circle}{circle}{circle}{key1} = "circles";
+
+ is( $db->{key1}, 'circles', "The value is there directly" );
+ is( $db->{circle}{key1}, 'circles', "The value is there in one loop of the circle" );
+ is( $db->{circle}{circle}{key1}, 'circles', "The value is there in two loops of the circle" );
+ is( $db->{circle}{circle}{circle}{key1}, 'circles', "The value is there in three loops of the circle" );
+
+ is( $db->{key4}{foo}, 'bar' );
+ is( $db->{key5}{foo}, 'bar' );
+ is( $db->{key6}{foo}, 'bar' );
+
+ $db->{key4}{foo2} = 'bar2';
+ is( $db->{key4}{foo2}, 'bar2' );
+ is( $db->{key5}{foo2}, 'bar2' );
+ is( $db->{key6}{foo2}, 'bar2' );
+
+ $db->{key4}{foo3} = 'bar3';
+ is( $db->{key4}{foo3}, 'bar3' );
+ is( $db->{key5}{foo3}, 'bar3' );
+ is( $db->{key6}{foo3}, 'bar3' );
+
+ $db->{key4}{foo4} = 'bar4';
+ is( $db->{key4}{foo4}, 'bar4' );
+ is( $db->{key5}{foo4}, 'bar4' );
+ is( $db->{key6}{foo4}, 'bar4' );
+}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 17;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
# Failure cases to make sure that things are caught right.
foreach my $type ( DBM::Deep->TYPE_HASH, DBM::Deep->TYPE_ARRAY ) {
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new({
- file => $filename,
- fh => $fh,
- type => $type,
- });
-
- # Load a scalar
- throws_ok {
- $db->import( 'foo' );
- } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails";
-
- # Load a ref of the wrong type
- # Load something with bad stuff in it
- my $x = 3;
- if ( $type eq 'A' ) {
- throws_ok {
- $db->import( { foo => 'bar' } );
- } qr/Cannot import a hash into an array/, "Wrong type fails";
-
- throws_ok {
- $db->import( [ \$x ] );
- } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
- }
- else {
- throws_ok {
- $db->import( [ 1 .. 3 ] );
- } qr/Cannot import an array into a hash/, "Wrong type fails";
+ my $dbm_factory = new_dbm( type => $type );
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+ # Load a scalar
throws_ok {
- $db->import( { foo => \$x } );
- } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
+ $db->import( 'foo' );
+ } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails";
+
+ # Load a ref of the wrong type
+ # Load something with bad stuff in it
+ my $x = 3;
+ if ( $type eq 'A' ) {
+ throws_ok {
+ $db->import( { foo => 'bar' } );
+ } qr/Cannot import a hash into an array/, "Wrong type fails";
+
+ throws_ok {
+ $db->import( [ \$x ] );
+ } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
+ }
+ else {
+ throws_ok {
+ $db->import( [ 1 .. 3 ] );
+ } qr/Cannot import an array into a hash/, "Wrong type fails";
+
+ throws_ok {
+ $db->import( { foo => \$x } );
+ } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
+ }
}
}
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new({
- file => $filename,
- fh => $fh,
- autobless => 1,
- });
-
-##
-# Create structure in memory
-##
+my $dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ ##
+ # Create structure in memory
+ ##
my $struct = {
key1 => "value1",
key2 => "value2",
ok( !exists $db->{hash1}->{foo}, "\$db->{hash1} doesn't have the 'foo' key, so \$struct->{hash1} is not tied" );
}
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new({
- file => $filename,
- fh => $fh,
- type => DBM::Deep->TYPE_ARRAY,
- });
+$dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
my $struct = [
1 .. 3,
}
# Failure case to verify that rollback occurs
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new({
- file => $filename,
- fh => $fh,
- autobless => 1,
- });
+$dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
$db->{foo} = 'bar';
}
}
+done_testing;
+
__END__
Need to add tests for:
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 6;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
},
);
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new({
- file => $filename,
- fh => $fh,
- autobless => 1,
-});
+my $dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-##
-# Create structure in DB
-##
-$db->import( \%struct );
+ ##
+ # Create structure in DB
+ ##
+ $db->import( \%struct );
-##
-# Export entire thing
-##
-my $compare = $db->export();
+ ##
+ # Export entire thing
+ ##
+ my $compare = $db->export();
-cmp_deeply(
- $compare,
- {
- key1 => "value1",
- key2 => "value2",
- array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ] ],
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2",
- subkey3 => bless( {
- sub_obj => bless([
- bless([], 'Foo'),
- ], 'Foo'),
- sub_obj2 => bless([], 'Foo'),
- }, 'Foo' ),
+ cmp_deeply(
+ $compare,
+ {
+ key1 => "value1",
+ key2 => "value2",
+ array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ] ],
+ hash1 => {
+ subkey1 => "subvalue1",
+ subkey2 => "subvalue2",
+ subkey3 => bless( {
+ sub_obj => bless([
+ bless([], 'Foo'),
+ ], 'Foo'),
+ sub_obj2 => bless([], 'Foo'),
+ }, 'Foo' ),
+ },
},
- },
- "Everything matches",
-);
+ "Everything matches",
+ );
+
+ isa_ok( tied(%{$db->{hash1}{subkey3}})->export, 'Foo' );
+ isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}})->export, 'Foo' );
+ isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}[0]})->export, 'Foo' );
+ isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj2}})->export, 'Foo' );
+}
-isa_ok( tied(%{$db->{hash1}{subkey3}})->export, 'Foo' );
-isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}})->export, 'Foo' );
-isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj}[0]})->export, 'Foo' );
-isa_ok( tied(@{$db->{hash1}{subkey3}{sub_obj2}})->export, 'Foo' );
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 9;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh2, $filename2) = new_fh();
-my $db2 = DBM::Deep->new( file => $filename2, fh => $fh2, );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-SKIP: {
- skip "Apparently, we cannot detect a tied scalar?", 1;
- tie my $foo, 'Tied::Scalar';
- throws_ok {
- $db2->{failure} = $foo;
- } qr/Cannot store something that is tied\./, "tied scalar storage fails";
-}
+ SKIP: {
+ skip "Apparently, we cannot detect a tied scalar?", 1;
+ tie my $foo, 'Tied::Scalar';
+ throws_ok {
+ $db->{failure} = $foo;
+ } qr/Cannot store something that is tied\./, "tied scalar storage fails";
+ }
-{
- tie my @foo, 'Tied::Array';
- throws_ok {
- $db2->{failure} = \@foo;
- } qr/Cannot store something that is tied\./, "tied array storage fails";
-}
+ {
+ tie my @foo, 'Tied::Array';
+ throws_ok {
+ $db->{failure} = \@foo;
+ } qr/Cannot store something that is tied\./, "tied array storage fails";
+ }
-{
- tie my %foo, 'Tied::Hash';
- throws_ok {
- $db2->{failure} = \%foo;
- } qr/Cannot store something that is tied\./, "tied hash storage fails";
-}
+ {
+ tie my %foo, 'Tied::Hash';
+ throws_ok {
+ $db->{failure} = \%foo;
+ } qr/Cannot store something that is tied\./, "tied hash storage fails";
+ }
+
+ # Need to create a second instance of a dbm here, but only of the type
+ # being tested.
+ if(0){
+ my $db2 = $dbm_maker->();
+
+ $db2->import({
+ hash1 => {
+ subkey1 => "subvalue1",
+ subkey2 => "subvalue2",
+ }
+ });
+ is( $db2->{hash1}{subkey1}, 'subvalue1', "Value1 imported correctly" );
+ is( $db2->{hash1}{subkey2}, 'subvalue2', "Value2 imported correctly" );
+
+ # Test cross-ref nested hash across DB objects
+ throws_ok {
+ $db->{copy} = $db2->{hash1};
+ } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails";
+
+ # This error text is for when internal cross-refs are implemented:
+ # qr/Cannot cross-reference\. Use export\(\) instead\./
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( file => $filename, fh => $fh, );
+ my $x = $db2->{hash1}->export;
+ $db->{copy} = $x;
+ }
##
- # Create structure in $db
+ # Make sure $db has copy of $db2's hash structure
##
- $db->import({
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2",
- }
- });
- is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
- is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
-
- # Test cross-ref nested hash accross DB objects
- throws_ok {
- $db2->{copy} = $db->{hash1};
- } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails";
-
- # This error text is for when internal cross-refs are implemented
- #} qr/Cannot cross-reference\. Use export\(\) instead\./, "cross-ref fails";
-
- $db2->{copy} = $db->{hash1}->export;
+# is( $db->{copy}{subkey1}, 'subvalue1', "Value1 copied correctly" );
+# is( $db->{copy}{subkey2}, 'subvalue2', "Value2 copied correctly" );
}
-##
-# Make sure $db2 has copy of $db's hash structure
-##
-is( $db2->{copy}{subkey1}, 'subvalue1', "Value copied correctly" );
-is( $db2->{copy}{subkey2}, 'subvalue2', "Value copied correctly" );
+done_testing;
package Tied::Scalar;
sub TIESCALAR { bless {}, $_[0]; }
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 11;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
-##
# testing the various modes of opening a file
-##
{
my ($fh, $filename) = new_fh();
my %hash;
throws_ok {
tie my @array, 'DBM::Deep', undef, file => $filename;
} qr/Odd number of parameters/, "Odd number of params to TIEARRAY fails";
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 7;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
} qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type";
$db->_get_self->_engine->storage->close( $db->_get_self );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 13;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
+
+use Test::More;
+use t::common qw( new_dbm new_fh );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( file => $filename, fh => $fh, );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-##
-# Create structure in $db
-##
-$db->import({
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2",
- },
- hash2 => {
- subkey3 => 'subvalue3',
- },
-});
+ $db->import({
+ hash1 => {
+ subkey1 => "subvalue1",
+ subkey2 => "subvalue2",
+ },
+ hash2 => {
+ subkey3 => 'subvalue3',
+ },
+ });
-is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
-is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
+ is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
+ is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
-$db->{copy} = $db->{hash1};
+ $db->{copy} = $db->{hash1};
-is( $db->{copy}{subkey1}, 'subvalue1', "Value copied correctly" );
-is( $db->{copy}{subkey2}, 'subvalue2', "Value copied correctly" );
+ is( $db->{copy}{subkey1}, 'subvalue1', "Value copied correctly" );
+ is( $db->{copy}{subkey2}, 'subvalue2', "Value copied correctly" );
-$db->{copy}{subkey1} = "another value";
-is( $db->{copy}{subkey1}, 'another value', "New value is set correctly" );
-is( $db->{hash1}{subkey1}, 'another value', "Old value is set to the new one" );
+ $db->{copy}{subkey1} = "another value";
+ is( $db->{copy}{subkey1}, 'another value', "New value is set correctly" );
+ is( $db->{hash1}{subkey1}, 'another value', "Old value is set to the new one" );
-is( scalar(keys %{$db->{hash1}}), 2, "Start with 2 keys in the original" );
-is( scalar(keys %{$db->{copy}}), 2, "Start with 2 keys in the copy" );
+ is( scalar(keys %{$db->{hash1}}), 2, "Start with 2 keys in the original" );
+ is( scalar(keys %{$db->{copy}}), 2, "Start with 2 keys in the copy" );
-delete $db->{copy}{subkey2};
+ delete $db->{copy}{subkey2};
-is( scalar(keys %{$db->{copy}}), 1, "Now only have 1 key in the copy" );
-is( scalar(keys %{$db->{hash1}}), 1, "... and only 1 key in the original" );
+ is( scalar(keys %{$db->{copy}}), 1, "Now only have 1 key in the copy" );
+ is( scalar(keys %{$db->{hash1}}), 1, "... and only 1 key in the original" );
-$db->{copy} = $db->{hash2};
-is( $db->{copy}{subkey3}, 'subvalue3', "After the second copy, we're still good" );
-my $max_keys = 1000;
+ $db->{copy} = $db->{hash2};
+ is( $db->{copy}{subkey3}, 'subvalue3', "After the second copy, we're still good" );
+}
-my ($fh2, $filename2) = new_fh();
{
- my $db = DBM::Deep->new( file => $filename2, fh => $fh2, );
+ my $max_keys = 1000;
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ {
+ my $db = $dbm_maker->();
- $db->{foo} = [ 1 .. 3 ];
- for ( 0 .. $max_keys ) {
- $db->{'foo' . $_} = $db->{foo};
- }
- ## Rewind handle otherwise the signature is not recognised below.
- ## The signature check should probably rewind the fh?
- seek $db->_get_self->_engine->storage->{fh}, 0, 0;
-}
+ $db->{foo} = [ 1 .. 3 ];
+ for ( 0 .. $max_keys ) {
+ $db->{'foo' . $_} = $db->{foo};
+ }
+ }
-{
- my $db = DBM::Deep->new( fh => $fh2, );
-
- my $base_offset = $db->{foo}->_base_offset;
- my $count = -1;
- for ( 0 .. $max_keys ) {
- $count = $_;
- unless ( $base_offset == $db->{'foo'.$_}->_base_offset ) {
- last;
+ {
+ my $db = $dbm_maker->();
+
+ my $base_offset = $db->{foo}->_base_offset;
+ my $count = -1;
+ for ( 0 .. $max_keys ) {
+ $count = $_;
+ unless ( $base_offset == $db->{'foo'.$_}->_base_offset ) {
+ last;
+ }
+ }
+ is( $count, $max_keys, "We read $count keys" );
}
}
- is( $count, $max_keys, "We read $count keys" );
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 7;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
$db->_get_self->_engine->storage->close( $db->_get_self );
ok( !$db->unlock, "Calling unlock() on a closed database returns false" );
}
+
+done_testing;
use strict;
+use warnings FATAL => 'all';
{
package Foo;
sub foo { 'foo' };
}
-use Test::More tests => 65;
-use t::common qw( new_fh );
+use Test::More;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-{
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- autobless => 1,
- );
+my $dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ {
+ my $db = $dbm_maker->();
- my $obj = bless {
- a => 1,
- b => [ 1 .. 3 ],
- }, 'Foo';
+ my $obj = bless {
+ a => 1,
+ b => [ 1 .. 3 ],
+ }, 'Foo';
- $db->{blessed} = $obj;
- is( $db->{blessed}{a}, 1 );
- is( $db->{blessed}{b}[0], 1 );
- is( $db->{blessed}{b}[1], 2 );
- is( $db->{blessed}{b}[2], 3 );
-
- my $obj2 = bless [
- { a => 'foo' },
- 2,
- ], 'Foo';
- $db->{blessed2} = $obj2;
-
- is( $db->{blessed2}[0]{a}, 'foo' );
- is( $db->{blessed2}[1], '2' );
-
- $db->{unblessed} = {};
- $db->{unblessed}{a} = 1;
- $db->{unblessed}{b} = [];
- $db->{unblessed}{b}[0] = 1;
- $db->{unblessed}{b}[1] = 2;
- $db->{unblessed}{b}[2] = 3;
-
- is( $db->{unblessed}{a}, 1 );
- is( $db->{unblessed}{b}[0], 1 );
- is( $db->{unblessed}{b}[1], 2 );
- is( $db->{unblessed}{b}[2], 3 );
-
- $db->{blessed_long} = bless {}, 'a' x 1000;
- $db->_get_self->_engine->storage->close( $db->_get_self );
-}
+ $db->{blessed} = $obj;
+ is( $db->{blessed}{a}, 1 );
+ is( $db->{blessed}{b}[0], 1 );
+ is( $db->{blessed}{b}[1], 2 );
+ is( $db->{blessed}{b}[2], 3 );
+
+ my $obj2 = bless [
+ { a => 'foo' },
+ 2,
+ ], 'Foo';
+ $db->{blessed2} = $obj2;
+
+ is( $db->{blessed2}[0]{a}, 'foo' );
+ is( $db->{blessed2}[1], '2' );
+
+ $db->{unblessed} = {};
+ $db->{unblessed}{a} = 1;
+ $db->{unblessed}{b} = [];
+ $db->{unblessed}{b}[0] = 1;
+ $db->{unblessed}{b}[1] = 2;
+ $db->{unblessed}{b}[2] = 3;
+
+ is( $db->{unblessed}{a}, 1 );
+ is( $db->{unblessed}{b}[0], 1 );
+ is( $db->{unblessed}{b}[1], 2 );
+ is( $db->{unblessed}{b}[2], 3 );
+
+ $db->{blessed_long} = bless {}, 'a' x 1000;
+ $db->_get_self->_engine->storage->close( $db->_get_self );
+ }
-{
- my $db = DBM::Deep->new(
- file => $filename,
- autobless => 1,
- );
-
- my $obj = $db->{blessed};
- isa_ok( $obj, 'Foo' );
- can_ok( $obj, 'export', 'foo' );
- ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
-
- is( $obj->{a}, 1 );
- is( $obj->{b}[0], 1 );
- is( $obj->{b}[1], 2 );
- is( $obj->{b}[2], 3 );
-
- my $obj2 = $db->{blessed2};
- isa_ok( $obj2, 'Foo' );
- can_ok( $obj2, 'export', 'foo' );
- ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
-
- is( $obj2->[0]{a}, 'foo' );
- is( $obj2->[1], '2' );
-
- is( $db->{unblessed}{a}, 1 );
- is( $db->{unblessed}{b}[0], 1 );
- is( $db->{unblessed}{b}[1], 2 );
- is( $db->{unblessed}{b}[2], 3 );
-
- $obj->{c} = 'new';
- is( $db->{blessed}{c}, 'new' );
-
- isa_ok( $db->{blessed_long}, 'a' x 1000 );
- $db->_get_self->_engine->storage->close( $db->_get_self );
-}
+ {
+ my $db = $dbm_maker->();
-{
- my $db = DBM::Deep->new(
- file => $filename,
- autobless => 1,
- );
- is( $db->{blessed}{c}, 'new' );
-
- my $structure = $db->export();
- use Data::Dumper;print Dumper $structure;
-
- my $obj = $structure->{blessed};
- isa_ok( $obj, 'Foo' );
- can_ok( $obj, 'export', 'foo' );
- ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
-
- is( $obj->{a}, 1 );
- is( $obj->{b}[0], 1 );
- is( $obj->{b}[1], 2 );
- is( $obj->{b}[2], 3 );
-
- my $obj2 = $structure->{blessed2};
- isa_ok( $obj2, 'Foo' );
- can_ok( $obj2, 'export', 'foo' );
- ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
-
- is( $obj2->[0]{a}, 'foo' );
- is( $obj2->[1], '2' );
-
- is( $structure->{unblessed}{a}, 1 );
- is( $structure->{unblessed}{b}[0], 1 );
- is( $structure->{unblessed}{b}[1], 2 );
- is( $structure->{unblessed}{b}[2], 3 );
- $db->_get_self->_engine->storage->close( $db->_get_self );
-}
+ my $obj = $db->{blessed};
+ isa_ok( $obj, 'Foo' );
+ can_ok( $obj, 'export', 'foo' );
+ ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
-{
- my $db = DBM::Deep->new(
- file => $filename,
- autobless => 0,
- );
-
- my $obj = $db->{blessed};
- isa_ok( $obj, 'DBM::Deep' );
- can_ok( $obj, 'export', 'STORE' );
- ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
-
- is( $obj->{a}, 1 );
- is( $obj->{b}[0], 1 );
- is( $obj->{b}[1], 2 );
- is( $obj->{b}[2], 3 );
-
- my $obj2 = $db->{blessed2};
- isa_ok( $obj2, 'DBM::Deep' );
- can_ok( $obj2, 'export', 'STORE' );
- ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
-
- is( $obj2->[0]{a}, 'foo' );
- is( $obj2->[1], '2' );
-
- is( $db->{unblessed}{a}, 1 );
- is( $db->{unblessed}{b}[0], 1 );
- is( $db->{unblessed}{b}[1], 2 );
- is( $db->{unblessed}{b}[2], 3 );
- $db->_get_self->_engine->storage->close( $db->_get_self );
+ is( $obj->{a}, 1 );
+ is( $obj->{b}[0], 1 );
+ is( $obj->{b}[1], 2 );
+ is( $obj->{b}[2], 3 );
+
+ my $obj2 = $db->{blessed2};
+ isa_ok( $obj2, 'Foo' );
+ can_ok( $obj2, 'export', 'foo' );
+ ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+ is( $obj2->[0]{a}, 'foo' );
+ is( $obj2->[1], '2' );
+
+ is( $db->{unblessed}{a}, 1 );
+ is( $db->{unblessed}{b}[0], 1 );
+ is( $db->{unblessed}{b}[1], 2 );
+ is( $db->{unblessed}{b}[2], 3 );
+
+ $obj->{c} = 'new';
+ is( $db->{blessed}{c}, 'new' );
+
+ isa_ok( $db->{blessed_long}, 'a' x 1000 );
+ $db->_get_self->_engine->storage->close( $db->_get_self );
+ }
+
+ {
+ my $db = $dbm_maker->();
+ is( $db->{blessed}{c}, 'new' );
+
+ my $structure = $db->export();
+ use Data::Dumper;print Dumper $structure;
+
+ my $obj = $structure->{blessed};
+ isa_ok( $obj, 'Foo' );
+ can_ok( $obj, 'export', 'foo' );
+ ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+ is( $obj->{a}, 1 );
+ is( $obj->{b}[0], 1 );
+ is( $obj->{b}[1], 2 );
+ is( $obj->{b}[2], 3 );
+
+ my $obj2 = $structure->{blessed2};
+ isa_ok( $obj2, 'Foo' );
+ can_ok( $obj2, 'export', 'foo' );
+ ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+ is( $obj2->[0]{a}, 'foo' );
+ is( $obj2->[1], '2' );
+
+ is( $structure->{unblessed}{a}, 1 );
+ is( $structure->{unblessed}{b}[0], 1 );
+ is( $structure->{unblessed}{b}[1], 2 );
+ is( $structure->{unblessed}{b}[2], 3 );
+ $db->_get_self->_engine->storage->close( $db->_get_self );
+ }
+
+ {
+ my $db = $dbm_maker->( autobless => 0 );
+
+ my $obj = $db->{blessed};
+ isa_ok( $obj, 'DBM::Deep' );
+ can_ok( $obj, 'export', 'STORE' );
+ ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
+
+ is( $obj->{a}, 1 );
+ is( $obj->{b}[0], 1 );
+ is( $obj->{b}[1], 2 );
+ is( $obj->{b}[2], 3 );
+
+ my $obj2 = $db->{blessed2};
+ isa_ok( $obj2, 'DBM::Deep' );
+ can_ok( $obj2, 'export', 'STORE' );
+ ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
+
+ is( $obj2->[0]{a}, 'foo' );
+ is( $obj2->[1], '2' );
+
+ is( $db->{unblessed}{a}, 1 );
+ is( $db->{unblessed}{b}[0], 1 );
+ is( $db->{unblessed}{b}[1], 2 );
+ is( $db->{unblessed}{b}[2], 3 );
+ $db->_get_self->_engine->storage->close( $db->_get_self );
+ }
}
-{
- my ($fh2, $filename2) = new_fh();
+$dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
{
- my $db = DBM::Deep->new(
- file => $filename2,
- fh => $fh2,
- autobless => 1,
- );
+ my $db = $dbm_maker->();
my $obj = bless {
a => 1,
b => [ 1 .. 3 ],
}, 'Foo';
$db->import( { blessed => $obj } );
- $db->_get_self->_engine->storage->close( $db->_get_self );
}
{
- my $db = DBM::Deep->new(
- file => $filename2,
- autobless => 1,
- );
+ my $db = $dbm_maker->();
my $blessed = $db->{blessed};
isa_ok( $blessed, 'Foo' );
is( $blessed->{a}, 1 );
- $db->_get_self->_engine->storage->close( $db->_get_self );
}
}
-{
- ##
- # test blessing hash into short named class (Foo), then re-blessing into
- # longer named class (FooFoo) and replacing key in db file, then validating
- # content after that point in file to check for corruption.
- ##
- my ($fh3, $filename3) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename3,
- fh => $fh3,
- autobless => 1,
- );
+# test blessing hash into short named class (Foo), then re-blessing into
+# longer named class (FooFoo) and replacing key in db file, then validating
+# content after that point in file to check for corruption.
+$dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
my $obj = bless {}, 'Foo';
is( $db->{after}, "hello" );
}
+
+done_testing;
use strict;
+use warnings FATAL => 'all';
-use Test::More tests => 5;
+use Test::More;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
isa_ok( $obj, 'DBM::Deep' );
is( reftype( $obj ), 'HASH', "... and its underlying representation is an HASH" );
}
+
+done_testing;
use strict;
+use warnings FATAL => 'all';
-use Test::More tests => 10;
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm new_fh );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-
my $x = 25;
-{
- my $db = DBM::Deep->new( $filename );
-
- throws_ok {
- $db->{scalarref} = \$x;
- } qr/Storage of references of type 'SCALAR' is not supported/,
- 'Storage of scalar refs not supported';
-
- throws_ok {
- $db->{scalarref} = \\$x;
- } qr/Storage of references of type 'REF' is not supported/,
- 'Storage of ref refs not supported';
-
- throws_ok {
- $db->{scalarref} = sub { 1 };
- } qr/Storage of references of type 'CODE' is not supported/,
- 'Storage of code refs not supported';
-
- throws_ok {
- $db->{scalarref} = $fh;
- } qr/Storage of references of type 'GLOB' is not supported/,
- 'Storage of glob refs not supported';
-
- $db->{scalar} = $x;
- TODO: {
- todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2;
- lives_ok {
- $db->{selfref} = \$db->{scalar};
- } "Refs to DBM::Deep objects are ok";
-
- is( ${$db->{selfref}}, $x, "A ref to a DBM::Deep object is ok" );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ {
+ my $db = $dbm_maker->();
+
+ throws_ok {
+ $db->{scalarref} = \$x;
+ } qr/Storage of references of type 'SCALAR' is not supported/,
+ 'Storage of scalar refs not supported';
+
+ throws_ok {
+ $db->{scalarref} = \\$x;
+ } qr/Storage of references of type 'REF' is not supported/,
+ 'Storage of ref refs not supported';
+
+ throws_ok {
+ $db->{scalarref} = sub { 1 };
+ } qr/Storage of references of type 'CODE' is not supported/,
+ 'Storage of code refs not supported';
+
+ throws_ok {
+ my ($fh, $filename) = new_fh;
+ $db->{scalarref} = $fh;
+ } qr/Storage of references of type 'GLOB' is not supported/,
+ 'Storage of glob refs not supported';
+
+ $db->{scalar} = $x;
+ TODO: {
+ todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2;
+ lives_ok {
+ $db->{selfref} = \$db->{scalar};
+ } "Refs to DBM::Deep objects are ok";
+
+ is( ${$db->{selfref}}, $x, "A ref to a DBM::Deep object is ok" );
+ }
}
-}
-{
- my $db = DBM::Deep->new( $filename );
+ {
+ my $db = $dbm_maker->();
- is( $db->{scalar}, $x, "Scalar retrieved ok" );
- TODO: {
- todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2;
- is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" );
- is( ${$db->{selfref}}, 26, "Scalarref to stored scalar retrieved ok" );
+ is( $db->{scalar}, $x, "Scalar retrieved ok" );
+ TODO: {
+ todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2;
+ is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" );
+ is( ${$db->{selfref}}, 26, "Scalarref to stored scalar retrieved ok" );
+ }
}
}
+
+done_testing;
-use 5.006_000;
-
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 14;
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
+# Need to have an explicit plan in order for the sub-testing to work right.
+#XXX Figure out how to use subtests for that.
+my $pre_fork_tests = 14;
+plan tests => $pre_fork_tests + 2;
+
use_ok( 'DBM::Deep' );
{
} qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
ok( !$db->exists( 'foo' ), "foo doesn't exist" );
+ throws_ok {
+ delete $db->{foo};
+ } qr/Cannot write to a readonly filehandle/, "Can't delete from a read-only filehandle";
+
+ throws_ok {
+ %$db = ();
+ } qr/Cannot write to a readonly filehandle/, "Can't clear from a read-only filehandle";
+
SKIP: {
skip( "No inode tests on Win32", 1 )
if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
my ($fh,$filename) = new_fh();
print $fh "#!$^X\n";
- print $fh <<'__END_FH__';
+ print $fh <<"__END_FH__";
use strict;
use Test::More 'no_plan';
Test::More->builder->no_ending(1);
-Test::More->builder->{Curr_Test} = 12;
+Test::More->builder->{Curr_Test} = $pre_fork_tests;
use_ok( 'DBM::Deep' );
-my $db = DBM::Deep->new({
+my \$db = DBM::Deep->new({
fh => *DATA,
});
-is($db->{x}, 'b', "and get at stuff in the database");
+is(\$db->{x}, 'b', "and get at stuff in the database");
__END_FH__
# The exec below prevents END blocks from doing this.
my $db = DBM::Deep->new({
file => $filename,
file_offset => $offset,
-#XXX For some reason, this is needed to make the test pass. Figure out why later.
-locking => 0,
+ #XXX For some reason, this is needed to make the test pass. Figure
+ #XXX out why later.
+ locking => 0,
});
$db->{x} = 'b';
use strict;
-use Test::More tests => 40;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
+my $dbm_factory = new_dbm(
+ locking => 1,
autoflush => 1,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-for ( 1 .. 17 ) {
- $db->{ $_ } = $_;
- is( $db->{$_}, $_, "Addition of $_ is still $_" );
-}
+ for ( 1 .. 17 ) {
+ $db->{ $_ } = $_;
+ is( $db->{$_}, $_, "Addition of $_ is still $_" );
+ }
-for ( 1 .. 17 ) {
- is( $db->{$_}, $_, "Verification of $_ is still $_" );
-}
+ for ( 1 .. 17 ) {
+ is( $db->{$_}, $_, "Verification of $_ is still $_" );
+ }
-my @keys = keys %$db;
-cmp_ok( scalar(@keys), '==', 17, "Right number of keys returned" );
+ my @keys = keys %$db;
+ cmp_ok( scalar(@keys), '==', 17, "Right number of keys returned" );
-ok( !exists $db->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" );
-is( $db->{does_not_exist}, undef, "autovivification works on large hashes" );
-ok( exists $db->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" );
-cmp_ok( scalar(keys %$db), '==', 18, "Number of keys after autovivify is correct" );
+ ok( !exists $db->{does_not_exist}, "EXISTS works on large hashes for non-existent keys" );
+ is( $db->{does_not_exist}, undef, "autovivification works on large hashes" );
+ ok( exists $db->{does_not_exist}, "EXISTS works on large hashes for newly-existent keys" );
+ cmp_ok( scalar(keys %$db), '==', 18, "Number of keys after autovivify is correct" );
+}
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 4;
-use t::common qw( new_fh );
+use warnings FATAL => 'all';
+
+use Test::More;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
-);
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ my $val1 = "a" x 6000;
-##
-# large keys
-##
-my $val1 = "a" x 6000;
+ $db->{foo} = $val1;
+ is( $db->{foo}, $val1, "6000 char value stored and retrieved" );
-$db->{foo} = $val1;
-is( $db->{foo}, $val1, "6000 char value stored and retrieved" );
+# delete $db->{foo};
+# my $size = -s $filename;
+# $db->{bar} = "a" x 300;
+# is( $db->{bar}, 'a' x 300, "New 256 char value is stored" );
+# cmp_ok( $size, '==', -s $filename, "Freespace is reused" );
+}
-delete $db->{foo};
-my $size = -s $filename;
-$db->{bar} = "a" x 300;
-is( $db->{bar}, 'a' x 300, "New 256 char value is stored" );
-cmp_ok( $size, '==', -s $filename, "Freespace is reused" );
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 7;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-{
{
- package My::Tie::Hash;
+ {
+ package My::Tie::Hash;
- sub TIEHASH {
- my $class = shift;
+ sub TIEHASH {
+ my $class = shift;
- return bless {
- }, $class;
+ return bless {
+ }, $class;
+ }
}
- }
- my %hash;
- tie %hash, 'My::Tie::Hash';
- isa_ok( tied(%hash), 'My::Tie::Hash' );
+ my %hash;
+ tie %hash, 'My::Tie::Hash';
+ isa_ok( tied(%hash), 'My::Tie::Hash' );
- throws_ok {
- $db->{foo} = \%hash;
- } qr/Cannot store something that is tied/, "Cannot store tied hashes";
-}
+ throws_ok {
+ $db->{foo} = \%hash;
+ } qr/Cannot store something that is tied/, "Cannot store tied hashes";
+ }
-{
{
- package My::Tie::Array;
+ {
+ package My::Tie::Array;
- sub TIEARRAY {
- my $class = shift;
+ sub TIEARRAY {
+ my $class = shift;
- return bless {
- }, $class;
- }
+ return bless {
+ }, $class;
+ }
- sub FETCHSIZE { 0 }
- }
+ sub FETCHSIZE { 0 }
+ }
- my @array;
- tie @array, 'My::Tie::Array';
- isa_ok( tied(@array), 'My::Tie::Array' );
+ my @array;
+ tie @array, 'My::Tie::Array';
+ isa_ok( tied(@array), 'My::Tie::Array' );
- throws_ok {
- $db->{foo} = \@array;
- } qr/Cannot store something that is tied/, "Cannot store tied arrays";
-}
+ throws_ok {
+ $db->{foo} = \@array;
+ } qr/Cannot store something that is tied/, "Cannot store tied arrays";
+ }
{
- package My::Tie::Scalar;
+ {
+ package My::Tie::Scalar;
- sub TIESCALAR {
- my $class = shift;
+ sub TIESCALAR {
+ my $class = shift;
- return bless {
- }, $class;
+ return bless {
+ }, $class;
+ }
}
- }
- my $scalar;
- tie $scalar, 'My::Tie::Scalar';
- isa_ok( tied($scalar), 'My::Tie::Scalar' );
+ my $scalar;
+ tie $scalar, 'My::Tie::Scalar';
+ isa_ok( tied($scalar), 'My::Tie::Scalar' );
+
+ throws_ok {
+ $db->{foo} = \$scalar;
+ } qr/Storage of references of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars";
+ }
+}
-throws_ok {
- $db->{foo} = \$scalar;
-} qr/Storage of references of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars";
+done_testing;
use strict;
+use warnings FATAL => 'all';
-use Test::More tests => 16;
+use Test::More;
use Test::Deep;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( file => $filename, fh => $fh, );
+ my %hash = (
+ foo => 1,
+ bar => [ 1 .. 3 ],
+ baz => { a => 42 },
+ );
-my %hash = (
- foo => 1,
- bar => [ 1 .. 3 ],
- baz => { a => 42 },
-);
+ $db->{hash} = \%hash;
+ isa_ok( tied(%hash), 'DBM::Deep::Hash' );
-$db->{hash} = \%hash;
-isa_ok( tied(%hash), 'DBM::Deep::Hash' );
+ is( $db->{hash}{foo}, 1 );
+ cmp_deeply( $db->{hash}{bar}, noclass([ 1 .. 3 ]) );
+ cmp_deeply( $db->{hash}{baz}, noclass({ a => 42 }) );
-is( $db->{hash}{foo}, 1 );
-cmp_deeply( $db->{hash}{bar}, noclass([ 1 .. 3 ]) );
-cmp_deeply( $db->{hash}{baz}, noclass({ a => 42 }) );
+ $hash{foo} = 2;
+ is( $db->{hash}{foo}, 2 );
-$hash{foo} = 2;
-is( $db->{hash}{foo}, 2 );
+ $hash{bar}[1] = 90;
+ is( $db->{hash}{bar}[1], 90 );
-$hash{bar}[1] = 90;
-is( $db->{hash}{bar}[1], 90 );
+ $hash{baz}{b} = 33;
+ is( $db->{hash}{baz}{b}, 33 );
-$hash{baz}{b} = 33;
-is( $db->{hash}{baz}{b}, 33 );
+ my @array = (
+ 1, [ 1 .. 3 ], { a => 42 },
+ );
-my @array = (
- 1, [ 1 .. 3 ], { a => 42 },
-);
+ $db->{array} = \@array;
+ isa_ok( tied(@array), 'DBM::Deep::Array' );
-$db->{array} = \@array;
-isa_ok( tied(@array), 'DBM::Deep::Array' );
+ is( $db->{array}[0], 1 );
+ cmp_deeply( $db->{array}[1], noclass([ 1 .. 3 ]) );
+ cmp_deeply( $db->{array}[2], noclass({ a => 42 }) );
-is( $db->{array}[0], 1 );
-cmp_deeply( $db->{array}[1], noclass([ 1 .. 3 ]) );
-cmp_deeply( $db->{array}[2], noclass({ a => 42 }) );
+ $array[0] = 2;
+ is( $db->{array}[0], 2 );
-$array[0] = 2;
-is( $db->{array}[0], 2 );
+ $array[1][2] = 9;
+ is( $db->{array}[1][2], 9 );
-$array[1][2] = 9;
-is( $db->{array}[1][2], 9 );
+ $array[2]{b} = 'floober';
+ is( $db->{array}[2]{b}, 'floober' );
-$array[2]{b} = 'floober';
-is( $db->{array}[2]{b}, 'floober' );
+ my %hash2 = ( abc => [ 1 .. 3 ] );
+ $array[3] = \%hash2;
-my %hash2 = ( abc => [ 1 .. 3 ] );
-$array[3] = \%hash2;
+ $hash2{ def } = \%hash;
+ is( $array[3]{def}{foo}, 2 );
+}
-$hash2{ def } = \%hash;
-is( $array[3]{def}{foo}, 2 );
+done_testing;
#!/usr/bin/perl -l
-##
-# DBM::Deep Test
-#
# Test for interference from -l on the commandline.
-##
use strict;
-use Test::More tests => 4;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
is( $db->get("key1"), "value1", "get() works with hash assignment" );
is( $db->fetch("key1"), "value1", "... fetch() works with hash assignment" );
is( $db->{key1}, "value1", "... and hash-access also works" );
+
+done_testing;
use strict;
-use Test::More tests => 99;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db1 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
-);
-
-my $db2 = DBM::Deep->new(
- file => $filename,
+my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ next unless $db1->supports( 'transactions' );
-$db1->{x} = 'y';
-is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
-is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
+ my $db2 = $dbm_maker->();
-cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ $db1->{x} = 'y';
+ is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
+ is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
-throws_ok {
- $db1->rollback;
-} qr/Cannot rollback without an active transaction/, "Attempting to rollback without a transaction throws an error";
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-throws_ok {
- $db1->commit;
-} qr/Cannot commit without an active transaction/, "Attempting to commit without a transaction throws an error";
+ throws_ok {
+ $db1->rollback;
+ } qr/Cannot rollback without an active transaction/, "Attempting to rollback without a transaction throws an error";
-$db1->begin_work;
+ throws_ok {
+ $db1->commit;
+ } qr/Cannot commit without an active transaction/, "Attempting to commit without a transaction throws an error";
-throws_ok {
$db1->begin_work;
-} qr/Cannot begin_work within an active transaction/, "Attempting to begin_work within a transaction throws an error";
-
-lives_ok {
- $db1->rollback;
-} "Rolling back an empty transaction is ok.";
-cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ throws_ok {
+ $db1->begin_work;
+ } qr/Cannot begin_work within an active transaction/, "Attempting to begin_work within a transaction throws an error";
-$db1->begin_work;
-
-lives_ok {
- $db1->commit;
-} "Committing an empty transaction is ok.";
-
-cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-
-$db1->begin_work;
+ lives_ok {
+ $db1->rollback;
+ } "Rolling back an empty transaction is ok.";
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
- is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
+ $db1->begin_work;
- $db2->{x} = 'a';
- is( $db1->{x}, 'y', "Within DB1 transaction, DB1's X is still Y" );
- is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is now A" );
+ lives_ok {
+ $db1->commit;
+ } "Committing an empty transaction is ok.";
- $db1->{x} = 'z';
- is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
- is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is still A" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- $db1->{z} = 'a';
- is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" );
- ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." );
+ $db1->begin_work;
- $db2->{other_x} = 'foo';
- is( $db2->{other_x}, 'foo', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
- ok( !exists $db1->{other_x}, "Since other_x was added after the transaction began, DB1 doesn't see it." );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- # Reset to an expected value
- $db2->{x} = 'y';
- is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is istill Z" );
- is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is now Y" );
+ is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
+ is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
- cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
+ $db2->{x} = 'a';
+ is( $db1->{x}, 'y', "Within DB1 transaction, DB1's X is still Y" );
+ is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is now A" );
-$db1->rollback;
+ $db1->{x} = 'z';
+ is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
+ is( $db2->{x}, 'a', "Within DB1 transaction, DB2's X is still A" );
-is( $db1->{x}, 'y', "After rollback, DB1's X is Y" );
-is( $db2->{x}, 'y', "After rollback, DB2's X is Y" );
+ $db1->{z} = 'a';
+ is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" );
+ ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." );
-is( $db1->{other_x}, 'foo', "After DB1 transaction is over, DB1 can see other_x" );
-is( $db2->{other_x}, 'foo', "After DB1 transaction is over, DB2 can still see other_x" );
+ $db2->{other_x} = 'foo';
+ is( $db2->{other_x}, 'foo', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
+ ok( !exists $db1->{other_x}, "Since other_x was added after the transaction began, DB1 doesn't see it." );
-$db1->begin_work;
+ # Reset to an expected value
+ $db2->{x} = 'y';
+ is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is istill Z" );
+ is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is now Y" );
- cmp_bag( [ keys %$db1 ], [qw( x other_x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
- is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
- is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
+ $db1->rollback;
- $db1->{x} = 'z';
- is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
- is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is still Y" );
+ is( $db1->{x}, 'y', "After rollback, DB1's X is Y" );
+ is( $db2->{x}, 'y', "After rollback, DB2's X is Y" );
- $db2->{other_x} = 'bar';
- is( $db2->{other_x}, 'bar', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
- is( $db1->{other_x}, 'foo', "Since other_x was modified after the transaction began, DB1 doesn't see the change." );
+ is( $db1->{other_x}, 'foo', "After DB1 transaction is over, DB1 can see other_x" );
+ is( $db2->{other_x}, 'foo', "After DB1 transaction is over, DB2 can still see other_x" );
- $db1->{z} = 'a';
- is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" );
- ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." );
+ $db1->begin_work;
- cmp_bag( [ keys %$db1 ], [qw( x other_x z )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x other_x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
-$db1->commit;
+ is( $db1->{x}, 'y', "DB1 transaction started, no actions - DB1's X is Y" );
+ is( $db2->{x}, 'y', "DB1 transaction started, no actions - DB2's X is Y" );
-is( $db1->{x}, 'z', "After commit, DB1's X is Z" );
-is( $db2->{x}, 'z', "After commit, DB2's X is Z" );
+ $db1->{x} = 'z';
+ is( $db1->{x}, 'z', "Within DB1 transaction, DB1's X is Z" );
+ is( $db2->{x}, 'y', "Within DB1 transaction, DB2's X is still Y" );
-is( $db1->{z}, 'a', "After commit, DB1's Z is A" );
-is( $db2->{z}, 'a', "After commit, DB2's Z is A" );
+ $db2->{other_x} = 'bar';
+ is( $db2->{other_x}, 'bar', "DB2 set other_x within DB1's transaction, so DB2 can see it" );
+ is( $db1->{other_x}, 'foo', "Since other_x was modified after the transaction began, DB1 doesn't see the change." );
-is( $db1->{other_x}, 'bar', "After commit, DB1's other_x is bar" );
-is( $db2->{other_x}, 'bar', "After commit, DB2's other_x is bar" );
+ $db1->{z} = 'a';
+ is( $db1->{z}, 'a', "Within DB1 transaction, DB1's Z is A" );
+ ok( !exists $db2->{z}, "Since z was added after the transaction began, DB2 doesn't see it." );
-$db1->begin_work;
+ cmp_bag( [ keys %$db1 ], [qw( x other_x z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x other_x )], "DB2 keys correct" );
- cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x z other_x )], "DB2 keys correct" );
+ $db1->commit;
is( $db1->{x}, 'z', "After commit, DB1's X is Z" );
is( $db2->{x}, 'z', "After commit, DB2's X is Z" );
is( $db1->{z}, 'a', "After commit, DB1's Z is A" );
is( $db2->{z}, 'a', "After commit, DB2's Z is A" );
- is( $db1->{other_x}, 'bar', "After begin_work, DB1's other_x is still bar" );
- is( $db2->{other_x}, 'bar', "After begin_work, DB2's other_x is still bar" );
+ is( $db1->{other_x}, 'bar', "After commit, DB1's other_x is bar" );
+ is( $db2->{other_x}, 'bar', "After commit, DB2's other_x is bar" );
- delete $db2->{other_x};
- ok( !exists $db2->{other_x}, "DB2 deleted other_x in DB1's transaction, so it can't see it anymore" );
- is( $db1->{other_x}, 'bar', "Since other_x was deleted after the transaction began, DB1 still sees it." );
+ $db1->begin_work;
- cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z other_x )], "DB2 keys correct" );
- delete $db1->{x};
- ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" );
- is( $db2->{x}, 'z', "But, DB2 can still see it" );
+ is( $db1->{x}, 'z', "After commit, DB1's X is Z" );
+ is( $db2->{x}, 'z', "After commit, DB2's X is Z" );
- cmp_bag( [ keys %$db1 ], [qw( other_x z )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
+ is( $db1->{z}, 'a', "After commit, DB1's Z is A" );
+ is( $db2->{z}, 'a', "After commit, DB2's Z is A" );
-$db1->rollback;
+ is( $db1->{other_x}, 'bar', "After begin_work, DB1's other_x is still bar" );
+ is( $db2->{other_x}, 'bar', "After begin_work, DB2's other_x is still bar" );
-ok( !exists $db2->{other_x}, "It's still deleted for DB2" );
-ok( !exists $db1->{other_x}, "And now DB1 sees the deletion" );
+ delete $db2->{other_x};
+ ok( !exists $db2->{other_x}, "DB2 deleted other_x in DB1's transaction, so it can't see it anymore" );
+ is( $db1->{other_x}, 'bar', "Since other_x was deleted after the transaction began, DB1 still sees it." );
-is( $db1->{x}, 'z', "The transaction was rolled back, so DB1 can see X now" );
-is( $db2->{x}, 'z', "DB2 can still see it" );
+ cmp_bag( [ keys %$db1 ], [qw( x z other_x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
+ delete $db1->{x};
+ ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" );
+ is( $db2->{x}, 'z', "But, DB2 can still see it" );
-$db1->begin_work;
+ cmp_bag( [ keys %$db1 ], [qw( other_x z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
- delete $db1->{x};
- ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" );
+ $db1->rollback;
- is( $db2->{x}, 'z', "But, DB2 can still see it" );
+ ok( !exists $db2->{other_x}, "It's still deleted for DB2" );
+ ok( !exists $db1->{other_x}, "And now DB1 sees the deletion" );
- cmp_bag( [ keys %$db1 ], [qw( z )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
+ is( $db1->{x}, 'z', "The transaction was rolled back, so DB1 can see X now" );
+ is( $db2->{x}, 'z', "DB2 can still see it" );
-$db1->commit;
+ cmp_bag( [ keys %$db1 ], [qw( x z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
-ok( !exists $db1->{x}, "The transaction was committed, so DB1 still deleted X" );
-ok( !exists $db2->{x}, "DB2 can now see the deletion of X" );
+ $db1->begin_work;
-$db1->{foo} = 'bar';
-is( $db1->{foo}, 'bar', "Set foo to bar in DB1" );
-is( $db2->{foo}, 'bar', "Set foo to bar in DB2" );
+ delete $db1->{x};
+ ok( !exists $db1->{x}, "DB1 deleted X in a transaction, so it can't see it anymore" );
-cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
+ is( $db2->{x}, 'z', "But, DB2 can still see it" );
-$db1->begin_work;
+ cmp_bag( [ keys %$db1 ], [qw( z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x z )], "DB2 keys correct" );
- %$db1 = (); # clear()
- ok( !exists $db1->{foo}, "Cleared foo" );
- is( $db2->{foo}, 'bar', "But in DB2, we can still see it" );
+ $db1->commit;
- cmp_bag( [ keys %$db1 ], [qw()], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
+ ok( !exists $db1->{x}, "The transaction was committed, so DB1 still deleted X" );
+ ok( !exists $db2->{x}, "DB2 can now see the deletion of X" );
-$db1->rollback;
+ $db1->{foo} = 'bar';
+ is( $db1->{foo}, 'bar', "Set foo to bar in DB1" );
+ is( $db2->{foo}, 'bar', "Set foo to bar in DB2" );
-is( $db1->{foo}, 'bar', "Rollback means 'foo' is still there" );
-is( $db2->{foo}, 'bar', "Rollback means 'foo' is still there" );
+ cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
+ $db1->begin_work;
-SKIP: {
- skip "Optimize tests skipped on Win32", 7
- if $^O eq 'MSWin32' || $^O eq 'cygwin';
+ %$db1 = (); # clear()
+ ok( !exists $db1->{foo}, "Cleared foo" );
+ is( $db2->{foo}, 'bar', "But in DB2, we can still see it" );
- $db1->optimize;
+ cmp_bag( [ keys %$db1 ], [qw()], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
- is( $db1->{foo}, 'bar', 'After optimize, everything is ok' );
- is( $db2->{foo}, 'bar', 'After optimize, everything is ok' );
+ $db1->rollback;
- is( $db1->{z}, 'a', 'After optimize, everything is ok' );
- is( $db2->{z}, 'a', 'After optimize, everything is ok' );
+ is( $db1->{foo}, 'bar', "Rollback means 'foo' is still there" );
+ is( $db2->{foo}, 'bar', "Rollback means 'foo' is still there" );
cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
- $db1->begin_work;
+ SKIP: {
+ skip "Optimize tests skipped on Win32", 7
+ if $^O eq 'MSWin32' || $^O eq 'cygwin';
- cmp_ok( $db1->_engine->trans_id, '==', 1, "Transaction ID has been reset after optimize" );
+ $db1->optimize;
- $db1->rollback;
+ is( $db1->{foo}, 'bar', 'After optimize, everything is ok' );
+ is( $db2->{foo}, 'bar', 'After optimize, everything is ok' );
+
+ is( $db1->{z}, 'a', 'After optimize, everything is ok' );
+ is( $db2->{z}, 'a', 'After optimize, everything is ok' );
+
+ cmp_bag( [ keys %$db1 ], [qw( foo z )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
+
+ $db1->begin_work;
+
+ cmp_ok( $db1->_engine->trans_id, '==', 1, "Transaction ID has been reset after optimize" );
+
+ $db1->rollback;
+ }
}
-__END__
+done_testing;
use strict;
-use Test::More tests => 47;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db1 = DBM::Deep->new(
- file => $filename,
+my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
type => DBM::Deep->TYPE_ARRAY,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ next unless $db1->supports( 'transactions' );
+ my $db2 = $dbm_maker->();
-my $db2 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
- type => DBM::Deep->TYPE_ARRAY,
-);
+ $db1->[0] = 'y';
+ is( $db1->[0], 'y', "Before transaction, DB1's 0 is Y" );
+ is( $db2->[0], 'y', "Before transaction, DB2's 0 is Y" );
-$db1->[0] = 'y';
-is( $db1->[0], 'y', "Before transaction, DB1's 0 is Y" );
-is( $db2->[0], 'y', "Before transaction, DB2's 0 is Y" );
+ $db1->begin_work;
-$db1->begin_work;
+ is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
+ is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
- is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
- is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
+ $db1->[0] = 'z';
+ is( $db1->[0], 'z', "Within DB1 transaction, DB1's 0 is Z" );
+ is( $db2->[0], 'y', "Within DB1 transaction, DB2's 0 is still Y" );
- $db1->[0] = 'z';
- is( $db1->[0], 'z', "Within DB1 transaction, DB1's 0 is Z" );
- is( $db2->[0], 'y', "Within DB1 transaction, DB2's 0 is still Y" );
+ $db2->[1] = 'foo';
+ is( $db2->[1], 'foo', "DB2 set 1 within DB1's transaction, so DB2 can see it" );
+ ok( !exists $db1->[1], "Since 1 was added after the transaction began, DB1 doesn't see it." );
- $db2->[1] = 'foo';
- is( $db2->[1], 'foo', "DB2 set 1 within DB1's transaction, so DB2 can see it" );
- ok( !exists $db1->[1], "Since 1 was added after the transaction began, DB1 doesn't see it." );
+ cmp_ok( scalar(@$db1), '==', 1, "DB1 has 1 element" );
+ cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
- cmp_ok( scalar(@$db1), '==', 1, "DB1 has 1 element" );
- cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
+ $db1->rollback;
-$db1->rollback;
+ is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
+ is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
-is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
-is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
+ is( $db1->[1], 'foo', "After DB1 transaction is over, DB1 can see 1" );
+ is( $db2->[1], 'foo', "After DB1 transaction is over, DB2 can still see 1" );
-is( $db1->[1], 'foo', "After DB1 transaction is over, DB1 can see 1" );
-is( $db2->[1], 'foo', "After DB1 transaction is over, DB2 can still see 1" );
+ cmp_ok( scalar(@$db1), '==', 2, "DB1 now has 2 elements" );
+ cmp_ok( scalar(@$db2), '==', 2, "DB2 still has 2 elements" );
-cmp_ok( scalar(@$db1), '==', 2, "DB1 now has 2 elements" );
-cmp_ok( scalar(@$db2), '==', 2, "DB2 still has 2 elements" );
+ $db1->begin_work;
-$db1->begin_work;
+ is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
+ is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
- is( $db1->[0], 'y', "DB1 transaction started, no actions - DB1's 0 is Y" );
- is( $db2->[0], 'y', "DB1 transaction started, no actions - DB2's 0 is Y" );
+ $db1->[2] = 'z';
+ is( $db1->[2], 'z', "Within DB1 transaction, DB1's 2 is Z" );
+ ok( !exists $db2->[2], "Within DB1 transaction, DB2 cannot see 2" );
- $db1->[2] = 'z';
- is( $db1->[2], 'z', "Within DB1 transaction, DB1's 2 is Z" );
- ok( !exists $db2->[2], "Within DB1 transaction, DB2 cannot see 2" );
+ cmp_ok( scalar(@$db1), '==', 3, "DB1 has 3 elements" );
+ cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
- cmp_ok( scalar(@$db1), '==', 3, "DB1 has 3 elements" );
- cmp_ok( scalar(@$db2), '==', 2, "DB2 has 2 elements" );
+ $db1->commit;
-$db1->commit;
+ is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
+ is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
-is( $db1->[0], 'y', "After rollback, DB1's 0 is Y" );
-is( $db2->[0], 'y', "After rollback, DB2's 0 is Y" );
+ is( $db1->[2], 'z', "After DB1 transaction is over, DB1 can still see 2" );
+ is( $db2->[2], 'z', "After DB1 transaction is over, DB2 can now see 2" );
-is( $db1->[2], 'z', "After DB1 transaction is over, DB1 can still see 2" );
-is( $db2->[2], 'z', "After DB1 transaction is over, DB2 can now see 2" );
+ cmp_ok( scalar(@$db1), '==', 3, "DB1 now has 2 elements" );
+ cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 2 elements" );
-cmp_ok( scalar(@$db1), '==', 3, "DB1 now has 2 elements" );
-cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 2 elements" );
+ $db1->begin_work;
-$db1->begin_work;
+ push @$db1, 'foo';
+ unshift @$db1, 'bar';
- push @$db1, 'foo';
- unshift @$db1, 'bar';
+ cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
+ cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
- cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
- cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
+ is( $db1->[0], 'bar' );
+ is( $db1->[-1], 'foo' );
- is( $db1->[0], 'bar' );
- is( $db1->[-1], 'foo' );
+ $db1->rollback;
-$db1->rollback;
+ cmp_ok( scalar(@$db1), '==', 3, "DB1 is back to 3 elements" );
+ cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
-cmp_ok( scalar(@$db1), '==', 3, "DB1 is back to 3 elements" );
-cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
+ $db1->begin_work;
-$db1->begin_work;
+ push @$db1, 'foo';
+ unshift @$db1, 'bar';
- push @$db1, 'foo';
- unshift @$db1, 'bar';
+ cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
+ cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
- cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
- cmp_ok( scalar(@$db2), '==', 3, "DB2 still has 3 elements" );
+ $db1->commit;
-$db1->commit;
+ cmp_ok( scalar(@$db1), '==', 5, "DB1 is still at 5 elements" );
+ cmp_ok( scalar(@$db2), '==', 5, "DB2 now has 5 elements" );
-cmp_ok( scalar(@$db1), '==', 5, "DB1 is still at 5 elements" );
-cmp_ok( scalar(@$db2), '==', 5, "DB2 now has 5 elements" );
-
-is( $db1->[0], 'bar' );
-is( $db1->[-1], 'foo' );
+ is( $db1->[0], 'bar' );
+ is( $db1->[-1], 'foo' );
-is( $db2->[0], 'bar' );
-is( $db2->[-1], 'foo' );
+ is( $db2->[0], 'bar' );
+ is( $db2->[-1], 'foo' );
-$db1->begin_work;
+ $db1->begin_work;
- @$db1 = (); # clear()
+ @$db1 = (); # clear()
- cmp_ok( scalar(@$db1), '==', 0, "DB1 now has 0 elements" );
- cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" );
+ cmp_ok( scalar(@$db1), '==', 0, "DB1 now has 0 elements" );
+ cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" );
-$db1->rollback;
+ $db1->rollback;
-cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
-cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" );
+ cmp_ok( scalar(@$db1), '==', 5, "DB1 now has 5 elements" );
+ cmp_ok( scalar(@$db2), '==', 5, "DB2 still has 5 elements" );
+}
+done_testing;
use strict;
-use Test::More tests => 51;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db1 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
-);
-
-my $db2 = DBM::Deep->new(
- file => $filename,
+my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ next unless $db1->supports( 'transactions' );
+ my $db2 = $dbm_maker->();
+ my $db3 = $dbm_maker->();
-my $db3 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
-);
+ $db1->{foo} = 'bar';
+ is( $db1->{foo}, 'bar', "Before transaction, DB1's foo is bar" );
+ is( $db2->{foo}, 'bar', "Before transaction, DB2's foo is bar" );
+ is( $db3->{foo}, 'bar', "Before transaction, DB3's foo is bar" );
-$db1->{foo} = 'bar';
-is( $db1->{foo}, 'bar', "Before transaction, DB1's foo is bar" );
-is( $db2->{foo}, 'bar', "Before transaction, DB2's foo is bar" );
-is( $db3->{foo}, 'bar', "Before transaction, DB3's foo is bar" );
+ $db1->begin_work;
-$db1->begin_work;
+ is( $db1->{foo}, 'bar', "Before transaction work, DB1's foo is bar" );
+ is( $db2->{foo}, 'bar', "Before transaction work, DB2's foo is bar" );
+ is( $db3->{foo}, 'bar', "Before transaction work, DB3's foo is bar" );
-is( $db1->{foo}, 'bar', "Before transaction work, DB1's foo is bar" );
-is( $db2->{foo}, 'bar', "Before transaction work, DB2's foo is bar" );
-is( $db3->{foo}, 'bar', "Before transaction work, DB3's foo is bar" );
+ $db1->{foo} = 'bar2';
-$db1->{foo} = 'bar2';
+ is( $db1->{foo}, 'bar2', "After DB1 foo to bar2, DB1's foo is bar2" );
+ is( $db2->{foo}, 'bar', "After DB1 foo to bar2, DB2's foo is bar" );
+ is( $db3->{foo}, 'bar', "After DB1 foo to bar2, DB3's foo is bar" );
-is( $db1->{foo}, 'bar2', "After DB1 foo to bar2, DB1's foo is bar2" );
-is( $db2->{foo}, 'bar', "After DB1 foo to bar2, DB2's foo is bar" );
-is( $db3->{foo}, 'bar', "After DB1 foo to bar2, DB3's foo is bar" );
+ $db1->{bar} = 'foo';
-$db1->{bar} = 'foo';
+ ok( exists $db1->{bar}, "After DB1 set bar to foo, DB1's bar exists" );
+ ok( !exists $db2->{bar}, "After DB1 set bar to foo, DB2's bar doesn't exist" );
+ ok( !exists $db3->{bar}, "After DB1 set bar to foo, DB3's bar doesn't exist" );
+
+ $db2->begin_work;
-ok( exists $db1->{bar}, "After DB1 set bar to foo, DB1's bar exists" );
-ok( !exists $db2->{bar}, "After DB1 set bar to foo, DB2's bar doesn't exist" );
-ok( !exists $db3->{bar}, "After DB1 set bar to foo, DB3's bar doesn't exist" );
-
-$db2->begin_work;
+ is( $db1->{foo}, 'bar2', "After DB2 transaction begin, DB1's foo is still bar2" );
+ is( $db2->{foo}, 'bar', "After DB2 transaction begin, DB2's foo is still bar" );
+ is( $db3->{foo}, 'bar', "After DB2 transaction begin, DB3's foo is still bar" );
-is( $db1->{foo}, 'bar2', "After DB2 transaction begin, DB1's foo is still bar2" );
-is( $db2->{foo}, 'bar', "After DB2 transaction begin, DB2's foo is still bar" );
-is( $db3->{foo}, 'bar', "After DB2 transaction begin, DB3's foo is still bar" );
+ ok( exists $db1->{bar}, "After DB2 transaction begin, DB1's bar exists" );
+ ok( !exists $db2->{bar}, "After DB2 transaction begin, DB2's bar doesn't exist" );
+ ok( !exists $db3->{bar}, "After DB2 transaction begin, DB3's bar doesn't exist" );
-ok( exists $db1->{bar}, "After DB2 transaction begin, DB1's bar exists" );
-ok( !exists $db2->{bar}, "After DB2 transaction begin, DB2's bar doesn't exist" );
-ok( !exists $db3->{bar}, "After DB2 transaction begin, DB3's bar doesn't exist" );
+ $db2->{foo} = 'bar333';
-$db2->{foo} = 'bar333';
+ is( $db1->{foo}, 'bar2', "After DB2 foo to bar2, DB1's foo is bar2" );
+ is( $db2->{foo}, 'bar333', "After DB2 foo to bar2, DB2's foo is bar333" );
+ is( $db3->{foo}, 'bar', "After DB2 foo to bar2, DB3's foo is bar" );
-is( $db1->{foo}, 'bar2', "After DB2 foo to bar2, DB1's foo is bar2" );
-is( $db2->{foo}, 'bar333', "After DB2 foo to bar2, DB2's foo is bar333" );
-is( $db3->{foo}, 'bar', "After DB2 foo to bar2, DB3's foo is bar" );
+ $db2->{bar} = 'mybar';
-$db2->{bar} = 'mybar';
+ ok( exists $db1->{bar}, "After DB2 set bar to mybar, DB1's bar exists" );
+ ok( exists $db2->{bar}, "After DB2 set bar to mybar, DB2's bar exists" );
+ ok( !exists $db3->{bar}, "After DB2 set bar to mybar, DB3's bar doesn't exist" );
-ok( exists $db1->{bar}, "After DB2 set bar to mybar, DB1's bar exists" );
-ok( exists $db2->{bar}, "After DB2 set bar to mybar, DB2's bar exists" );
-ok( !exists $db3->{bar}, "After DB2 set bar to mybar, DB3's bar doesn't exist" );
+ is( $db1->{bar}, 'foo', "DB1's bar is still foo" );
+ is( $db2->{bar}, 'mybar', "DB2's bar is now mybar" );
-is( $db1->{bar}, 'foo', "DB1's bar is still foo" );
-is( $db2->{bar}, 'mybar', "DB2's bar is now mybar" );
+ $db2->{mykey} = 'myval';
-$db2->{mykey} = 'myval';
+ ok( !exists $db1->{mykey}, "After DB2 set mykey to myval, DB1's mykey doesn't exist" );
+ ok( exists $db2->{mykey}, "After DB2 set mykey to myval, DB2's mykey exists" );
+ ok( !exists $db3->{mykey}, "After DB2 set mykey to myval, DB3's mykey doesn't exist" );
-ok( !exists $db1->{mykey}, "After DB2 set mykey to myval, DB1's mykey doesn't exist" );
-ok( exists $db2->{mykey}, "After DB2 set mykey to myval, DB2's mykey exists" );
-ok( !exists $db3->{mykey}, "After DB2 set mykey to myval, DB3's mykey doesn't exist" );
+ cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db3 ], [qw( foo )], "DB3 keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
-cmp_bag( [ keys %$db3 ], [qw( foo )], "DB3 keys correct" );
+ $db1->commit;
-$db1->commit;
+ is( $db1->{foo}, 'bar2', "After DB1 commit, DB1's foo is bar2" );
+ is( $db2->{foo}, 'bar333', "After DB1 commit, DB2's foo is bar333" );
+ is( $db3->{foo}, 'bar2', "After DB1 commit, DB3's foo is bar2" );
-is( $db1->{foo}, 'bar2', "After DB1 commit, DB1's foo is bar2" );
-is( $db2->{foo}, 'bar333', "After DB1 commit, DB2's foo is bar333" );
-is( $db3->{foo}, 'bar2', "After DB1 commit, DB3's foo is bar2" );
+ is( $db1->{bar}, 'foo', "DB1's bar is still foo" );
+ is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" );
+ is( $db3->{bar}, 'foo', "DB3's bar is now foo" );
-is( $db1->{bar}, 'foo', "DB1's bar is still foo" );
-is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" );
-is( $db3->{bar}, 'foo', "DB3's bar is now foo" );
+ cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db3 ], [qw( foo bar )], "DB3 keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( foo bar )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
-cmp_bag( [ keys %$db3 ], [qw( foo bar )], "DB3 keys correct" );
+ $db2->commit;
-$db2->commit;
+ is( $db1->{foo}, 'bar333', "After DB2 commit, DB1's foo is bar333" );
+ is( $db2->{foo}, 'bar333', "After DB2 commit, DB2's foo is bar333" );
+ is( $db3->{foo}, 'bar333', "After DB2 commit, DB3's foo is bar333" );
-is( $db1->{foo}, 'bar333', "After DB2 commit, DB1's foo is bar333" );
-is( $db2->{foo}, 'bar333', "After DB2 commit, DB2's foo is bar333" );
-is( $db3->{foo}, 'bar333', "After DB2 commit, DB3's foo is bar333" );
+ is( $db1->{bar}, 'mybar', "DB1's bar is now mybar" );
+ is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" );
+ is( $db3->{bar}, 'mybar', "DB3's bar is now mybar" );
-is( $db1->{bar}, 'mybar', "DB1's bar is now mybar" );
-is( $db2->{bar}, 'mybar', "DB2's bar is still mybar" );
-is( $db3->{bar}, 'mybar', "DB3's bar is now mybar" );
+ cmp_bag( [ keys %$db1 ], [qw( foo bar mykey )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db3 ], [qw( foo bar mykey )], "DB3 keys correct" );
+}
-cmp_bag( [ keys %$db1 ], [qw( foo bar mykey )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( foo bar mykey )], "DB2 keys correct" );
-cmp_bag( [ keys %$db3 ], [qw( foo bar mykey )], "DB3 keys correct" );
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 8;
+use warnings FATAL => 'all';
+
+use Test::More;
use t::common qw( new_fh );
{
my $db = DBM::Deep->new(
file => $filename,
- fh => $fh,
data_sector_size => 32,
);
{
my $db = DBM::Deep->new(
file => $filename,
- fh => $fh,
data_sector_size => 64,
);
{
my $db = DBM::Deep->new(
file => $filename,
- fh => $fh,
data_sector_size => 128,
);
{
my $db = DBM::Deep->new(
file => $filename,
- fh => $fh,
data_sector_size => 256,
);
cmp_ok( $sizes{128}, '>', $sizes{64}, "Filesize for 128 > filesize for 64" );
cmp_ok( $sizes{64}, '>', $sizes{32}, "Filesize for 64 > filesize for 32" );
+done_testing;
use strict;
-use Test::More tests => 11;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- );
+my $dbm_factory = new_dbm(
+ locking => 1,
+ autoflush => 1,
+);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ SKIP: {
+ skip "This engine doesn't support singletons", 8
+ unless $db->supports( 'singletons' );
+
+ $db->{a} = 1;
+ $db->{foo} = { a => 'b' };
+ my $x = $db->{foo};
+ my $y = $db->{foo};
- $db->{a} = 1;
- $db->{foo} = { a => 'b' };
- my $x = $db->{foo};
- my $y = $db->{foo};
-
- is( $x, $y, "The references are the same" );
-
- delete $db->{foo};
- is( $x, undef, "After deleting the DB location, external references are also undef (\$x)" );
- is( $y, undef, "After deleting the DB location, external references are also undef (\$y)" );
- is( $x + 0, undef, "DBM::Deep::Null can be added to." );
- is( $y + 0, undef, "DBM::Deep::Null can be added to." );
- is( $db->{foo}, undef, "The {foo} location is also undef." );
-
- # These shenanigans work to get another hashref
- # into the same data location as $db->{foo} was.
- $db->{foo} = {};
- delete $db->{foo};
- $db->{foo} = {};
- $db->{bar} = {};
-
- is( $x, undef, "After re-assigning to {foo}, external references to old values are still undef (\$x)" );
- is( $y, undef, "After re-assigning to {foo}, external references to old values are still undef (\$y)" );
+ is( $x, $y, "The references are the same" );
+
+ delete $db->{foo};
+ is( $x, undef, "After deleting the DB location, external references are also undef (\$x)" );
+ is( $y, undef, "After deleting the DB location, external references are also undef (\$y)" );
+ is( eval { $x + 0 }, undef, "DBM::Deep::Null can be added to." );
+ is( eval { $y + 0 }, undef, "DBM::Deep::Null can be added to." );
+ is( $db->{foo}, undef, "The {foo} location is also undef." );
+
+ # These shenanigans work to get another hashref
+ # into the same data location as $db->{foo} was.
+ $db->{foo} = {};
+ delete $db->{foo};
+ $db->{foo} = {};
+ $db->{bar} = {};
+
+ is( $x, undef, "After re-assigning to {foo}, external references to old values are still undef (\$x)" );
+ is( $y, undef, "After re-assigning to {foo}, external references to old values are still undef (\$y)" );
+ }
}
SKIP: {
skip "What do we do with external references and txns?", 2;
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
+
+ my $dbm_factory = new_dbm(
+ locking => 1,
autoflush => 1,
- num_txns => 2,
+ num_txns => 2,
);
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- $db->{foo} = { a => 'b' };
- my $x = $db->{foo};
+ $db->{foo} = { a => 'b' };
+ my $x = $db->{foo};
- $db->begin_work;
+ $db->begin_work;
- $db->{foo} = { c => 'd' };
- my $y = $db->{foo};
+ $db->{foo} = { c => 'd' };
+ my $y = $db->{foo};
- # XXX What should happen here with $x and $y?
- is( $x, $y );
- is( $x->{c}, 'd' );
+ # XXX What should happen here with $x and $y?
+ is( $x, $y );
+ is( $x->{c}, 'd' );
- $db->rollback;
+ $db->rollback;
+ }
}
+
+done_testing;
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 13;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
- fh => $fh,
autoflush => 1,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
- fh => $fh,
autoflush => 1,
});
cmp_ok( $expected, '==', -s $filename, "No reindexing after deletion" );
}
+
+done_testing;
use strict;
-use Test::More tests => 41;
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db1 = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- locking => 1,
+my $dbm_factory = new_dbm(
+ locking => 1,
autoflush => 1,
num_txns => 2,
);
-seek $db1->_get_self->_engine->storage->{fh}, 0, 0;
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ next unless $db1->supports('transactions');
+ my $db2 = $dbm_maker->();
-my $db2 = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- locking => 1,
- autoflush => 1,
- num_txns => 2,
-);
-
-$db1->{x} = { xy => { foo => 'y' } };
-is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" );
-is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" );
-
-$db1->begin_work;
+ $db1->{x} = { xy => { foo => 'y' } };
+ is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" );
+ is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" );
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
- is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" );
- is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" );
+ $db1->begin_work;
- $db1->{x} = { yz => { bar => 30 } };
- ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" );
- is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
-$db1->rollback;
+ cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
+ cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" );
+ is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" );
-cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
-cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+ $db1->{x} = { yz => { bar => 30 } };
+ ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" );
+ is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" );
-cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
-cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
-is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" );
-is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" );
-
-$db1->begin_work;
+ $db1->rollback;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
- is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" );
- is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" );
+ is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" );
+ is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" );
- $db1->{x} = { yz => { bar => 30 } };
- ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" );
- is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X->YZ is Y" );
+ $db1->begin_work;
- cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+
+ cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
+ cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
+
+ is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" );
+ is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" );
+
+ $db1->{x} = { yz => { bar => 30 } };
+ ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" );
+ is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X->YZ is Y" );
-$db1->commit;
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
-cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
-cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ $db1->commit;
-cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
-cmp_bag( [ keys %{$db2->{x}} ], [qw( yz )], "DB2->X keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( yz )], "DB2->X keys correct" );
-cmp_bag( [ keys %{$db1->{x}{yz}} ], [qw( bar )], "DB1->X->XY keys correct" );
-cmp_bag( [ keys %{$db2->{x}{yz}} ], [qw( bar )], "DB2->X->XY keys correct" );
+ cmp_bag( [ keys %{$db1->{x}{yz}} ], [qw( bar )], "DB1->X->XY keys correct" );
+ cmp_bag( [ keys %{$db2->{x}{yz}} ], [qw( bar )], "DB2->X->XY keys correct" );
+}
-$db1->_get_self->_engine->storage->close( $db1->_get_self );
-$db2->_get_self->_engine->storage->close( $db2->_get_self );
+done_testing;
use strict;
-use Test::More tests => 81;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
# can occur as early as 18 keys and as late as 4097 (256*16+1) keys.
{
- my ($fh, $filename) = new_fh();
- my $db1 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
- );
-
- my $db2 = DBM::Deep->new(
- file => $filename,
+ my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ next unless $db1->supports( 'transactions' );
+ my $db2 = $dbm_maker->();
- $db1->{x} = 'y';
- is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
- is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
+ $db1->{x} = 'y';
+ is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
+ is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
- $db1->begin_work;
+ $db1->begin_work;
- cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- # Add enough keys to force a reindex
- $db1->{"K$_"} = "V$_" for 1 .. 16;
+ # Add enough keys to force a reindex
+ $db1->{"K$_"} = "V$_" for 1 .. 16;
- cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- $db1->rollback;
+ $db1->rollback;
- cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- ok( !exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16;
- ok( !exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16;
+ ok( !exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16;
+ ok( !exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16;
+ }
}
{
- my ($fh, $filename) = new_fh();
- my $db1 = DBM::Deep->new(
- file => $filename,
+ my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ next unless $db1->supports( 'transactions' );
+ my $db2 = $dbm_maker->();
- my $db2 = DBM::Deep->new(
- file => $filename,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
- );
+ $db1->{x} = 'y';
+ is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
+ is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
- $db1->{x} = 'y';
- is( $db1->{x}, 'y', "Before transaction, DB1's X is Y" );
- is( $db2->{x}, 'y', "Before transaction, DB2's X is Y" );
+ $db1->begin_work;
- $db1->begin_work;
+ cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
+ # Add enough keys to force a reindex
+ $db1->{"K$_"} = "V$_" for 1 .. 16;
- # Add enough keys to force a reindex
- $db1->{"K$_"} = "V$_" for 1 .. 16;
+ cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-
- $db1->commit;
+ $db1->commit;
- cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
- cmp_bag( [ keys %$db2 ], ['x', (map { "K$_" } 1 .. 16)], "DB2 keys correct" );
+ cmp_bag( [ keys %$db1 ], ['x', (map { "K$_" } 1 .. 16)], "DB1 keys correct" );
+ cmp_bag( [ keys %$db2 ], ['x', (map { "K$_" } 1 .. 16)], "DB2 keys correct" );
- ok( exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16;
- ok( exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16;
+ ok( exists $db1->{"K$_"}, "DB1: Key K$_ doesn't exist" ) for 1 .. 16;
+ ok( exists $db2->{"K$_"}, "DB2: Key K$_ doesn't exist" ) for 1 .. 16;
+ }
}
+
+done_testing;
use strict;
+use warnings FATAL => 'all';
+
use Test::More;
use Test::Deep;
use Test::Exception;
-use t::common qw( new_fh );
-
-use DBM::Deep;
+use t::common qw( new_dbm );
-my $max_txns = 255;
+use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
+my $max_txns = 220;
-my @dbs = grep { $_ } map {
- eval {
- DBM::Deep->new(
- file => $filename,
- num_txns => $max_txns,
- );
- };
-} 1 .. $max_txns;
+my $dbm_factory = new_dbm(
+ num_txns => $max_txns,
+);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my @dbs = ( $dbm_maker->() );
+ next unless $dbs[0]->supports('transactions');
-my $num = $#dbs;
+ push @dbs, grep { $_ } map {
+ eval { $dbm_maker->() }
+ } 2 .. $max_txns;
-plan tests => do {
- my $n = $num + 1;
- 2 * $n;
-};
+ cmp_ok( scalar(@dbs), '==', $max_txns, "We could open enough DB handles" );
-my %trans_ids;
-for my $n (0 .. $num) {
- lives_ok {
- $dbs[$n]->begin_work
- } "DB $n can begin_work";
+ my %trans_ids;
+ for my $n (0 .. $#dbs) {
+ lives_ok {
+ $dbs[$n]->begin_work
+ } "DB $n can begin_work";
- my $trans_id = $dbs[$n]->_engine->trans_id;
- ok( !exists $trans_ids{ $trans_id }, "DB $n has a unique transaction ID ($trans_id)" );
- $trans_ids{ $trans_id } = $n;
+ my $trans_id = $dbs[$n]->_engine->trans_id;
+ ok( !exists $trans_ids{ $trans_id }, "DB $n has a unique transaction ID ($trans_id)" );
+ $trans_ids{ $trans_id } = $n;
+ }
}
+
+done_testing;
use strict;
use Test::More;
+plan skip_all => "upgrade_db.pl doesn't actually do anything correct.";
+
# Add skips here
BEGIN {
plan skip_all => "Skipping the upgrade_db.pl tests on Win32/cygwin for now."
-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 15;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
+my $dbm_factory = new_dbm(
locking => 1,
autoflush => 1,
num_txns => 16,
);
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db1 = $dbm_maker->();
+ next unless $db1->supports( 'transactions' );
+ my $db2 = $dbm_maker->();
-seek $db->_get_self->_engine->storage->{fh}, 0, 0;
+ $db1->{foo} = 5;
+ $db1->{bar} = $db1->{foo};
-my $db2 = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- locking => 1,
- autoflush => 1,
- num_txns => 16,
-);
-
-$db->{foo} = 5;
-$db->{bar} = $db->{foo};
+ is( $db1->{foo}, 5, "Foo is still 5" );
+ is( $db1->{bar}, 5, "Bar is now 5" );
-is( $db->{foo}, 5, "Foo is still 5" );
-is( $db->{bar}, 5, "Bar is now 5" );
+ $db1->{foo} = 6;
-$db->{foo} = 6;
+ is( $db1->{foo}, 6, "Foo is now 6" );
+ is( $db1->{bar}, 5, "Bar is still 5" );
-is( $db->{foo}, 6, "Foo is now 6" );
-is( $db->{bar}, 5, "Bar is still 5" );
+ $db1->{foo} = [ 1 .. 3 ];
+ $db1->{bar} = $db1->{foo};
-$db->{foo} = [ 1 .. 3 ];
-$db->{bar} = $db->{foo};
+ is( $db1->{foo}[1], 2, "Foo[1] is still 2" );
+ is( $db1->{bar}[1], 2, "Bar[1] is now 2" );
-is( $db->{foo}[1], 2, "Foo[1] is still 2" );
-is( $db->{bar}[1], 2, "Bar[1] is now 2" );
+ $db1->{foo}[3] = 42;
-$db->{foo}[3] = 42;
+ is( $db1->{foo}[3], 42, "Foo[3] is now 42" );
+ is( $db1->{bar}[3], 42, "Bar[3] is also 42" );
-is( $db->{foo}[3], 42, "Foo[3] is now 42" );
-is( $db->{bar}[3], 42, "Bar[3] is also 42" );
+ delete $db1->{foo};
+ is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
-delete $db->{foo};
-is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+ $db1->{foo} = $db1->{bar};
+ $db2->begin_work;
-$db->{foo} = $db->{bar};
-$db2->begin_work;
+ delete $db2->{bar};
+ delete $db2->{foo};
- delete $db2->{bar};
- delete $db2->{foo};
+ is( $db2->{bar}, undef, "It's deleted in the transaction" );
+ is( $db1->{bar}[3], 42, "... but not in the main" );
- is( $db2->{bar}, undef, "It's deleted in the transaction" );
- is( $db->{bar}[3], 42, "... but not in the main" );
+ $db2->rollback;
-$db2->rollback;
+ # Why hasn't this failed!? Is it because stuff isn't getting deleted as
+ # expected? I need a test that walks the sectors
+ is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+ is( $db2->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
-# Why hasn't this failed!? Is it because stuff isn't getting deleted as expected?
-# I need a test that walks the sectors
-is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
-is( $db2->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+ delete $db1->{foo};
-delete $db->{foo};
+ is( $db1->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+}
-is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
+done_testing;
__END__
-warn "-2\n";
$db2->begin_work;
-warn "-1\n";
delete $db2->{bar};
-warn "0\n";
$db2->commit;
-warn "1\n";
-ok( !exists $db->{bar}, "After commit, bar is gone" );
-warn "2\n";
+ok( !exists $db1->{bar}, "After commit, bar is gone" );
# This test (and accompanying patch) was submitted by Father Chrysostomos (sprout@cpan.org)
-use 5.006;
-
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 5;
+use Test::More;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- ok eval {
- for ( # the checksums of all these begin with ^@:
+ ok eval {
+ for ( # the checksums of all these begin with ^@:
+ qw/ s340l 1970 thronos /,
+ "\320\277\320\276\320\262\320\265\320\273\320\265\320\275".
+ "\320\275\320\276\320\265", qw/ mr094 despite
+ geographically binding bed handmaiden infer lela infranarii
+ lxv evtropia recognizes maladies /
+ ) {
+ $db->{$_} = undef;
+ }
+ 1;
+ }, '2 indices can be created at once';
+
+ is_deeply [sort keys %$db], [ sort
qw/ s340l 1970 thronos /,
"\320\277\320\276\320\262\320\265\320\273\320\265\320\275".
"\320\275\320\276\320\265", qw/ mr094 despite
geographically binding bed handmaiden infer lela infranarii
lxv evtropia recognizes maladies /
- ) {
- $db->{$_} = undef;
- }
- 1;
- }, '2 indices can be created at once';
-
- is_deeply [sort keys %$db], [ sort
- qw/ s340l 1970 thronos /,
- "\320\277\320\276\320\262\320\265\320\273\320\265\320\275".
- "\320\275\320\276\320\265", qw/ mr094 despite
- geographically binding bed handmaiden infer lela infranarii
- lxv evtropia recognizes maladies /
- ], 'and the keys were stored correctly';
+ ], 'and the keys were stored correctly';
+ }
}
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- ok eval {
- for ( # the checksums of all these begin with ^@^@^@:
+ ok eval {
+ for ( # the checksums of all these begin with ^@^@^@:
+ qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda
+ lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII
+ FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW /
+ ) {
+ $db->{$_} = undef;
+ }
+ 1;
+ }, 'multiple nested indices can be created at once';
+
+ is_deeply [sort keys %$db], [ sort
qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda
lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII
FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW /
- ) {
- $db->{$_} = undef;
- }
- 1;
- }, 'multiple nested indices can be created at once';
-
- is_deeply [sort keys %$db], [ sort
- qw/ dzqtz aqkdqz cxzysd czclmy ktajsi kvlybo kyxowd lvlsda
- lyzfdi mbethb mcoqeq VMPJC ATZMZZ AXXJDX BXUUFN EIVTII
- FMOKOI HITVDG JSSJSZ JXQPFK LCVVXW /
- ], 'and the keys were stored correctly';
+ ], 'and the keys were stored correctly';
+ }
}
-__END__
+done_testing;
-use 5.006;
-
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 13;
+use Test::More;
use Test::Exception;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
# This is bug #34819, reported by EJS
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- my $bar = bless { foo => 'ope' }, 'Foo';
+ my $bar = bless { foo => 'ope' }, 'Foo';
- eval {
- $db->{bar} = $bar;
- $db->{bar} = $bar;
- };
+ eval {
+ $db->{bar} = $bar;
+ $db->{bar} = $bar;
+ }; if ( $@ ) { warn $@ }
- ok(!$@, "repeated object assignment");
- isa_ok($db->{bar}, 'Foo');
+ ok(!$@, "repeated object assignment");
+ isa_ok($db->{bar}, 'Foo');
+ }
}
-
+done_testing;
+__END__
# This is bug #29957, reported by HANENKAMP
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
- $db->{foo} = [];
+ $db->{foo} = [];
- for my $value ( 1 .. 3 ) {
- lives_ok {
- my $ref = $db->{foo};
- push @$ref, $value;
- $db->{foo} = $ref;
- } "Successfully added value $value";
- }
+ for my $value ( 1 .. 3 ) {
+ lives_ok {
+ my $ref = $db->{foo};
+ push @$ref, $value;
+ $db->{foo} = $ref;
+ } "Successfully added value $value";
+ }
- cmp_deeply( [1,2,3], noclass($db->{foo}), "Everything looks ok" );
+ cmp_deeply( [1,2,3], noclass($db->{foo}), "Everything looks ok" );
+ }
}
# This is bug #33863, reported by PJS
{
- my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- );
-
- $db->{foo} = [ 42 ];
- my $foo = shift @{ $db->{foo} };
- cmp_ok( @{ $db->{foo} }, '==', 0, "Shifting a scalar leaves no values" );
- cmp_ok( $foo, '==', 42, "... And the value is correct." );
-
- $db->{bar} = [ [] ];
- my $bar = shift @{ $db->{bar} };
- cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" );
-
- $db->{baz} = { foo => [ 1 .. 3 ] };
- $db->{baz2} = [ $db->{baz} ];
- my $baz2 = shift @{ $db->{baz2} };
- cmp_ok( @{ $db->{baz2} }, '==', 0, "Shifting an arrayref leaves no values" );
- ok( exists $db->{baz}{foo} );
- ok( exists $baz2->{foo} );
+ my $dbm_factory = new_dbm();
+ while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ $db->{foo} = [ 42 ];
+ my $foo = shift @{ $db->{foo} };
+ cmp_ok( @{ $db->{foo} }, '==', 0, "Shifting a scalar leaves no values" );
+ cmp_ok( $foo, '==', 42, "... And the value is correct." );
+
+ $db->{bar} = [ [] ];
+ my $bar = shift @{ $db->{bar} };
+ cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" );
+
+ $db->{baz} = { foo => [ 1 .. 3 ] };
+ $db->{baz2} = [ $db->{baz} ];
+ my $baz2 = shift @{ $db->{baz2} };
+ cmp_ok( @{ $db->{baz2} }, '==', 0, "Shifting an arrayref leaves no values" );
+ ok( exists $db->{baz}{foo} );
+ ok( exists $baz2->{foo} );
+ }
}
-__END__
+done_testing;
-use 5.006;
-
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 2;
+use Test::More;
use Test::Deep;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-{
- my ($fh, $filename) = t::common::new_fh();
- my $db = DBM::Deep->new(
- file => $filename,
- fh => $fh,
- );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
# Add a self-referencing connection to test export
my %struct = (
);
}
-__END__
+done_testing;
-use 5.006_000;
-
use strict;
use warnings FATAL => 'all';
use Test::More;
-use t::common qw( new_fh );
+use t::common qw( new_dbm );
my $max = 10;
-plan tests => $max + 1;
-
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( file => $filename, fh => $fh, );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-my $x = 1;
-while( $x <= $max ) {
- eval {
- delete $db->{borked}{test};
- $db->{borked}{test} = 1;
- };
+ my $x = 1;
+ while( $x <= $max ) {
+ eval {
+ delete $db->{borked}{test};
+ $db->{borked}{test} = 1;
+ };
- ok(!$@, "No eval failure after ${x}th iteration");
- $x++;
+ ok(!$@, "No eval failure after ${x}th iteration");
+ $x++;
+ }
}
+
+done_testing;
-
# This was discussed here:
# http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab
# brought up by Alex Gallichotte
use warnings FATAL => 'all';
use Test::More;
-use DBM::Deep;
plan skip_all => "Need to figure out what platforms this runs on";
-use t::common qw( new_fh );
+use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( file => $filename, fh => $fh, );
+use t::common qw( new_dbm );
-my $todo = 1000;
-my $allow = $todo*0.02; # NOTE: a 2% fail rate is hardly a failure
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
-$db->{randkey()} = 1 for 1 .. 1000;
+ my $todo = 1000;
+ my $allow = $todo*0.02; # NOTE: a 2% fail rate is hardly a failure
-plan tests => $todo*2;
+ $db->{randkey()} = 1 for 1 .. 1000;
-my $error_count = 0;
-my @mem = (mem(0), mem(1));
-for my $i (1 .. $todo) {
- $db->{randkey()} = [@mem];
+ my $error_count = 0;
+ my @mem = (mem(0), mem(1));
+ for my $i (1 .. $todo) {
+ $db->{randkey()} = [@mem];
- ## DEBUG ## print STDERR " @mem \r";
+ ## DEBUG ## print STDERR " @mem \r";
- my @tm = (mem(0), mem(1));
+ my @tm = (mem(0), mem(1));
- skip( not($mem[0]), ($tm[0] <= $mem[0] or --$allow>0) );
- skip( not($mem[1]), ($tm[1] <= $mem[1] or --$allow>0) );
+ skip( not($mem[0]), ($tm[0] <= $mem[0] or --$allow>0) );
+ skip( not($mem[1]), ($tm[1] <= $mem[1] or --$allow>0) );
- $error_count ++ if $tm[0] > $mem[0] or $tm[1] > $mem[1];
- die " ERROR: that's enough failures to prove the point ... " if $error_count > 20;
+ $error_count ++ if $tm[0] > $mem[0] or $tm[1] > $mem[1];
+ die " ERROR: that's enough failures to prove the point ... " if $error_count > 20;
- @mem = @tm;
+ @mem = @tm;
+ }
}
sub randkey {
-
# This was discussed here:
# http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab
# brought up by Alex Gallichotte
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 4;
-use t::common qw( new_fh );
+use Test::More;
+use t::common qw( new_dbm );
use_ok( 'DBM::Deep' );
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( file => $filename, fh => $fh );
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+ eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures");
-eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures");
+ eval {
+ #$db->begin_work;
+ $db->{randkey()} = randkey() for 1 .. 10;
+ #$db->commit;
+ };
+ ok(!$@, "No eval failures from the transaction");
-eval {
-# $db->begin_work;
- $db->{randkey()} = randkey() for 1 .. 10;
-# $db->commit;
-};
-ok(!$@, "No eval failures from the transaction");
+ eval { $db->{randkey()} = randkey() for 1 .. 10; };
+ ok(!$@, "No eval failures");
+}
-eval { $db->{randkey()} = randkey() for 1 .. 10; }; ok(!$@, "No eval failures");
+done_testing;
sub randkey {
- our $i ++;
+ our $i++;
my @k = map { int rand 100 } 1 .. 10;
local $" = "-";
--- /dev/null
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More;
+use Test::Exception;
+use t::common qw( new_dbm );
+
+use_ok( 'DBM::Deep' );
+
+my $dbm_factory = new_dbm();
+while ( my $dbm_maker = $dbm_factory->() ) {
+ my $db = $dbm_maker->();
+
+ my $h = {};
+ my $tmp = $h;
+ for (1..99) { # 98 is ok, 99 is bad.
+ %$tmp = ("" => {});
+ $tmp = $tmp->{""};
+ }
+ lives_ok {
+ $db->{""} = $h;
+ } 'deep recursion causes no errors';
+}
+
+done_testing;
--- /dev/null
+#vim: ft=perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More;
+use Test::Exception;
+
+use lib 't/lib';
+
+use_ok( 'DBM::Deep' );
+
+throws_ok {
+ DBM::Deep->new({ _test => 1 });
+} qr/lock_exclusive must be implemented in a child class/, 'Must define lock_exclusive in Storage';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Storage::Test::lock_exclusive"} = sub { 1 };
+}
+
+throws_ok {
+ DBM::Deep->new({ _test => 1 });
+} qr/setup must be implemented in a child class/, 'Must define setup in Engine';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Engine::Test::setup"} = sub { 1 };
+}
+
+throws_ok {
+ DBM::Deep->new({ _test => 1 });
+} qr/unlock must be implemented in a child class/, 'Must define unlock in Storage';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Storage::Test::unlock"} = sub { 1 };
+}
+
+throws_ok {
+ DBM::Deep->new({ _test => 1 });
+} qr/flush must be implemented in a child class/, 'Must define flush in Storage';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Storage::Test::flush"} = sub { 1 };
+}
+
+my $db;
+lives_ok {
+ $db = DBM::Deep->new({ _test => 1 });
+} "We finally have enough defined to instantiate";
+
+throws_ok {
+ $db->lock_shared;
+} qr/lock_shared must be implemented in a child class/, 'Must define lock_shared in Storage';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Storage::Test::lock_shared"} = sub { 1 };
+}
+
+lives_ok {
+ $db->lock_shared;
+} 'We have lock_shared defined';
+
+# Yes, this is ordered for good reason. Think about it.
+my @methods = (
+ 'begin_work' => [
+ Engine => 'begin_work',
+ ],
+ 'rollback' => [
+ Engine => 'rollback',
+ ],
+ 'commit' => [
+ Engine => 'commit',
+ ],
+ 'supports' => [
+ Engine => 'supports',
+ ],
+ 'store' => [
+ Storage => 'is_writable',
+ Engine => 'write_value',
+ ],
+ 'fetch' => [
+ Engine => 'read_value',
+ ],
+ 'delete' => [
+ Engine => 'delete_key',
+ ],
+ 'exists' => [
+ Engine => 'key_exists',
+ ],
+ # Why is this one's error message bleeding through?
+ 'clear' => [
+ Engine => 'clear',
+ ],
+);
+
+# Add the following:
+# in_txn
+
+# If only I could use natatime(). *sighs*
+while ( @methods ) {
+ my ($entry, $requirements) = splice @methods, 0, 2;
+ while ( @$requirements ) {
+ my ($class, $child_method) = splice @$requirements, 0, 2;
+
+ throws_ok {
+ $db->$entry( 1 );
+ } qr/$child_method must be implemented in a child class/,
+ "'$entry' requires '$child_method' to be defined in the '$class'";
+
+ {
+ no strict 'refs';
+ *{"DBM::Deep::${class}::Test::${child_method}"} = sub { 1 };
+ }
+ }
+
+ lives_ok {
+ $db->$entry( 1 );
+ } "Finally have enough for '$entry' to work";
+}
+
+throws_ok {
+ $db->_engine->sector_type;
+} qr/sector_type must be implemented in a child class/, 'Must define sector_type in Storage';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Engine::Test::sector_type"} = sub { 'DBM::Deep::Iterator::Test' };
+}
+
+lives_ok {
+ $db->_engine->sector_type;
+} 'We have sector_type defined';
+
+throws_ok {
+ $db->first_key;
+} qr/iterator_class must be implemented in a child class/, 'Must define iterator_class in Iterator';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Engine::Test::iterator_class"} = sub { 'DBM::Deep::Iterator::Test' };
+}
+
+throws_ok {
+ $db->first_key;
+} qr/reset must be implemented in a child class/, 'Must define reset in Iterator';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Iterator::Test::reset"} = sub { 1 };
+}
+
+throws_ok {
+ $db->first_key;
+} qr/get_next_key must be implemented in a child class/, 'Must define get_next_key in Iterator';
+
+{
+ no strict 'refs';
+ *{"DBM::Deep::Iterator::Test::get_next_key"} = sub { 1 };
+}
+
+lives_ok {
+ $db->first_key;
+} 'Finally have enough for first_key to work.';
+
+done_testing;
use strict;
-use Test::More tests => 3;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Deep;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
- file => $filename,
-);
+my $db = DBM::Deep->new( $filename );
is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
NumTxns: 1
$db->{foo} = 'bar';
-is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
+is( $db->_dump_file, <<"__END_DUMP__", "Dump of file after single assignment" );
NumTxns: 1
Chains(B):
Chains(D):
00000545: D 0064 foo
__END_DUMP__
+done_testing;
package # Hide from PAUSE
t::common;
-use 5.006_000;
-
use strict;
-use warnings;
-
-our $VERSION = '0.01';
+use warnings FATAL => 'all';
use base 'Exporter';
our @EXPORT_OK = qw(
+ new_dbm
new_fh
);
my $parent = $ENV{WORK_DIR} || File::Spec->tmpdir;
our $dir = tempdir( CLEANUP => 1, DIR => $parent );
-#my $dir = tempdir( DIR => '.' );
sub new_fh {
my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir, UNLINK => 1 );
return ($fh, $filename);
}
+sub new_dbm {
+ my @args = @_;
+ my ($fh, $filename) = new_fh();
+
+ my (@names, @reset_funcs, @extra_args);
+
+ unless ( $ENV{NO_TEST_FILE} ) {
+ push @names, 'File';
+ push @reset_funcs, undef;
+ push @extra_args, [
+ file => $filename,
+ ];
+ }
+
+ if ( $ENV{TEST_SQLITE} ) {
+ (undef, my $filename) = new_fh();
+ push @names, 'SQLite';
+ push @reset_funcs, sub {
+ require 'DBI.pm';
+ my $dbh = DBI->connect(
+ "dbi:SQLite:dbname=$filename", '', '',
+ );
+ my $sql = do {
+ my $filename = 'etc/sqlite_tables.sql';
+ open my $fh, '<', $filename
+ or die "Cannot open '$filename' for reading: $!\n";
+ local $/;
+ <$fh>
+ };
+ foreach my $line ( split ';', $sql ) {
+ $dbh->do( "$line" ) if $line =~ /\S/;
+ }
+ };
+ push @extra_args, [
+ dbi => {
+ dsn => "dbi:SQLite:dbname=$filename",
+ user => '',
+ password => '',
+ },
+ ];
+ }
+
+ if ( $ENV{TEST_MYSQL_DSN} ) {
+ push @names, 'MySQL';
+ push @reset_funcs, sub {
+ require 'DBI.pm';
+ my $dbh = DBI->connect(
+ $ENV{TEST_MYSQL_DSN},
+ $ENV{TEST_MYSQL_USER},
+ $ENV{TEST_MYSQL_PASS},
+ );
+ my $sql = do {
+ my $filename = 'etc/mysql_tables.sql';
+ open my $fh, '<', $filename
+ or die "Cannot open '$filename' for reading: $!\n";
+ local $/;
+ <$fh>
+ };
+ foreach my $line ( split ';', $sql ) {
+ $dbh->do( "$line" ) if $line =~ /\S/;
+ }
+ };
+ push @extra_args, [
+ dbi => {
+ dsn => $ENV{TEST_MYSQL_DSN},
+ user => $ENV{TEST_MYSQL_USER},
+ password => $ENV{TEST_MYSQL_PASS},
+ },
+ ];
+ }
+
+ return sub {
+ return unless @extra_args;
+ my @these_args = @{ shift @extra_args };
+ if ( my $reset = shift @reset_funcs ) {
+ $reset->();
+ }
+ Test::More::diag( "Testing '@{[shift @names]}'\n" ) if $ENV{TEST_VERBOSE};
+ return sub {
+ DBM::Deep->new( @these_args, @args, @_ )
+ };
+ };
+}
+
1;
__END__
--- /dev/null
+package DBM::Deep::Engine::Test;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Engine );
+
+use DBM::Deep::Storage::Test;
+
+sub new {
+ return bless {
+ storage => DBM::Deep::Storage::Test->new,
+ }, shift;
+}
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Iterator::Test;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Iterator );
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Storage::Test;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Storage );
+
+sub new {
+ return bless {
+ }, shift;
+}
+
+1;
+__END__
projects / dbsrgits/DBM-Deep.git / commitdiff