test and fix added for defect #34819

git-svn-id: http://svn.ali.as/cpan/trunk/DBM-Deep@3370 88f4d9cd-8a04-0410-9d60-8f63309c3137

diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index 8364128..45e7eca 100644 (file)
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -7,8 +7,8 @@ use warnings;
 
 our $VERSION = q(1.0010);
 
-use Scalar::Util ();
-
+use Scalar::Util qw(refaddr reftype);
+use Data::Dumper;
 # File-wide notes:
 # * Every method in here assumes that the storage has been appropriately
 #   safeguarded. This can be anything from flock() to some sort of manual
@@ -279,7 +279,53 @@ sub write_value {
         $class = 'DBM::Deep::Engine::Sector::Null';
     }
     elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
-        my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep' ); };
+
+    #
+    # Checking if $value is tied and getting it's underlying variable
+    #
+    my $tmpvar;
+    if ( $r eq 'ARRAY' ) {
+        $tmpvar = tied @$value;
+    } elsif ( $r eq 'HASH' ) {
+        $tmpvar = tied %$value;
+    }
+
+    #
+    # Checking if underlying variable is a DBM::Deep instance
+    #
+    my $is_ref_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
+    if ( $is_ref_dbm_deep ) {
+        #
+        # Checking if storage of destination and source variables is the same
+        #
+        if ( $tmpvar->_engine->storage == $self->storage ) {
+            #
+            # If yes - loading source sector and getting it's data reference address
+            #
+            my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
+            my $data_addr = refaddr $value_sector->data;
+            my $origin_addr;
+            #
+            # Getting destination reference address for data by key
+            #
+            if ( reftype $sector->data eq 'ARRAY' ) {
+                $origin_addr = refaddr ${$sector->data}[$key];
+            } elsif ( reftype $sector->data eq 'HASH' ) {
+                $origin_addr = refaddr ${$sector->data}{$key};
+            }
+
+            #
+            # Do nothing if reference addresses of source and destination data are same
+            #
+            if (defined $data_addr && defined $origin_addr) {
+                return 1 if ($data_addr == $origin_addr);
+            }
+        } else {
+            DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
+        }
+    }
+
+    my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $value->isa( 'DBM::Deep' ); };
         if ( $is_dbm_deep ) {
             if ( $value->_engine->storage == $self->storage ) {
                 my $value_sector = $self->_load_sector( $value->_base_offset );
@@ -317,7 +363,6 @@ sub write_value {
         data   => $value,
         type   => $type,
     });
-
     $sector->write_data({
         key     => $key,
         key_md5 => $self->_apply_digest( $key ),

diff --git a/t/47_odd_reference_behaviors.t b/t/47_odd_reference_behaviors.t
index 1157dbc..8b716f0 100644 (file)
--- a/t/47_odd_reference_behaviors.t
+++ b/t/47_odd_reference_behaviors.t
@@ -4,12 +4,31 @@ use strict;
 use warnings FATAL => 'all';
 
 use Scalar::Util qw( reftype );
-use Test::More tests => 10;
+use Test::More tests => 12;
 
 use t::common qw( new_fh );
 
 use_ok( 'DBM::Deep' );
 
+# This is bug #34819, reported by EJS
+{
+    my ($fh, $filename) = new_fh();
+    my $db = DBM::Deep->new(
+        file => $filename,
+        fh => $fh,
+    );
+
+    my $bar = bless { foo => 'bar' }, 'Foo';
+
+    eval {
+        $db->{bar} = $bar;
+        $db->{bar} = $bar;
+    };
+
+    ok(!$@, "repeated object assignment");
+    isa_ok($db->{bar}, 'Foo');
+}
+
 # This is bug #29957, reported by HANENKAMP
 TODO: {
     todo_skip "This crashes the code", 4;