From: rkinyon Date: Tue, 11 Apr 2006 03:01:11 +0000 (+0000) Subject: Tagged 0.983 and removed the branch X-Git-Tag: 0-983~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4fa63b60bff9e4157c4b926e6d3cd9fb3719ad81;p=dbsrgits%2FDBM-Deep.git Tagged 0.983 and removed the branch --- diff --git a/Changes b/Changes index 42090f5..4e74e3b 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,6 @@ 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 @@ -8,9 +8,7 @@ Revision history for DBM::Deep. $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 diff --git a/MANIFEST b/MANIFEST index af4e0b4..cf4cea0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -25,14 +25,14 @@ t/15_digest.t 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 diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 5452843..e1a25ef 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -36,7 +36,7 @@ use Digest::MD5 (); 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. @@ -90,7 +90,6 @@ set_digest(); 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' } @@ -206,6 +205,8 @@ sub _open { ## my $self = $_[0]->_get_self; + local($/,$\); + if (defined($self->_fh)) { $self->_close(); } my $flags = O_RDWR | O_CREAT | O_BINARY; @@ -295,6 +296,8 @@ sub _create_tag { ## my ($self, $offset, $sig, $content) = @_; my $size = length($content); + + local($/,$\); my $fh = $self->_fh; @@ -319,6 +322,8 @@ sub _load_tag { ## my $self = shift; my $offset = shift; + + local($/,$\); my $fh = $self->_fh; @@ -364,6 +369,21 @@ sub _add_bucket { 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' ) }; @@ -430,7 +450,7 @@ sub _add_bucket { } else { $actual_length = length($value); } - if ($actual_length <= $size) { + if ($actual_length <= ($size || 0)) { $location = $subloc; } else { @@ -512,11 +532,17 @@ sub _add_bucket { ## 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; @@ -603,6 +629,8 @@ sub _get_bucket_value { my ($tag, $md5) = @_; my $keys = $tag->{content}; + local($/,$\); + my $fh = $self->_fh; ## @@ -696,6 +724,8 @@ sub _delete_bucket { my ($tag, $md5) = @_; my $keys = $tag->{content}; + local($/,$\); + my $fh = $self->_fh; ## @@ -795,6 +825,8 @@ sub _traverse_index { ## my ($self, $offset, $ch, $force_return_next) = @_; $force_return_next = undef unless $force_return_next; + + local($/,$\); my $tag = $self->_load_tag( $offset ); @@ -1294,6 +1326,8 @@ sub STORE { 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])) @@ -2697,10 +2731,10 @@ B report on this module's test suite. ---------------------------- ------ ------ ------ ------ ------ ------ ------ 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 diff --git a/lib/DBM/Deep/Scalar.pm b/lib/DBM/Deep/Scalar.pm deleted file mode 100644 index 1d03e04..0000000 --- a/lib/DBM/Deep/Scalar.pm +++ /dev/null @@ -1,24 +0,0 @@ -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__ diff --git a/t/19_crossref.t b/t/19_crossref.t deleted file mode 100644 index 339c14c..0000000 --- a/t/19_crossref.t +++ /dev/null @@ -1,84 +0,0 @@ -## -# 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' ); diff --git a/t/26_scalar_ref.t b/t/26_scalar_ref.t deleted file mode 100644 index 0de6cde..0000000 --- a/t/26_scalar_ref.t +++ /dev/null @@ -1,42 +0,0 @@ -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" ); - } -} diff --git a/t/29_dash_ell.t b/t/29_dash_ell.t new file mode 100644 index 0000000..0c316ed --- /dev/null +++ b/t/29_dash_ell.t @@ -0,0 +1,23 @@ +#!/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" ); diff --git a/t/30_already_tied.t b/t/30_already_tied.t new file mode 100644 index 0000000..9d98630 --- /dev/null +++ b/t/30_already_tied.t @@ -0,0 +1,74 @@ +## +# 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";