Compare commits
4 Commits
Author | SHA1 | Date |
---|---|---|
Petr Písař | 539842d610 | |
Petr Písař | c1517c8a01 | |
Petr Písař | 74534d920a | |
Petr Písař | ce32964da6 |
|
@ -5,3 +5,4 @@
|
||||||
/Storable-3.09.tar.gz
|
/Storable-3.09.tar.gz
|
||||||
/Storable-3.11.tar.gz
|
/Storable-3.11.tar.gz
|
||||||
/Storable-3.11_repackaged.tar.gz
|
/Storable-3.11_repackaged.tar.gz
|
||||||
|
/Storable-3.15.tar.gz
|
||||||
|
|
|
@ -0,0 +1,92 @@
|
||||||
|
From 16f2ddb794883529d5a3ad8326974a07aae7e567 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 10 Jun 2019 10:17:20 +1000
|
||||||
|
Subject: [PATCH] (perl #134179) include regexps in the seen objects table on
|
||||||
|
retrieve
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Also, bless the regexp object, so freezing/thawing bless qr//, "Foo"
|
||||||
|
returns a "Foo" blesses regexp.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Storable/Storable.xs | 5 +++--
|
||||||
|
dist/Storable/t/regexp.t | 4 +++-
|
||||||
|
dist/Storable/t/weak.t | 10 +++++++++-
|
||||||
|
3 files changed, 15 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
|
||||||
|
index ed729c94a6..6a45d8adf2 100644
|
||||||
|
--- a/dist/Storable/Storable.xs
|
||||||
|
+++ b/dist/Storable/Storable.xs
|
||||||
|
@@ -6808,8 +6808,7 @@ static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) {
|
||||||
|
SV *sv;
|
||||||
|
dSP;
|
||||||
|
I32 count;
|
||||||
|
-
|
||||||
|
- PERL_UNUSED_ARG(cname);
|
||||||
|
+ HV *stash;
|
||||||
|
|
||||||
|
ENTER;
|
||||||
|
SAVETMPS;
|
||||||
|
@@ -6857,6 +6856,8 @@ static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) {
|
||||||
|
|
||||||
|
sv = SvRV(re_ref);
|
||||||
|
SvREFCNT_inc(sv);
|
||||||
|
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
|
||||||
|
+ SEEN_NN(sv, stash, 0);
|
||||||
|
|
||||||
|
FREETMPS;
|
||||||
|
LEAVE;
|
||||||
|
diff --git a/dist/Storable/t/regexp.t b/dist/Storable/t/regexp.t
|
||||||
|
index acf28cfec6..e7c6c7e94a 100644
|
||||||
|
--- a/dist/Storable/t/regexp.t
|
||||||
|
+++ b/dist/Storable/t/regexp.t
|
||||||
|
@@ -37,7 +37,7 @@ while (<DATA>) {
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 9 + 3*scalar(@tests);
|
||||||
|
+plan tests => 10 + 3*scalar(@tests);
|
||||||
|
|
||||||
|
SKIP:
|
||||||
|
{
|
||||||
|
@@ -75,6 +75,8 @@ SKIP:
|
||||||
|
ok(!eval { dclone($re) }, "should fail to clone, even with use re 'eval'");
|
||||||
|
}
|
||||||
|
|
||||||
|
+is(ref(dclone(bless qr//, "Foo")), "Foo", "check reblessed regexps");
|
||||||
|
+
|
||||||
|
for my $test (@tests) {
|
||||||
|
my ($code, $not, $match, $matchc, $name) = @$test;
|
||||||
|
my $qr = eval $code;
|
||||||
|
diff --git a/dist/Storable/t/weak.t b/dist/Storable/t/weak.t
|
||||||
|
index 220c70160f..48752fbec4 100644
|
||||||
|
--- a/dist/Storable/t/weak.t
|
||||||
|
+++ b/dist/Storable/t/weak.t
|
||||||
|
@@ -29,7 +29,7 @@ sub BEGIN {
|
||||||
|
}
|
||||||
|
|
||||||
|
use Test::More 'no_plan';
|
||||||
|
-use Storable qw (store retrieve freeze thaw nstore nfreeze);
|
||||||
|
+use Storable qw (store retrieve freeze thaw nstore nfreeze dclone);
|
||||||
|
require 'testlib.pl';
|
||||||
|
our $file;
|
||||||
|
use strict;
|
||||||
|
@@ -143,3 +143,11 @@ foreach (@tests) {
|
||||||
|
$stored = nfreeze $input;
|
||||||
|
tester($stored, \&freeze_and_thaw, $testsub, 'network string');
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+{
|
||||||
|
+ # [perl #134179] sv_upgrade from type 7 down to type 1
|
||||||
|
+ my $foo = [qr//,[]];
|
||||||
|
+ weaken($foo->[1][0][0] = $foo->[1]);
|
||||||
|
+ my $out = dclone($foo); # croaked here
|
||||||
|
+ is_deeply($out, $foo, "check they match");
|
||||||
|
+}
|
||||||
|
--
|
||||||
|
2.20.1
|
||||||
|
|
|
@ -0,0 +1,53 @@
|
||||||
|
From f7724052d1b8b75339f5ec2cc3d5b35ca5d130b5 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed, 7 Aug 2019 11:13:53 +1000
|
||||||
|
Subject: [PATCH] Storable: make count large enough
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
AvARRAY() could be very large, and we check for that at line 3807,
|
||||||
|
but int was (potentially) too small to make that comparison
|
||||||
|
meaningful.
|
||||||
|
|
||||||
|
CID 174681.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Storable/Storable.xs | 6 +++---
|
||||||
|
1 file changed, 3 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
|
||||||
|
index 6a45d8adf2..d75125b839 100644
|
||||||
|
--- a/dist/Storable/Storable.xs
|
||||||
|
+++ b/dist/Storable/Storable.xs
|
||||||
|
@@ -3662,7 +3662,7 @@ static int store_hook(
|
||||||
|
SV *ref;
|
||||||
|
AV *av;
|
||||||
|
SV **ary;
|
||||||
|
- int count; /* really len3 + 1 */
|
||||||
|
+ IV count; /* really len3 + 1 */
|
||||||
|
unsigned char flags;
|
||||||
|
char *pv;
|
||||||
|
int i;
|
||||||
|
@@ -3752,7 +3752,7 @@ static int store_hook(
|
||||||
|
SvREFCNT_dec(ref); /* Reclaim temporary reference */
|
||||||
|
|
||||||
|
count = AvFILLp(av) + 1;
|
||||||
|
- TRACEME(("store_hook, array holds %d items", count));
|
||||||
|
+ TRACEME(("store_hook, array holds %" IVdf " items", count));
|
||||||
|
|
||||||
|
/*
|
||||||
|
* If they return an empty list, it means they wish to ignore the
|
||||||
|
@@ -3986,7 +3986,7 @@ static int store_hook(
|
||||||
|
*/
|
||||||
|
|
||||||
|
TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
|
||||||
|
- "class=%" IVdf " len=%" IVdf " len2=%" IVdf " len3=%d",
|
||||||
|
+ "class=%" IVdf " len=%" IVdf " len2=%" IVdf " len3=%" IVdf,
|
||||||
|
recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
|
||||||
|
|
||||||
|
/* SX_HOOK <flags> [<extra>] */
|
||||||
|
--
|
||||||
|
2.20.1
|
||||||
|
|
|
@ -1,295 +0,0 @@
|
||||||
From 120060c86e233cb9f588314214137f3ed1b48e2a Mon Sep 17 00:00:00 2001
|
|
||||||
From: Tony Cook <tony@develop-help.com>
|
|
||||||
Date: Tue, 7 Aug 2018 15:34:06 +1000
|
|
||||||
Subject: [PATCH] (perl #133326) fix and clarify handling of recurs_sv.
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
There were a few problems:
|
|
||||||
|
|
||||||
- the purpose of recur_sv wasn't clear, I believe I understand it
|
|
||||||
now from looking at where recur_sv was actually being used.
|
|
||||||
Frankly the logic of the code itself was hard to follow, apparently
|
|
||||||
only counting a level if the recur_sv was equal to the current
|
|
||||||
SV.
|
|
||||||
|
|
||||||
Fixed by adding some documentation to recur_sv in the context
|
|
||||||
structure. The logic has been re-worked (see below) to hopefully
|
|
||||||
make it more understandable.
|
|
||||||
|
|
||||||
- the conditional checks for inc/decrementing recur_depth didn't
|
|
||||||
match between the beginnings and ends of the store_array() and
|
|
||||||
store_hash() handlers didn't match, since recur_sv was both
|
|
||||||
explicitly modified by those functions and implicitly modified
|
|
||||||
in their recursive calls to process elements.
|
|
||||||
|
|
||||||
Fixing by storing the starting value of cxt->recur_sv locally
|
|
||||||
testing against that instead of against the value that might be
|
|
||||||
modified recursively.
|
|
||||||
|
|
||||||
- the checks in store_ref(), store_array(), store_l?hash() were
|
|
||||||
over complex, obscuring their purpose.
|
|
||||||
|
|
||||||
Fixed by:
|
|
||||||
- always count a recursion level in store_ref() and store the
|
|
||||||
RV in recur_sv
|
|
||||||
- only count a recursion level in the array/hash handlers if
|
|
||||||
the SV didn't match.
|
|
||||||
- skip the check against cxt->entry, if we're in this code
|
|
||||||
we could be recursing, so we want to detect it.
|
|
||||||
|
|
||||||
- (after the other changes) the recursion checks in store_hash()/
|
|
||||||
store_lhash() only checked the limit if the SV didn't match the
|
|
||||||
recur_sv, which horribly broke things.
|
|
||||||
|
|
||||||
Fixed by:
|
|
||||||
- Now only make the depth increment conditional, and always
|
|
||||||
check against the limit if one is set.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
dist/Storable/Storable.xs | 98 ++++++++++++++++++++++++++++++-----------------
|
|
||||||
dist/Storable/t/recurse.t | 16 +++++++-
|
|
||||||
2 files changed, 77 insertions(+), 37 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
|
|
||||||
index 6a90e24814..f6df32b121 100644
|
|
||||||
--- a/dist/Storable/Storable.xs
|
|
||||||
+++ b/dist/Storable/Storable.xs
|
|
||||||
@@ -418,6 +418,24 @@ typedef struct stcxt {
|
|
||||||
SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */
|
|
||||||
SV *prev; /* contexts chained backwards in real recursion */
|
|
||||||
SV *my_sv; /* the blessed scalar who's SvPVX() I am */
|
|
||||||
+
|
|
||||||
+ /* recur_sv:
|
|
||||||
+
|
|
||||||
+ A hashref of hashrefs or arrayref of arrayrefs is actually a
|
|
||||||
+ chain of four SVs, eg for an array ref containing an array ref:
|
|
||||||
+
|
|
||||||
+ RV -> AV (element) -> RV -> AV
|
|
||||||
+
|
|
||||||
+ To make this depth appear natural from a perl level we only
|
|
||||||
+ want to count this as two levels, so store_ref() stores it's RV
|
|
||||||
+ into recur_sv and store_array()/store_hash() will only count
|
|
||||||
+ that level if the AV/HV *isn't* recur_sv.
|
|
||||||
+
|
|
||||||
+ We can't just have store_hash()/store_array() not count that
|
|
||||||
+ level, since it's possible for XS code to store an AV or HV
|
|
||||||
+ directly as an element (though perl code trying to access such
|
|
||||||
+ an object will generally croak.)
|
|
||||||
+ */
|
|
||||||
SV *recur_sv; /* check only one recursive SV */
|
|
||||||
int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */
|
|
||||||
int flags; /* controls whether to bless or tie objects */
|
|
||||||
@@ -431,8 +449,13 @@ typedef struct stcxt {
|
|
||||||
|
|
||||||
#define RECURSION_TOO_DEEP() \
|
|
||||||
(cxt->max_recur_depth != -1 && ++cxt->recur_depth > cxt->max_recur_depth)
|
|
||||||
+
|
|
||||||
+/* There's cases where we need to check whether the hash recursion
|
|
||||||
+ limit has been reached without bumping the recursion levels, so the
|
|
||||||
+ hash check doesn't bump the depth.
|
|
||||||
+*/
|
|
||||||
#define RECURSION_TOO_DEEP_HASH() \
|
|
||||||
- (cxt->max_recur_depth_hash != -1 && ++cxt->recur_depth > cxt->max_recur_depth_hash)
|
|
||||||
+ (cxt->max_recur_depth_hash != -1 && cxt->recur_depth > cxt->max_recur_depth_hash)
|
|
||||||
#define MAX_DEPTH_ERROR "Max. recursion depth with nested structures exceeded"
|
|
||||||
|
|
||||||
static int storable_free(pTHX_ SV *sv, MAGIC* mg);
|
|
||||||
@@ -2360,21 +2383,20 @@ static int store_ref(pTHX_ stcxt_t *cxt, SV *sv)
|
|
||||||
} else
|
|
||||||
PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
|
|
||||||
|
|
||||||
- TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
|
|
||||||
- PTR2UV(cxt->recur_sv)));
|
|
||||||
- if (cxt->entry && cxt->recur_sv == sv) {
|
|
||||||
- if (RECURSION_TOO_DEEP()) {
|
|
||||||
+ cxt->recur_sv = sv;
|
|
||||||
+
|
|
||||||
+ TRACEME((">ref recur_depth %" IVdf ", recur_sv (0x%" UVxf ") max %" IVdf, cxt->recur_depth,
|
|
||||||
+ PTR2UV(cxt->recur_sv), cxt->max_recur_depth));
|
|
||||||
+ if (RECURSION_TOO_DEEP()) {
|
|
||||||
#if PERL_VERSION < 15
|
|
||||||
- cleanup_recursive_data(aTHX_ (SV*)sv);
|
|
||||||
+ cleanup_recursive_data(aTHX_ (SV*)sv);
|
|
||||||
#endif
|
|
||||||
- CROAK((MAX_DEPTH_ERROR));
|
|
||||||
- }
|
|
||||||
+ CROAK((MAX_DEPTH_ERROR));
|
|
||||||
}
|
|
||||||
- cxt->recur_sv = sv;
|
|
||||||
|
|
||||||
retval = store(aTHX_ cxt, sv);
|
|
||||||
- if (cxt->entry && cxt->recur_sv == sv && cxt->recur_depth > 0) {
|
|
||||||
- TRACEME(("recur_depth --%" IVdf, cxt->recur_depth));
|
|
||||||
+ if (cxt->max_recur_depth != -1 && cxt->recur_depth > 0) {
|
|
||||||
+ TRACEME(("<ref recur_depth --%" IVdf, cxt->recur_depth));
|
|
||||||
--cxt->recur_depth;
|
|
||||||
}
|
|
||||||
return retval;
|
|
||||||
@@ -2635,6 +2657,7 @@ static int store_array(pTHX_ stcxt_t *cxt, AV *av)
|
|
||||||
UV len = av_len(av) + 1;
|
|
||||||
UV i;
|
|
||||||
int ret;
|
|
||||||
+ SV *const recur_sv = cxt->recur_sv;
|
|
||||||
|
|
||||||
TRACEME(("store_array (0x%" UVxf ")", PTR2UV(av)));
|
|
||||||
|
|
||||||
@@ -2659,9 +2682,9 @@ static int store_array(pTHX_ stcxt_t *cxt, AV *av)
|
|
||||||
TRACEME(("size = %d", (int)l));
|
|
||||||
}
|
|
||||||
|
|
||||||
- TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
|
|
||||||
- PTR2UV(cxt->recur_sv)));
|
|
||||||
- if (cxt->entry && cxt->recur_sv == (SV*)av) {
|
|
||||||
+ TRACEME((">array recur_depth %" IVdf ", recur_sv (0x%" UVxf ") max %" IVdf, cxt->recur_depth,
|
|
||||||
+ PTR2UV(cxt->recur_sv), cxt->max_recur_depth));
|
|
||||||
+ if (recur_sv != (SV*)av) {
|
|
||||||
if (RECURSION_TOO_DEEP()) {
|
|
||||||
/* with <= 5.14 it recurses in the cleanup also, needing 2x stack size */
|
|
||||||
#if PERL_VERSION < 15
|
|
||||||
@@ -2670,7 +2693,6 @@ static int store_array(pTHX_ stcxt_t *cxt, AV *av)
|
|
||||||
CROAK((MAX_DEPTH_ERROR));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
- cxt->recur_sv = (SV*)av;
|
|
||||||
|
|
||||||
/*
|
|
||||||
* Now store each item recursively.
|
|
||||||
@@ -2701,9 +2723,12 @@ static int store_array(pTHX_ stcxt_t *cxt, AV *av)
|
|
||||||
return ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
- if (cxt->entry && cxt->recur_sv == (SV*)av && cxt->recur_depth > 0) {
|
|
||||||
- TRACEME(("recur_depth --%" IVdf, cxt->recur_depth));
|
|
||||||
- --cxt->recur_depth;
|
|
||||||
+ if (recur_sv != (SV*)av) {
|
|
||||||
+ assert(cxt->max_recur_depth == -1 || cxt->recur_depth > 0);
|
|
||||||
+ if (cxt->max_recur_depth != -1 && cxt->recur_depth > 0) {
|
|
||||||
+ TRACEME(("<array recur_depth --%" IVdf, cxt->recur_depth));
|
|
||||||
+ --cxt->recur_depth;
|
|
||||||
+ }
|
|
||||||
}
|
|
||||||
TRACEME(("ok (array)"));
|
|
||||||
|
|
||||||
@@ -2766,6 +2791,7 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
|
|
||||||
#endif
|
|
||||||
) ? 1 : 0);
|
|
||||||
unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
|
|
||||||
+ SV * const recur_sv = cxt->recur_sv;
|
|
||||||
|
|
||||||
/*
|
|
||||||
* Signal hash by emitting SX_HASH, followed by the table length.
|
|
||||||
@@ -2817,17 +2843,17 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
|
|
||||||
TRACEME(("size = %d, used = %d", (int)l, (int)HvUSEDKEYS(hv)));
|
|
||||||
}
|
|
||||||
|
|
||||||
- TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
|
|
||||||
- PTR2UV(cxt->recur_sv)));
|
|
||||||
- if (cxt->entry && cxt->recur_sv == (SV*)hv) {
|
|
||||||
- if (RECURSION_TOO_DEEP_HASH()) {
|
|
||||||
+ TRACEME((">hash recur_depth %" IVdf ", recur_sv (0x%" UVxf ") max %" IVdf, cxt->recur_depth,
|
|
||||||
+ PTR2UV(cxt->recur_sv), cxt->max_recur_depth_hash));
|
|
||||||
+ if (recur_sv != (SV*)hv && cxt->max_recur_depth_hash != -1) {
|
|
||||||
+ ++cxt->recur_depth;
|
|
||||||
+ }
|
|
||||||
+ if (RECURSION_TOO_DEEP_HASH()) {
|
|
||||||
#if PERL_VERSION < 15
|
|
||||||
- cleanup_recursive_data(aTHX_ (SV*)hv);
|
|
||||||
+ cleanup_recursive_data(aTHX_ (SV*)hv);
|
|
||||||
#endif
|
|
||||||
- CROAK((MAX_DEPTH_ERROR));
|
|
||||||
- }
|
|
||||||
+ CROAK((MAX_DEPTH_ERROR));
|
|
||||||
}
|
|
||||||
- cxt->recur_sv = (SV*)hv;
|
|
||||||
|
|
||||||
/*
|
|
||||||
* Save possible iteration state via each() on that table.
|
|
||||||
@@ -3107,8 +3133,9 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
|
|
||||||
TRACEME(("ok (hash 0x%" UVxf ")", PTR2UV(hv)));
|
|
||||||
|
|
||||||
out:
|
|
||||||
- if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) {
|
|
||||||
- TRACEME(("recur_depth --%" IVdf , cxt->recur_depth));
|
|
||||||
+ assert(cxt->max_recur_depth_hash != -1 && cxt->recur_depth > 0);
|
|
||||||
+ TRACEME(("<hash recur_depth --%" IVdf , cxt->recur_depth));
|
|
||||||
+ if (cxt->max_recur_depth_hash != -1 && recur_sv != (SV*)hv && cxt->recur_depth > 0) {
|
|
||||||
--cxt->recur_depth;
|
|
||||||
}
|
|
||||||
HvRITER_set(hv, riter); /* Restore hash iterator state */
|
|
||||||
@@ -3221,6 +3248,7 @@ static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags)
|
|
||||||
#ifdef DEBUGME
|
|
||||||
UV len = (UV)HvTOTALKEYS(hv);
|
|
||||||
#endif
|
|
||||||
+ SV * const recur_sv = cxt->recur_sv;
|
|
||||||
if (hash_flags) {
|
|
||||||
TRACEME(("store_lhash (0x%" UVxf ") (flags %x)", PTR2UV(hv),
|
|
||||||
(int) hash_flags));
|
|
||||||
@@ -3231,15 +3259,15 @@ static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags)
|
|
||||||
|
|
||||||
TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
|
|
||||||
PTR2UV(cxt->recur_sv)));
|
|
||||||
- if (cxt->entry && cxt->recur_sv == (SV*)hv) {
|
|
||||||
- if (RECURSION_TOO_DEEP_HASH()) {
|
|
||||||
+ if (recur_sv != (SV*)hv && cxt->max_recur_depth_hash != -1) {
|
|
||||||
+ ++cxt->recur_depth;
|
|
||||||
+ }
|
|
||||||
+ if (RECURSION_TOO_DEEP_HASH()) {
|
|
||||||
#if PERL_VERSION < 15
|
|
||||||
- cleanup_recursive_data(aTHX_ (SV*)hv);
|
|
||||||
+ cleanup_recursive_data(aTHX_ (SV*)hv);
|
|
||||||
#endif
|
|
||||||
- CROAK((MAX_DEPTH_ERROR));
|
|
||||||
- }
|
|
||||||
+ CROAK((MAX_DEPTH_ERROR));
|
|
||||||
}
|
|
||||||
- cxt->recur_sv = (SV*)hv;
|
|
||||||
|
|
||||||
array = HvARRAY(hv);
|
|
||||||
for (i = 0; i <= (Size_t)HvMAX(hv); i++) {
|
|
||||||
@@ -3252,7 +3280,7 @@ static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags)
|
|
||||||
return ret;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
- if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) {
|
|
||||||
+ if (recur_sv == (SV*)hv && cxt->max_recur_depth_hash != -1 && cxt->recur_depth > 0) {
|
|
||||||
TRACEME(("recur_depth --%" IVdf, cxt->recur_depth));
|
|
||||||
--cxt->recur_depth;
|
|
||||||
}
|
|
||||||
diff --git a/dist/Storable/t/recurse.t b/dist/Storable/t/recurse.t
|
|
||||||
index fa8be0b374..63fde90fdf 100644
|
|
||||||
--- a/dist/Storable/t/recurse.t
|
|
||||||
+++ b/dist/Storable/t/recurse.t
|
|
||||||
@@ -20,7 +20,7 @@ use Storable qw(freeze thaw dclone);
|
|
||||||
|
|
||||||
$Storable::flags = Storable::FLAGS_COMPAT;
|
|
||||||
|
|
||||||
-use Test::More tests => 38;
|
|
||||||
+use Test::More tests => 39;
|
|
||||||
|
|
||||||
package OBJ_REAL;
|
|
||||||
|
|
||||||
@@ -364,5 +364,17 @@ else {
|
|
||||||
dclone $t;
|
|
||||||
};
|
|
||||||
like $@, qr/Max\. recursion depth with nested structures exceeded/,
|
|
||||||
- 'Caught href stack overflow '.MAX_DEPTH*2;
|
|
||||||
+ 'Caught href stack overflow '.MAX_DEPTH_HASH*2;
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
+{
|
|
||||||
+ # perl #133326
|
|
||||||
+ my @tt;
|
|
||||||
+ #$Storable::DEBUGME=1;
|
|
||||||
+ for (1..16000) {
|
|
||||||
+ my $t = [[[]]];
|
|
||||||
+ push @tt, $t;
|
|
||||||
+ }
|
|
||||||
+ ok(eval { dclone \@tt; 1 },
|
|
||||||
+ "low depth structure shouldn't be treated as nested");
|
|
||||||
}
|
|
||||||
--
|
|
||||||
2.14.4
|
|
||||||
|
|
|
@ -0,0 +1,67 @@
|
||||||
|
From ea1e86cfdf26a330e58ea377a80273de7110011b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed, 21 Aug 2019 11:37:58 +1000
|
||||||
|
Subject: [PATCH] disallow vstring magic strings over 2GB-1
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
On reads this could result in buffer overflows, so avoid writing
|
||||||
|
such large vstrings to avoid causing problems for older Storable.
|
||||||
|
|
||||||
|
Since we no longer write such large vstrings, we don't want to accept
|
||||||
|
them.
|
||||||
|
|
||||||
|
I doubt that restricting versions strings to under 2GB-1 will have
|
||||||
|
a practical effect on downstream users.
|
||||||
|
|
||||||
|
fixes #17306
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Storable/Storable.xs | 19 ++++++++++++++++---
|
||||||
|
1 file changed, 16 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
|
||||||
|
index c2335680ab..d27ac58012 100644
|
||||||
|
--- a/dist/Storable/Storable.xs
|
||||||
|
+++ b/dist/Storable/Storable.xs
|
||||||
|
@@ -2628,6 +2628,12 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
|
||||||
|
/* The macro passes this by address, not value, and a lot of
|
||||||
|
called code assumes that it's 32 bits without checking. */
|
||||||
|
const SSize_t len = mg->mg_len;
|
||||||
|
+ /* we no longer accept vstrings over I32_SIZE-1, so don't emit
|
||||||
|
+ them, also, older Storables handle them badly.
|
||||||
|
+ */
|
||||||
|
+ if (len >= I32_MAX) {
|
||||||
|
+ CROAK(("vstring too large to freeze"));
|
||||||
|
+ }
|
||||||
|
STORE_PV_LEN((const char *)mg->mg_ptr,
|
||||||
|
len, SX_VSTRING, SX_LVSTRING);
|
||||||
|
}
|
||||||
|
@@ -5937,12 +5943,19 @@ static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname)
|
||||||
|
{
|
||||||
|
#ifdef SvVOK
|
||||||
|
char *s;
|
||||||
|
- I32 len;
|
||||||
|
+ U32 len;
|
||||||
|
SV *sv;
|
||||||
|
|
||||||
|
RLEN(len);
|
||||||
|
- TRACEME(("retrieve_lvstring (#%d), len = %" IVdf,
|
||||||
|
- (int)cxt->tagnum, (IV)len));
|
||||||
|
+ TRACEME(("retrieve_lvstring (#%d), len = %" UVuf,
|
||||||
|
+ (int)cxt->tagnum, (UV)len));
|
||||||
|
+
|
||||||
|
+ /* Since we'll no longer produce such large vstrings, reject them
|
||||||
|
+ here too.
|
||||||
|
+ */
|
||||||
|
+ if (len >= I32_MAX) {
|
||||||
|
+ CROAK(("vstring too large to fetch"));
|
||||||
|
+ }
|
||||||
|
|
||||||
|
New(10003, s, len+1, char);
|
||||||
|
SAFEPVREAD(s, len, s);
|
||||||
|
--
|
||||||
|
2.21.0
|
||||||
|
|
|
@ -1,22 +1,20 @@
|
||||||
Name: perl-Storable
|
Name: perl-Storable
|
||||||
Epoch: 1
|
Epoch: 1
|
||||||
Version: 3.11
|
Version: 3.15
|
||||||
Release: 6%{?dist}
|
Release: 4%{?dist}
|
||||||
Summary: Persistence for Perl data structures
|
Summary: Persistence for Perl data structures
|
||||||
# __Storable__.pm: GPL+ or Artistic
|
# __Storable__.pm: GPL+ or Artistic
|
||||||
## Not in the binary packages
|
|
||||||
# t/CVE-2015-1592.inc: BSD (same as Metasploit Framwork)
|
|
||||||
License: GPL+ or Artistic
|
License: GPL+ or Artistic
|
||||||
URL: https://metacpan.org/release/Storable
|
URL: https://metacpan.org/release/Storable
|
||||||
# Storable-3.11 was repackaged without t/CVE-2015-1592.inc file (perl commit
|
Source0: https://cpan.metacpan.org/authors/id/X/XS/XSAWYERX/Storable-%{version}.tar.gz
|
||||||
# fb5f378b17e3b41db03064c19b9205db64a3354c) to silent antivirus alerts,
|
# Fix deep cloning regular expression objects, RT#134179,
|
||||||
# RT#133706, in perl upstream after 5.29.5, Original source URL:
|
# in Perl upstream after 5.31.0
|
||||||
# https://cpan.metacpan.org/authors/id/X/XS/XSAWYERX/Storable-%%{version}.tar.gz
|
Patch0: Storable-3.15-perl-134179-include-regexps-in-the-seen-objects-tabl.patch
|
||||||
Source0: Storable-3.11_repackaged.tar.gz
|
# Fix array length check in a store hook, in Perl upstream after 5.31.2
|
||||||
# Fix recursion check, RT#133326
|
Patch1: Storable-3.16-Storable-make-count-large-enough.patch
|
||||||
Patch0: perl-5.29.2-perl-133326-fix-and-clarify-handling-of-recurs_sv.patch
|
# Fix a buffer overflow when processing a vstring longer than 2^31-1,
|
||||||
# bash for stacksize script (ulimit) that is executed at build time
|
# Perl GH#17306, in perl upstream after 5.31.6
|
||||||
BuildRequires: bash
|
Patch2: perl-5.31.6-disallow-vstring-magic-strings-over-2GB-1.patch
|
||||||
BuildRequires: gcc
|
BuildRequires: gcc
|
||||||
BuildRequires: make
|
BuildRequires: make
|
||||||
BuildRequires: perl-devel
|
BuildRequires: perl-devel
|
||||||
|
@ -32,7 +30,6 @@ BuildRequires: perl(warnings)
|
||||||
# Win32 not used on Linux
|
# Win32 not used on Linux
|
||||||
# Win32API::File not used on Linux
|
# Win32API::File not used on Linux
|
||||||
# Run-time:
|
# Run-time:
|
||||||
# Carp substitutes missing Log::Agent
|
|
||||||
BuildRequires: perl(Carp)
|
BuildRequires: perl(Carp)
|
||||||
BuildRequires: perl(Exporter)
|
BuildRequires: perl(Exporter)
|
||||||
# Fcntl is optional, but locking is good
|
# Fcntl is optional, but locking is good
|
||||||
|
@ -63,8 +60,6 @@ BuildRequires: perl(Hash::Util)
|
||||||
# core Storable.
|
# core Storable.
|
||||||
BuildRequires: perl(Tie::Hash)
|
BuildRequires: perl(Tie::Hash)
|
||||||
Requires: perl(:MODULE_COMPAT_%(eval "`perl -V:version`"; echo $version))
|
Requires: perl(:MODULE_COMPAT_%(eval "`perl -V:version`"; echo $version))
|
||||||
# Carp substitutes missing Log::Agent
|
|
||||||
Requires: perl(Carp)
|
|
||||||
Requires: perl(Config)
|
Requires: perl(Config)
|
||||||
# Fcntl is optional, but locking is good
|
# Fcntl is optional, but locking is good
|
||||||
Requires: perl(Fcntl)
|
Requires: perl(Fcntl)
|
||||||
|
@ -80,19 +75,21 @@ can be conveniently stored to disk and retrieved at a later time.
|
||||||
%prep
|
%prep
|
||||||
%setup -q -n Storable-%{version}
|
%setup -q -n Storable-%{version}
|
||||||
%patch0 -p3
|
%patch0 -p3
|
||||||
|
%patch1 -p3
|
||||||
|
%patch2 -p3
|
||||||
|
|
||||||
%build
|
%build
|
||||||
perl Makefile.PL INSTALLDIRS=vendor NO_PACKLIST=1 OPTIMIZE="$RPM_OPT_FLAGS"
|
perl Makefile.PL INSTALLDIRS=vendor NO_PACKLIST=1 NO_PERLLOCAL=1 OPTIMIZE="$RPM_OPT_FLAGS"
|
||||||
make %{?_smp_mflags}
|
%{make_build}
|
||||||
|
|
||||||
%install
|
%install
|
||||||
make pure_install DESTDIR=$RPM_BUILD_ROOT
|
%{make_install}
|
||||||
find $RPM_BUILD_ROOT -type f -name '*.bs' -size 0 -delete
|
find $RPM_BUILD_ROOT -type f -name '*.bs' -size 0 -delete
|
||||||
find $RPM_BUILD_ROOT -type f -name '*.3pm' -size 0 -delete
|
find $RPM_BUILD_ROOT -type f -name '*.3pm' -size 0 -delete
|
||||||
%{_fixperms} $RPM_BUILD_ROOT/*
|
%{_fixperms} $RPM_BUILD_ROOT/*
|
||||||
|
|
||||||
%check
|
%check
|
||||||
unset PERL_TEST_MEMORY PERL_RUN_SLOW_TESTS
|
unset PERL_CORE PERL_TEST_MEMORY PERL_RUN_SLOW_TESTS
|
||||||
make test
|
make test
|
||||||
|
|
||||||
%files
|
%files
|
||||||
|
@ -102,6 +99,19 @@ make test
|
||||||
%{_mandir}/man3/*
|
%{_mandir}/man3/*
|
||||||
|
|
||||||
%changelog
|
%changelog
|
||||||
|
* Mon Nov 25 2019 Petr Pisar <ppisar@redhat.com> - 1:3.15-4
|
||||||
|
- Fix a buffer overflow when processing a vstring longer than 2^31-1
|
||||||
|
(Perl GH#17306)
|
||||||
|
|
||||||
|
* Thu Aug 08 2019 Petr Pisar <ppisar@redhat.com> - 1:3.15-3
|
||||||
|
- Fix array length check in a store hook
|
||||||
|
|
||||||
|
* Tue Jun 11 2019 Petr Pisar <ppisar@redhat.com> - 1:3.15-2
|
||||||
|
- Fix deep cloning regular expression objects (RT#134179)
|
||||||
|
|
||||||
|
* Wed Apr 24 2019 Petr Pisar <ppisar@redhat.com> - 1:3.15-1
|
||||||
|
- 3.15 bump
|
||||||
|
|
||||||
* Mon Jan 07 2019 Petr Pisar <ppisar@redhat.com> - 1:3.11-6
|
* Mon Jan 07 2019 Petr Pisar <ppisar@redhat.com> - 1:3.11-6
|
||||||
- Storable-3.11 source archive repackaged without a t/CVE-2015-1592.inc file
|
- Storable-3.11 source archive repackaged without a t/CVE-2015-1592.inc file
|
||||||
(RT#133706)
|
(RT#133706)
|
||||||
|
|
2
sources
2
sources
|
@ -1 +1 @@
|
||||||
SHA512 (Storable-3.11_repackaged.tar.gz) = dea3d07ce6715818c805ce6974fd6fbecf6bbb0e8e46ba9ff4f15e4403c5b407f2744f44c067287cc7721e8fdc30896fc88a62ef700c123abb82b4fac5266ab1
|
SHA512 (Storable-3.15.tar.gz) = cd84d50a75b2d639b3075a671615ca1e879fe7b3322bf987843b5c08a8644807b58a671bee340f9694645d789b5a0f7ae93176cb06c94d795fe629697ca077ba
|
||||||
|
|
Loading…
Reference in New Issue