packages/perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

update perl to 5.28.3

Browse Source
This commit is contained in:
root 2020-08-25 14:23:03 +08:00
parent 32b6f2d797
commit 0a00666458
15 changed files with 39 additions and 1054 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
CVE-2018-18312-1.patch
View File

@ -1,10 +0,0 @@
--- a/regcomp.c 2018-05-21 20:29:23.000000000 +0800
+++ b/regcomp.c 2019-04-11 09:51:08.493000000 +0800
@@ -15591,7 +15591,6 @@ redo_curchar:
if (UCHARAT(RExC_parse) != ')')
vFAIL("Expecting close paren for wrapper for nested extended charclass");
- RExC_parse++;
RExC_flags = save_flags;
goto handle_operand;
}

11
CVE-2018-18312-2.patch
View File

@ -1,11 +0,0 @@
--- a/t/re/reg_mesg.t 2018-05-21 20:29:23.000000000 +0800
+++ b/t/re/reg_mesg.t 2019-04-11 09:54:59.622000000 +0800
@@ -122,6 +122,8 @@ my $tab_hex = sprintf "%02X", ord("\t");
#
# The first set are those that should be fatal errors.
+my $bug133423 = "(?[(?^:(?[\\\x00]))\\]\x00|2[^^]\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80])R.\\670";
+
my @death =
(
'/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions {#} m/[[=foo=]{#}]/',

10
CVE-2018-18312-3.patch
View File

@ -1,10 +0,0 @@
--- a/t/re/reg_mesg-change.t 2019-04-11 10:07:36.626000000 +0800
+++ b/t/re/reg_mesg.t 2019-04-11 10:08:20.032000000 +0800
@@ -309,6 +309,7 @@ my @death =
'/\A{/' => 'Unescaped left brace in regex is illegal here {#} m/\A{{#}/',
'/(?<=/' => 'Sequence (?... not terminated {#} m/(?<={#}/', # [perl #128170]
'/\p{vertical tab}/' => 'Can\'t find Unicode property definition "vertical tab" {#} m/\\p{vertical tab}{#}/', # [perl #132055]
+ "/$bug133423/" => "Operand with no preceding operator {#} m/(?[(?^:(?[\\\0]))\\{#}]\0|2[^^]\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80])R.\\670/",
);

93
Fix-script-run-bug-1-followed-by-Thai-digit.patch
View File

