From: rkinyon Date: Mon, 20 Mar 2006 19:13:37 +0000 (+0000) Subject: Children are now tied directly instead of copied. This makes code behave more as... X-Git-Tag: 0-99_01~53 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9d4fa373569515c80202db567b7275103bd37371;p=dbsrgits%2FDBM-Deep.git Children are now tied directly instead of copied. This makes code behave more as expected. tied variables are no longer allowed, except for purely internal references. This includes banning DBM::Deep references that aren't purely internal. --- diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index d300451..1b09bdc 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -393,6 +393,59 @@ sub add_bucket { return $result; } +sub _get_tied { + my $item = shift; + my $r = Scalar::Util::reftype( $item ) || return; + if ( $r eq 'HASH' ) { + return tied(%$item); + } + elsif ( $r eq 'ARRAY' ) { + return tied(@$item); + } + else { + return; + }; +} + +sub _get_dbm_object { + my $item = shift; + + my $obj = eval { + local $SIG{__DIE__}; + if ($item->isa( 'DBM::Deep' )) { + return $item; + } + return; + }; + return $obj if $obj; + + my $r = Scalar::Util::reftype( $item ) || ''; + if ( $r eq 'HASH' ) { + my $obj = eval { + local $SIG{__DIE__}; + my $obj = tied(%$item); + if ($obj->isa( 'DBM::Deep' )) { + return $obj; + } + return; + }; + return $obj if $obj; + } + elsif ( $r eq 'ARRAY' ) { + my $obj = eval { + local $SIG{__DIE__}; + my $obj = tied(@$item); + if ($obj->isa( 'DBM::Deep' )) { + return $obj; + } + return; + }; + return $obj if $obj; + } + + return; +} + sub write_value { my $self = shift; my ($obj, $location, $key, $value) = @_; @@ -400,12 +453,10 @@ sub write_value { my $fh = $obj->_fh; my $root = $obj->_root; - my $is_dbm_deep = eval { - local $SIG{'__DIE__'}; - $value->isa( 'DBM::Deep' ); - }; - - my $is_internal_ref = $is_dbm_deep && ($value->_root eq $root); + my $dbm_deep_obj = _get_dbm_object( $value ); + if ( $dbm_deep_obj && $dbm_deep_obj->_root ne $obj->_root ) { + $obj->_throw_error( "Cannot cross-reference. Use export() instead" ); + } seek($fh, $location + $root->{file_offset}, SEEK_SET); @@ -413,18 +464,18 @@ sub write_value { # Write signature based on content type, set content length and write # actual value. ## - my $r = Scalar::Util::reftype($value) || ''; - if ( $is_internal_ref ) { - $self->write_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $value->_base_offset) ); + my $r = Scalar::Util::reftype( $value ) || ''; + if ( $dbm_deep_obj ) { + $self->write_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $dbm_deep_obj->_base_offset) ); } elsif ($r eq 'HASH') { - if ( !$is_dbm_deep && tied %{$value} ) { + if ( !$dbm_deep_obj && tied %{$value} ) { $obj->_throw_error( "Cannot store something that is tied" ); } $self->write_tag( $obj, undef, SIG_HASH, chr(0)x$self->{index_size} ); } elsif ($r eq 'ARRAY') { - if ( !$is_dbm_deep && tied @{$value} ) { + if ( !$dbm_deep_obj && tied @{$value} ) { $obj->_throw_error( "Cannot store something that is tied" ); } $self->write_tag( $obj, undef, SIG_ARRAY, chr(0)x$self->{index_size} ); @@ -442,14 +493,14 @@ sub write_value { print( $fh pack($self->{data_pack}, length($key)) . $key ); # Internal references don't care about autobless - return 1 if $is_internal_ref; + return 1 if $dbm_deep_obj; ## # If value is blessed, preserve class name ## if ( $root->{autobless} ) { my $value_class = Scalar::Util::blessed($value); - if ( defined $value_class && !$is_dbm_deep ) { + if ( defined $value_class && !$dbm_deep_obj ) { print( $fh chr(1) ); print( $fh pack($self->{data_pack}, length($value_class)) . $value_class ); } @@ -462,23 +513,21 @@ sub write_value { # If content is a hash or array, create new child DBM::Deep object and # pass each key or element to it. ## - if ( !$is_internal_ref ) { - if ($r eq 'HASH') { - my %x = %$value; - tie %$value, 'DBM::Deep', { - base_offset => $location, - root => $root, - }; - %$value = %x; - } - elsif ($r eq 'ARRAY') { - my @x = @$value; - tie @$value, 'DBM::Deep', { - base_offset => $location, - root => $root, - }; - @$value = @x; - } + if ($r eq 'HASH') { + my %x = %$value; + tie %$value, 'DBM::Deep', { + base_offset => $location, + root => $root, + }; + %$value = %x; + } + elsif ($r eq 'ARRAY') { + my @x = @$value; + tie @$value, 'DBM::Deep', { + base_offset => $location, + root => $root, + }; + @$value = @x; } return 1; diff --git a/t/19_crossref.t b/t/19_crossref.t index 6f6120a..aa49512 100644 --- a/t/19_crossref.t +++ b/t/19_crossref.t @@ -2,7 +2,8 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 5; +use Test::More tests => 6; +use Test::Exception; use File::Temp qw( tempfile tempdir ); use Fcntl qw( :flock ); @@ -33,7 +34,10 @@ my $db2 = DBM::Deep->new( $filename2 ); ## # Cross-ref nested hash accross DB objects ## - $db2->{copy} = $db->{hash1}; + throws_ok { + $db2->{copy} = $db->{hash1}; + } qr/Cannot cross-reference\. Use export\(\) instead/, "cross-ref fails"; + $db2->{copy} = $db->{hash1}->export; } ## diff --git a/t/31_references.t b/t/31_references.t index af5fc32..2becbe2 100644 --- a/t/31_references.t +++ b/t/31_references.t @@ -2,7 +2,7 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 15; +use Test::More tests => 16; use Test::Exception; use File::Temp qw( tempfile tempdir ); use Fcntl qw( :flock ); @@ -55,3 +55,9 @@ is( $db->{array}[1][2], 9 ); $array[2]{b} = 'floober'; is( $db->{array}[2]{b}, 'floober' ); + +my %hash2 = ( abc => [ 1 .. 3 ] ); +$array[3] = \%hash2; +$hash2{ def } = \%hash; + +is( $array[3]{def}{foo}, 2 );