Revision history for DBM::Deep.
-0.983 Mar 25 08:00:00 2006 Pacific
+0.983 Apr 10 20:00:00 2006 Pacific
- Added patch inspired by Jeff Janes (Thanks!)
- Autovivification now works correctly
- The following now works correctly
$db->{hash} = \%hash;
$hash{b} = 2;
cmp_ok( $db->{hash}{b}, '==', 2 );
- - NOTE: This patch works by tying the underlying datastructure that was
- passed in. There are currently no checks to see if the datastructure was
- previously tied.
+ - (RT#18530) - DBM::Deep now plays nicely with -l
0.982 Mar 08 11:00:00 2006 Pacific
- Fixed smoketests that were failing on Win32
t/16_circular.t
t/17_import.t
t/18_export.t
-t/19_crossref.t
t/20_tie.t
t/21_tie_access.t
t/22_internal_copy.t
t/23_misc.t
t/24_autobless.t
t/25_tie_return_value.t
-t/26_scalar_ref.t
t/27_filehandle.t
t/27_filehandle.t.db
t/28_DATA.t
+t/29_dash_ell.t
+t/30_already_tied.t
use Scalar::Util ();
use vars qw( $VERSION );
-$VERSION = q(0.982);
+$VERSION = q(0.983);
##
# Set to 4 and 'N' for 32-bit offset tags (default). Theoretical limit of 4 GB per file.
sub SIG_FILE () { 'DPDB' }
sub SIG_HASH () { 'H' }
sub SIG_ARRAY () { 'A' }
-sub SIG_SCALAR () { 'S' }
sub SIG_NULL () { 'N' }
sub SIG_DATA () { 'D' }
sub SIG_INDEX () { 'I' }
##
my $self = $_[0]->_get_self;
+ local($/,$\);
+
if (defined($self->_fh)) { $self->_close(); }
my $flags = O_RDWR | O_CREAT | O_BINARY;
##
my ($self, $offset, $sig, $content) = @_;
my $size = length($content);
+
+ local($/,$\);
my $fh = $self->_fh;
##
my $self = shift;
my $offset = shift;
+
+ local($/,$\);
my $fh = $self->_fh;
my $location = 0;
my $result = 2;
+ local($/,$\);
+
+ # This verifies that only supported values will be stored.
+ {
+ my $r = Scalar::Util::reftype( $value );
+ last if !defined $r;
+
+ last if $r eq 'HASH';
+ last if $r eq 'ARRAY';
+
+ $self->_throw_error(
+ "Storage of variables of type '$r' is not supported."
+ );
+ }
+
my $root = $self->_root;
my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep' ) };
}
else { $actual_length = length($value); }
- if ($actual_length <= $size) {
+ if ($actual_length <= ($size || 0)) {
$location = $subloc;
}
else {
##
my $r = Scalar::Util::reftype($value) || '';
if ($r eq 'HASH') {
+ if ( !$internal_ref && tied %{$value} ) {
+ return $self->_throw_error("Cannot store a tied value");
+ }
print( $fh TYPE_HASH );
print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
$content_length = $INDEX_SIZE;
}
elsif ($r eq 'ARRAY') {
+ if ( !$internal_ref && tied @{$value} ) {
+ return $self->_throw_error("Cannot store a tied value");
+ }
print( $fh TYPE_ARRAY );
print( $fh pack($DATA_LENGTH_PACK, $INDEX_SIZE) . chr(0) x $INDEX_SIZE );
$content_length = $INDEX_SIZE;
my ($tag, $md5) = @_;
my $keys = $tag->{content};
+ local($/,$\);
+
my $fh = $self->_fh;
##
my ($tag, $md5) = @_;
my $keys = $tag->{content};
+ local($/,$\);
+
my $fh = $self->_fh;
##
##
my ($self, $offset, $ch, $force_return_next) = @_;
$force_return_next = undef unless $force_return_next;
+
+ local($/,$\);
my $tag = $self->_load_tag( $offset );
my $self = $_[0]->_get_self;
my $key = $_[1];
+ local($/,$\);
+
# User may be storing a hash, in which case we do not want it run
# through the filtering system
my $value = ($self->_root->{filter_store_value} && !ref($_[2]))
---------------------------- ------ ------ ------ ------ ------ ------ ------
File stmt bran cond sub pod time total
---------------------------- ------ ------ ------ ------ ------ ------ ------
- blib/lib/DBM/Deep.pm 95.2 83.8 70.0 98.2 100.0 58.0 91.0
- blib/lib/DBM/Deep/Array.pm 100.0 91.1 100.0 100.0 n/a 26.7 98.0
- blib/lib/DBM/Deep/Hash.pm 95.3 80.0 100.0 100.0 n/a 15.3 92.4
- Total 96.2 84.8 74.4 98.8 100.0 100.0 92.4
+ blib/lib/DBM/Deep.pm 95.4 84.6 69.1 98.2 100.0 60.3 91.0
+ blib/lib/DBM/Deep/Array.pm 100.0 91.1 100.0 100.0 n/a 26.4 98.0
+ blib/lib/DBM/Deep/Hash.pm 95.3 80.0 100.0 100.0 n/a 13.3 92.4
+ Total 96.4 85.4 73.1 98.8 100.0 100.0 92.4
---------------------------- ------ ------ ------ ------ ------ ------ ------
=head1 MORE INFORMATION
+++ /dev/null
-package DBM::Deep::Scalar;
-
-use strict;
-
-use base 'DBM::Deep';
-
-sub _get_self {
- eval { local $SIG{'__DIE__'}; tied( ${$_[0]} ) } || $_[0]
-}
-
-sub TIESCALAR {
- ##
- # Tied hash constructor method, called by Perl's tie() function.
- ##
- my $class = shift;
- my $args = $class->_get_args( @_ );
-
- $args->{type} = $class->TYPE_SCALAR;
-
- return $class->_init($args);
-}
-
-1;
-__END__
+++ /dev/null
-##
-# DBM::Deep Test
-##
-use strict;
-use Test::More tests => 15;
-
-use_ok( 'DBM::Deep' );
-
-unlink "t/test.db";
-my $db = DBM::Deep->new( "t/test.db" );
-if ($db->error()) {
- die "ERROR: " . $db->error();
-}
-
-unlink "t/test2.db";
-my $db2 = DBM::Deep->new( "t/test2.db" );
-if ($db2->error()) {
- die "ERROR: " . $db2->error();
-}
-
-##
-# Create structure in $db
-##
-$db->import(
- hash1 => {
- subkey1 => "subvalue1",
- subkey2 => "subvalue2"
- }
-);
-
-is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
-is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
-
-##
-# Cross-ref nested hash accross DB objects
-##
-$db2->{copy} = $db->{hash1};
-
-$db->{hash1}{subkey3} = 'where does this go?';
-is( $db->{hash1}{subkey3}, 'where does this go?' );
-
-$db2->{copy}{subkey4} = 'from the other side';
-is( $db2->{copy}{subkey4}, 'from the other side' );
-
-########
-# This is the failure case
-#
-{
- my $left = $db->{hash1};
- $db2->{right} = $left;
-
- $db2->{right}{rightward} = 'floober';
- is( $db2->{right}{rightward}, 'floober' );
- isnt( $db->{hash1}{rightward}, 'floober' );
-}
-#
-#
-########
-
-##
-# close, delete $db
-##
-undef $db;
-
-{
- my $db3 = DBM::Deep->new( 't/test.db' );
- if ($db3->error()) {
- die "ERROR: " . $db3->error();
- }
- is( $db3->{hash1}{subkey1}, 'subvalue1' );
- is( $db3->{hash1}{subkey2}, 'subvalue2' );
- is( $db3->{hash1}{subkey3}, 'where does this go?' );
- isnt( $db3->{hash1}{subkey4}, 'from the other side' );
-}
-
-unlink "t/test.db";
-
-##
-# 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" );
-isnt( $db2->{copy}{subkey3}, 'where does this go?' );
-is( $db2->{copy}{subkey4}, 'from the other side' );
+++ /dev/null
-use strict;
-
-use Test::More tests => 7;
-
-use_ok( 'DBM::Deep' );
-
-unlink "t/test.db";
-{
- my $db = DBM::Deep->new( "t/test.db" );
- if ($db->error()) {
- die "ERROR: " . $db->error();
- }
-
- my $x = 25;
- my $y = 30;
- $db->{scalar} = $x;
- $db->{scalarref} = \$y;
- $db->{selfref} = \$x;
-
- is( $db->{scalar}, $x, "Scalar retrieved ok" );
- TODO: {
- todo_skip "Scalar refs aren't implemented yet", 2;
- is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" );
- is( ${$db->{selfref}}, 25, "Scalarref to stored scalar retrieved ok" );
- }
-}
-
-{
- my $db = DBM::Deep->new( "t/test.db" );
- if ($db->error()) {
- die "ERROR: " . $db->error();
- }
-
- my $x = 25;
- my $y = 30;
- is( $db->{scalar}, $x, "Scalar retrieved ok" );
- TODO: {
- todo_skip "Scalar refs aren't implemented yet", 2;
- is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" );
- is( ${$db->{selfref}}, 25, "Scalarref to stored scalar retrieved ok" );
- }
-}
--- /dev/null
+#!/usr/bin/perl -l
+
+##
+# DBM::Deep Test
+#
+# Test for interference from -l on the commandline.
+##
+use strict;
+use Test::More tests => 4;
+use Test::Exception;
+
+use_ok( 'DBM::Deep' );
+
+unlink "t/test.db";
+my $db = DBM::Deep->new( 't/test.db' );
+
+##
+# 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" );
--- /dev/null
+##
+# DBM::Deep Test
+##
+use strict;
+use Test::More tests => 7;
+use Test::Exception;
+
+use_ok( 'DBM::Deep' );
+
+unlink 't/test.db';
+my $db = DBM::Deep->new( 't/test.db' );
+
+{
+ {
+ package My::Tie::Hash;
+
+ sub TIEHASH {
+ my $class = shift;
+
+ return bless {
+ }, $class;
+ }
+ }
+
+ my %hash;
+ tie %hash, 'My::Tie::Hash';
+ isa_ok( tied(%hash), 'My::Tie::Hash' );
+
+ throws_ok {
+ $db->{foo} = \%hash;
+ } qr/Cannot store a tied value/, "Cannot store tied hashes";
+}
+
+{
+ {
+ package My::Tie::Array;
+
+ sub TIEARRAY {
+ my $class = shift;
+
+ return bless {
+ }, $class;
+ }
+
+ sub FETCHSIZE { 0 }
+ }
+
+ my @array;
+ tie @array, 'My::Tie::Array';
+ isa_ok( tied(@array), 'My::Tie::Array' );
+
+ throws_ok {
+ $db->{foo} = \@array;
+ } qr/Cannot store a tied value/, "Cannot store tied arrays";
+}
+
+ {
+ package My::Tie::Scalar;
+
+ sub TIESCALAR {
+ my $class = shift;
+
+ return bless {
+ }, $class;
+ }
+ }
+
+ my $scalar;
+ tie $scalar, 'My::Tie::Scalar';
+ isa_ok( tied($scalar), 'My::Tie::Scalar' );
+
+throws_ok {
+ $db->{foo} = \$scalar;
+} qr/Storage of variables of type 'SCALAR' is not supported/, "Cannot store scalar references, let alone tied scalars";
projects / dbsrgits/DBM-Deep.git / commitdiff