@ -1,93 +0,0 @@
From 7da8e27b9d7d2be4e770d074405ddb9941e6c8b7 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Thu, 16 Aug 2018 16:14:01 -0600
Subject: [PATCH] Fix script run bug '1' followed by Thai digit
This does not have a ticket, but was pointed out in
http://nntp.perl.org/group/perl.perl5.porters/251870
The logic for deciding if it was needed to check if a character is a
digit was flawed.
---
regexec.c | 46 +++++++++++++++++++++++++++++++---------------
t/re/script_run.t | 5 +++++
2 files changed, 36 insertions(+), 15 deletions(-)
diff --git a/regexec.c b/regexec.c
index 6f39670c4a..c927abc611 100644
--- a/regexec.c
+++ b/regexec.c
@@ -10626,23 +10626,39 @@ Perl_isSCRIPT_RUN(pTHX_ const U8 * s, const U8 * send, const bool utf8_target)
scripts_match:
/* Here, the script of the character is compatible with that of the
- * run. Either they match exactly, or one or both can be any of
- * several scripts, and the intersection is not empty. If the
- * character is not a decimal digit, we are done with it. Otherwise,
- * it could still fail if it is from a different set of 10 than seen
- * already (or we may not have seen any, and we need to set the
- * sequence). If we have determined a single script and that script
- * only has one set of digits (almost all scripts are like that), then
- * this isn't a problem, as any digit must come from the same sequence.
- * The only scripts that have multiple sequences have been constructed
- * to be 0 in 'script_zeros[]'.
+ * run. That means that in most cases, it continues the script run.
+ * Either it and the run match exactly, or one or both can be in any of
+ * several scripts, and the intersection is not empty. But if the
+ * character is a decimal digit, we need further handling. If we
+ * haven't seen a digit before, it would establish what set of 10 all
+ * must come from; and if we have established a set, we need to check
+ * that this is in it.
*
- * Here we check if it is a digit. */
+ * But there are cases we can rule out without having to look up if
+ * this is a digit:
+ * a. All instances of [0-9] have been dealt with earlier.
+ * b. The next digit encoded by Unicode is 1600 code points further
+ * on, so if the code point in this loop iteration is less than
+ * that, it isn't a digit.
+ * c. Most scripts that have digits have a single set of 10. If
+ * we've encountered a digit in such a script, 'zero_of_run' is
+ * set to the code point (call it z) whose numeric value is 0.
+ * If the code point in this loop iteration is in the range
+ * z..z+9, it is in the script's set of 10, and we've actually
+ * handled it earlier in this function and won't reach this
+ * point. But, code points in that script that aren't in that
+ * range can't be digits, so we don't have to look any such up.
+ * We can tell if this script is such a one by looking at
+ * 'script_zeros[]' for it. It is non-zero iff it has a single
+ * set of digits. This rule doesn't apply if we haven't narrowed
+ * down the possible scripts to a single one yet. Nor if the
+ * zero of the run is '0', as that also hasn't narrowed things
+ * down completely */
if ( cp >= FIRST_NON_ASCII_DECIMAL_DIGIT
- && ( ( zero_of_run == 0
- || ( ( script_of_char >= 0
- && script_zeros[script_of_char] == 0)
- || intersection))))
+ && ( intersection
+ || script_of_char < 0 /* Also implies an intersection */
+ || zero_of_run == '0'
+ || script_zeros[script_of_char] == 0))
{
SSize_t range_zero_index;
range_zero_index = _invlist_search(decimals_invlist, cp);
diff --git a/t/re/script_run.t b/t/re/script_run.t
index ca234d9d4e..10c71034c4 100644
--- a/t/re/script_run.t
+++ b/t/re/script_run.t
@@ -84,6 +84,11 @@ foreach my $type ('script_run', 'sr', 'atomic_script_run', 'asr') {
# From UTS 39
like("写真だけの結婚式", $script_run, "Mixed Hiragana and Han");
+
+ unlike "\N{THAI DIGIT FIVE}1", $script_run, "Thai digit followed by '1'";
+ unlike "1\N{THAI DIGIT FIVE}", $script_run, "'1' followed by Thai digit ";
+ unlike "\N{BENGALI DIGIT ZERO}\N{CHAKMA DIGIT SEVEN}", $script_run,
+ "Two digits in same extended script but from different sets of 10";
}
# Until fixed, this was skipping the '['
--
2.19.1

175
Perl_my_setenv-handle-integer-wrap.patch
View File

@ -1,175 +0,0 @@
From 34716e2a6ee2af96078d62b065b7785c001194be Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Fri, 29 Jun 2018 13:37:03 +0100
Subject: [PATCH] Perl_my_setenv(); handle integer wrap
RT #133204
Wean this function off int/I32 and onto UV/Size_t.
Also, replace all malloc-ish calls with a wrapper that does
overflow checks,
In particular, it was doing (nlen + vlen + 2) which could wrap when
the combined length of the environment variable name and value
exceeded around 0x7fffffff.
The wrapper check function is probably overkill, but belt and braces...
NB this function has several variant parts, #ifdef'ed by platform
type; I have blindly changed the parts that aren't compiled under linux.
---
util.c | 76 ++++++++++++++++++++++++++++++++++++++++------------------
1 file changed, 53 insertions(+), 23 deletions(-)
diff --git a/util.c b/util.c
index 7282dd9cfe..c5c7becc0f 100644
--- a/util.c
+++ b/util.c
@@ -2061,8 +2061,40 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
*(s+(nlen+1+vlen)) = '\0'
#ifdef USE_ENVIRON_ARRAY
- /* VMS' my_setenv() is in vms.c */
+
+/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
+ * 'current' is non-null, with up to three sizes that are added together.
+ * It handles integer overflow.
+ */
+static char *
+S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
+{
+ void *p;
+ Size_t sl, l = l1 + l2;
+
+ if (l < l2)
+ goto panic;
+ l += l3;
+ if (l < l3)
+ goto panic;
+ sl = l * size;
+ if (sl < l)
+ goto panic;
+
+ p = current
+ ? safesysrealloc(current, sl)
+ : safesysmalloc(sl);
+ if (p)
+ return (char*)p;
+
+ panic:
+ croak_memory_wrap();
+}
+
+
+/* VMS' my_setenv() is in vms.c */
#if !defined(WIN32) && !defined(NETWARE)
+
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
@@ -2078,28 +2110,27 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
#ifndef PERL_USE_SAFE_PUTENV
if (!PL_use_safe_putenv) {
/* most putenv()s leak, so we manipulate environ directly */
- I32 i;
- const I32 len = strlen(nam);
- int nlen, vlen;
+ UV i;
+ Size_t vlen, nlen = strlen(nam);
/* where does it go? */
for (i = 0; environ[i]; i++) {
- if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+ if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
break;
}
if (environ == PL_origenviron) { /* need we copy environment? */
- I32 j;
- I32 max;
+ UV j, max;
char **tmpenv;
max = i;
while (environ[max])
max++;
- tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+ /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
+ tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
for (j=0; j<max; j++) { /* copy environment */
- const int len = strlen(environ[j]);
- tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ const Size_t len = strlen(environ[j]);
+ tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
Copy(environ[j], tmpenv[j], len+1, char);
}
tmpenv[max] = NULL;
@@ -2118,15 +2149,15 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
#endif
}
if (!environ[i]) { /* does not exist yet */
- environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+ environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
environ[i+1] = NULL; /* make sure it's null terminated */
}
else
safesysfree(environ[i]);
- nlen = strlen(nam);
+
vlen = strlen(val);
- environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
/* all that work just for this */
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
@@ -2150,22 +2181,21 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
if (environ) /* old glibc can crash with null environ */
(void)unsetenv(nam);
} else {
- const int nlen = strlen(nam);
- const int vlen = strlen(val);
- char * const new_env =
- (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ const Size_t nlen = strlen(nam);
+ const Size_t vlen = strlen(val);
+ char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
}
# else /* ! HAS_UNSETENV */
char *new_env;
- const int nlen = strlen(nam);
- int vlen;
+ const Size_t nlen = strlen(nam);
+ Size_t vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
/* all that work just for this */
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
@@ -2187,14 +2217,14 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
char *envstr;
- const int nlen = strlen(nam);
- int vlen;
+ const Size_t nlen = strlen(nam);
+ Size_t vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- Newx(envstr, nlen+vlen+2, char);
+ envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
--
2.19.1

36
backport-CVE-2020-10543.patch
View File

@ -1,36 +0,0 @@
From ea6af8d23101db9d575ada0fc659eb03cd2177d8 Mon Sep 17 00:00:00 2001
From: John Lightsey <jd@cpanel.net>
Date: Wed, 20 Nov 2019 20:02:45 -0600
Subject: [PATCH] regcomp.c: Prevent integer overflow from nested regex
quantifiers.
(CVE-2020-10543) On 32bit systems the size calculations for nested regular
expression quantifiers could overflow causing heap memory corruption.
Fixes: Perl/perl5-security#125
(cherry picked from commit bfd31397db5dc1a5c5d3e0a1f753a4f89a736e71)
port from:
https://github.com/perl/perl5/commit/897d1f7fd515b828e4b198d8b8bef76c6faf03ed
Signed-off-by: Peibao Liu <peibao.liu@windriver.com>
---
regcomp.c | 6 ++++++
1 file changed, 6 insertions(+)
diff -Naur a/regcomp.c b/regcomp.c
--- a/regcomp.c 2020-07-14 14:52:25.197000000 -0400
+++ b/regcomp.c 2020-07-14 14:56:41.823000000 -0400
@@ -5181,6 +5181,12 @@
(void)ReREFCNT_inc(RExC_rx_sv);
}
+ if ( ( minnext > 0 && mincount >= SSize_t_MAX / minnext )
+ || min >= SSize_t_MAX - minnext * mincount )
+ {
+ FAIL("Regexp out of space");
+ }
+
min += minnext * mincount;
is_inf_internal |= deltanext == SSize_t_MAX
|| (maxcount == REG_INFTY && minnext + deltanext > 0);

144
backport-CVE-2020-10878.patch
View File

@ -1,144 +0,0 @@
From 0a320d753fe7fca03df259a4dfd8e641e51edaa8 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Tue, 18 Feb 2020 13:51:16 +0000
Subject: [PATCH] study_chunk: extract rck_elide_nothing
(CVE-2020-10878)
(cherry picked from commit 93dee06613d4e1428fb10905ce1c3c96f53113dc)
---
embed.fnc | 1 +
embed.h | 1 +
proto.h | 3 +++
regcomp.c | 70 ++++++++++++++++++++++++++++++++++---------------------
4 files changed, 48 insertions(+), 27 deletions(-)
diff -Naur a/embed.fnc b/embed.fnc
--- a/embed.fnc 2020-07-14 15:07:54.374000000 -0400
+++ b/embed.fnc 2020-07-14 15:14:46.619000000 -0400
@@ -2476,6 +2476,7 @@
|I32 stopparen|U32 recursed_depth \
|NULLOK regnode_ssc *and_withp \
|U32 flags|U32 depth
+Es |void |rck_elide_nothing|NN regnode *node
EsR |SV * |get_ANYOFM_contents|NN const regnode * n
EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
|NN const char* const s|const U32 n
diff -Naur a/embed.h b/embed.h
--- a/embed.h 2020-07-14 15:07:54.399000000 -0400
+++ b/embed.h 2020-07-14 15:15:08.491000000 -0400
@@ -1202,6 +1202,7 @@
#define output_or_return_posix_warnings(a,b,c) S_output_or_return_posix_warnings(aTHX_ a,b,c)
#define parse_lparen_question_flags(a) S_parse_lparen_question_flags(aTHX_ a)
#define populate_ANYOF_from_invlist(a,b) S_populate_ANYOF_from_invlist(aTHX_ a,b)
+#define rck_elide_nothing(a) S_rck_elide_nothing(aTHX_ a)
#define reg(a,b,c,d) S_reg(aTHX_ a,b,c,d)
#define reg2Lanode(a,b,c,d) S_reg2Lanode(aTHX_ a,b,c,d)
#define reg_node(a,b) S_reg_node(aTHX_ a,b)
diff -Naur a/proto.h b/proto.h
--- a/proto.h 2020-07-14 15:07:54.369000000 -0400
+++ b/proto.h 2020-07-14 15:15:37.435000000 -0400
@@ -5482,6 +5482,9 @@
STATIC void S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr);
#define PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST \
assert(node); assert(invlist_ptr)
+STATIC void S_rck_elide_nothing(pTHX_ regnode *node);
+#define PERL_ARGS_ASSERT_RCK_ELIDE_NOTHING \
+ assert(node)
PERL_STATIC_NO_RET void S_re_croak2(pTHX_ bool utf8, const char* pat1, const char* pat2, ...)
__attribute__noreturn__;
#define PERL_ARGS_ASSERT_RE_CROAK2 \
diff -Naur a/regcomp.c b/regcomp.c
--- a/regcomp.c 2020-07-14 15:07:54.394000000 -0400
+++ b/regcomp.c 2020-07-14 15:17:39.845000000 -0400
@@ -4178,6 +4178,44 @@
} while (f);
}
+/* Follow the next-chain of the current node and optimize away
+ * all the NOTHINGs from it.
+ * */
+STATIC void
+S_rck_elide_nothing(pTHX_ regnode *node)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_RCK_ELIDE_NOTHING;
+
+ if (OP(node) != CURLYX) {
+ const int max = (reg_off_by_arg[OP(node)]
+ ? I32_MAX
+ /* I32 may be smaller than U16 on CRAYs! */
+ : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
+ int off = (reg_off_by_arg[OP(node)] ? ARG(node) : NEXT_OFF(node));
+ int noff;
+ regnode *n = node;
+
+ /* Skip NOTHING and LONGJMP. */
+ while (
+ (n = regnext(n))
+ && (
+ (PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
+ || ((OP(n) == LONGJMP) && (noff = ARG(n)))
+ )
+ && off + noff < max
+ ) {
+ off += noff;
+ }
+ if (reg_off_by_arg[OP(node)])
+ ARG(node) = off;
+ else
+ NEXT_OFF(node) = off;
+ }
+ return;
+}
+
/* the return from this sub is the minimum length that could possibly match */
STATIC SSize_t
S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
@@ -4277,28 +4315,10 @@
*/
JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
- /* Follow the next-chain of the current node and optimize
- away all the NOTHINGs from it. */
- if (OP(scan) != CURLYX) {
- const int max = (reg_off_by_arg[OP(scan)]
- ? I32_MAX
- /* I32 may be smaller than U16 on CRAYs! */
- : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
- int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
- int noff;
- regnode *n = scan;
-
- /* Skip NOTHING and LONGJMP. */
- while ((n = regnext(n))
- && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
- || ((OP(n) == LONGJMP) && (noff = ARG(n))))
- && off + noff < max)
- off += noff;
- if (reg_off_by_arg[OP(scan)])
- ARG(scan) = off;
- else
- NEXT_OFF(scan) = off;
- }
+ /* Follow the next-chain of the current node and optimize
+ away all the NOTHINGs from it.
+ */
+ rck_elide_nothing(scan);
/* The principal pseudo-switch. Cannot be a switch, since we
look into several different things. */
@@ -5425,11 +5445,7 @@
if (data && (fl & SF_HAS_EVAL))
data->flags |= SF_HAS_EVAL;
optimize_curly_tail:
- if (OP(oscan) != CURLYX) {
- while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
- && NEXT_OFF(next))
- NEXT_OFF(oscan) += NEXT_OFF(next);
- }
+ rck_elide_nothing(oscan);
continue;
default:

