r12193@rob-kinyons-computer-2 (orig r10512): rkinyon | 2008-01-10 23:43:35 -0500
Fixes for 1.0007
r592@rob-kinyons-computer-2 (orig r10555): rkinyon | 2008-01-15 14:19:42 -0500
Changed POD a little bit
r688@rob-kinyons-computer-2 (orig r10891): rkinyon | 2008-03-09 20:20:16 -0400
r583@rob-kinyons-computer-2 (orig r10209): rkinyon | 2007-11-09 10:15:50 -0500
Branch for integrating the Win32 fixes provided by Buk and xdg
r585@rob-kinyons-computer-2 (orig r10212): rkinyon | 2007-11-09 10:59:00 -0500
Added BrowserUk's changes so that the tests work in Win32. Have verified that they work in OSX, will test Win32 via Parallels soon.
r586@rob-kinyons-computer-2 (orig r10258): rkinyon | 2007-11-15 16:33:11 -0500
Fixed a bug in autovivification regarding how locking is handled.
r587@rob-kinyons-computer-2 (orig r10261): rkinyon | 2007-11-15 23:19:31 -0500
Added more stringent tests to the multilevel transactions and started the release management process
r681@rob-kinyons-computer-2 (orig r10884): rkinyon | 2008-03-09 19:49:57 -0400
Are we ready for release?
r682@rob-kinyons-computer-2 (orig r10885): rkinyon | 2008-03-09 19:56:39 -0400
Workaround hack for Win32 and autovivification
r683@rob-kinyons-computer-2 (orig r10886): rkinyon | 2008-03-09 19:58:05 -0400
Fixed numbering of skipped tests for Win32
r684@rob-kinyons-computer-2 (orig r10887): rkinyon | 2008-03-09 20:01:21 -0400
Added some skips for win32/cygwin in order to ship
r685@rob-kinyons-computer-2 (orig r10888): rkinyon | 2008-03-09 20:08:33 -0400
Added BrowserUk's to a few tests missing it (fh => in addition to file => )
r686@rob-kinyons-computer-2 (orig r10889): rkinyon | 2008-03-09 20:12:16 -0400
Added opening for the files (stupid win32 warnings)
r687@rob-kinyons-computer-2 (orig r10890): rkinyon | 2008-03-09 20:19:31 -0400
A couple documentation fixes
r5021@rob-kinyons-computer-2 (orig r10948): rkinyon | 2008-03-19 11:45:11 -0400
r693@rob-kinyons-computer-2 (orig r10898): rkinyon | 2008-03-10 02:03:23 -0400
Removed _fh() method from DBM::Deep and refactored appropriately
r5020@rob-kinyons-computer-2 (orig r10947): rkinyon | 2008-03-19 11:44:54 -0400
Fixed a couple problems, wrote tests for a couple more
'FileHandle::Fmode' => '0.05',
},
optional => {
+ 'Pod::Usage' => '1.3',
},
build_requires => {
'File::Path' => '0.01',
Revision history for DBM::Deep.
+1.0009 Mar 19 12:00:00 2008 EDT
+ - (This version is compatible with 1.0008)
+ - Internal refactorings to prepare for some optimizations.
+ - _fh() has been removed. It was marked as private, so don't complain.
+ - Skip a test that was spuriously failing on Win32 (Thanks, Alias!)
+
+1.0008 Mar 09 20:00:00 2008 EDT
+ - (This version is compatible with 1.0007)
+ - Fixed a number of Win32 issues (Reported by Steven Samelson - thank you!)
+ - Much thanks to Nigel Sandever and David Golden for their help
+ debugging the issues, particularly with DBM::Deep's usage of
+ File::Temp (which removes a number of warnings).
+ - Autovivification now works on Win32. It turns out that when a
+ process takes a shared flock on a file, it's not allowed to write to
+ it under Win32, unlike *nix. This is probably a good catch.
+ - Note: The fix is a hack. All locks are now exclusive until a
+ better fix is found.
+
+1.0007 Jan 10 00:00:00 2008 EDT
+ - (This version is compatible with 1.0006)
+ - Applied a patch+failing test submitted by sprout@cpan.org. Thanks!
+ - Turns out that the case of 17 keys with the same first character in the
+ MD5 hash wasn't being tested for. This was a crashbug.
+ - A fix has been made to upgrade_db.pl (RT# 30067)
+ - The version determinations were in the wrong order or evaluation. This
+ meant that upgrade_db.pl wouldn't work as expected (or at all).
+ - Added a minimum Pod::Usage requirement (RT# 29976)
+ - It's an optional item in Build.PL
+ - utils/upgrade_db.pl now checks for that version, as does the test.
+
1.0006 Oct 01 23:15:00 2007 EDT
- (This version is compatible with 1.0005)
- Removed Clone and replaced it with a hand-written datastructure walker.
t/43_transaction_maximum.t
t/44_upgrade_db.t
t/45_references.t
+t/46_blist_reindex.t
+t/47_odd_reference_behaviors.t
t/97_dump_file.t
t/98_pod.t
t/99_pod_coverage.t
use strict;
use warnings;
-our $VERSION = q(1.0006);
+our $VERSION = q(1.0009);
use Fcntl qw( :flock );
-
-use Digest::MD5 ();
-use FileHandle::Fmode ();
use Scalar::Util ();
use DBM::Deep::Engine;
'""' => sub { overload::StrVal( $_[0] ) },
fallback => 1;
+use constant DEBUG => 0;
+
##
# Setup constants for users to pass to new()
##
#XXX Do we have to lock the tempfile?
#XXX Should we use tempfile() here instead of a hard-coded name?
+ my $temp_filename = $self->_storage->{file} . '.tmp';
my $db_temp = DBM::Deep->new(
- file => $self->_storage->{file} . '.tmp',
+ file => $temp_filename,
type => $self->_type,
# Bring over all the parameters that we need to bring over
##
# Attempt to copy user, group and permissions over to new file
##
- my @stats = stat($self->_fh);
- my $perms = $stats[2] & 07777;
- my $uid = $stats[4];
- my $gid = $stats[5];
- chown( $uid, $gid, $self->_storage->{file} . '.tmp' );
- chmod( $perms, $self->_storage->{file} . '.tmp' );
+ $self->_storage->copy_stats( $temp_filename );
# q.v. perlport for more information on this variable
if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
$self->_storage->close;
}
- if (!rename $self->_storage->{file} . '.tmp', $self->_storage->{file}) {
- unlink $self->_storage->{file} . '.tmp';
+ if (!rename $temp_filename, $self->_storage->{file}) {
+ unlink $temp_filename;
$self->unlock();
$self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
}
return $self->{staleness};
}
-sub _fh {
- my $self = $_[0]->_get_self;
- return $self->_storage->{fh};
-}
-
##
# Utility methods
##
##
my $self = shift->_get_self;
my ($key, $value) = @_;
+ warn "STORE($self, $key, $value)\n" if DEBUG;
- if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
+ unless ( $self->_storage->is_writable ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
##
my $self = shift->_get_self;
my ($key) = @_;
+ warn "FETCH($self,$key)\n" if DEBUG;
##
# Request shared lock for reading
##
my $self = shift->_get_self;
my ($key) = @_;
+ warn "DELETE($self,$key)\n" if DEBUG;
- if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
+ unless ( $self->_storage->is_writable ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
##
my $self = shift->_get_self;
my ($key) = @_;
+ warn "EXISTS($self,$key)\n" if DEBUG;
##
# Request shared lock for reading
# Clear all keys from hash, or all elements from array.
##
my $self = shift->_get_self;
+ warn "CLEAR($self)\n" if DEBUG;
- if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
+ unless ( $self->_storage->is_writable ) {
$self->_throw_error( 'Cannot write to a readonly filehandle' );
}
# something here
$db->unlock();
+=head2 Win32/Cygwin
+
+Due to Win32 actually enforcing the read-only status of a shared lock, all
+locks on Win32 and cygwin are exclusive. This is because of how autovivification
+currently works. Hopefully, this will go away in a future release.
+
=head1 IMPORTING/EXPORTING
You can import existing complex structures by calling the C<import()> method,
=head1 CODE COVERAGE
-B<Devel::Cover> is used to test the code coverage of the tests. Below is the
-B<Devel::Cover> report on this distribution's test suite.
+L<Devel::Cover/> is used to test the code coverage of the tests. Below is the
+L<Devel::Cover/> report on this distribution's test suite.
------------------------------------------ ------ ------ ------ ------ ------
File stmt bran cond sub total
use strict;
use warnings;
-our $VERSION = q(1.0006);
+our $VERSION = q(1.0009);
# This is to allow DBM::Deep::Array to handle negative indices on
# its own. Otherwise, Perl would intercept the call to negative
sub DELETE {
my $self = shift->_get_self;
my ($key) = @_;
+ warn "ARRAY::DELETE($self,$key)\n" if DBM::Deep::DEBUG;
$self->lock( $self->LOCK_EX );
sub SHIFT {
my $self = shift->_get_self;
+ warn "SHIFT($self)\n" if DBM::Deep::DEBUG;
$self->lock( $self->LOCK_EX );
for (my $i = 0; $i < $length - 1; $i++) {
$self->_move_value( $i+1, $i );
}
+
$self->DELETE( $length - 1 );
$self->unlock;
use strict;
use warnings;
-our $VERSION = q(1.0006);
+our $VERSION = q(1.0009);
use Scalar::Util ();
$sector->find_md5( $args->{key_md5} );
# See whether or not we need to reindex the bucketlist
- if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {
+ # Yes, the double-braces are there for a reason. if() doesn't create a redo-able block,
+ # so we have to create a bare block within the if() for redo-purposes. Patch and idea
+ # submitted by sprout@cpan.org. -RobK, 2008-01-09
+ if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
+ my $redo;
+
my $new_index = DBM::Deep::Engine::Sector::Index->new({
engine => $engine,
});
# Handle the new item separately.
{
my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
- 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 all the previous blist's items have been thrown into one
+ # blist and the new item belongs in there too, we need
+ # another index.
+ if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
+ ++$i, ++$redo;
+ } else {
+ 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,
+ }),
+ });
+ }
+# 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->free;
+ if ( $redo ) {
+ (undef, $sector) = %blist_cache;
+ $last_sector = $new_index;
+ redo;
+ }
+
$sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
$sector->find_md5( $args->{key_md5} );
- }
+ }}
return $sector;
}
);
my ($loc, $staleness) = unpack( $StP{$e->byte_size} . ' ' . $StP{$STALE_SIZE}, $buffer );
+ # XXX Merge the two if-clauses below
if ( $args->{trans_id} ) {
# We have found an entry that is old, so get rid of it
if ( $staleness != (my $s = $e->get_txn_staleness_counter( $args->{trans_id} ) ) ) {
idx => $args->{idx},
});
}
+
return $loc <= 1 ? 0 : $loc;
}
use strict;
use warnings;
-our $VERSION = q(1.0006);
+our $VERSION = q(1.0009);
use Fcntl qw( :DEFAULT :flock :seek );
+use FileHandle::Fmode ();
sub new {
my $class = shift;
seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
}
- print( $fh @_ );
+ print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
return 1;
}
$type = LOCK_EX unless defined $type;
+ #XXX This is a temporary fix for Win32 and autovivification. It
+ # needs to improve somehow. -RobK, 2008-03-09
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
+ $type = LOCK_EX;
+ }
+
if (!defined($self->{fh})) { return; }
+ #XXX This either needs to allow for upgrading a shared lock to an
+ # exclusive lock or something else with autovivification.
+ # -RobK, 2008-03-09
if ($self->{locking}) {
if (!$self->{locked}) {
flock($self->{fh}, $type);
return 1;
}
+sub is_writable {
+ my $self = shift;
+ return FileHandle::Fmode::is_W( $self->{fh} );
+}
+
+sub copy_stats {
+ my $self = shift;
+ my ($temp_filename) = @_;
+
+ my @stats = stat( $self->{fh} );
+ my $perms = $stats[2] & 07777;
+ my $uid = $stats[4];
+ my $gid = $stats[5];
+ chown( $uid, $gid, $temp_filename );
+ chmod( $perms, $temp_filename );
+}
+
1;
__END__
use strict;
use warnings;
-our $VERSION = q(1.0006);
+our $VERSION = q(1.0009);
use base 'DBM::Deep';
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $db = DBM::Deep->new(
+ file => $filename,
+ fh => $fh,
+);
##
# put/get key
# Make sure DB still works after closing / opening
##
undef $db;
-$db = DBM::Deep->new( $filename );
+open $fh, '+<', $filename;
+$db = DBM::Deep->new(
+ file => $filename,
+ fh => $fh,
+);
is( $db->get("key1"), "value222222222222222222222222", "The value we set is still there after closure" );
##
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
- file => $filename,
- type => DBM::Deep->TYPE_ARRAY
+ file => $filename,
+ fh => $fh,
+ type => DBM::Deep->TYPE_ARRAY
);
##
throws_ok {
$db->[-6] = 'whoops!';
-} qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown";
+} qr/Modification of non-creatable array value attempted, subscript -6/, "Correct error thrown";
my $popped = $db->pop;
is( $db->length, 4, "... and we have four after popping" );
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_ARRAY
);
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
- file => $filename,
- locking => 1,
+ file => $filename,
+ fh => $fh,
+ locking => 1,
);
lives_ok {
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_HASH,
);
}
{
+ open $fh, '+<', $filename;
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_HASH,
);
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_ARRAY,
);
}
{
+ open $fh, '+<', $filename;
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_ARRAY,
);
# DBM::Deep Test
##
use strict;
-use Test::More tests => 9;
-use File::Temp qw( tmpnam );
+use Test::More;
+
+plan skip_all => "Skipping the optimize tests on Win32/cygwin for now."
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
+
+plan tests => 9;
+
+use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
-my $filename = tmpnam();
+my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
- file => $filename,
- autoflush => 1,
+ file => $filename,
+ autoflush => 1,
);
##
##
# take byte count readings before, and after optimize
##
-my $before = (stat($db->_fh()))[7];
+my $before = (stat($filename))[7];
my $result = $db->optimize();
-my $after = (stat($db->_fh()))[7];
+my $after = (stat($filename))[7];
ok( $result, "optimize succeeded" );
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" );
+$db->_get_self->_storage->close( $db->_get_self );
+
##
# now for the tricky one -- try to store a new key while file is being
-# optimized and locked by another process. filehandle should be invalidated,
-# and automatically re-opened transparently. Cannot test on Win32, due to
+# optimized and locked by another process. filehandle should be invalidated,
+# and automatically re-opened transparently. Cannot test on Win32, due to
# problems with fork()ing, flock()ing, etc. Win32 very bad.
##
SKIP: {
+ skip "Fork tests skipped until fh/filename question solved.", 4;
skip "Fork tests skipped on Win32", 4
if $^O eq 'MSWin32' || $^O eq 'cygwin';
##
- # first things first, get us about 1000 keys so the optimize() will take
+ # first things first, get us about 1000 keys so the optimize() will take
# at least a few seconds on any machine, and re-open db with locking
##
for (1..1000) { $db->STORE( $_, $_ +1 ); }
unless ( $pid ) {
# child fork
-
+
# re-open db
$db = DBM::Deep->new(
file => $filename,
autoflush => 1,
locking => 1
);
-
+
# optimize and exit
$db->optimize();
}
# parent fork
ok( defined($pid), "fork was successful" ); # make sure fork was successful
-
+
# re-open db
$db = DBM::Deep->new(
file => $filename,
# sleep for 1 second to make sure optimize() is running in the other fork
sleep(1);
-
+
# now, try to get a lock and store a key
$db->{parentfork} = "hello";
-
+
# see if it was stored successfully
is( $db->{parentfork}, "hello", "stored key while optimize took place" );
autoflush => 1,
locking => 1
);
-
+
# now check some existing values from before
is( $db->{key1}, 'value1', "key1's value is still there after optimize" );
is( $db->{a}{c}, 'value2', "key2's value is still there after optimize" );
);
$db->{key1} = "value1";
$db->{key2} = "value2";
- $default = (stat($db->_fh()))[7];
+ $default = (stat($filename))[7];
}
{
$db->{key1} = "value1";
$db->{key2} = "value2";
- $medium = (stat($db->_fh()))[7];
+ $medium = (stat($filename))[7];
}
# This tests the header to verify that the pack_size is really there
$db->{key1} = "value1";
$db->{key2} = "value2";
- $small = (stat($db->_fh()))[7];
+ $small = (stat($filename))[7];
}
# This tests the header to verify that the pack_size is really there
$db->{key1} = "value1";
$db->{key2} = "value2";
- $large = (stat($db->_fh()))[7];
+ $large = (stat($filename))[7];
}
# This tests the header to verify that the pack_size is really there
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $db = DBM::Deep->new( file => $filename, fh => $fh, );
##
# put/get simple keys
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
type => $type,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autobless => 1,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
type => DBM::Deep->TYPE_ARRAY,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autobless => 1,
});
my $x;
my $struct = {
key1 => [
- 2, \$x, 3,
+ 2, \$x, 3,
],
};
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autobless => 1,
});
use_ok( 'DBM::Deep' );
my ($fh2, $filename2) = new_fh();
-my $db2 = DBM::Deep->new( $filename2 );
+my $db2 = DBM::Deep->new( file => $filename2, fh => $fh2, );
SKIP: {
skip "Apparently, we cannot detect a tied scalar?", 1;
{
my ($fh, $filename) = new_fh();
- my $db = DBM::Deep->new( $filename );
+ my $db = DBM::Deep->new( file => $filename, fh => $fh, );
##
# Create structure in $db
$hash{key1} = 'value';
is( $hash{key1}, 'value', 'Set and retrieved key1' );
+ tied( %hash )->_get_self->_storage->close( tied( %hash )->_get_self );
}
{
is( keys %hash, 1, "There's one key so far" );
ok( exists $hash{key1}, "... and it's key1" );
+ tied( %hash )->_get_self->_storage->close( tied( %hash )->_get_self );
}
{
file => $filename,
type => DBM::Deep->TYPE_ARRAY,
};
+ tied( @array )->_get_self->_storage->close( tied( @array )->_get_self );
} qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type";
}
{
my ($fh, $filename) = new_fh();
- DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY );
+ my $db = DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY );
throws_ok {
tie my %hash, 'DBM::Deep', {
type => DBM::Deep->TYPE_HASH,
};
} qr/DBM::Deep: File type mismatch/, "\$SIG_TYPE doesn't match file's type";
+ $db->_get_self->_storage->close( $db->_get_self );
}
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $db = DBM::Deep->new( file => $filename, fh => $fh, );
##
# Create structure in $db
##
$db->import({
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2",
- },
+ hash1 => {
+ subkey1 => "subvalue1",
+ subkey2 => "subvalue2",
+ },
hash2 => {
subkey3 => 'subvalue3',
},
my ($fh2, $filename2) = new_fh();
{
- my $db = DBM::Deep->new( $filename2 );
+ my $db = DBM::Deep->new( file => $filename2, fh => $fh2, );
$db->{foo} = [ 1 .. 3 ];
for ( 0 .. $max_keys ) {
$db->{'foo' . $_} = $db->{foo};
}
+ ## Rewind handle otherwise the signature is not recognised below.
+ ## The signature check should probably rewind the fh?
+ seek $db->_get_self->_storage->{fh}, 0, 0;
}
{
- my $db = DBM::Deep->new( $filename2 );
+ my $db = DBM::Deep->new( fh => $fh2, );
my $base_offset = $db->{foo}->_base_offset;
my $count = -1;
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
autobless => 1,
);
is( $db->{unblessed}{b}[2], 3 );
$db->{blessed_long} = bless {}, 'a' x 1000;
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
is( $db->{blessed}{c}, 'new' );
isa_ok( $db->{blessed_long}, 'a' x 1000 );
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
my $structure = $db->export();
use Data::Dumper;print Dumper $structure;
-
+
my $obj = $structure->{blessed};
isa_ok( $obj, 'Foo' );
can_ok( $obj, 'export', 'foo' );
is( $structure->{unblessed}{b}[0], 1 );
is( $structure->{unblessed}{b}[1], 2 );
is( $structure->{unblessed}{b}[2], 3 );
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
is( $db->{unblessed}{b}[0], 1 );
is( $db->{unblessed}{b}[1], 2 );
is( $db->{unblessed}{b}[2], 3 );
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
{
my $db = DBM::Deep->new(
file => $filename2,
+ fh => $fh2,
autobless => 1,
);
my $obj = bless {
}, 'Foo';
$db->import( { blessed => $obj } );
+ $db->_get_self->_storage->close( $db->_get_self );
}
{
my $blessed = $db->{blessed};
isa_ok( $blessed, 'Foo' );
is( $blessed->{a}, 1 );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
{
- ##
- # test blessing hash into short named class (Foo), then re-blessing into
- # longer named class (FooFoo) and replacing key in db file, then validating
- # content after that point in file to check for corruption.
- ##
+ ##
+ # test blessing hash into short named class (Foo), then re-blessing into
+ # longer named class (FooFoo) and replacing key in db file, then validating
+ # content after that point in file to check for corruption.
+ ##
my ($fh3, $filename3) = new_fh();
my $db = DBM::Deep->new(
file => $filename3,
+ fh => $fh3,
autobless => 1,
);
$db->{blessed} = $obj;
$db->{after} = "hello";
-
+
my $obj2 = bless {}, 'FooFoo';
-
+
$db->{blessed} = $obj2;
is( $db->{after}, "hello" );
'Storage of code refs not supported';
throws_ok {
- $db->{scalarref} = $db->_get_self->_fh;
+ $db->{scalarref} = $fh;
} qr/Storage of references of type 'GLOB' is not supported/,
'Storage of glob refs not supported';
} qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
ok( !$db->exists( 'foo' ), "foo doesn't exist" );
- my $db_obj = $db->_get_self;
- ok( $db_obj->_storage->{inode}, "The inode has been set" );
+ SKIP: {
+ skip( "No inode tests on Win32", 1 )
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
+ my $db_obj = $db->_get_self;
+ ok( $db_obj->_storage->{inode}, "The inode has been set" );
+ }
close($fh);
}
use_ok( 'DBM::Deep' );
my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new( $filename );
+my $db = DBM::Deep->new( file => $filename, fh => $fh, );
my %hash = (
foo => 1,
cmp_bag( [ keys %$db2 ], [qw( foo z )], "DB2 keys correct" );
SKIP: {
- skip "Optimize tests skipped on Win32", 5
+ skip "Optimize tests skipped on Win32", 7
if $^O eq 'MSWin32' || $^O eq 'cygwin';
$db1->optimize;
use t::common qw( new_fh );
+sub do_stuff {
+ my ($db) = @_;
+
+ $db->{foo}{bar} = [ 1 .. 3 ];
+}
+
+sub verify {
+ my ($db) = @_;
+
+ cmp_ok( $db->{foo}{bar}[2], '==', 3, "Correct value found" );
+}
+
use_ok( 'DBM::Deep' );
my %sizes;
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
data_sector_size => 32,
);
$sizes{32} = -s $filename;
{
- my $db = DBM::Deep->new( $filename );
+ my $db = DBM::Deep->new( file => $filename );
verify( $db );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
data_sector_size => 64,
);
{
my $db = DBM::Deep->new( $filename );
verify( $db );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
data_sector_size => 128,
);
{
my $db = DBM::Deep->new( $filename );
verify( $db );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
{
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
data_sector_size => 256,
);
{
my $db = DBM::Deep->new( $filename );
verify( $db );
+ $db->_get_self->_storage->close( $db->_get_self );
}
}
cmp_ok( $sizes{128}, '>', $sizes{64}, "Filesize for 128 > filesize for 64" );
cmp_ok( $sizes{64}, '>', $sizes{32}, "Filesize for 64 > filesize for 32" );
-sub do_stuff {
- my ($db) = @_;
-
- $db->{foo}{bar} = [ 1 .. 3 ];
-}
-
-sub verify {
- my ($db) = @_;
-
- cmp_ok( $db->{foo}{bar}[2], '==', 3, "Correct value found" );
-}
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autoflush => 1,
});
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new({
file => $filename,
+ fh => $fh,
autoflush => 1,
});
# trigger a reindex. This requires knowing how much space is taken. Good thing
# we wrote this dreck ...
my $size = -s $filename;
-
+
my $data_sector_size = $db->_engine->data_sector_size;
my $expected = $size + 9 * ( 2 * $data_sector_size );
use strict;
-use Test::More tests => 33;
+use Test::More tests => 41;
use Test::Deep;
use t::common qw( new_fh );
my ($fh, $filename) = new_fh();
my $db1 = DBM::Deep->new(
file => $filename,
+ fh => $fh,
locking => 1,
autoflush => 1,
num_txns => 2,
);
+seek $db1->_get_self->_storage->{fh}, 0, 0;
my $db2 = DBM::Deep->new(
file => $filename,
+ fh => $fh,
locking => 1,
autoflush => 1,
num_txns => 2,
);
-$db1->{x} = { foo => 'y' };
-is( $db1->{x}{foo}, 'y', "Before transaction, DB1's X is Y" );
-is( $db2->{x}{foo}, 'y', "Before transaction, DB2's X is Y" );
+$db1->{x} = { xy => { foo => 'y' } };
+is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" );
+is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" );
$db1->begin_work;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( foo )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X keys correct" );
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
- is( $db1->{x}{foo}, 'y', "After transaction, DB1's X is Y" );
- is( $db2->{x}{foo}, 'y', "After transaction, DB2's X is Y" );
+ cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
+ cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
- $db1->{x} = { bar => 30 };
- ok( !exists $db1->{x}{foo}, "DB1: After reassignment of X, X->FOO is gone" );
- is( $db2->{x}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" );
+ is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" );
+ is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( bar )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X keys correct" );
+ $db1->{x} = { yz => { bar => 30 } };
+ ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" );
+ is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" );
+
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
$db1->rollback;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-cmp_bag( [ keys %{$db1->{x}} ], [qw( foo )], "DB1->X keys correct" );
-cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X keys correct" );
+cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
+cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+
+cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
+cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
-is( $db1->{x}{foo}, 'y', "Before transaction, DB1's X is Y" );
-is( $db2->{x}{foo}, 'y', "Before transaction, DB2's X is Y" );
+is( $db1->{x}{xy}{foo}, 'y', "Before transaction, DB1's X is Y" );
+is( $db2->{x}{xy}{foo}, 'y', "Before transaction, DB2's X is Y" );
$db1->begin_work;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( foo )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X keys correct" );
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( xy )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
+
+ cmp_bag( [ keys %{$db1->{x}{xy}} ], [qw( foo )], "DB1->X->XY keys correct" );
+ cmp_bag( [ keys %{$db2->{x}{xy}} ], [qw( foo )], "DB2->X->XY keys correct" );
- is( $db1->{x}{foo}, 'y', "After transaction, DB1's X is Y" );
- is( $db2->{x}{foo}, 'y', "After transaction, DB2's X is Y" );
+ is( $db1->{x}{xy}{foo}, 'y', "After transaction, DB1's X is Y" );
+ is( $db2->{x}{xy}{foo}, 'y', "After transaction, DB2's X is Y" );
- $db1->{x} = { bar => 30 };
- ok( !exists $db1->{x}{foo}, "DB1: After reassignment of X, X->FOO is gone" );
- is( $db2->{x}{foo}, 'y', "DB2: After reassignment of DB1 X, X is Y" );
+ $db1->{x} = { yz => { bar => 30 } };
+ ok( !exists $db1->{x}{xy}, "DB1: After reassignment of X, X->XY is gone" );
+ is( $db2->{x}{xy}{foo}, 'y', "DB2: After reassignment of DB1 X, X->YZ is Y" );
- cmp_bag( [ keys %{$db1->{x}} ], [qw( bar )], "DB1->X keys correct" );
- cmp_bag( [ keys %{$db2->{x}} ], [qw( foo )], "DB2->X keys correct" );
+ cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+ cmp_bag( [ keys %{$db2->{x}} ], [qw( xy )], "DB2->X keys correct" );
$db1->commit;
cmp_bag( [ keys %$db1 ], [qw( x )], "DB1 keys correct" );
cmp_bag( [ keys %$db2 ], [qw( x )], "DB2 keys correct" );
-cmp_bag( [ keys %{$db1->{x}} ], [qw( bar )], "DB1->X keys correct" );
-cmp_bag( [ keys %{$db2->{x}} ], [qw( bar )], "DB2->X keys correct" );
+cmp_bag( [ keys %{$db1->{x}} ], [qw( yz )], "DB1->X keys correct" );
+cmp_bag( [ keys %{$db2->{x}} ], [qw( yz )], "DB2->X keys correct" );
+
+cmp_bag( [ keys %{$db1->{x}{yz}} ], [qw( bar )], "DB1->X->XY keys correct" );
+cmp_bag( [ keys %{$db2->{x}{yz}} ], [qw( bar )], "DB2->X->XY keys correct" );
+
+$db1->_get_self->_storage->close( $db1->_get_self );
+$db2->_get_self->_storage->close( $db2->_get_self );
# Add skips here
BEGIN {
+ plan skip_all => "Skipping the upgrade_db.pl tests on Win32/cygwin for now."
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
+
my @failures;
- eval { use Pod::Usage; }; push @failures, 'Pod::Usage' if $@;
+ eval { use Pod::Usage 1.3; }; push @failures, 'Pod::Usage' if $@;
eval { use IO::Scalar; }; push @failures, 'IO::Scalar' if $@;
if ( @failures ) {
my $missing = join ',', @failures;
}
}
-plan tests => 222;
+plan tests => 252;
use t::common qw( new_fh );
use File::Spec;
"Input is not a DBM::Deep file",
);
+unlink $input_filename;unlink $output_filename;
+
# All files are of the form:
# $db->{foo} = [ 1 .. 3 ];
'0.981', '0.982', '0.983',
'0.99_01', '0.99_02', '0.99_03', '0.99_04',
'1.00', '1.000', '1.0000', '1.0001', '1.0002',
- '1.0003', '1.0004', '1.0005', '1.0006',
+ '1.0003', '1.0004', '1.0005', '1.0006', '1.0007', '1.0008', '1.0009',
);
foreach my $input_filename (
die "$output\n" if $output;
my $db;
- if ( $v =~ /^0/ ) {
- push @INC, File::Spec->catdir( 'utils', 'lib' );
- eval "use DBM::Deep::09830";
- $db = DBM::Deep::09830->new( $output_filename );
+ if ( $v =~ /^1\.000[3-9]/ ) {
+ push @INC, 'lib';
+ eval "use DBM::Deep";
+ $db = DBM::Deep->new( $output_filename );
}
elsif ( $v =~ /^1\.000?[0-2]?/ ) {
push @INC, File::Spec->catdir( 'utils', 'lib' );
eval "use DBM::Deep::10002";
$db = DBM::Deep::10002->new( $output_filename );
}
- elsif ( $v =~ /^1\.000[3-6]/ ) {
- push @INC, 'lib';
- eval "use DBM::Deep";
- $db = DBM::Deep->new( $output_filename );
+ elsif ( $v =~ /^0/ ) {
+ push @INC, File::Spec->catdir( 'utils', 'lib' );
+ eval "use DBM::Deep::09830";
+ $db = DBM::Deep::09830->new( $output_filename );
}
else {
die "How did we get here?!\n";
my ($fh, $filename) = new_fh();
my $db = DBM::Deep->new(
file => $filename,
+ fh => $fh,
locking => 1,
autoflush => 1,
num_txns => 16,
);
+seek $db->_get_self->_storage->{fh}, 0, 0;
+
my $db2 = DBM::Deep->new(
file => $filename,
+ fh => $fh,
locking => 1,
autoflush => 1,
num_txns => 16,
--- /dev/null
+# 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 t::common qw( new_fh );
+
+use_ok( 'DBM::Deep' );
+
+{
+ my ($fh, $filename) = new_fh();
+ my $db = DBM::Deep->new( $filename );
+
+ 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 /
+ ], 'and the keys were stored correctly';
+}
+
+{
+ my ($fh, $filename) = new_fh();
+ my $db = DBM::Deep->new( $filename );
+
+ 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 /
+ ], 'and the keys were stored correctly';
+}
+
+__END__
--- /dev/null
+use 5.006;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Scalar::Util qw( reftype );
+use Test::More tests => 10;
+
+use t::common qw( new_fh );
+
+use_ok( 'DBM::Deep' );
+
+# This is bug #29957, reported by HANENKAMP
+TODO: {
+ todo_skip "This crashes the code", 4;
+ my ($fh, $filename) = new_fh();
+ my $db = DBM::Deep->new(
+ file => $filename,
+ fh => $fh,
+ );
+
+ $db->{foo} = [];
+
+ for my $value ( 1 .. 3 ) {
+ my $ref = $db->{foo};
+ push @$ref, $value;
+ $db->{foo} = $ref;
+ ok( 1, "T $value" );
+ }
+}
+
+# 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" );
+# use Data::Dumper; warn Dumper $bar;
+
+ $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__
-package t::common;
+package # Hide from PAUSE
+ t::common;
use 5.006_000;
my $parent = $ENV{WORK_DIR} || File::Spec->tmpdir;
my $dir = tempdir( CLEANUP => 1, DIR => $parent );
+#my $dir = tempdir( DIR => '.' );
sub new_fh {
- my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir );
+ my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir, UNLINK => 1 );
# This is because tempfile() returns a flock'ed $fh on MacOSX.
flock $fh, LOCK_UN;
1;
__END__
-
use lib File::Spec->catdir( $FindBin::Bin, '..', 'lib' );
use Getopt::Long qw( GetOptions );
-use Pod::Usage;
+use Pod::Usage 1.3;
my %headerver_to_module = (
'0' => 'DBM::Deep::09830',
my %opts = (
man => 0,
help => 0,
- version => '1.0006',
+ version => '1.0007',
autobless => 1,
);
GetOptions( \%opts,
{
my $ver = $opts{version};
- if ( $ver =~ /^0\.9[1-8]/ ) {
- $ver = 0;
- }
- elsif ( $ver =~ /^0\.99/) {
- $ver = 1;
+ if ( $ver =~ /^1\.000[3-9]/) {
+ $ver = 3;
}
elsif ( $ver =~ /^1\.000?[0-2]?/) {
$ver = 2;
}
- elsif ( $ver =~ /^1\.000[3-6]/) {
- $ver = 3;
+ elsif ( $ver =~ /^0\.99/) {
+ $ver = 1;
+ }
+ elsif ( $ver =~ /^0\.9[1-8]/ ) {
+ $ver = 0;
}
else {
_exit( "'$ver' is an unrecognized version." );
projects / dbsrgits/DBM-Deep.git / commitdiff