diff -Naur Storable-2.18.orig/ChangeLog Storable-2.18/ChangeLog
--- Storable-2.18.orig/ChangeLog 2007-11-21 23:59:46.000000000 -0800
+++ Storable-2.18/ChangeLog 2008-11-17 09:06:18.000000000 -0800
@@ -1,3 +1,12 @@
+Mon Nov 17 08:54:39 PST 2008 Robert Stone <talby@trap.mtview.ca.us>
+
+ Version 2.18+talby
+
+ 1. Fixes STORABLE_attach nested reference bug #21685
+ 2. Introduces class factory support (see t/forwarder.t for
+ examples)
+ 3. Mild optimizations and leak guards for STORABLE_attach
+
Thu Nov 22 13:24:18 IST 2007 Abhijit Menon-Sen <ams@toroid.org>
Version 2.18
diff -Naur Storable-2.18.orig/Storable.xs Storable-2.18/Storable.xs
--- Storable-2.18.orig/Storable.xs 2007-11-21 23:52:48.000000000 -0800
+++ Storable-2.18/Storable.xs 2008-11-17 08:53:26.000000000 -0800
@@ -2997,6 +2997,51 @@
return store_blessed(aTHX_ cxt, sv, type, pkg);
}
+ {
+ /* class factory support:
+ *
+ * if a hashref is returned in place of the
+ * serialization, it should contain a "serial" key with
+ * the traditional serialization form, and can also
+ * contain a "target" classref which Storable will route
+ * thaw/attach hooks to.
+ *
+ * sub STORABLE_freeze {
+ * my($self) = @_;
+ * return {
+ * target => "MyClassFactory::Deserializer",
+ * serial => $self->toString,
+ * };
+ * }
+ *
+ * This facilitates Storable interoperating with class
+ * factories. Probably this is far more useful with
+ * _attach hooks than _thaw calls.
+ */
+ SV **first = av_fetch(av, 0, 0);
+ if (SvROK(*first) && !sv_isobject(*first)) {
+ HV *inner = (HV *)SvRV(*first);
+ if (SvTYPE(inner) == SVt_PVHV) {
+ const char *target = "target";
+ const char *serial = "serial";
+ SV **class = hv_fetch(inner,
+ target, strlen(target), 0);
+ SV **str = hv_fetch(inner,
+ serial, strlen(serial), 0);
+ if (!str) CROAK(("serial key required"));
+ if (class) {
+ pkg = gv_stashsv(*class, 0);
+ if(!pkg) CROAK(("thaw target %s"
+ " must be loaded",
+ SvPV_nolen(*class)));
+ classname = HvNAME_get(pkg);
+ len = strlen(classname);
+ }
+ av_store(av, 0, SvREFCNT_inc(*str));
+ }
+ }
+ }
+
/*
* Get frozen string.
*/
@@ -4070,7 +4115,9 @@
SV *hook;
SV *sv;
SV *rv;
- GV *attach;
+ GV *attach = NULL;
+ SV *class;
+ HV *stash;
int obj_type;
int clone = cxt->optype & ST_CLONE;
char mtype = '\0';
@@ -4173,6 +4220,7 @@
CROAK(("Class name #%"IVdf" should have been seen already",
(IV) idx));
+ class = *sva;
classname = SvPVX(*sva); /* We know it's a PV, by construction */
TRACEME(("class ID %d => %s", idx, classname));
@@ -4204,7 +4252,8 @@
* Record new classname.
*/
- if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) {
+ class = newSVpvn(classname, len);
+ if (!av_store(cxt->aclass, cxt->classnum++, class)) {
Safefree(malloced_classname);
return (SV *) 0;
}
@@ -4236,6 +4285,64 @@
TRACEME(("frozen string: %d bytes", len2));
+ /* Have enough to drop out if this is an _attach call; again
+ * can't use pkg_can because it only caches one method */
+ stash = gv_stashsv(class, FALSE);
+ if (stash) attach = gv_fetchmethod_autoload(
+ stash, "STORABLE_attach", FALSE);
+ if (!attach) {
+ /* would a 'require' help? check for $INC{class}. To
+ * do this one must convert package name to filename
+ * (s/::/\//sg; s/$/.pm/s;) */
+ STRLEN len;
+ char *cur = SvPV(class, len);
+ char *hunk;
+ SV *k = newSV(len + 3);
+ sv_setpv(k, "");
+ while ((hunk = strstr(cur, "::")) != NULL) {
+ sv_catpvf(k, "%*s/", hunk - cur, cur);
+ cur = hunk + 2;
+ }
+ sv_catpv(k, cur);
+ sv_catpv(k, ".pm");
+ HV *inc = get_hv("INC", 0);
+ if (!hv_exists_ent(inc, k, 0)) {
+ require_pv(SvPV_nolen(k));
+ stash = gv_stashsv(class, FALSE);
+ if (stash) attach = gv_fetchmethod_autoload(
+ stash, "STORABLE_attach", FALSE);
+ }
+ SvREFCNT_dec(k);
+ }
+ if (attach && isGV(attach)) {
+ SV *res;
+ SV* attached;
+ SV* attach_hook;
+
+ if (flags & SHF_HAS_LIST) CROAK(("STORABLE_attach "
+ "called with unexpected references"));
+ attach_hook = newRV((SV*) GvCV(attach));
+ av = av_make(1, &frozen);
+ attached = scalar_call(aTHX_ class, attach_hook, clone,
+ av, G_SCALAR);
+ /* attached is already mortal */
+ av_undef(av);
+ SvREFCNT_dec(attach_hook);
+ if (!(attached && SvROK(attached) &&
+ sv_derived_from(attached, classname)))
+ CROAK(("STORABLE_attach did not return a "
+ "%s object", classname));
+ res = SvRV(attached);
+ av_delete(cxt->aseen, cxt->tagnum - 1, G_DISCARD);
+ av_store(cxt->aseen, cxt->tagnum - 1,
+ SvREFCNT_inc(res));
+
+ SvREFCNT_dec(frozen);
+ if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
+ Safefree(classname);
+ return res;
+ }
+
/*
* Decode object-ID list length, if present.
*/
@@ -4297,28 +4404,6 @@
BLESS(sv, classname);
- /* Handle attach case; again can't use pkg_can because it only
- * caches one method */
- attach = gv_fetchmethod_autoload(SvSTASH(sv), "STORABLE_attach", FALSE);
- if (attach && isGV(attach)) {
- SV* attached;
- SV* attach_hook = newRV((SV*) GvCV(attach));
-
- if (av)
- CROAK(("STORABLE_attach called with unexpected references"));
- av = newAV();
- av_extend(av, 1);
- AvFILLp(av) = 0;
- AvARRAY(av)[0] = SvREFCNT_inc(frozen);
- rv = newSVpv(classname, 0);
- attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
- if (attached &&
- SvROK(attached) &&
- sv_derived_from(attached, classname))
- return SvRV(attached);
- CROAK(("STORABLE_attach did not return a %s object", classname));
- }
-
hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
if (!hook) {
/*
diff -Naur Storable-2.18.orig/t/attach_singleton.t Storable-2.18/t/attach_singleton.t
--- Storable-2.18.orig/t/attach_singleton.t 2005-04-24 18:09:09.000000000 -0700
+++ Storable-2.18/t/attach_singleton.t 2008-11-17 08:53:26.000000000 -0800
@@ -23,7 +23,7 @@
}
}
-use Test::More tests => 11;
+use Test::More tests => 16;
use Storable ();
# Get the singleton
@@ -57,6 +57,11 @@
$struct->[1]->{value} = 'Goodbye cruel world!';
is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' );
+$struct = [ $object, $object ];
+$frozen = Storable::freeze($struct);
+$thawed = Storable::thaw($frozen);
+is("$thawed->[0]", "$thawed->[1]", "Multiple Singletons thaw correctly");
+
# End Tests
###########
diff -Naur Storable-2.18.orig/t/forwarder.t Storable-2.18/t/forwarder.t
--- Storable-2.18.orig/t/forwarder.t 1969-12-31 16:00:00.000000000 -0800
+++ Storable-2.18/t/forwarder.t 2008-11-17 08:53:26.000000000 -0800
@@ -0,0 +1,65 @@
+use strict;
+use warnings;
+use Test::More tests => 9;
+
+BEGIN { use_ok('Storable') }
+require_ok('Storable');
+
+{
+ package MyClassFactory;
+ sub new { my($class, $name) = @_;
+ my $tclass = "${class}::${name}";
+ return $tclass if UNIVERSAL::can($tclass, 'name');
+ eval qq(
+ package $tclass;
+ use base 'MyClassFactory';
+ sub name { '$name' }
+ sub new { bless { value => \$_[1] }, \$_[0] }
+ sub value { \$_[0]->{'value'} }
+ sub things { \$_[0]->value . ", " . \$_[0]->SUPER::things }
+ );
+ return $tclass;
+ }
+ sub stuff { __PACKAGE__ }
+ sub things { "they are delicious" }
+ sub STORABLE_freeze { my($self, $cloning) = @_;
+ die "only instances supported" unless ref $self and $self->{'value'};
+ # the instance class should route thaw calls back to the factory
+ return {
+ target => __PACKAGE__,
+ serial => $self->name . "\a" . $self->value,
+ };
+ }
+ sub STORABLE_attach { my($class, $cloning, $str) = @_;
+ my($name, $value) = split /\a/, $str;
+ return $class->new($name)->new($value);
+ }
+}
+
+my $c = MyClassFactory->new("quip");
+is($c, "MyClassFactory::quip", 'factory works');
+my $o = $c->new("I like children");
+isa_ok($o, $c);
+my $p = Storable::freeze($o);
+my $q = Storable::thaw($p);
+
+isa_ok($q, $c);
+is($q->things(), "I like children, they are delicious", "method works");
+is_deeply($q, $o, "dclone matches");
+
+{
+ # manipulating the serialized forms of strings is not part of the
+ # API proper, but I am trying to test that a class this interpreter
+ # hasn't yet touched will be properly constructed by the factory as
+ # a result of the STORABLE_attach() call.
+ #
+ # If the opaque serialization format is changed (such as the
+ # addition of a compression layer), this test will need work.
+
+ my $evil = $p;
+ $evil =~ s/quip/blat/;
+ $evil =~ s/like/love/;
+ my $r = Storable::thaw($evil);
+ isa_ok($r, "MyClassFactory::blat");
+ is($r->things(), "I love children, they are delicious", "method works");
+}