277
backport-CVE-2020-12723.patch
View File

@ -1,277 +0,0 @@
From c0b79e3c354b25f9fb732bd49f668ae5eeaa723a Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Sat, 11 Apr 2020 14:10:24 +0100
Subject: [PATCH] study_chunk: avoid mutating regexp program within GOSUB
gh16947 and gh17743: studying GOSUB may restudy in an inner call
(via a mix of recursion and enframing) something that an outer call
is in the middle of looking at. Let the outer frame deal with it.
(CVE-2020-12723)
(cherry picked from commit c4033e740bd18d9fbe3456a9db2ec2053cdc5271)
port from:
https://github.com/perl/perl5/commit/66bbb51b93253a3f87d11c2695cfb7bdb782184a
Signed-off-by: Peibao Liu <peibao.liu@windriver.com>
---
embed.fnc | 2 +-
embed.h | 2 +-
proto.h | 2 +-
regcomp.c | 42 ++++++++++++++++++++++++++++++------------
t/re/pat.t | 27 ++++++++++++++++++++++++++-
5 files changed, 59 insertions(+), 16 deletions(-)
diff -Naur a/embed.fnc b/embed.fnc
--- a/embed.fnc 2020-07-14 15:18:38.077000000 -0400
+++ b/embed.fnc 2020-07-14 15:21:38.116000000 -0400
@@ -2475,7 +2475,7 @@
|NULLOK struct scan_data_t *data \
|I32 stopparen|U32 recursed_depth \
|NULLOK regnode_ssc *and_withp \
- |U32 flags|U32 depth
+ |U32 flags|U32 depth|bool was_mutate_ok
Es |void |rck_elide_nothing|NN regnode *node
EsR |SV * |get_ANYOFM_contents|NN const regnode * n
EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
diff -Naur a/embed.h b/embed.h
--- a/embed.h 2020-07-14 15:18:38.095000000 -0400
+++ b/embed.h 2020-07-14 15:21:58.416000000 -0400
@@ -1232,7 +1232,7 @@
#define ssc_is_cp_posixl_init S_ssc_is_cp_posixl_init
#define ssc_or(a,b,c) S_ssc_or(aTHX_ a,b,c)
#define ssc_union(a,b,c) S_ssc_union(aTHX_ a,b,c)
-#define study_chunk(a,b,c,d,e,f,g,h,i,j,k) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k)
+#define study_chunk(a,b,c,d,e,f,g,h,i,j,k,l) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k,l)
# endif
# if defined(PERL_IN_REGCOMP_C) || defined (PERL_IN_DUMP_C)
#define _invlist_dump(a,b,c,d) Perl__invlist_dump(aTHX_ a,b,c,d)
diff -Naur a/proto.h b/proto.h
--- a/proto.h 2020-07-14 15:18:38.074000000 -0400
+++ b/proto.h 2020-07-14 15:22:41.447000000 -0400
@@ -5593,7 +5593,7 @@
#define PERL_ARGS_ASSERT_SSC_UNION \
assert(ssc); assert(invlist)
#endif
-STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U32 recursed_depth, regnode_ssc *and_withp, U32 flags, U32 depth);
+STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U32 recursed_depth, regnode_ssc *and_withp, U32 flags, U32 depth, bool was_mutate_ok);
#define PERL_ARGS_ASSERT_STUDY_CHUNK \
assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last)
#endif
diff -Naur a/regcomp.c b/regcomp.c
--- a/regcomp.c 2020-07-14 15:18:38.091000000 -0400
+++ b/regcomp.c 2020-07-14 15:34:01.739000000 -0400
@@ -110,6 +110,7 @@
regnode *next_regnode; /* next node to process when last is reached */
U32 prev_recursed_depth;
I32 stopparen; /* what stopparen do we use */
+ bool in_gosub; /* this or an outer frame is for GOSUB */
struct scan_frame *this_prev_frame; /* this previous frame */
struct scan_frame *prev_frame; /* previous frame */
@@ -4225,7 +4226,7 @@
I32 stopparen,
U32 recursed_depth,
regnode_ssc *and_withp,
- U32 flags, U32 depth)
+ U32 flags, U32 depth, bool was_mutate_ok)
/* scanp: Start here (read-write). */
/* deltap: Write maxlen-minlen here. */
/* last: Stop before this one. */
@@ -4303,6 +4304,10 @@
node length to get a real minimum (because
the folded version may be shorter) */
bool unfolded_multi_char = FALSE;
+ /* avoid mutating ops if we are anywhere within the recursed or
+ * enframed handling for a GOSUB: the outermost level will handle it.
+ */
+ bool mutate_ok = was_mutate_ok && !(frame && frame->in_gosub);
/* Peephole optimizer: */
DEBUG_STUDYDATA("Peep", data, depth, is_inf);
DEBUG_PEEP("Peep", scan, depth, flags);
@@ -4313,7 +4318,8 @@
* parsing code, as each (?:..) is handled by a different invocation of
* reg() -- Yves
*/
- JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
+ if (mutate_ok)
+ JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
/* Follow the next-chain of the current node and optimize
away all the NOTHINGs from it.
@@ -4345,7 +4351,7 @@
/* DEFINEP study_chunk() recursion */
(void)study_chunk(pRExC_state, &scan, &minlen,
&deltanext, next, &data_fake, stopparen,
- recursed_depth, NULL, f, depth+1);
+ recursed_depth, NULL, f, depth+1, mutate_ok);
scan = next;
} else
@@ -4413,7 +4419,8 @@
/* recurse study_chunk() for each BRANCH in an alternation */
minnext = study_chunk(pRExC_state, &scan, minlenp,
&deltanext, next, &data_fake, stopparen,
- recursed_depth, NULL, f,depth+1);
+ recursed_depth, NULL, f, depth+1,
+ mutate_ok);
if (min1 > minnext)
min1 = minnext;
@@ -4480,9 +4487,10 @@
}
}
- if (PERL_ENABLE_TRIE_OPTIMISATION &&
- OP( startbranch ) == BRANCH )
- {
+ if (PERL_ENABLE_TRIE_OPTIMISATION
+ && OP(startbranch) == BRANCH
+ && mutate_ok
+ ) {
/* demq.
Assuming this was/is a branch we are dealing with: 'scan'
@@ -4933,6 +4941,9 @@
newframe->stopparen = stopparen;
newframe->prev_recursed_depth = recursed_depth;
newframe->this_prev_frame= frame;
+ newframe->in_gosub = (
+ (frame && frame->in_gosub) || OP(scan) == GOSUB
+ );
DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
DEBUG_PEEP("fnew", scan, depth, flags);
@@ -5153,7 +5164,7 @@
(mincount == 0
? (f & ~SCF_DO_SUBSTR)
: f)
- ,depth+1);
+ , depth+1, mutate_ok);
if (flags & SCF_DO_STCLASS)
data->start_class = oclass;
@@ -5221,7 +5232,9 @@
if ( OP(oscan) == CURLYX && data
&& data->flags & SF_IN_PAR
&& !(data->flags & SF_HAS_EVAL)
- && !deltanext && minnext == 1 ) {
+ && !deltanext && minnext == 1
+ && mutate_ok
+ ) {
/* Try to optimize to CURLYN. */
regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
regnode * const nxt1 = nxt;
@@ -5267,10 +5280,10 @@
&& !(data->flags & SF_HAS_EVAL)
&& !deltanext /* atom is fixed width */
&& minnext != 0 /* CURLYM can't handle zero width */
-
/* Nor characters whose fold at run-time may be
* multi-character */
&& ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
+ && mutate_ok
) {
/* XXXX How to optimize if data == 0? */
/* Optimize to a simpler form. */
@@ -5318,7 +5331,8 @@
/* Optimize again: */
/* recurse study_chunk() on optimised CURLYX => CURLYM */
study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
- NULL, stopparen, recursed_depth, NULL, 0,depth+1);
+ NULL, stopparen, recursed_depth, NULL, 0,
+ depth+1, mutate_ok);
}
else
oscan->flags = 0;
@@ -5735,7 +5749,8 @@
/* recurse study_chunk() for lookahead body */
minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
last, &data_fake, stopparen,
- recursed_depth, NULL, f, depth+1);
+ recursed_depth, NULL, f, depth+1,
+ mutate_ok);
if (scan->flags) {
if (deltanext) {
FAIL("Variable length lookbehind not implemented");
@@ -5827,7 +5842,7 @@
*minnextp = study_chunk(pRExC_state, &nscan, minnextp,
&deltanext, last, &data_fake,
stopparen, recursed_depth, NULL,
- f,depth+1);
+ f, depth+1, mutate_ok);
if (scan->flags) {
if (deltanext) {
FAIL("Variable length lookbehind not implemented");
@@ -5988,7 +6003,8 @@
/* optimise study_chunk() for TRIE */
minnext = study_chunk(pRExC_state, &scan, minlenp,
&deltanext, (regnode *)nextbranch, &data_fake,
- stopparen, recursed_depth, NULL, f,depth+1);
+ stopparen, recursed_depth, NULL, f, depth+1,
+ mutate_ok);
}
if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
nextbranch= regnext((regnode*)nextbranch);
@@ -7673,7 +7689,7 @@
&data, -1, 0, NULL,
SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
| (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
- 0);
+ 0, TRUE);
CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
@@ -7802,7 +7818,7 @@
SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
? SCF_TRIE_DOING_RESTUDY
: 0),
- 0);
+ 0, TRUE);
CHECK_RESTUDY_GOTO_butfirst(NOOP);
diff -Naur a/t/re/pat.t b/t/re/pat.t
--- a/t/re/pat.t 2020-07-14 15:18:37.898000000 -0400
+++ b/t/re/pat.t 2020-07-14 15:40:01.252000000 -0400
@@ -23,7 +23,7 @@
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
skip_all_without_unicode_tables();
-plan tests => 848; # Update this when adding/deleting tests.
+plan tests => 852; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1948,6 +1948,30 @@
fresh_perl_is('m m0*0+\Rm', "",{},"Undefined behavior in address sanitizer");
}
+ # gh16947: test regexp corruption (GOSUB)
+ {
+ fresh_perl_is(q{
+ 'xy' =~ /x(?0)|x(?|y|y)/ && print 'ok'
+ }, 'ok', {}, 'gh16947: test regexp corruption (GOSUB)');
+ }
+ # gh16947: test fix doesn't break SUSPEND
+ {
+ fresh_perl_is(q{ 'sx' =~ m{ss++}i; print 'ok' },
+ 'ok', {}, "gh16947: test fix doesn't break SUSPEND");
+ }
+
+ # gh17743: more regexp corruption via GOSUB
+ {
+ fresh_perl_is(q{
+ "0" =~ /((0(?0)|000(?|0000|0000)(?0))|)/; print "ok"
+ }, 'ok', {}, 'gh17743: test regexp corruption (1)');
+
+ fresh_perl_is(q{
+ "000000000000" =~ /(0(())(0((?0)())|000(?|\x{ef}\x{bf}\x{bd}|\x{ef}\x{bf}\x{bd}))|)/;
+ print "ok"
+ }, 'ok', {}, 'gh17743: test regexp corruption (2)');
+ }
+
} # End of sub run_tests
1;

