In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/44abc0fa4ee9c5847d874ad63deb4db0d4df8aae?hp=8465c88d321256783d00b03482a840dab3ad16be>
- Log -----------------------------------------------------------------
commit 44abc0fa4ee9c5847d874ad63deb4db0d4df8aae
Author: Father Chrysostomos <spr...@cpan.org>
Date: Tue May 22 20:10:47 2012 -0700
Add Igor Zaytsev to AUTHORS
M AUTHORS
commit ecc6a8caad561b753246c15601484e230150a3b2
Author: Igor Zaytsev <igor.zayt...@gmail.com>
Date: Tue May 22 18:02:02 2012 -0700
[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.
M dist/Storable/Storable.xs
M dist/Storable/t/attach_errors.t
-----------------------------------------------------------------------
Summary of changes:
AUTHORS | 1 +
dist/Storable/Storable.xs | 12 +++++++++++-
dist/Storable/t/attach_errors.t | 37 ++++++++++++++++++++++++++++++++++++-
3 files changed, 48 insertions(+), 2 deletions(-)
diff --git a/AUTHORS b/AUTHORS
index 579a556..111f14a 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -452,6 +452,7 @@ Ian Maloney <ian.malo...@ubs.com>
Ian Phillipps <ian.philli...@iname.com>
Ignasi Roca Carrió <ignasi.r...@fujitsu-siemens.com>
Igor Sutton <i...@cpan.org>
+Igor Zaytsev <igor.zayt...@gmail.com>
Ilmari Karonen <il...@sci.fi>
Ilya Martynov <i...@martynov.org>
Ilya N. Golubev <g...@mo.msk.ru>
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 30f9281..e091e9d 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 df8a79f..c163ca0 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
--
Perl5 Master Repository
