Skip Menu |
 

Preferred bug tracker

Please visit the preferred bug tracker to report your issue.

This queue is for tickets about the Storable CPAN distribution.

Report information
The Basics
Id: 21685
Status: open
Priority: 0/
Queue: Storable

People
Owner: Nobody in particular
Requestors: terry.glanfield [...] printsoft.com
Cc:
AdminCc:

Bug Information
Severity: (no value)
Broken in: (no value)
Fixed in: (no value)



Received: from la.mx.develooper.com (x1.develooper.com [63.251.223.170]) by diesel.bestpractical.com (Postfix) with SMTP id 2DC334D810A for <bug-storable [...] rt.cpan.org>; Mon, 25 Sep 2006 05:25:51 -0400 (EDT)
Received: (qmail 12300 invoked by alias); 25 Sep 2006 09:25:50 -0000
Received: from mailgate.program-products.net (HELO mailgate.program-products.co.uk) (62.49.148.242) by la.mx.develooper.com (qpsmtpd/0.28) with ESMTP; Mon, 25 Sep 2006 02:25:46 -0700
Received: from sv2.south.ppsl (sv2.south.ppsl [10.10.10.5]) by mailgate.program-products.co.uk (8.12.8p1/8.12.8) with ESMTP id k8P9Jq9I011129 for <bug-storable [...] rt.cpan.org>; Mon, 25 Sep 2006 09:19:52 GMT (envelope-from terry [...] printsoft.com)
Received: (from root [...] localhost) by sv2.south.ppsl (8.13.1/8.13.1/Submit) id k8P9JsV0004978 for bug-storable [...] rt.cpan.org.procmail; Mon, 25 Sep 2006 10:19:54 +0100 (BST) (envelope-from terry [...] program-products.co.uk)
Received: (from terry [...] localhost) by edam.headcorn (8.13.4/8.13.4/Submit) id k8P9OX4w068957; Mon, 25 Sep 2006 10:24:33 +0100 (BST) (envelope-from terry)
Delivered-To: cpan-bug+storable [...] diesel.bestpractical.com
Subject: STORABLE_attach bug
X-Spam-Status: No, hits=2.1 required=8.0 tests=BAYES_40,DEAR_SOMETHING,FORGED_RCVD_HELO,UNPARSEABLE_RELAY
Return-Path: <terry [...] printsoft.com>
X-Spam-Check-BY: la.mx.develooper.com
X-Original-To: bug-storable [...] rt.cpan.org
Date: Mon, 25 Sep 2006 10:24:33 +0100 (BST)
Received-SPF: unknown (x1.develooper.com: error in processing during lookup of terry [...] printsoft.com)
Message-Id: <200609250924.k8P9OX4w068957 [...] edam.headcorn>
X-Virus-Scanned: by AMaViS perl-11
To: bug-Storable [...] rt.cpan.org
From: Terry Glanfield <terry.glanfield [...] printsoft.com>
X-RT-Original-Encoding: ascii
content-type: text/plain; charset="utf-8"
Content-Length: 678
Download (untitled) / with headers
text/plain 678b
Dear Sir/Madam. Here is a diff to t/attach_singleton.t that demonstrates that an object stored twice in the same structure comes back as two different objects. I believe it is not being properly cached; STORABLE_attach is only called once during the thaw process. If you also put other data in the object then only the first copy with still contain it. Regards, Terry. 26c26 < use Test::More tests => 11; --- Show quoted text
> use Test::More tests => 16;
58a59,64 Show quoted text
> > # test multiple instances > $struct = [ $object, $object ]; > $frozen = Storable::freeze( $struct ); > $thawed = Storable::thaw( $frozen ); > is( "$thawed->[0]", "$thawed->[1]", 'Multiple Singletons thaw correctly' );
X-Spam-Status: No, hits=-2.5 required=8.0 tests=BAYES_00,FORGED_RCVD_HELO,UNPARSEABLE_RELAY
In-Reply-To: "Bugs in Storable via RT"'s message of "Mon, 25 Sep 2006 05:25:56 -0400"
X-Mailer: Gnus v5.6.44/Emacs 19.34
Received-SPF: unknown (x1.develooper.com: error in processing during lookup of terry [...] printsoft.com)
References: <RT-Ticket-21685 [...] rt.cpan.org> <200609250924.k8P9OX4w068957 [...] edam.headcorn> <rt-3.6.HEAD-12305-1159176356-951.21685-3-0 [...] rt.cpan.org>
Lines: 15
Content-Type: text/plain; charset="utf-8"
X-Virus-Scanned: by AMaViS perl-11
X-RT-Original-Encoding: ascii
Received: from la.mx.develooper.com (x1.develooper.com [63.251.223.170]) by diesel.bestpractical.com (Postfix) with SMTP id 741EB4D8103 for <bug-storable [...] rt.cpan.org>; Mon, 25 Sep 2006 05:32:44 -0400 (EDT)
Received: (qmail 14667 invoked by alias); 25 Sep 2006 09:32:43 -0000
Received: from mailgate.program-products.net (HELO mailgate.program-products.co.uk) (62.49.148.242) by la.mx.develooper.com (qpsmtpd/0.28) with ESMTP; Mon, 25 Sep 2006 02:32:42 -0700
Received: from sv2.south.ppsl (sv2.south.ppsl [10.10.10.5]) by mailgate.program-products.co.uk (8.12.8p1/8.12.8) with ESMTP id k8P9Qp9I011150 for <bug-storable [...] rt.cpan.org>; Mon, 25 Sep 2006 09:26:51 GMT (envelope-from terry [...] printsoft.com)
Received: (from root [...] localhost) by sv2.south.ppsl (8.13.1/8.13.1/Submit) id k8P9Qsk3008786 for bug-storable [...] rt.cpan.org.procmail; Mon, 25 Sep 2006 10:26:54 +0100 (BST) (envelope-from terry [...] program-products.co.uk)
Received: (from terry [...] localhost) by edam.headcorn (8.13.4/8.13.4/Submit) id k8P9Vxng069111; Mon, 25 Sep 2006 10:31:59 +0100 (BST) (envelope-from terry)
Delivered-To: cpan-bug+storable [...] diesel.bestpractical.com
Subject: Re: [rt.cpan.org #21685] AutoReply: STORABLE_attach bug
Return-Path: <terry [...] printsoft.com>
X-Spam-Check-BY: la.mx.develooper.com
X-Original-To: bug-storable [...] rt.cpan.org
Date: 25 Sep 2006 10:31:59 +0100
Sender: terry [...] printsoft.com
Message-Id: <eeju02sxc.fsf [...] printsoft.com>
To: bug-Storable [...] rt.cpan.org
From: Terry Glanfield <terry.glanfield [...] printsoft.com>
X-RT-Original-Encoding: utf-8
RT-Message-ID: <rt-3.6.HEAD-12205-1159176766-966.21685-0-0 [...] rt.cpan.org>
Content-Length: 325
Download (untitled) / with headers
text/plain 325b
I ought to know better: Storable version 2.15 perl --version This is perl, v5.8.8 built for MSWin32-x86-multi-thread (with 25 registered patches, see perl -V for more detail) Copyright 1987-2006, Larry Wall Binary build 817 [257965] provided by ActiveState http://www.ActiveState.com Built Mar 20 2006 17:54:25
MIME-Version: 1.0
In-Reply-To: <200609250924.k8P9OX4w068957 [...] edam.headcorn>
X-Mailer: MIME-tools 5.426 (Entity 5.426)
Charset: utf8
References: <200609250924.k8P9OX4w068957 [...] edam.headcorn>
Message-Id: <rt-3.6.HEAD-4408-1222457941-1214.21685-0-0 [...] rt.cpan.org>
Content-Type: multipart/mixed; boundary="----------=_1222457941-4408-15"
From: talby [...] trap.mtview.ca.us
X-RT-Original-Encoding: utf-8
Content-Length: 0
Content-Disposition: inline
Content-Type: text/plain
Content-Transfer-Encoding: binary
X-RT-Original-Encoding: utf-8
Content-Length: 854
Download (untitled) / with headers
text/plain 854b
On Mon Sep 25 05:25:56 2006, terry.glanfield@printsoft.com wrote: Show quoted text
> > Here is a diff to t/attach_singleton.t that demonstrates that an > object stored twice in the same structure comes back as two different > objects. I believe it is not being properly cached; STORABLE_attach > is only called once during the thaw process. If you also put other > data in the object then only the first copy with still contain it.
This appears to be the result of the "aseen" list of previously constructed data structures built during thaw() not being updated after STORABLE_attach() is called. This is not a complete fix for this problem because it seems like there is a bootstrapping problem possible related to thawing cyclic data structures. Nevertheless, this patch resolves your testcase and makes STORABLE_attach() a lot more practical for my use patterns.
MIME-Version: 1.0
X-Mailer: MIME-tools 5.426 (Entity 5.426)
Content-Type: multipart/mixed; boundary="----------=_1222457941-4408-14"
Charset: utf8
Content-Length: 0
Content-Type: text/plain
Content-Disposition: inline
Content-Transfer-Encoding: binary
X-RT-Original-Encoding: iso-8859-1
Content-Length: 0
Content-Type: text/x-patch; name="attach_cache.diff"
Content-Disposition: inline; filename="attach_cache.diff"
Content-Transfer-Encoding: binary
Content-Length: 1532
Download attach_cache.diff
text/x-diff 1.4k
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-09-26 11:00:55.000000000 -0700 @@ -4314,8 +4314,14 @@ 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)) { + /* ugly and dangerous hack to update cache entry */ + SvREFCNT_inc(SvRV(attached)); + SV **tmp = av_fetch(cxt->aseen, cxt->tagnum - 1, 1); + SvREFCNT_dec(SvRV(*tmp)); + *tmp = SvRV(attached); return SvRV(attached); + } CROAK(("STORABLE_attach did not return a %s object", classname)); } 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-09-25 16:38:18.000000000 -0700 @@ -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 ###########
MIME-Version: 1.0
In-Reply-To: <rt-3.6.HEAD-4408-1222457941-1214.21685-0-0 [...] rt.cpan.org>
X-Mailer: MIME-tools 5.426 (Entity 5.426)
Charset: utf8
References: <200609250924.k8P9OX4w068957 [...] edam.headcorn> <rt-3.6.HEAD-4408-1222457941-1214.21685-0-0 [...] rt.cpan.org>
Message-Id: <rt-3.6.HEAD-5586-1226943412-665.21685-0-0 [...] rt.cpan.org>
Content-Type: multipart/mixed; boundary="----------=_1226943413-5586-171"
From: talby [...] trap.mtview.ca.us
X-RT-Original-Encoding: utf-8
Content-Length: 0
Content-Disposition: inline
Content-Type: text/plain
Content-Transfer-Encoding: binary
X-RT-Original-Encoding: utf-8
Content-Length: 427
Download (untitled) / with headers
text/plain 427b
I've spent more time with this problem. STORABLE_attach handling has been moved to earlier in the thaw process (to make analysis easier), some memory leaks have been addressed, and a STORABLE_freeze enhancement to support class factories was implemented. Class factories are handled by letting STORABLE_freeze select an alternate class to route STORABLE_thaw/attach calls to (though it is only practical for STORABLE_attach).
MIME-Version: 1.0
X-Mailer: MIME-tools 5.426 (Entity 5.426)
Content-Type: multipart/mixed; boundary="----------=_1226943411-5586-170"
Charset: utf8
Content-Length: 0
Content-Type: text/plain
Content-Disposition: inline
Content-Transfer-Encoding: binary
X-RT-Original-Encoding: iso-8859-1
Content-Length: 0
Content-Type: text/x-patch; name="attach_cache.diff"
Content-Disposition: inline; filename="attach_cache.diff"
Content-Transfer-Encoding: binary
Content-Length: 8790
Download attach_cache.diff
text/x-diff 8.5k
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"); +}
MIME-Version: 1.0
In-Reply-To: <rt-3.6.HEAD-5586-1226943412-665.21685-0-0 [...] rt.cpan.org>
X-Mailer: MIME-tools 5.427 (Entity 5.427)
References: <200609250924.k8P9OX4w068957 [...] edam.headcorn> <rt-3.6.HEAD-4408-1222457941-1214.21685-0-0 [...] rt.cpan.org> <rt-3.6.HEAD-5586-1226943412-665.21685-0-0 [...] rt.cpan.org>
Content-Type: multipart/mixed; boundary="----------=_1272912538-6788-68"
Message-ID: <rt-3.8.HEAD-6788-1272912537-1615.21685-0-0 [...] rt.cpan.org>
From: talby [...] trap.mtview.ca.us
X-RT-Original-Encoding: utf-8
Content-Length: 0
Content-Disposition: inline
Content-Type: text/plain; charset="UTF-8"
Content-Transfer-Encoding: binary
X-RT-Original-Encoding: utf-8
Content-Length: 242
Download (untitled) / with headers
text/plain 242b
I recently found a bug in my previous patch, a "%*s" in a printf style argument should have been a "%0.*s". It wanted to limit the maximum string width rather than force a minimum. Additionally the patch has been updated for Storable v2.21.
MIME-Version: 1.0
Subject: attach_cache-2.21.diff
X-Mailer: MIME-tools 5.427 (Entity 5.427)
Content-Type: text/x-patch; name="attach_cache-2.21.diff"
Content-Disposition: inline; filename="attach_cache-2.21.diff"
Content-Transfer-Encoding: binary
Content-Length: 8759
diff -Naur Storable-2.21.orig/ChangeLog Storable-2.21/ChangeLog --- Storable-2.21.orig/ChangeLog 2009-08-05 22:27:19.000000000 -0700 +++ Storable-2.21/ChangeLog 2010-05-03 10:46:37.000000000 -0700 @@ -1,3 +1,11 @@ +Mon May 3 10:45:13 PDT 2010 Robert Stone <talby@trap.mtview.ca.us> + + Version 2.21+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 Aug 6 10:55:50 IST 2009 Abhijit Menon-Sen <ams@toroid.org> Version 2.21 diff -Naur Storable-2.21.orig/Storable.xs Storable-2.21/Storable.xs --- Storable-2.21.orig/Storable.xs 2009-05-17 21:07:57.000000000 -0700 +++ Storable-2.21/Storable.xs 2010-05-03 10:42:23.000000000 -0700 @@ -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. */ @@ -4076,7 +4121,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'; @@ -4179,6 +4226,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)); @@ -4210,7 +4258,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; } @@ -4242,6 +4291,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, "%0.*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. */ @@ -4303,28 +4410,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.21.orig/t/attach_singleton.t Storable-2.21/t/attach_singleton.t --- Storable-2.21.orig/t/attach_singleton.t 2005-04-24 18:09:09.000000000 -0700 +++ Storable-2.21/t/attach_singleton.t 2010-05-03 10:41:54.000000000 -0700 @@ -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.21.orig/t/forwarder.t Storable-2.21/t/forwarder.t --- Storable-2.21.orig/t/forwarder.t 1969-12-31 16:00:00.000000000 -0800 +++ Storable-2.21/t/forwarder.t 2010-05-03 10:41:54.000000000 -0700 @@ -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"); +}


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.