56
create-libperl-soname.patch
View File

@ -1,54 +1,60 @@
From fe7ae3db489775f409b9284c5e81ce91ab8578da Mon Sep 17 00:00:00 2001
From fa2f0dd5a7767223df10149d3f16d7ed7013e16f Mon Sep 17 00:00:00 2001
From: Torsten Veller <tove@gentoo.org>
Date: Mon, 30 Dec 2019 15:10:30 +0800
Subject: [PATCH] create libperl soname
Date: Sat, 14 Apr 2012 13:49:18 +0200
Subject: Set libperl soname
See details: https://bugs.gentoo.org/286840
Bug-Gentoo: https://bugs.gentoo.org/286840
Patch-Name: gentoo/create_libperl_soname.diff
---
Makefile.SH | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
Makefile.SH | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
diff --git a/Makefile.SH b/Makefile.SH
index 123903d..e73f0ec 100755
index 3f1851d..ac2903b 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -68,7 +68,7 @@ true)
${api_revision}.${api_version}.${api_subversion} \
-current_version \
${revision}.${patchlevel}.${subversion} \
- -install_name \$(shrpdir)/\$@"
+ -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
@@ -70,11 +70,11 @@ true)
${revision}.${patchlevel}.${subversion}"
case "$osvers" in
1[5-9]*|[2-9]*)
- shrpldflags="$shrpldflags -install_name `pwd`/\$@ -Xlinker -headerpad_max_install_names"
+ shrpldflags="$shrpldflags -install_name `pwd`/libperl.${revision}.${patchlevel}.dylib -Xlinker -headerpad_max_install_names"
exeldflags="-Xlinker -headerpad_max_install_names"
;;
*)
- shrpldflags="$shrpldflags -install_name \$(shrpdir)/\$@"
+ shrpldflags="$shrpldflags -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
;;
esac
;;
cygwin*)
shrpldflags="$shrpldflags -Wl,--out-implib=libperl.dll.a -Wl,--image-base,0x52000000"
@@ -76,13 +76,16 @@ true)
@@ -84,13 +84,15 @@ true)
;;
sunos*)
linklibperl="-lperl"
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;;
netbsd*|freebsd[234]*|openbsd*|dragonfly*|bitrig*)
linklibperl="-L. -lperl"
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;;
interix*)
linklibperl="-L. -lperl"
shrpldflags="$shrpldflags -Wl,--image-base,0x57000000"
+ shrpldflags="$shrpldflags -Wl,--image-base,0x57000000 -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
- shrpldflags="$shrpldflags -Wl,--image-base,0x57000000"
+ shrpldflags="$shrpldflags -Wl,--image-base,0x57000000 -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;;
aix*)
case "$cc" in
@@ -120,6 +123,9 @@ true)
@@ -128,6 +130,9 @@ true)
linklibperl='libperl.x'
DPERL_EXTERNAL_GLOB=''
;;
+ linux*)
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
+ ;;
+ linux*)
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
+ ;;
esac
case "$ldlibpthname" in
'') ;;
--
1.8.3.1
2.23.0

