From: rkinyon Date: Sat, 4 Mar 2006 03:43:32 +0000 (+0000) Subject: Added guard to make sure values that cannot be read correctly aren't stored, plus... X-Git-Tag: 0-99_01~78 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=eea0d863c52e7c02bd19be5c65f6e96b1a2db79b;p=dbsrgits%2FDBM-Deep.git Added guard to make sure values that cannot be read correctly aren't stored, plus documentation on the issue --- diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 72fb3ba..6aeaed8 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -1564,6 +1564,56 @@ As of Perl 5.8.7, this bug still exists. I have walked very carefully through the execution path, and Perl indeed passes an empty hash to the STORE() method. Probably a bug in Perl. +=head2 REFERENCES + +(The reasons given assume a high level of Perl understanding, specifically of +references. You can safely skip this section.) + +Currently, the only references supported are HASH and ARRAY. The other reference +types (SCALAR, CODE, GLOB, and REF) cannot be supported for various reasons. + +=over 4 + +=item * GLOB + +These are things like filehandles and other sockets. They can't be supported +because it's completely unclear how DBM::Deep should serialize them. + +=item * SCALAR / REF + +The discussion here refers to the following type of example: + + my $x = 25; + $db->{key1} = \$x; + + $x = 50; + + # In some other process ... + + my $val = ${ $db->{key1} }; + + is( $val, 50, "What actually gets stored in the DB file?" ); + +The problem is one of synchronization. When the variable being referred to +changes value, the reference isn't notified. This means that the new value won't +be stored in the datafile for other processes to read. There is no TIEREF. + +It is theoretically possible to store references to values already within a +DBM::Deep object because everything already is synchronized, but the change to +the internals would be quite large. Specifically, DBM::Deep would have to tie +every single value that is stored. This would bloat the RAM footprint of +DBM::Deep at least twofold (if not more) and be a significant performance drain, +all to support a feature that has never been requested. + +=item * CODE + +L provides a +mechanism for serializing coderefs, including saving off all closure state. +However, just as for SCALAR and REF, that closure state may change without +notifying the DBM::Deep object storing the reference. + +=back + =head2 FILE CORRUPTION The current level of error handling in DBM::Deep is minimal. Files I checked diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index a281395..b53b868 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -29,8 +29,8 @@ sub TIEARRAY { } sub FETCH { - my $self = $_[0]->_get_self; - my $key = $_[1]; + my $self = shift->_get_self; + my ($key) = @_; $self->lock( $self->LOCK_SH ); @@ -91,8 +91,8 @@ sub STORE { } sub EXISTS { - my $self = $_[0]->_get_self; - my $key = $_[1]; + my $self = shift->_get_self; + my ($key) = @_; $self->lock( $self->LOCK_SH ); @@ -116,8 +116,8 @@ sub EXISTS { } sub DELETE { - my $self = $_[0]->_get_self; - my $key = $_[1]; + my $self = shift->_get_self; + my ($key) = @_; my $unpacked_key = $key; @@ -175,8 +175,8 @@ sub STORESIZE { ## # Set the length of the array ## - my $self = $_[0]->_get_self; - my $new_length = $_[1]; + my $self = shift->_get_self; + my ($new_length) = @_; $self->lock( $self->LOCK_EX ); @@ -196,7 +196,7 @@ sub POP { ## # Remove and return the last element on the array ## - my $self = $_[0]->_get_self; + my $self = shift->_get_self; $self->lock( $self->LOCK_EX ); @@ -241,7 +241,7 @@ sub SHIFT { # Remove and return first element on the array. # Shift over remaining elements to take up space. ## - my $self = $_[0]->_get_self; + my $self = shift->_get_self; $self->lock( $self->LOCK_EX ); diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index 1ffb2d3..195cfab 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -270,6 +270,19 @@ sub add_bucket { my $self = shift; my ($obj, $tag, $md5, $plain_key, $value) = @_; + # 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'; + + $obj->_throw_error( + "Storage of variables of type '$r' is not supported." + ); + } + my $location = 0; my $result = 2; diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index ac6b7cd..062c8bd 100644 --- a/lib/DBM/Deep/Hash.pm +++ b/lib/DBM/Deep/Hash.pm @@ -61,7 +61,7 @@ sub FIRSTKEY { ## # Locate and return first key (in no particular order) ## - my $self = $_[0]->_get_self; + my $self = shift->_get_self; ## # Request shared lock for reading @@ -81,11 +81,11 @@ sub NEXTKEY { ## # Return next key (in no particular order), given previous one ## - my $self = $_[0]->_get_self; + my $self = shift->_get_self; my $prev_key = ($self->_root->{filter_store_key}) - ? $self->_root->{filter_store_key}->($_[1]) - : $_[1]; + ? $self->_root->{filter_store_key}->($_[0]) + : $_[0]; my $prev_md5 = $self->{engine}{digest}->($prev_key); diff --git a/lib/DBM/Deep/Ref.pm b/lib/DBM/Deep/Ref.pm index 1d03e04..6890536 100644 --- a/lib/DBM/Deep/Ref.pm +++ b/lib/DBM/Deep/Ref.pm @@ -1,4 +1,4 @@ -package DBM::Deep::Scalar; +package DBM::Deep::Ref; use strict; @@ -20,5 +20,16 @@ sub TIESCALAR { return $class->_init($args); } +sub FETCH { + my $self = shift->_get_self; + + #my $value = $self-> +} + +sub STORE { + my $self = shift->_get_self; + my ($value) = @_; +} + 1; __END__ diff --git a/t/16_circular.t b/t/16_circular.t index 1b428e2..456e1a9 100644 --- a/t/16_circular.t +++ b/t/16_circular.t @@ -2,7 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 31; +use Test::More tests => 32; use File::Temp qw( tempfile tempdir ); use_ok( 'DBM::Deep' ); @@ -69,6 +69,8 @@ is( $db->{circle}{circle}{circle}{key1}, 'value1', "The value is there in three ## $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" ); diff --git a/t/26_scalar_ref.t b/t/26_scalar_ref.t index 405c6fe..7a77c39 100644 --- a/t/26_scalar_ref.t +++ b/t/26_scalar_ref.t @@ -1,6 +1,7 @@ use strict; -use Test::More tests => 7; +use Test::More tests => 10; +use Test::Exception; use File::Temp qw( tempfile tempdir ); use_ok( 'DBM::Deep' ); @@ -8,32 +9,48 @@ use_ok( 'DBM::Deep' ); my $dir = tempdir( CLEANUP => 1 ); my ($fh, $filename) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir ); +my $x = 25; { my $db = DBM::Deep->new( $filename ); - my $x = 25; - my $y = 30; - $db->{scalar} = $x; - $db->{scalarref} = \$y; - $db->{selfref} = \$x; + throws_ok { + $db->{scalarref} = \$x; + } qr/Storage of variables of type 'SCALAR' is not supported/, + 'Storage of scalar refs not supported'; - is( $db->{scalar}, $x, "Scalar retrieved ok" ); + throws_ok { + $db->{scalarref} = \\$x; + } qr/Storage of variables of type 'REF' is not supported/, + 'Storage of ref refs not supported'; + + throws_ok { + $db->{scalarref} = sub { 1 }; + } qr/Storage of variables of type 'CODE' is not supported/, + 'Storage of code refs not supported'; + + throws_ok { + $db->{scalarref} = $db->_get_self->_fh; + } qr/Storage of variables of type 'GLOB' is not supported/, + 'Storage of glob refs not supported'; + + $db->{scalar} = $x; 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" ); + 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 $x = 25; - my $y = 30; is( $db->{scalar}, $x, "Scalar retrieved ok" ); TODO: { - todo_skip "Scalar refs aren't implemented yet", 2; + todo_skip "Refs to DBM::Deep objects aren't implemented yet", 2; is( ${$db->{scalarref}}, 30, "Scalarref retrieved ok" ); - is( ${$db->{selfref}}, 25, "Scalarref to stored scalar retrieved ok" ); + is( ${$db->{selfref}}, 26, "Scalarref to stored scalar retrieved ok" ); } }