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!)
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.0008);
+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' );
}
use strict;
use warnings;
-our $VERSION = q(1.0008);
+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.0008);
+our $VERSION = q(1.0009);
use Scalar::Util ();
use strict;
use warnings;
-our $VERSION = q(1.0008);
+our $VERSION = q(1.0009);
use Fcntl qw( :DEFAULT :flock :seek );
+use FileHandle::Fmode ();
sub new {
my $class = shift;
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.0008);
+our $VERSION = q(1.0009);
use base 'DBM::Deep';
##
# 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
);
$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
'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);
}
}
}
-plan tests => 232;
+plan tests => 252;
use t::common qw( new_fh );
use File::Spec;
'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.0007',
+ '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 =~ /^1\.000[3-7]/ ) {
+ if ( $v =~ /^1\.000[3-9]/ ) {
push @INC, 'lib';
eval "use DBM::Deep";
$db = DBM::Deep->new( $output_filename );
--- /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__
{
my $ver = $opts{version};
- if ( $ver =~ /^1\.000[3-7]/) {
+ if ( $ver =~ /^1\.000[3-9]/) {
$ver = 3;
}
elsif ( $ver =~ /^1\.000?[0-2]?/) {
projects / dbsrgits/DBM-Deep.git / commitdiff