In perl.git, the branch tonyc/127743-cperl-storable-fixes has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/aa060bea5c3eb0bee9f357e611932c8c882ce7dd?hp=3944c89c8cc00f0ae8ceb6cb84b8168524b5def7>
- Log -----------------------------------------------------------------
commit aa060bea5c3eb0bee9f357e611932c8c882ce7dd
Author: Tony Cook <t...@develop-help.com>
Date: Mon Dec 11 23:02:47 2017 +0100
(perl #25933) always rethrow exceptions thrown through or by the XS
implementation
Also, preserve any references thrown.
Such references could be thrown by STORABLE_freeze, STORABLE_thaw or
STORABLE_attach implementations.
Several of the wrappers in Storable.pm had code similar to:
eval { ... };
logcroak $@ if $@ =~ s/\.?\n$/,/;
with $@ discarded if the condition failed.
This lead to two problems:
- exceptions not ending in "\n" (which is just references without
string overloading, or with overloading but that didn't return a
string ending in "\n") would not be rethrown.
- thrown references that did happen to have overloading that returned
"\n" would be converted into strings.
This behaviour appears to have been present since the initial release
of Storable.
commit 7e1adb0ccd5ca60820a340ba0593c013220ee49d
Author: Tony Cook <t...@develop-help.com>
Date: Mon Dec 11 03:52:05 2017 +0100
fix type typo
commit 62de7af9916b2f620c3b98f839fd6a8ac9ecb5ad
Author: Tony Cook <t...@develop-help.com>
Date: Mon Dec 11 00:53:35 2017 +0100
(perl #127743) improve performance in -DDEBUGGING builds
The changes imported from cperl included a change to enable Storable's
debugging
output mechanism for -DDEBUGGING builds.
When built with debugging output, Storable's TRACEME() macro fetched
the $Storable::DEBUGME global and checked its truth, this
significantly slowed down Storable, especially noticable for dumps
with large numbers of objects.
I added a cached traceme value to the Storable context object and
modified TRACEME() to used that instead. A few TRACEME()'s that are
called before the context object is available have been replaced with
calls to TRACEMD(), a new macro that does what TRACEME() did before.
-----------------------------------------------------------------------
Summary of changes:
dist/Storable/Storable.xs | 72 +++++++++++++++++++++++++++++++++----------
dist/Storable/__Storable__.pm | 25 ++++++++++++---
dist/Storable/t/blessed.t | 61 ++++++++++++++++++++++++++++++++++--
3 files changed, 135 insertions(+), 23 deletions(-)
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 1714d5cb50..81d699b9b1 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -111,16 +111,35 @@
#endif
/*
- * TRACEME() will only output things when the $Storable::DEBUGME is true.
+ * TRACEME() will only output things when the $Storable::DEBUGME is true,
+ * using the value traceme cached in the context.
+ *
+ *
+ * TRACEMED() directly looks at the variable, for use before traceme has been
+ * updated.
*/
#define TRACEME(x) \
+ STMT_START { \
+ if (cxt->traceme) \
+ { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
+ } STMT_END
+
+#define TRACEMED(x) \
STMT_START { \
if (SvTRUE(get_sv("Storable::DEBUGME", GV_ADD))) \
{ PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
} STMT_END
+
+#define INIT_TRACEME \
+ STMT_START { \
+ cxt->traceme = SvTRUE(get_sv("Storable::DEBUGME", GV_ADD)); \
+ } STMT_END
+
#else
#define TRACEME(x)
+#define TRACEMED(x)
+#define INIT_TRACEME
#endif /* DEBUGME */
#ifdef DASSERT
@@ -403,6 +422,9 @@ typedef struct stcxt {
int in_retrieve_overloaded; /* performance hack for retrieving overloaded
objects */
int flags; /* controls whether to bless or tie objects */
U16 recur_depth; /* avoid stack overflows RT #97526 */
+#ifdef DEBUGME
+ int traceme; /* TRACEME() produces output */
+#endif
} stcxt_t;
/* Note: We dont count nested scalars. This will have to count all refs
@@ -1525,7 +1547,7 @@ static SV *mbuf2sv(pTHX);
static void init_perinterp(pTHX)
{
INIT_STCXT;
-
+ INIT_TRACEME;
cxt->netorder = 0; /* true if network order used */
cxt->forgive_me = -1; /* whether to be forgiving... */
cxt->accept_future_minor = -1; /* would otherwise occur too late */
@@ -1557,6 +1579,8 @@ static void init_store_context(pTHX_
int optype,
int network_order)
{
+ INIT_TRACEME;
+
TRACEME(("init_store_context"));
cxt->netorder = network_order;
@@ -1656,7 +1680,7 @@ static void clean_store_context(pTHX_ stcxt_t *cxt)
{
HE *he;
- TRACEME(("clean_store_context"));
+ TRACEMED(("clean_store_context"));
ASSERT(cxt->optype & ST_STORE, ("was performing a store()"));
@@ -1744,6 +1768,8 @@ static void clean_store_context(pTHX_ stcxt_t *cxt)
static void init_retrieve_context(pTHX_
stcxt_t *cxt, int optype, int is_tainted)
{
+ INIT_TRACEME;
+
TRACEME(("init_retrieve_context"));
/*
@@ -1796,7 +1822,7 @@ static void init_retrieve_context(pTHX_
*/
static void clean_retrieve_context(pTHX_ stcxt_t *cxt)
{
- TRACEME(("clean_retrieve_context"));
+ TRACEMED(("clean_retrieve_context"));
ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
@@ -1848,7 +1874,7 @@ static void clean_retrieve_context(pTHX_ stcxt_t *cxt)
*/
static void clean_context(pTHX_ stcxt_t *cxt)
{
- TRACEME(("clean_context"));
+ TRACEMED(("clean_context"));
ASSERT(cxt->s_dirty, ("dirty context"));
@@ -1878,11 +1904,11 @@ static stcxt_t *allocate_context(pTHX_ stcxt_t
*parent_cxt)
{
stcxt_t *cxt;
- TRACEME(("allocate_context"));
-
ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
NEW_STORABLE_CXT_OBJ(cxt);
+ TRACEMED(("allocate_context"));
+
cxt->prev = parent_cxt->my_sv;
SET_STCXT(cxt);
@@ -1901,7 +1927,7 @@ static void free_context(pTHX_ stcxt_t *cxt)
{
stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0);
- TRACEME(("free_context"));
+ TRACEMED(("free_context"));
ASSERT(!cxt->s_dirty, ("clean context"));
ASSERT(prev, ("not freeing root context"));
@@ -1980,7 +2006,9 @@ static SV *pkg_fetchmeth(pTHX_
GV *gv;
SV *sv;
const char *hvname = HvNAME_get(pkg);
-
+#ifdef DEBUGME
+ dSTCXT;
+#endif
/*
* The following code is the same as the one performed by UNIVERSAL::can
@@ -2053,6 +2081,9 @@ static SV *pkg_can(pTHX_
SV **svh;
SV *sv;
const char *hvname = HvNAME_get(pkg);
+#ifdef DEBUGME
+ dSTCXT;
+#endif
TRACEME(("pkg_can for %s->%s", hvname, method));
@@ -2097,6 +2128,9 @@ static SV *scalar_call(pTHX_
dSP;
int count;
SV *sv = 0;
+#ifdef DEBUGME
+ dSTCXT;
+#endif
TRACEME(("scalar_call (cloning=%d)", cloning));
@@ -2152,6 +2186,9 @@ static AV *array_call(pTHX_
int count;
AV *av;
int i;
+#ifdef DEBUGME
+ dSTCXT;
+#endif
TRACEME(("array_call (cloning=%d)", cloning));
@@ -2209,7 +2246,7 @@ cleanup_recursive_av(pTHX_ AV* av) {
static void
cleanup_recursive_hv(pTHX_ HV* hv) {
- Ssize_t i = HvTOTALKEYS(hv);
+ SSize_t i = HvTOTALKEYS(hv);
HE** arr = HvARRAY(hv);
if (SvMAGICAL(hv)) return;
while (i >= 0) {
@@ -4466,7 +4503,7 @@ static int do_store(pTHX_
ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res,
("must supply result SV pointer for real recursion to memory"));
- TRACEME(("do_store (optype=%d, netorder=%d)",
+ TRACEMED(("do_store (optype=%d, netorder=%d)",
optype, network_order));
optype |= ST_STORE;
@@ -4488,6 +4525,8 @@ static int do_store(pTHX_
if (cxt->entry)
cxt = allocate_context(aTHX_ cxt);
+ INIT_TRACEME;
+
cxt->entry++;
ASSERT(cxt->entry == 1, ("starting new recursion"));
@@ -7180,8 +7219,8 @@ static SV *do_retrieve(
int is_tainted; /* Is input source tainted? */
int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */
- TRACEME(("do_retrieve (optype = 0x%x)", optype));
- TRACEME(("do_retrieve (flags = 0x%x)", flags));
+ TRACEMED(("do_retrieve (optype = 0x%x, flags=0x%x)",
+ (unsigned)optype, (unsigned)flags));
optype |= ST_RETRIEVE;
cxt->flags = flags;
@@ -7215,6 +7254,7 @@ static SV *do_retrieve(
cxt = allocate_context(aTHX_ cxt);
cxt->flags = flags;
}
+ INIT_TRACEME;
cxt->entry++;
@@ -7409,7 +7449,7 @@ static SV *do_retrieve(
*/
static SV *pretrieve(pTHX_ PerlIO *f, IV flag)
{
- TRACEME(("pretrieve"));
+ TRACEMED(("pretrieve"));
return do_retrieve(aTHX_ f, Nullsv, 0, (int)flag);
}
@@ -7420,7 +7460,7 @@ static SV *pretrieve(pTHX_ PerlIO *f, IV flag)
*/
static SV *mretrieve(pTHX_ SV *sv, IV flag)
{
- TRACEME(("mretrieve"));
+ TRACEMED(("mretrieve"));
return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0, (int)flag);
}
@@ -7444,7 +7484,7 @@ static SV *dclone(pTHX_ SV *sv)
stcxt_t *real_context;
SV *out;
- TRACEME(("dclone"));
+ TRACEMED(("dclone"));
/*
* Workaround for CROAK leak: if they enter with a "dirty" context,
diff --git a/dist/Storable/__Storable__.pm b/dist/Storable/__Storable__.pm
index 038e7d959a..a9ad1afe31 100644
--- a/dist/Storable/__Storable__.pm
+++ b/dist/Storable/__Storable__.pm
@@ -275,7 +275,10 @@ sub _store {
if (!(close(FILE) or undef $ret) || $@) {
unlink($file) or warn "Can't unlink $file: $!\n";
}
- logcroak $@ if $@ =~ s/\.?\n$/,/;
+ if ($@) {
+ $@ =~ s/\.?\n$/,/ unless ref $@;
+ logcroak $@;
+ }
$@ = $da;
return $ret;
}
@@ -348,7 +351,10 @@ sub _freeze {
my $ret;
# Call C routine mstore or net_mstore, depending on network order
eval { $ret = &$xsptr($self) };
- logcroak $@ if $@ =~ s/\.?\n$/,/;
+ if ($@) {
+ $@ =~ s/\.?\n$/,/ unless ref $@;
+ logcroak $@;
+ }
$@ = $da;
return $ret ? $ret : undef;
}
@@ -397,7 +403,10 @@ sub _retrieve {
}
eval { $self = pretrieve($FILE, $flags) }; # Call C routine
close($FILE);
- logcroak $@ if $@ =~ s/\.?\n$/,/;
+ if ($@) {
+ $@ =~ s/\.?\n$/,/ unless ref $@;
+ logcroak $@;
+ }
$@ = $da;
return $self;
}
@@ -415,7 +424,10 @@ sub fd_retrieve {
my $self;
my $da = $@; # Could be from exception
handler
eval { $self = pretrieve($file, $flags) }; # Call C routine
- logcroak $@ if $@ =~ s/\.?\n$/,/;
+ if ($@) {
+ $@ =~ s/\.?\n$/,/ unless ref $@;
+ logcroak $@;
+ }
$@ = $da;
return $self;
}
@@ -440,7 +452,10 @@ sub thaw {
my $self;
my $da = $@; # Could be from exception
handler
eval { $self = mretrieve($frozen, $flags) };# Call C routine
- logcroak $@ if $@ =~ s/\.?\n$/,/;
+ if ($@) {
+ $@ =~ s/\.?\n$/,/ unless ref $@;
+ logcroak $@;
+ }
$@ = $da;
return $self;
}
diff --git a/dist/Storable/t/blessed.t b/dist/Storable/t/blessed.t
index b37d020fc6..d9a77b3723 100644
--- a/dist/Storable/t/blessed.t
+++ b/dist/Storable/t/blessed.t
@@ -36,7 +36,7 @@ sub BEGIN {
use Test::More;
-use Storable qw(freeze thaw store retrieve);
+use Storable qw(freeze thaw store retrieve fd_retrieve);
%::weird_refs =
(REF => \(my $aref = []),
@@ -45,7 +45,7 @@ use Storable qw(freeze thaw store retrieve);
LVALUE => \(my $substr = substr((my $str = "foo"), 0, 3)));
my $test = 13;
-my $tests = $test + 23 + (2 * 6 * keys %::immortals) + (3 * keys
%::weird_refs);
+my $tests = $test + 41 + (2 * 6 * keys %::immortals) + (3 * keys
%::weird_refs);
plan(tests => $tests);
package SHORT_NAME;
@@ -357,3 +357,60 @@ is(ref $t, 'STRESS_THE_STACK');
ok(eval {thaw($y)}, "empty serialized") or diag $@; # <-- dies here with
"Bad data"
}
+
+{
+ {
+ package FreezeHookDies;
+ sub STORABLE_freeze {
+ die ${$_[0]}
+ }
+
+ package ThawHookDies;
+ sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ my $tmp = $$self;
+ return "a", \$tmp;
+ }
+ sub STORABLE_thaw {
+ my ($self, $cloning, $str, $obj) = @_;
+ die $$obj;
+ }
+ }
+ my $x = bless \(my $tmpx = "Foo"), "FreezeHookDies";
+ my $y = bless \(my $tmpy = []), "FreezeHookDies";
+
+ ok(!eval { store($x, "store$$"); 1 }, "store of hook which throws no NL
died");
+ ok(!eval { store($y, "store$$"); 1 }, "store of hook which throws ref
died");
+
+ ok(!eval { freeze($x); 1 }, "freeze of hook which throws no NL died");
+ ok(!eval { freeze($y); 1 }, "freeze of hook which throws ref died");
+
+ ok(!eval { dclone($x); 1 }, "dclone of hook which throws no NL died");
+ ok(!eval { dclone($y); 1 }, "dclone of hook which throws ref died");
+
+ my $ostr = bless \(my $tmpstr = "Foo"), "ThawHookDies";
+ my $oref = bless \(my $tmpref = []), "ThawHookDies";
+ ok(store($ostr, "store$$"), "save throw Foo on thaw");
+ ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw Foo on thaw died");
+ open FH, "<", "store$$" or die;
+ binmode FH;
+ ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw Foo on thaw died");
+ ok(!ref $@, "right thing thrown");
+ close FH;
+ ok(store($oref, "store$$"), "save throw ref on thaw");
+ ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw ref on thaw died");
+ open FH, "<", "store$$" or die;
+ binmode FH;
+ ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw [] on thaw died");
+ ok(ref $@, "right thing thrown");
+ close FH;
+
+ my $strdata = freeze($ostr);
+ ok(!eval { thaw($strdata); 1 }, "thaw of throw Foo on thaw died");
+ ok(!ref $@, "and a string thrown");
+ my $refdata = freeze($oref);
+ ok(!eval { thaw($refdata); 1 }, "thaw of throw [] on thaw died");
+ ok(ref $@, "and a ref thrown");
+
+ unlink("store$$");
+}
--
Perl5 Master Repository