56
perl-132655-nul-terminate-result-of-unpack-u-of-inva.patch
View File

@ -1,56 +0,0 @@
From 12cad9bd99725bba72029e2651b2b7f0cab2e0b0 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 20 Aug 2018 16:31:45 +1000
Subject: [PATCH] (perl #132655) nul terminate result of unpack "u" of invalid
data
In the given test case, Perl_atof2() would run off the end of the PV,
producing an error from ASAN.
---
pp_pack.c | 5 ++++-
t/op/pack.t | 9 ++++++++-
2 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/pp_pack.c b/pp_pack.c
index 5e9cc64301..f8be9d48ae 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -1727,7 +1727,10 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
if (!checksum) {
const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
sv = sv_2mortal(newSV(l));
- if (l) SvPOK_on(sv);
+ if (l) {
+ SvPOK_on(sv);
+ *SvEND(sv) = '\0';
+ }
}
/* Note that all legal uuencoded strings are ASCII printables, so
diff --git a/t/op/pack.t b/t/op/pack.t
index cf0e286509..bb9f865091 100644
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -12,7 +12,7 @@ my $no_endianness = $] > 5.009 ? '' :
my $no_signedness = $] > 5.009 ? '' :
"Signed/unsigned pack modifiers not available on this perl";
-plan tests => 14717;
+plan tests => 14718;
use strict;
use warnings qw(FATAL all);
@@ -2081,3 +2081,10 @@ SKIP:
fresh_perl_like('pack "c10f1073741824"', qr/Out of memory during pack/, { stderr => 1 },
"integer overflow calculating allocation (multiply)");
}
+
+{
+ # [perl #132655] heap-buffer-overflow READ of size 11
+ # only expect failure under ASAN (and maybe valgrind)
+ fresh_perl_is('0.0 + unpack("u", "ab")', "", { stderr => 1 },
+ "ensure unpack u of invalid data nul terminates result");
+}
--
2.19.1

97
perl-133314-always-close-the-directory-handle-on-cle.patch
View File

@ -1,97 +0,0 @@
From 3d5e9c119db6b727684fe75dfcfe5831c4351bec Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 2 Jul 2018 10:43:19 +1000
Subject: [PATCH] (perl #133314) always close the directory handle on clean up
Previously the directory handle was only closed if the rest of the
magic free clean up is done, but in most success cases that code
doesn't run, leaking the directory handle.
So always close the directory if our AV is available.
---
doio.c | 56 +++++++++++++++++++++++++++++++-------------------------
1 file changed, 31 insertions(+), 25 deletions(-)
diff --git a/doio.c b/doio.c
index 4b8923f77c..16daf9fd11 100644
--- a/doio.c
+++ b/doio.c
@@ -1163,44 +1163,50 @@ S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
/* mg_obj can be NULL if a thread is created with the handle open, in which
case we leave any clean up to the parent thread */
- if (mg->mg_obj && IoIFP(io)) {
- SV **pid_psv;
+ if (mg->mg_obj) {
#ifdef ARGV_USE_ATFUNCTIONS
SV **dir_psv;
DIR *dir;
+
+ dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
+ assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
+ dir = INT2PTR(DIR *, SvIV(*dir_psv));
#endif
- PerlIO *iop = IoIFP(io);
+ if (IoIFP(io)) {
+ SV **pid_psv;
+ PerlIO *iop = IoIFP(io);
- assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
+ assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
- pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
+ pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
- assert(pid_psv && *pid_psv);
+ assert(pid_psv && *pid_psv);
- if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
- /* if we get here the file hasn't been closed explicitly by the
- user and hadn't been closed implicitly by nextargv(), so
- abandon the edit */
- SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
- const char *temp_pv = SvPVX(*temp_psv);
+ if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
+ /* if we get here the file hasn't been closed explicitly by the
+ user and hadn't been closed implicitly by nextargv(), so
+ abandon the edit */
+ SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
+ const char *temp_pv = SvPVX(*temp_psv);
- assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
- (void)PerlIO_close(iop);
- IoIFP(io) = IoOFP(io) = NULL;
+ assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
+ (void)PerlIO_close(iop);
+ IoIFP(io) = IoOFP(io) = NULL;
#ifdef ARGV_USE_ATFUNCTIONS
- dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
- assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
- dir = INT2PTR(DIR *, SvIV(*dir_psv));
- if (dir) {
- if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
- NotSupported(errno))
- (void)UNLINK(temp_pv);
- closedir(dir);
- }
+ if (dir) {
+ if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
+ NotSupported(errno))
+ (void)UNLINK(temp_pv);
+ }
#else
- (void)UNLINK(temp_pv);
+ (void)UNLINK(temp_pv);
#endif
+ }
}
+#ifdef ARGV_USE_ATFUNCTIONS
+ if (dir)
+ closedir(dir);
+#endif
}
return 0;
--
2.19.1

