[perl #111918] Fix thawing seen objects in STORABLE_attach hook

Before any thaw hook is called Storable creates a new blessed object that
is stored in a seen cache and then is provided to the hook. That is fine
for STORABLE_thaw which fills in this object and returns it. STORABLE_attach
on the other hand can create entirely new object by itself, so one
memoized before should be thrown out to be replaced by that new object.

2 files changed, 47 insertions, 2 deletions

diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 30f9281bb5..e091e9d3b5 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -1040,6 +1040,12 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
 static int store(pTHX_ stcxt_t *cxt, SV *sv);
 static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname);
 
+#define UNSEE()                             \
+  STMT_START {                              \
+    av_pop(cxt->aseen);                     \
+    cxt->tagnum--;                          \
+  } STMT_END
+
 /*
  * Dynamic dispatching table for SV store.
  */
@@ -4215,8 +4221,12 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
 	    attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
 	    if (attached &&
 	        SvROK(attached) && 
-	        sv_derived_from(attached, classname))
+	        sv_derived_from(attached, classname)
+        ) {
+	        UNSEE();
+	        SEEN(SvRV(attached), 0, 0);
 	        return SvRV(attached);
+        }
 	    CROAK(("STORABLE_attach did not return a %s object", classname));
 	}
 
diff --git a/dist/Storable/t/attach_errors.t b/dist/Storable/t/attach_errors.t
index df8a79fccb..c163ca04fa 100644
--- a/dist/Storable/t/attach_errors.t
+++ b/dist/Storable/t/attach_errors.t
@@ -22,7 +22,7 @@ sub BEGIN {
     }
 }
 
-use Test::More tests => 35;
+use Test::More tests => 40;
 use Storable ();
 
 
@@ -215,6 +215,41 @@ use Storable ();
 	}
 }
 
+# Good case - multiple references to the same object should be attached properly
+{
+	my $obj = bless { id => 111 }, 'My::GoodAttach::MultipleReferences';
+    my $arr = [$obj];
+
+    push @$arr, $obj;
+
+	my $frozen = Storable::freeze($arr);
+
+	ok( $frozen, 'My::GoodAttach return as expected' );
+
+	my $thawed = eval {
+		Storable::thaw( $frozen );
+	};
+
+	isa_ok( $thawed->[0], 'My::GoodAttach::MultipleReferences' );
+	isa_ok( $thawed->[1], 'My::GoodAttach::MultipleReferences' );
+
+	is($thawed->[0], $thawed->[1], 'References to the same object are attached properly');
+	is($thawed->[1]{id}, $obj->{id}, 'Object with multiple references attchached properly');
+
+    package My::GoodAttach::MultipleReferences;
+
+    sub STORABLE_freeze {
+        my ($obj) = @_;
+        $obj->{id}
+    }
+
+    sub STORABLE_attach {
+        my ($class, $cloning, $id) = @_;
+        bless { id => $id }, $class;
+    }
+
+}
+
 
 
 # Bad Cases - die on thaw