BIN
perl-5.28.0.tar.xz → perl-5.28.3.tar.xz
View File

Binary file not shown.

26
perl.spec
View File

@ -17,8 +17,8 @@
Name: perl
License: (GPL+ or Artistic) and (GPLv2+ or Artistic) and MIT and UCD and Public Domain and BSD
Epoch: 4
Version: 5.28.0
Release: 435
Version: 5.28.3
Release: 1
Summary: A highly capable, feature-rich programming language
Url: https://www.perl.org/
Source0: https://www.cpan.org/src/5.0/%{name}-%{version}.tar.xz
@ -33,44 +33,28 @@ Patch5: create-libperl-soname.patch
Patch8: perl-5.18.2-Destroy-GDBM-NDBM-ODBM-SDBM-_File-objects-only-from-.patch
# PATCH-FIX-OPENEULER--RT#133295
Patch12: delete-ext-GDBM_File-t-fatal.t.patch
# PATCH-FIX-UPSTREAM--RT#133204, upstream 5.29.0
Patch13: Perl_my_setenv-handle-integer-wrap.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.0
Patch14: regexec.c-Call-macro-with-correct-args.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.0
Patch15: perl.h-Add-parens-around-macro-arguments.patch
# PATCH-FIX-UPSTREAM--RT#133368, upstream 5.29.0
Patch16: treat-when-index-1-as-a-boolean-expression.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.0
Patch17: locale.c-Fix-conditional-compilation.patch
# PATCH-FIX-UPSTREAM--RT#133314, upstream 5.29.1
Patch18: perl-133314-test-for-handle-leaks-from-in-place-edit.patch
Patch19: perl-133314-always-close-the-directory-handle-on-cle.patch
# PATCH-FIX-UPSTREAM--Fix buffer overrun, upstream 5.29.1
Patch20: utf8.c-Make-safer-a-deprecated-function.patch
# PATCH-FIX-UPSTREAM--Fix time race, upstream 5.29.1
Patch21: Time-HiRes-t-itimer.t-avoid-race-condition.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.1
Patch22: Fix-script-run-bug-1-followed-by-Thai-digit.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.1
Patch23: Update-Time-Piece-to-CPAN-version-1.33.patch
# PATCH-FIX-UPSTREAM-- RT#133441, upstream 5.29.2
Patch24: multiconcat-mutator-not-seen-in-lex.patch
# PATCH-FIX-UPSTREAM-- RT#132683, upstream 5.29.2
Patch25: perl-132683-don-t-try-to-convert-PL_sv_placeholder-i.patch
# PATCH-FIX-UPSTREAM-- RT#132655, upstream 5.29.2
Patch26: perl-132655-nul-terminate-result-of-unpack-u-of-inva.patch
# PATCH-FIX-OPENEULER
# In 2020, a year of 70 starts to mean 2070. So cpan/Time-Local/t/Local.t test
Patch27: Fix-time-local-tests-in-2020.patch
Patch6000: CVE-2018-18312-1.patch
Patch6001: CVE-2018-18312-2.patch
Patch6002: CVE-2018-18312-3.patch
Patch6003: backport-CVE-2020-10543.patch
Patch6004: backport-CVE-2020-10878.patch
Patch6005: backport-CVE-2020-12723.patch
BuildRequires: gcc bash findutils coreutils make tar procps bzip2-devel gdbm-devel
BuildRequires: zlib-devel systemtap-sdt-devel perl-interpreter perl-generators gdb
@ -514,6 +498,12 @@ make test_harness
%{_mandir}/man3/*
%changelog
* Thu Aug 13 2020 openEuler Buildteam <buildteam@openeuler.org> - 4:5.28.3-1
- Type:enhancement
- ID:NA
- SUG:NA
- DESC:update version to 5.28.3
* Mon Aug 3 2020 wenzhanli<wenzhanli2@huawei.com> - 4:5.28.0-435
- Type:bugfix
- ID:NA

4
perl.yaml
View File

@ -1,4 +0,0 @@
version_control: github
src_repo: Perl/perl5
tag_prefix: ^v
seperator: .

98
treat-when-index-1-as-a-boolean-expression.patch
View File

@ -1,98 +0,0 @@
From 6b877bbd2c071b3e0659fab552a74dc2ff7e08fb Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Sat, 14 Jul 2018 10:47:04 +0100
Subject: [PATCH] treat when(index() > -1) as a boolean expression
RT #133368
when(X) is normally compiled as when($_ ~~ X) *except* when X appears to
be a boolean expression, in which case it's used directly.
5.28.0 introduced an optimisation whereby comparisons involving index
like
index(...) != -1
eliminated the comparison, and pp_index() returned a boolean value
directly. This defeated the 'look for a boolean op' mechanism, and so
when(index(...) != -1)
and similar were being incorrectly compiled as
when($_ ~~ (index(...) != -1))
---
op.c | 8 +++++++-
t/op/switch.t | 23 ++++++++++++++++++++++-
2 files changed, 29 insertions(+), 2 deletions(-)
diff --git a/op.c b/op.c
index a05a1319d4..ddeb484b64 100644
--- a/op.c
+++ b/op.c
@@ -9072,6 +9072,13 @@ S_looks_like_bool(pTHX_ const OP *o)
case OP_FLOP:
return TRUE;
+
+ case OP_INDEX:
+ case OP_RINDEX:
+ /* optimised-away (index() != -1) or similar comparison */
+ if (o->op_private & OPpTRUEBOOL)
+ return TRUE;
+ return FALSE;
case OP_CONST:
/* Detect comparisons that have been optimized away */
@@ -9081,7 +9088,6 @@ S_looks_like_bool(pTHX_ const OP *o)
return TRUE;
else
return FALSE;
-
/* FALLTHROUGH */
default:
return FALSE;
diff --git a/t/op/switch.t b/t/op/switch.t
index e5385df0b4..6ff69e0bce 100644
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -10,7 +10,7 @@ use strict;
use warnings;
no warnings 'experimental::smartmatch';
-plan tests => 195;
+plan tests => 197;
# The behaviour of the feature pragma should be tested by lib/feature.t
# using the tests in t/lib/feature/*. This file tests the behaviour of
@@ -1358,6 +1358,27 @@ given("xyz") {
"scalar value of false when";
}
+# RT #133368
+# index() and rindex() comparisons such as '> -1' are optimised away. Make
+# sure that they're still treated as a direct boolean expression rather
+# than when(X) being implicitly converted to when($_ ~~ X)
+
+{
+ my $s = "abc";
+ my $ok = 0;
+ given("xyz") {
+ when (index($s, 'a') > -1) { $ok = 1; }
+ }
+ ok($ok, "RT #133368 index");
+
+ $ok = 0;
+ given("xyz") {
+ when (rindex($s, 'a') > -1) { $ok = 1; }
+ }
+ ok($ok, "RT #133368 rindex");
+}
+
+
# Okay, that'll do for now. The intricacies of the smartmatch
# semantics are tested in t/op/smartmatch.t. Taintedness of
# returned values is checked in t/op/taint.t.
--
2.19.1