Compare commits
No commits in common. 'c9' and 'c8-stream-5.30' have entirely different histories.
c9
...
c8-stream-
@ -1 +1 @@
|
||||
SOURCES/perl-5.32.1.tar.xz
|
||||
SOURCES/perl-5.30.1.tar.xz
|
||||
|
||||
@ -1 +1 @@
|
||||
1fb4f710d139da1e1a3e1fa4eaba201fcaa8e18e SOURCES/perl-5.32.1.tar.xz
|
||||
4bc190b6ac368f573e6a028f91430f831d40d30a SOURCES/perl-5.30.1.tar.xz
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,389 @@
|
||||
From fd30a7c49a661aecfb361045646da264cdadea8f Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Fri, 23 Aug 2019 12:40:24 -0600
|
||||
Subject: [PATCH] PATCH: [perl #134329] Use after free in regcomp.c
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
A compiled regex is composed of nodes, forming a linked list, with
|
||||
normally a maximum of 16 bits used to specify the offset of the next
|
||||
link. For patterns that require more space than this, the nodes that
|
||||
jump around are replaced with ones that have wider offsets. Most nodes
|
||||
are unaffected, as they just contain the offset of the next node, and
|
||||
that number is always small. The jump nodes are the ones affected.
|
||||
|
||||
When compiling a pattern, the 16 bit mechanism is used, until it
|
||||
overflows, at which point the pattern is recompiled with the long jumps
|
||||
instead.
|
||||
|
||||
When I rewrote the compiler last year to make it generally one pass, I
|
||||
noticed a lot of the cases where a node was added didn't check if the
|
||||
result overflowed (the function that does this returns FALSE in that
|
||||
case). I presumed the prior authors knew better, and did not change
|
||||
things, except to put in a bogus value in the link (offset) field that
|
||||
should cause a crash if it were used. That's what's happening in this
|
||||
ticket.
|
||||
|
||||
But seeing this example, it's clear that the return value should be
|
||||
checked every time, because you can reach the limit at any time. This
|
||||
commit changes to do that, and to require the function's return value to
|
||||
not be ignored, to guard against future changes.
|
||||
|
||||
My guess is that the reason it generally worked when there were multiple
|
||||
passes is that the first pass didn't do anything except count space, and
|
||||
that at some point before the end of the pass the return value did get
|
||||
checked, so by the time the nodes were allocated for real, it knew
|
||||
enough to use the long jumps.
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
3b2e5620ed4a6b341f97ffd1d4b6466cc2c4bc5b.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 1 +
|
||||
embed.fnc | 4 +-
|
||||
proto.h | 8 ++-
|
||||
regcomp.c | 109 ++++++++++++++++++++++++++++-----------
|
||||
t/re/bigfuzzy_not_utf8.t | Bin 0 -> 36399 bytes
|
||||
5 files changed, 88 insertions(+), 34 deletions(-)
|
||||
create mode 100644 t/re/bigfuzzy_not_utf8.t
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 10e2cc0..cc24cd7 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -5839,6 +5839,7 @@ t/porting/test_bootstrap.t Test that the instructions for test bootstrapping are
|
||||
t/porting/utils.t Check that utility scripts still compile
|
||||
t/re/alpha_assertions.t See if things like '(*postive_lookahed:...) work properly
|
||||
t/re/anyof.t See if bracketed char classes [...] compile properly
|
||||
+t/re/bigfuzzy_not_utf8.t Big and ugly tests not storable as UTF-8
|
||||
t/re/charset.t See if regex modifiers like /d, /u work properly
|
||||
t/re/fold_grind.pl Core file to see if regex case folding works properly
|
||||
t/re/fold_grind_8.t Wrapper for fold_grind.pl for /l testing with a UTF-8 locale
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index c977d39..c2c5f16 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -2427,7 +2427,7 @@ Es |void |reginsert |NN RExC_state_t *pRExC_state \
|
||||
|const U8 op \
|
||||
|const regnode_offset operand \
|
||||
|const U32 depth
|
||||
-Es |bool |regtail |NN RExC_state_t * pRExC_state \
|
||||
+EsR |bool |regtail |NN RExC_state_t * pRExC_state \
|
||||
|NN const regnode_offset p \
|
||||
|NN const regnode_offset val \
|
||||
|const U32 depth
|
||||
@@ -2561,7 +2561,7 @@ Es |void |dump_trie_interim_list|NN const struct _reg_trie_data *trie\
|
||||
Es |void |dump_trie_interim_table|NN const struct _reg_trie_data *trie\
|
||||
|NULLOK HV* widecharmap|NN AV *revcharmap\
|
||||
|U32 next_alloc|U32 depth
|
||||
-Es |bool |regtail_study |NN RExC_state_t *pRExC_state \
|
||||
+EsR |bool |regtail_study |NN RExC_state_t *pRExC_state \
|
||||
|NN regnode_offset p|NN const regnode_offset val|U32 depth
|
||||
# endif
|
||||
#endif
|
||||
diff --git a/proto.h b/proto.h
|
||||
index e0ea55b..2ef7ce2 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -4457,9 +4457,11 @@ PERL_CALLCONV int Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...);
|
||||
assert(fmt)
|
||||
STATIC void S_regdump_extflags(pTHX_ const char *lead, const U32 flags);
|
||||
STATIC void S_regdump_intflags(pTHX_ const char *lead, const U32 flags);
|
||||
-STATIC bool S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, const regnode_offset val, U32 depth);
|
||||
+STATIC bool S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, const regnode_offset val, U32 depth)
|
||||
+ __attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_REGTAIL_STUDY \
|
||||
assert(pRExC_state); assert(p); assert(val)
|
||||
+
|
||||
# endif
|
||||
# if defined(PERL_IN_REGEXEC_C)
|
||||
STATIC void S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8, const char *start, const char *end, const char *blurb);
|
||||
@@ -5599,9 +5601,11 @@ STATIC regnode_offset S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 o
|
||||
STATIC regnode_offset S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth);
|
||||
#define PERL_ARGS_ASSERT_REGPIECE \
|
||||
assert(pRExC_state); assert(flagp)
|
||||
-STATIC bool S_regtail(pTHX_ RExC_state_t * pRExC_state, const regnode_offset p, const regnode_offset val, const U32 depth);
|
||||
+STATIC bool S_regtail(pTHX_ RExC_state_t * pRExC_state, const regnode_offset p, const regnode_offset val, const U32 depth)
|
||||
+ __attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_REGTAIL \
|
||||
assert(pRExC_state); assert(p); assert(val)
|
||||
+
|
||||
STATIC void S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, struct scan_data_t *data, SSize_t *minlenp, int is_inf);
|
||||
#define PERL_ARGS_ASSERT_SCAN_COMMIT \
|
||||
assert(pRExC_state); assert(data); assert(minlenp)
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index dfc22bc..b93fbe7 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -11307,10 +11307,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
return 0;
|
||||
}
|
||||
|
||||
- REGTAIL(pRExC_state, ret, atomic);
|
||||
+ if (! REGTAIL(pRExC_state, ret, atomic)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
|
||||
- REGTAIL(pRExC_state, atomic,
|
||||
- reg_node(pRExC_state, SRCLOSE));
|
||||
+ if (! REGTAIL(pRExC_state, atomic, reg_node(pRExC_state,
|
||||
+ SRCLOSE)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
|
||||
RExC_in_script_run = 0;
|
||||
return ret;
|
||||
@@ -11769,7 +11774,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
RExC_flags & RXf_PMf_COMPILETIME
|
||||
);
|
||||
FLAGS(REGNODE_p(ret)) = 2;
|
||||
- REGTAIL(pRExC_state, ret, eval);
|
||||
+ if (! REGTAIL(pRExC_state, ret, eval)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
/* deal with the length of this later - MJD */
|
||||
return ret;
|
||||
}
|
||||
@@ -11822,7 +11829,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
|
||||
tail = reg(pRExC_state, 1, &flag, depth+1);
|
||||
RETURN_FAIL_ON_RESTART(flag, flagp);
|
||||
- REGTAIL(pRExC_state, ret, tail);
|
||||
+ if (! REGTAIL(pRExC_state, ret, tail)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
goto insert_if;
|
||||
}
|
||||
else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
|
||||
@@ -11914,15 +11923,22 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
}
|
||||
nextchar(pRExC_state);
|
||||
insert_if:
|
||||
- REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
|
||||
+ if (! REGTAIL(pRExC_state, ret, reganode(pRExC_state,
|
||||
+ IFTHEN, 0)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
br = regbranch(pRExC_state, &flags, 1, depth+1);
|
||||
if (br == 0) {
|
||||
RETURN_FAIL_ON_RESTART(flags,flagp);
|
||||
FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
|
||||
(UV) flags);
|
||||
} else
|
||||
- REGTAIL(pRExC_state, br, reganode(pRExC_state,
|
||||
- LONGJMP, 0));
|
||||
+ if (! REGTAIL(pRExC_state, br, reganode(pRExC_state,
|
||||
+ LONGJMP, 0)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
c = UCHARAT(RExC_parse);
|
||||
nextchar(pRExC_state);
|
||||
if (flags&HASWIDTH)
|
||||
@@ -11939,7 +11955,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
|
||||
(UV) flags);
|
||||
}
|
||||
- REGTAIL(pRExC_state, ret, lastbr);
|
||||
+ if (! REGTAIL(pRExC_state, ret, lastbr)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (flags&HASWIDTH)
|
||||
*flagp |= HASWIDTH;
|
||||
c = UCHARAT(RExC_parse);
|
||||
@@ -11954,16 +11972,26 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
vFAIL("Switch (?(condition)... contains too many branches");
|
||||
}
|
||||
ender = reg_node(pRExC_state, TAIL);
|
||||
- REGTAIL(pRExC_state, br, ender);
|
||||
+ if (! REGTAIL(pRExC_state, br, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (lastbr) {
|
||||
- REGTAIL(pRExC_state, lastbr, ender);
|
||||
- REGTAIL(pRExC_state, REGNODE_OFFSET(
|
||||
- NEXTOPER(
|
||||
- NEXTOPER(REGNODE_p(lastbr)))),
|
||||
- ender);
|
||||
+ if (! REGTAIL(pRExC_state, lastbr, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
+ if (! REGTAIL(pRExC_state,
|
||||
+ REGNODE_OFFSET(
|
||||
+ NEXTOPER(
|
||||
+ NEXTOPER(REGNODE_p(lastbr)))),
|
||||
+ ender))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
#if 0 /* Removing this doesn't cause failures in the test suite -- khw */
|
||||
RExC_size++; /* XXX WHY do we need this?!!
|
||||
For large programs it seems to be required
|
||||
@@ -12113,7 +12141,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
*flagp |= flags&SIMPLE;
|
||||
}
|
||||
if (is_open) { /* Starts with OPEN. */
|
||||
- REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
|
||||
+ if (! REGTAIL(pRExC_state, ret, br)) { /* OPEN -> first. */
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else if (paren != '?') /* Not Conditional */
|
||||
ret = br;
|
||||
@@ -12121,12 +12151,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
lastbr = br;
|
||||
while (*RExC_parse == '|') {
|
||||
if (RExC_use_BRANCHJ) {
|
||||
+ bool shut_gcc_up;
|
||||
+
|
||||
ender = reganode(pRExC_state, LONGJMP, 0);
|
||||
|
||||
/* Append to the previous. */
|
||||
- REGTAIL(pRExC_state,
|
||||
- REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
|
||||
- ender);
|
||||
+ shut_gcc_up = REGTAIL(pRExC_state,
|
||||
+ REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
|
||||
+ ender);
|
||||
+ PERL_UNUSED_VAR(shut_gcc_up);
|
||||
}
|
||||
nextchar(pRExC_state);
|
||||
if (freeze_paren) {
|
||||
@@ -12237,9 +12270,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
is_nothing= 0;
|
||||
}
|
||||
else if (op == BRANCHJ) {
|
||||
- REGTAIL_STUDY(pRExC_state,
|
||||
- REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
|
||||
- ender);
|
||||
+ bool shut_gcc_up = REGTAIL_STUDY(pRExC_state,
|
||||
+ REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
|
||||
+ ender);
|
||||
+ PERL_UNUSED_VAR(shut_gcc_up);
|
||||
/* for now we always disable this optimisation * /
|
||||
if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
|
||||
|| regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender))
|
||||
@@ -12551,7 +12585,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
const regnode_offset w = reg_node(pRExC_state, WHILEM);
|
||||
|
||||
FLAGS(REGNODE_p(w)) = 0;
|
||||
- REGTAIL(pRExC_state, ret, w);
|
||||
+ if (! REGTAIL(pRExC_state, ret, w)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (RExC_use_BRANCHJ) {
|
||||
reginsert(pRExC_state, LONGJMP, ret, depth+1);
|
||||
reginsert(pRExC_state, NOTHING, ret, depth+1);
|
||||
@@ -12566,7 +12602,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
if (RExC_use_BRANCHJ)
|
||||
NEXT_OFF(REGNODE_p(ret)) = 3; /* Go over NOTHING to
|
||||
LONGJMP. */
|
||||
- REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
|
||||
+ if (! REGTAIL(pRExC_state, ret, reg_node(pRExC_state,
|
||||
+ NOTHING)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
RExC_whilem_seen++;
|
||||
MARK_NAUGHTY_EXP(1, 4); /* compound interest */
|
||||
}
|
||||
@@ -12638,16 +12678,22 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
if (*RExC_parse == '?') {
|
||||
nextchar(pRExC_state);
|
||||
reginsert(pRExC_state, MINMOD, ret, depth+1);
|
||||
- REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else if (*RExC_parse == '+') {
|
||||
regnode_offset ender;
|
||||
nextchar(pRExC_state);
|
||||
ender = reg_node(pRExC_state, SUCCEED);
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
reginsert(pRExC_state, SUSPEND, ret, depth+1);
|
||||
ender = reg_node(pRExC_state, TAIL);
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
|
||||
if (ISMULT2(RExC_parse)) {
|
||||
@@ -19815,8 +19861,8 @@ S_regtail(pTHX_ RExC_state_t * pRExC_state,
|
||||
}
|
||||
else {
|
||||
if (val - scan > U16_MAX) {
|
||||
- /* Since not all callers check the return value, populate this with
|
||||
- * something that won't loop and will likely lead to a crash if
|
||||
+ /* Populate this with something that won't loop and will likely
|
||||
+ * lead to a crash if the caller ignores the failure return, and
|
||||
* execution continues */
|
||||
NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
|
||||
return FALSE;
|
||||
@@ -19927,6 +19973,9 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p,
|
||||
}
|
||||
else {
|
||||
if (val - scan > U16_MAX) {
|
||||
+ /* Populate this with something that won't loop and will likely
|
||||
+ * lead to a crash if the caller ignores the failure return, and
|
||||
+ * execution continues */
|
||||
NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
|
||||
return FALSE;
|
||||
}
|
||||
diff --git a/t/re/bigfuzzy_not_utf8.t b/t/re/bigfuzzy_not_utf8.t
|
||||
new file mode 100644
|
||||
index 0000000000000000000000000000000000000000..b4dfd150a9297172af5d8e7811357fd68931f8d7
|
||||
GIT binary patch
|
||||
literal 36399
|
||||
zcmeI5y>Ht_6u>V)vj`|)bnw`ot)P-@MMCTpNTQ@6nzlsHpvaKGfa6%8#FNC9CKZxu
|
||||
z;)Jf$YRJ%zoeHDqo_|0?hWr89EXQ;I1&?0XN7}J$MN%l4pVm7V_T9aA@8fqzil1_F
|
||||
zE|;$}O->{eN&28B=@fnhT2nU|t*9E+ShXPw8fDMw8q;-2Rj9#qL#IYfFlbp&QU)zC
|
||||
zsvD}tL@Ma?;e+olU(13qL4mf$Xi2KlMpfR-(n>>?sal~`K`RMWM$0up6UqkD^enA1
|
||||
zg=vB;ZywbQuvXdxGnK~k=b({GBpSNyN0Z7%!KptLG(}RXdLfa}8zrhWl%f+Fv@e<T
|
||||
z7QF(MZ@%O2{zzXWD3o$dlr)+$QdFwY%c5N?I0B75X-E+19aX7F)dH0^>Z)eEZ=O;~
|
||||
z<?^<VTwP8TfX(4J=(JPOnNc)URn{G8|1eoC_e<>oje1d1%IQ=tmzSkdDoay2=T|Pz
|
||||
zo*8+Kr80%Y79{wyR4)RabV^adFWpeZh73a5P-K`EDzb{C0J1N?-Bg5osvt7$#*LDy
|
||||
z8pU1*;Hb;O`}w=|H2|VCNgvil!C)|-F!4`oOre4(0@l39WM)9+aK3^6G2ryE+cJd2
|
||||
zG%)O}9%o(Xh5+npOk+9dJvA{f4-S<VFd0eu$X<3dd1d+P^3wIkj=-L!jZMnkKb#l4
|
||||
zS%FnoE840>Nl&MqX!&&dnrWK5-2KkXUdJ@kJhZYzBs1%)nFU8yw#)YRc86bC;+Jl5
|
||||
zgy&7Z`^Fw(?OiZUet&)S)$APMGYhtb_713ZrNwu<++Ih39!HYq+wJzw?PH0VT{$4+
|
||||
zz%lmLw7_MJYpy#@2q4sQ7fUP%j9esxG8j3)cOk6*w(m~R0TQqY5H30#e)2t(Pe1U0
|
||||
zo7x9RuwyuZKZc9WF8Sr`COoz9_eZT+t&ggp!nq?r$P9^7Qf{`Z-{X`J#)<@xfTsj3
|
||||
zt7*Z}u%|ZB*f}Q9ILEnRY6A%n(u&6pLLV6Zhn*Je^046bHe3TpU@8gBV?hE)AbtcU
|
||||
z+*`#j(Lf`1Pqq2ly)J6Thrs2aLgj*Tgns-Zu;!m>A1&i8UmxMd)HGfL@L=Np^}xmu
|
||||
z6KnnbWTw9d+eiQj_)Fjmf6b$HBoG*ZvmFNFos+;OYFZqXdWnYd{P*jg`)Jij({(%|
|
||||
z`6Q@2v~b4IiYzkMz+$L)vsWgF{`mxB#u(y$sg7Y3RpU)yZB+QhQ9`d|Ekc6YFM1X7
|
||||
zv7KL!Yu;A|z5IoJ9um0Yp{;0|@_teFTYTByaiWdaEl<FRQ}wer1&gsF0VEJ%0z*Cq
|
||||
zPFzulaPT39=F90?E5wAR)%Dpf=7vno3fVuppO8RoQO7l$E%7!gQ^8*6kwlia=^
|
||||
z7B0VddLMEq9(*#931rOF{~Aj_u33(iBr5k4z;mpAB2(G^Zz{9Kq>+G^1Vp#S{&b=E
|
||||
zj|&}JWy0IK6Ap73lq)qn<QR$RqGeqiso;SyjOXJ#2pdfx0VLp>z?y5#A&T&w<H48c
|
||||
zUiJx|1$vwg0zrO}lpkL`u+~3K_<CVK5ue+x_nNLxR(uXP3g#_eo?nPUW*EaL0(kl}
|
||||
zicZin*SoHPf#Jg+1F=k5r(avNUv|&?^aT4NA<j}5>#6r1;mt7IkM<dnBRjm-J$jnL
|
||||
zl=}L=Xoe&f=@$t@+-3rNH|>W2eFfxdF(5w^x}jvkffEfIvgHNTjXV5+K%<*L3ET_R
|
||||
z+c|c&wLM;PQ@lgr#v_H=NB{{Sfw2f&z<1F4c?Err>gK7){ur^11cD`i`-xzApY~Qf
|
||||
z-Soco%zKmLS;Xfudc5$tj2??=s^NXSD9!fSp38_*Cb5m>t!bHAQk&zN(xREQTJ4>c
|
||||
zC4OI8w7BN_>Y<Q`P|Yl)JEqC+?<=onyWQ@36FPXvI!i<{<A|?8t9(>=zWZjEyWg?)
|
||||
z-~n%be|`1U>>S}U3wvP0@z9kP-|cdH9RYeANt%btP&>Dm_#=s#T{$4+fFnF_9>oX|
|
||||
zooo&c`N+|sIY^}|4akg;3*^W-WYBK!OJAAU-%N9Mt_49ZzRWCquG}WPRkz@uPUllu
|
||||
jIzOMKFSg+CqdL=Mn!K`nb$RLf<M~V>L7{9Vwi5pX0LDXb
|
||||
|
||||
literal 0
|
||||
HcmV?d00001
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,75 @@
|
||||
From 7e5b390a008ccad094a39c350f385d58e8a5102a Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Fri, 3 May 2019 13:57:47 -0600
|
||||
Subject: [PATCH] Remove undefined behavior from IV shifting
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
It is undefined behavior to shift a negative integer to the left. This
|
||||
commit avoids that by treating the value as unsigned, then casting back
|
||||
to integer for return.
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
814735a391b874af8f00eaf89469e5ec7f38cd4aa.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
asan_ignore | 5 -----
|
||||
pp.c | 21 ++++++++++++++++++++-
|
||||
2 files changed, 20 insertions(+), 6 deletions(-)
|
||||
|
||||
diff --git a/asan_ignore b/asan_ignore
|
||||
index e0f5685..f520546 100644
|
||||
--- a/asan_ignore
|
||||
+++ b/asan_ignore
|
||||
@@ -18,11 +18,6 @@
|
||||
|
||||
fun:Perl_pp_i_*
|
||||
|
||||
-# Perl's << is defined as using the underlying C's << operator, with the
|
||||
-# same undefined behaviour for shifts greater than the word size.
|
||||
-# (UVs normally, IVs with 'use integer')
|
||||
-
|
||||
-fun:Perl_pp_left_shift
|
||||
|
||||
# this function numifies the field width in eg printf "%10f".
|
||||
# It has its own overflow detection, so don't warn about it
|
||||
diff --git a/pp.c b/pp.c
|
||||
index 7afb090..3ca04e1 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1991,10 +1991,29 @@ static IV S_iv_shift(IV iv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
+
|
||||
if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return iv < 0 && !left ? -1 : 0;
|
||||
}
|
||||
- return left ? iv << shift : iv >> shift;
|
||||
+ /* For left shifts, perl 5 has chosen to treat the value as unsigned for
|
||||
+ * the * purposes of shifting, then cast back to signed. This is very
|
||||
+ * different from perl 6:
|
||||
+ *
|
||||
+ * $ perl6 -e 'say -2 +< 5'
|
||||
+ * -64
|
||||
+ *
|
||||
+ * $ ./perl -le 'print -2 << 5'
|
||||
+ * 18446744073709551552
|
||||
+ * */
|
||||
+ if (left) {
|
||||
+ if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
|
||||
+ return 0;
|
||||
+ }
|
||||
+ return (IV) (((UV) iv) << shift);
|
||||
+ }
|
||||
+
|
||||
+ /* Here is right shift */
|
||||
+ return iv >> shift;
|
||||
}
|
||||
|
||||
#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,191 @@
|
||||
From 8e9cf86aa69cb79c91edf5ff0586f87bfe4c91bd Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 2 Jul 2019 14:16:35 +1000
|
||||
Subject: [PATCH] (perl #134221) support append mode for open .. undef
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
45b29440d38be155c5177c8d6f9a5d4e7c2c098c.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
doio.c | 15 +++++++++++++++
|
||||
embed.fnc | 1 +
|
||||
perlio.c | 26 +++++++++++++++++++++-----
|
||||
perlio.h | 3 +++
|
||||
proto.h | 5 +++++
|
||||
t/io/perlio_open.t | 14 ++++++++++++--
|
||||
6 files changed, 57 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/doio.c b/doio.c
|
||||
index 05a0696..424e0e3 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -265,6 +265,21 @@ Perl_my_mkstemp_cloexec(char *templte)
|
||||
#endif
|
||||
}
|
||||
|
||||
+int
|
||||
+Perl_my_mkostemp_cloexec(char *templte, int flags)
|
||||
+{
|
||||
+ dVAR;
|
||||
+ PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC;
|
||||
+#if defined(O_CLOEXEC)
|
||||
+ DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
|
||||
+ PL_strategy_mkstemp,
|
||||
+ Perl_my_mkostemp(templte, flags | O_CLOEXEC),
|
||||
+ Perl_my_mkostemp(templte, flags));
|
||||
+#else
|
||||
+ DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags));
|
||||
+#endif
|
||||
+}
|
||||
+
|
||||
#ifdef HAS_PIPE
|
||||
int
|
||||
Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index 259affd..c977d39 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -476,6 +476,7 @@ p |int |PerlLIO_dup2_cloexec|int oldfd|int newfd
|
||||
pR |int |PerlLIO_open_cloexec|NN const char *file|int flag
|
||||
pR |int |PerlLIO_open3_cloexec|NN const char *file|int flag|int perm
|
||||
pnoR |int |my_mkstemp_cloexec|NN char *templte
|
||||
+pnoR |int |my_mkostemp_cloexec|NN char *templte|int flags
|
||||
#ifdef HAS_PIPE
|
||||
pR |int |PerlProc_pipe_cloexec|NN int *pipefd
|
||||
#endif
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index 904d47a..5a0cd36 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -1490,7 +1490,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
|
||||
int imode, int perm, PerlIO *f, int narg, SV **args)
|
||||
{
|
||||
if (!f && narg == 1 && *args == &PL_sv_undef) {
|
||||
- if ((f = PerlIO_tmpfile())) {
|
||||
+ int imode = PerlIOUnix_oflags(mode);
|
||||
+
|
||||
+ if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
|
||||
if (!layers || !*layers)
|
||||
layers = Perl_PerlIO_context_layers(aTHX_ mode);
|
||||
if (layers && *layers)
|
||||
@@ -5048,6 +5050,15 @@ PerlIO_stdoutf(const char *fmt, ...)
|
||||
#undef PerlIO_tmpfile
|
||||
PerlIO *
|
||||
PerlIO_tmpfile(void)
|
||||
+{
|
||||
+ return PerlIO_tmpfile_flags(0);
|
||||
+}
|
||||
+
|
||||
+#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
|
||||
+#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
|
||||
+
|
||||
+PerlIO *
|
||||
+PerlIO_tmpfile_flags(int imode)
|
||||
{
|
||||
#ifndef WIN32
|
||||
dTHX;
|
||||
@@ -5063,27 +5074,32 @@ PerlIO_tmpfile(void)
|
||||
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
|
||||
SV * sv = NULL;
|
||||
int old_umask = umask(0177);
|
||||
+ imode &= ~MKOSTEMP_MODE_MASK;
|
||||
if (tmpdir && *tmpdir) {
|
||||
/* if TMPDIR is set and not empty, we try that first */
|
||||
sv = newSVpv(tmpdir, 0);
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
}
|
||||
if (fd < 0) {
|
||||
SvREFCNT_dec(sv);
|
||||
sv = NULL;
|
||||
/* else we try /tmp */
|
||||
- fd = Perl_my_mkstemp_cloexec(tempname);
|
||||
+ fd = Perl_my_mkostemp_cloexec(tempname, imode);
|
||||
}
|
||||
if (fd < 0) {
|
||||
/* Try cwd */
|
||||
sv = newSVpvs(".");
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
}
|
||||
umask(old_umask);
|
||||
if (fd >= 0) {
|
||||
- f = PerlIO_fdopen(fd, "w+");
|
||||
+ /* fdopen() with a numeric mode */
|
||||
+ char mode[8];
|
||||
+ int writing = 1;
|
||||
+ (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
|
||||
+ f = PerlIO_fdopen(fd, mode);
|
||||
if (f)
|
||||
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
|
||||
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
|
||||
diff --git a/perlio.h b/perlio.h
|
||||
index d515020..ee16ab8 100644
|
||||
--- a/perlio.h
|
||||
+++ b/perlio.h
|
||||
@@ -286,6 +286,9 @@ PERL_CALLCONV SSize_t PerlIO_get_bufsiz(PerlIO *);
|
||||
#ifndef PerlIO_tmpfile
|
||||
PERL_CALLCONV PerlIO *PerlIO_tmpfile(void);
|
||||
#endif
|
||||
+#ifndef PerlIO_tmpfile_flags
|
||||
+PERL_CALLCONV PerlIO *PerlIO_tmpfile_flags(int flags);
|
||||
+#endif
|
||||
#ifndef PerlIO_stdin
|
||||
PERL_CALLCONV PerlIO *PerlIO_stdin(void);
|
||||
#endif
|
||||
diff --git a/proto.h b/proto.h
|
||||
index 74a8e46..e0ea55b 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -2270,6 +2270,11 @@ PERL_CALLCONV Pid_t Perl_my_fork(void);
|
||||
PERL_CALLCONV I32 Perl_my_lstat(pTHX);
|
||||
#endif
|
||||
PERL_CALLCONV I32 Perl_my_lstat_flags(pTHX_ const U32 flags);
|
||||
+PERL_CALLCONV int Perl_my_mkostemp_cloexec(char *templte, int flags)
|
||||
+ __attribute__warn_unused_result__;
|
||||
+#define PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC \
|
||||
+ assert(templte)
|
||||
+
|
||||
PERL_CALLCONV int Perl_my_mkstemp_cloexec(char *templte)
|
||||
__attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC \
|
||||
diff --git a/t/io/perlio_open.t b/t/io/perlio_open.t
|
||||
index 99d7e51..56c354b 100644
|
||||
--- a/t/io/perlio_open.t
|
||||
+++ b/t/io/perlio_open.t
|
||||
@@ -11,7 +11,7 @@ BEGIN {
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
-plan tests => 6;
|
||||
+plan tests => 10;
|
||||
|
||||
use Fcntl qw(:seek);
|
||||
|
||||
@@ -31,6 +31,16 @@ use Fcntl qw(:seek);
|
||||
is($data, "the right read stuff", "found the right stuff");
|
||||
}
|
||||
|
||||
-
|
||||
+SKIP:
|
||||
+{
|
||||
+ ok((open my $fh, "+>>", undef), "open my \$fh, '+>>', undef")
|
||||
+ or skip "can't open temp for append: $!", 3;
|
||||
+ print $fh "abc";
|
||||
+ ok(seek($fh, 0, SEEK_SET), "seek to zero");
|
||||
+ print $fh "xyz";
|
||||
+ ok(seek($fh, 0, SEEK_SET), "seek to zero again");
|
||||
+ my $data = <$fh>;
|
||||
+ is($data, "abcxyz", "check the second write appended");
|
||||
+}
|
||||
|
||||
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,102 @@
|
||||
From 3f8dbf40138bd2bcb569b23c88888a41ede9c355 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 5 Aug 2019 15:23:45 +1000
|
||||
Subject: [PATCH] (perl #134266) make sure $@ is writable when we write to it
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
when unwinding.
|
||||
|
||||
Since except_sv might be ERRSV we try to preserve it's value,
|
||||
if not the actual SV (which we have an extra refcount on if it is
|
||||
except_sv).
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
933e3e630076d4fdbe32a101eeb5f12e37ec4ac2.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perl.h | 17 +++++++++++++++++
|
||||
pp_ctl.c | 10 ++++++++--
|
||||
t/lib/croak/pp_ctl | 8 ++++++++
|
||||
3 files changed, 33 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/perl.h b/perl.h
|
||||
index e5a5585..383487c 100644
|
||||
--- a/perl.h
|
||||
+++ b/perl.h
|
||||
@@ -1357,6 +1357,23 @@ EXTERN_C char *crypt(const char *, const char *);
|
||||
} \
|
||||
} STMT_END
|
||||
|
||||
+/* contains inlined gv_add_by_type */
|
||||
+#define SANE_ERRSV() STMT_START { \
|
||||
+ SV ** const svp = &GvSV(PL_errgv); \
|
||||
+ if (!*svp) { \
|
||||
+ *svp = newSVpvs(""); \
|
||||
+ } else if (SvREADONLY(*svp)) { \
|
||||
+ SV *dupsv = newSVsv(*svp); \
|
||||
+ SvREFCNT_dec_NN(*svp); \
|
||||
+ *svp = dupsv; \
|
||||
+ } else { \
|
||||
+ SV *const errsv = *svp; \
|
||||
+ if (SvMAGICAL(errsv)) { \
|
||||
+ mg_free(errsv); \
|
||||
+ } \
|
||||
+ } \
|
||||
+ } STMT_END
|
||||
+
|
||||
|
||||
#ifdef PERL_CORE
|
||||
# define DEFSV (0 + GvSVn(PL_defgv))
|
||||
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||
index a38b9c1..1f2d812 100644
|
||||
--- a/pp_ctl.c
|
||||
+++ b/pp_ctl.c
|
||||
@@ -1720,9 +1720,13 @@ Perl_die_unwind(pTHX_ SV *msv)
|
||||
* perls 5.13.{1..7} which had late setting of $@ without this
|
||||
* early-setting hack.
|
||||
*/
|
||||
- if (!(in_eval & EVAL_KEEPERR))
|
||||
+ if (!(in_eval & EVAL_KEEPERR)) {
|
||||
+ /* remove any read-only/magic from the SV, so we don't
|
||||
+ get infinite recursion when setting ERRSV */
|
||||
+ SANE_ERRSV();
|
||||
sv_setsv_flags(ERRSV, exceptsv,
|
||||
(SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
|
||||
+ }
|
||||
|
||||
if (in_eval & EVAL_KEEPERR) {
|
||||
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
|
||||
@@ -1784,8 +1788,10 @@ Perl_die_unwind(pTHX_ SV *msv)
|
||||
*/
|
||||
S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
|
||||
|
||||
- if (!(in_eval & EVAL_KEEPERR))
|
||||
+ if (!(in_eval & EVAL_KEEPERR)) {
|
||||
+ SANE_ERRSV();
|
||||
sv_setsv(ERRSV, exceptsv);
|
||||
+ }
|
||||
PL_restartjmpenv = restartjmpenv;
|
||||
PL_restartop = restartop;
|
||||
JMPENV_JUMP(3);
|
||||
diff --git a/t/lib/croak/pp_ctl b/t/lib/croak/pp_ctl
|
||||
index b1e754c..de0221b 100644
|
||||
--- a/t/lib/croak/pp_ctl
|
||||
+++ b/t/lib/croak/pp_ctl
|
||||
@@ -51,3 +51,11 @@ use 5.01;
|
||||
default{}
|
||||
EXPECT
|
||||
Can't "default" outside a topicalizer at - line 2.
|
||||
+########
|
||||
+# NAME croak with read only $@
|
||||
+eval '"a" =~ /${*@=\_})/';
|
||||
+die;
|
||||
+# this would previously recurse infinitely in the eval
|
||||
+EXPECT
|
||||
+Unmatched ) in regex; marked by <-- HERE in m/_) <-- HERE / at (eval 1) line 1.
|
||||
+ ...propagated at - line 2.
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,42 @@
|
||||
From 4f0ded009bf6de2da6a2a2022bec03576dcb80ca Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Wed, 1 May 2019 10:41:38 -0600
|
||||
Subject: [PATCH] pp.c: Add two UNLIKELY()s
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
It should be uncommon to shift beyond a full word
|
||||
|
||||
Signed-off-by: Ported to 5.30.0 from
|
||||
bae047b68c92622bb4bb04499e36cdaa48138909.
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp.c | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index 90db3a0..7afb090 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1979,7 +1979,7 @@ static UV S_uv_shift(UV uv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
- if (shift >= IV_BITS) {
|
||||
+ if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return 0;
|
||||
}
|
||||
return left ? uv << shift : uv >> shift;
|
||||
@@ -1991,7 +1991,7 @@ static IV S_iv_shift(IV iv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
- if (shift >= IV_BITS) {
|
||||
+ if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return iv < 0 && !left ? -1 : 0;
|
||||
}
|
||||
return left ? iv << shift : iv >> shift;
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,47 @@
|
||||
From a0148bb8496444302b087bc0ffcf8dad42f8e475 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 11 Nov 2019 14:43:42 +1100
|
||||
Subject: [PATCH] handle s being updated without len being updated
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
fix #17279
|
||||
|
||||
Petr Písař: Ported to 5.30.1 from
|
||||
e56dfd967ce460481a9922d14e931b438548093d.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
numeric.c | 2 +-
|
||||
t/lib/croak/regcomp | 4 ++++
|
||||
2 files changed, 5 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/numeric.c b/numeric.c
|
||||
index d6ce53e..35adebe 100644
|
||||
--- a/numeric.c
|
||||
+++ b/numeric.c
|
||||
@@ -1552,7 +1552,7 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
|
||||
/* strtold() accepts 0x-prefixed hex and in POSIX implementations,
|
||||
0b-prefixed binary numbers, which is backward incompatible
|
||||
*/
|
||||
- if ((len == 0 || len >= 2) && *s == '0' &&
|
||||
+ if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
|
||||
(isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
|
||||
*value = 0;
|
||||
return (char *)s+1;
|
||||
diff --git a/t/lib/croak/regcomp b/t/lib/croak/regcomp
|
||||
index 0ba705e..c0c2710 100644
|
||||
--- a/t/lib/croak/regcomp
|
||||
+++ b/t/lib/croak/regcomp
|
||||
@@ -70,3 +70,7 @@ qr/((a))/;
|
||||
EXPECT
|
||||
Too many nested open parens in regex; marked by <-- HERE in m/(( <-- HERE a))/ at - line 3.
|
||||
########
|
||||
+# NAME numeric parsing buffer overflow in numeric.c
|
||||
+0=~/\p{nV:-0}/
|
||||
+EXPECT
|
||||
+Can't find Unicode property definition "nV:-0" in regex; marked by <-- HERE in m/\p{nV:-0} <-- HERE / at - line 1.
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,116 @@
|
||||
From b061e315b4eac4d82edb3ca14581805417a68936 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 11 Sep 2019 11:50:23 +1000
|
||||
Subject: [PATCH] (perl #125557) correctly handle overload for bin/oct floats
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The hexfp code doesn't check that the shift is 4, and so also
|
||||
accepts binary and octal fp numbers.
|
||||
|
||||
Unfortunately the call to S_new_constant() always passed a prefix
|
||||
of 0x, so overloading would be trying to parse the wrong number.
|
||||
|
||||
Another option is to simply allow only hex floats, though some work
|
||||
was done in 131894 to improve oct/bin float support.
|
||||
|
||||
Petr Písař: Ported to 5.30.1 from
|
||||
2cb5a7e8af11acb0eca22421ec5a4df7ef18e2a9.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/hexfp.t | 16 +++++++++++++++-
|
||||
toke.c | 21 ++++++++++++++++-----
|
||||
2 files changed, 31 insertions(+), 6 deletions(-)
|
||||
|
||||
diff --git a/t/op/hexfp.t b/t/op/hexfp.t
|
||||
index 64f8136..0f239d4 100644
|
||||
--- a/t/op/hexfp.t
|
||||
+++ b/t/op/hexfp.t
|
||||
@@ -10,7 +10,7 @@ use strict;
|
||||
|
||||
use Config;
|
||||
|
||||
-plan(tests => 123);
|
||||
+plan(tests => 125);
|
||||
|
||||
# Test hexfloat literals.
|
||||
|
||||
@@ -277,6 +277,20 @@ is(0b1p0, 1);
|
||||
is(0b10p0, 2);
|
||||
is(0b1.1p0, 1.5);
|
||||
|
||||
+# previously these would pass "0x..." to the overload instead of the appropriate
|
||||
+# "0b" or "0" prefix.
|
||||
+fresh_perl_is(<<'CODE', "1", {}, "overload binary fp");
|
||||
+use overload;
|
||||
+BEGIN { overload::constant float => sub { return eval $_[0]; }; }
|
||||
+print 0b0.1p1;
|
||||
+CODE
|
||||
+
|
||||
+fresh_perl_is(<<'CODE', "1", {}, "overload octal fp");
|
||||
+use overload;
|
||||
+BEGIN { overload::constant float => sub { return eval $_[0]; }; }
|
||||
+print 00.1p3;
|
||||
+CODE
|
||||
+
|
||||
# sprintf %a/%A testing is done in sprintf2.t,
|
||||
# trickier than necessary because of long doubles,
|
||||
# and because looseness of the spec.
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 03c4f2b..3fa20dc 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -10966,6 +10966,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
const char *lastub = NULL; /* position of last underbar */
|
||||
static const char* const number_too_long = "Number too long";
|
||||
bool warned_about_underscore = 0;
|
||||
+ I32 shift; /* shift per digit for hex/oct/bin, hoisted here for fp */
|
||||
#define WARN_ABOUT_UNDERSCORE() \
|
||||
do { \
|
||||
if (!warned_about_underscore) { \
|
||||
@@ -11012,8 +11013,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
{
|
||||
/* variables:
|
||||
u holds the "number so far"
|
||||
- shift the power of 2 of the base
|
||||
- (hex == 4, octal == 3, binary == 1)
|
||||
overflowed was the number more than we can hold?
|
||||
|
||||
Shift is used when we add a digit. It also serves as an "are
|
||||
@@ -11022,7 +11021,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
*/
|
||||
NV n = 0.0;
|
||||
UV u = 0;
|
||||
- I32 shift;
|
||||
bool overflowed = FALSE;
|
||||
bool just_zero = TRUE; /* just plain 0 or binary number? */
|
||||
static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
|
||||
@@ -11369,8 +11367,21 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
if (hexfp) {
|
||||
floatit = TRUE;
|
||||
*d++ = '0';
|
||||
- *d++ = 'x';
|
||||
- s = start + 2;
|
||||
+ switch (shift) {
|
||||
+ case 4:
|
||||
+ *d++ = 'x';
|
||||
+ s = start + 2;
|
||||
+ break;
|
||||
+ case 3:
|
||||
+ s = start + 1;
|
||||
+ break;
|
||||
+ case 1:
|
||||
+ *d++ = 'b';
|
||||
+ s = start + 2;
|
||||
+ break;
|
||||
+ default:
|
||||
+ NOT_REACHED; /* NOTREACHED */
|
||||
+ }
|
||||
}
|
||||
|
||||
/* read next group of digits and _ and copy into d */
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,85 @@
|
||||
From 1a1d29aaa2e0c668f9a8c960d52b516415f28983 Mon Sep 17 00:00:00 2001
|
||||
From: Vickenty Fesunov <kent@setattr.net>
|
||||
Date: Fri, 22 Sep 2017 19:00:46 -0400
|
||||
Subject: [PATCH] %{^CAPTURE_ALL} was intended to be an alias for %-; make it
|
||||
so.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
For: RT #131867
|
||||
|
||||
Add Vickenty Fesunov to AUTHORS.
|
||||
|
||||
Signed-off-by: Ported to 5.30 from 1a1d29aaa2e0c668f9a8c960d52b516415f28983.
|
||||
|
||||
---
|
||||
AUTHORS | 1 +
|
||||
ext/Tie-Hash-NamedCapture/NamedCapture.xs | 5 ++++-
|
||||
ext/Tie-Hash-NamedCapture/t/tiehash.t | 11 ++++++++---
|
||||
|
||||
diff --git a/AUTHORS b/AUTHORS
|
||||
index 0091100600..c920d52e96 100644
|
||||
--- a/AUTHORS
|
||||
+++ b/AUTHORS
|
||||
@@ -1265,6 +1265,7 @@ Unicode Consortium <unicode.org>
|
||||
Vadim Konovalov <vkonovalov@lucent.com>
|
||||
Valeriy E. Ushakov <uwe@ptc.spbu.ru>
|
||||
Vernon Lyon <vlyon@cpan.org>
|
||||
+Vickenty Fesunov <kent@setattr.net>
|
||||
Victor Adam <victor@drawall.cc>
|
||||
Victor Efimov <victor@vsespb.ru>
|
||||
Viktor Turskyi <koorchik@gmail.com>
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/NamedCapture.xs b/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
index 7eaae5614d..a607c10090 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
+++ b/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
@@ -25,8 +25,11 @@ _tie_it(SV *sv)
|
||||
GV * const gv = (GV *)sv;
|
||||
HV * const hv = GvHVn(gv);
|
||||
SV *rv = newSV_type(SVt_RV);
|
||||
+ const char *gv_name = GvNAME(gv);
|
||||
CODE:
|
||||
- SvRV_set(rv, newSVuv(*GvNAME(gv) == '-' ? RXapif_ALL : RXapif_ONE));
|
||||
+ SvRV_set(rv, newSVuv(
|
||||
+ strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
|
||||
+ ? RXapif_ALL : RXapif_ONE));
|
||||
SvROK_on(rv);
|
||||
sv_bless(rv, GvSTASH(CvGV(cv)));
|
||||
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/t/tiehash.t b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
index 3ebc81ad68..962754085f 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
+++ b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
@@ -3,7 +3,12 @@ use strict;
|
||||
|
||||
use Test::More;
|
||||
|
||||
-my %hashes = ('+' => \%+, '-' => \%-);
|
||||
+my %hashes = (
|
||||
+ '+' => \%+,
|
||||
+ '-' => \%-,
|
||||
+ '{^CAPTURE}' => \%{^CAPTURE},
|
||||
+ '{^CAPTURE_ALL}' => \%{^CAPTURE_ALL},
|
||||
+);
|
||||
|
||||
foreach (['plus1'],
|
||||
['minus1', all => 1],
|
||||
@@ -20,12 +25,12 @@ foreach (['plus1'],
|
||||
is("abcdef" =~ /(?<foo>[ab])*(?<bar>c)(?<foo>d)(?<bar>[ef]*)/, 1,
|
||||
"We matched");
|
||||
|
||||
-foreach my $name (qw(+ plus1 plus2 plus3)) {
|
||||
+foreach my $name (qw(+ {^CAPTURE} plus1 plus2 plus3)) {
|
||||
my $hash = $hashes{$name};
|
||||
is_deeply($hash, { foo => 'b', bar => 'c' }, "%$name is as expected");
|
||||
}
|
||||
|
||||
-foreach my $name (qw(- minus1 minus2)) {
|
||||
+foreach my $name (qw(- {^CAPTURE_ALL} minus1 minus2)) {
|
||||
my $hash = $hashes{$name};
|
||||
is_deeply($hash, { foo => [qw(b d)], bar => [qw(c ef)] },
|
||||
"%$name is as expected");
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,181 @@
|
||||
From 3a019afd6f6291c3249c254b5c01e244e4ec83ab Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sun, 28 Apr 2019 17:42:44 -0600
|
||||
Subject: [PATCH 1/3] Create fcn for lossless conversion of NV to IV
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Essentially the same code was being used in three places, and had
|
||||
undefined C behavior for some inputs.
|
||||
|
||||
This consolidates the code into one inline function, and rewrites it to
|
||||
avoid undefined behavior.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
embed.fnc | 1 +
|
||||
embed.h | 3 +++
|
||||
inline.h | 34 ++++++++++++++++++++++++++++++++++
|
||||
pp.c | 20 ++++----------------
|
||||
pp_hot.c | 10 ++--------
|
||||
proto.h | 7 +++++++
|
||||
6 files changed, 51 insertions(+), 24 deletions(-)
|
||||
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index 45597f67b6..259affded0 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -2272,6 +2272,7 @@ sR |SV* |refto |NN SV* sv
|
||||
: Used in pp_hot.c
|
||||
pRxo |GV* |softref2xv |NN SV *const sv|NN const char *const what \
|
||||
|const svtype type|NN SV ***spp
|
||||
+inR |bool |lossless_NV_to_IV|const NV nv|NN IV * ivp
|
||||
#endif
|
||||
|
||||
#if defined(PERL_IN_PP_PACK_C)
|
||||
diff --git a/embed.h b/embed.h
|
||||
index 75c91f77f4..9178c51e92 100644
|
||||
--- a/embed.h
|
||||
+++ b/embed.h
|
||||
@@ -1924,6 +1924,9 @@
|
||||
#define do_delete_local() S_do_delete_local(aTHX)
|
||||
#define refto(a) S_refto(aTHX_ a)
|
||||
# endif
|
||||
+# if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+#define lossless_NV_to_IV S_lossless_NV_to_IV
|
||||
+# endif
|
||||
# if defined(PERL_IN_PP_CTL_C)
|
||||
#define check_type_and_open(a) S_check_type_and_open(aTHX_ a)
|
||||
#define destroy_matcher(a) S_destroy_matcher(aTHX_ a)
|
||||
diff --git a/inline.h b/inline.h
|
||||
index 654f801b75..de1e33e8ce 100644
|
||||
--- a/inline.h
|
||||
+++ b/inline.h
|
||||
@@ -1913,6 +1913,40 @@ S_should_warn_nl(const char *pv) {
|
||||
|
||||
#endif
|
||||
|
||||
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+
|
||||
+PERL_STATIC_INLINE bool
|
||||
+S_lossless_NV_to_IV(const NV nv, IV *ivp)
|
||||
+{
|
||||
+ /* This function determines if the input NV 'nv' may be converted without
|
||||
+ * loss of data to an IV. If not, it returns FALSE taking no other action.
|
||||
+ * But if it is possible, it does the conversion, returning TRUE, and
|
||||
+ * storing the converted result in '*ivp' */
|
||||
+
|
||||
+ PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
|
||||
+
|
||||
+# if defined(Perl_isnan)
|
||||
+
|
||||
+ if (UNLIKELY(Perl_isnan(nv))) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+# endif
|
||||
+
|
||||
+ if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+ if ((IV) nv != nv) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+ *ivp = (IV) nv;
|
||||
+ return TRUE;
|
||||
+}
|
||||
+
|
||||
+#endif
|
||||
+
|
||||
/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
|
||||
|
||||
#define MAX_CHARSET_NAME_LENGTH 2
|
||||
diff --git a/pp.c b/pp.c
|
||||
index c89cb7198c..0956121b27 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1268,16 +1268,10 @@ PP(pp_multiply)
|
||||
NV nr = SvNVX(svr);
|
||||
NV result;
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
result = nl * nr;
|
||||
# if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
|
||||
@@ -1849,16 +1843,10 @@ PP(pp_subtract)
|
||||
NV nl = SvNVX(svl);
|
||||
NV nr = SvNVX(svr);
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
|
||||
SETs(TARG);
|
||||
diff --git a/pp_hot.c b/pp_hot.c
|
||||
index 7d5ffc02fd..2df5df8303 100644
|
||||
--- a/pp_hot.c
|
||||
+++ b/pp_hot.c
|
||||
@@ -1435,16 +1435,10 @@ PP(pp_add)
|
||||
NV nl = SvNVX(svl);
|
||||
NV nr = SvNVX(svr);
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
|
||||
SETs(TARG);
|
||||
diff --git a/proto.h b/proto.h
|
||||
index 0f8feed187..74a8e46ab7 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -5224,6 +5224,13 @@ STATIC SV* S_refto(pTHX_ SV* sv)
|
||||
|
||||
#endif
|
||||
#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+#ifndef PERL_NO_INLINE_FUNCTIONS
|
||||
+PERL_STATIC_INLINE bool S_lossless_NV_to_IV(const NV nv, IV * ivp)
|
||||
+ __attribute__warn_unused_result__;
|
||||
+#define PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV \
|
||||
+ assert(ivp)
|
||||
+#endif
|
||||
+
|
||||
PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const svtype type, SV ***spp)
|
||||
__attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_SOFTREF2XV \
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,87 @@
|
||||
From 1d31efef7dd4388fd606972e67bda3318e8838fe Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= <ilmari@ilmari.org>
|
||||
Date: Tue, 21 May 2019 17:34:49 +0100
|
||||
Subject: [PATCH] Don't use PL_check[op_type] to check for filetets ops to
|
||||
stack
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This breaks hooking the filetest ops' check function by modules like
|
||||
bareword::filehandles. Instead use the OP_IS_FILETEST() macro to decide
|
||||
check for filetest ops. Also add an OP_IS_STAT() macro for when we want
|
||||
to check for (l)stat as well as the filetest ops.
|
||||
|
||||
c.f. https://rt.cpan.org/Ticket/Display.html?id=127073
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 11 ++++-------
|
||||
op.h | 2 ++
|
||||
regen/opcodes | 1 +
|
||||
3 files changed, 7 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index 29181ba731..dba7ac7fea 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -991,8 +991,7 @@ Perl_op_clear(pTHX_ OP *o)
|
||||
o->op_targ = 0;
|
||||
break;
|
||||
default:
|
||||
- if (!(o->op_flags & OPf_REF)
|
||||
- || (PL_check[o->op_type] != Perl_ck_ftst))
|
||||
+ if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
|
||||
break;
|
||||
/* FALLTHROUGH */
|
||||
case OP_GVSV:
|
||||
@@ -4413,8 +4412,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
|
||||
/* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
|
||||
their argument is a filehandle; thus \stat(".") should not set
|
||||
it. AMS 20011102 */
|
||||
- if (type == OP_REFGEN &&
|
||||
- PL_check[o->op_type] == Perl_ck_ftst)
|
||||
+ if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
|
||||
return o;
|
||||
|
||||
if (type != OP_LEAVESUBLV)
|
||||
@@ -11696,9 +11694,8 @@ Perl_ck_ftst(pTHX_ OP *o)
|
||||
scalar((OP *) kid);
|
||||
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
|
||||
o->op_private |= OPpFT_ACCESS;
|
||||
- if (type != OP_STAT && type != OP_LSTAT
|
||||
- && PL_check[kidtype] == Perl_ck_ftst
|
||||
- && kidtype != OP_STAT && kidtype != OP_LSTAT
|
||||
+ if (OP_IS_FILETEST(type)
|
||||
+ && OP_IS_FILETEST(kidtype)
|
||||
) {
|
||||
o->op_private |= OPpFT_STACKED;
|
||||
kid->op_private |= OPpFT_STACKING;
|
||||
diff --git a/op.h b/op.h
|
||||
index c9f05b2271..ad6cf7fe49 100644
|
||||
--- a/op.h
|
||||
+++ b/op.h
|
||||
@@ -1021,6 +1021,8 @@ C<sib> is non-null. For a higher-level interface, see C<L</op_sibling_splice>>.
|
||||
#define OP_TYPE_ISNT_AND_WASNT(o, type) \
|
||||
( (o) && OP_TYPE_ISNT_AND_WASNT_NN(o, type) )
|
||||
|
||||
+/* should match anything that uses ck_ftst in regen/opcodes */
|
||||
+#define OP_IS_STAT(op) (OP_IS_FILETEST(op) || (op) == OP_LSTAT || (op) == OP_STAT)
|
||||
|
||||
# define OpHAS_SIBLING(o) (cBOOL((o)->op_moresib))
|
||||
# define OpSIBLING(o) (0 + (o)->op_moresib ? (o)->op_sibparent : NULL)
|
||||
diff --git a/regen/opcodes b/regen/opcodes
|
||||
index b4bf904fdc..4e8236947a 100644
|
||||
--- a/regen/opcodes
|
||||
+++ b/regen/opcodes
|
||||
@@ -397,6 +397,7 @@ getsockname getsockname ck_fun is% Fs
|
||||
getpeername getpeername ck_fun is% Fs
|
||||
|
||||
# Stat calls. OP_IS_FILETEST wants them consecutive.
|
||||
+# Also needs to match OP_IS_STAT() in op.h
|
||||
|
||||
lstat lstat ck_ftst u- F?
|
||||
stat stat ck_ftst u- F?
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,75 @@
|
||||
From cc16d262eb72677cdda2aa9395e943818b85ba38 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 29 Apr 2019 15:24:18 -0600
|
||||
Subject: [PATCH] PATCH: [perl #134059] panic outputting a warning
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This was due to a logic error on my part. We need to save and restore a
|
||||
value. Instead, it was getting restored to the wrong value.
|
||||
|
||||
This particular instance of the bug was outputting a fatal error
|
||||
message, so that the only harm is not giving the user the correct info,
|
||||
and creating unnecessary work for them and us when it gets reported.
|
||||
But this bug could manifest itself when trying to output just a warning
|
||||
that the program otherwise would carry on from.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 12 ++++++++++--
|
||||
t/re/reg_mesg.t | 1 +
|
||||
2 files changed, 11 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 3ad09c52b2..1c54fe3f38 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -131,6 +131,8 @@ struct RExC_state_t {
|
||||
char *parse; /* Input-scan pointer. */
|
||||
char *copy_start; /* start of copy of input within
|
||||
constructed parse string */
|
||||
+ char *save_copy_start; /* Provides one level of saving
|
||||
+ and restoring 'copy_start' */
|
||||
char *copy_start_in_input; /* Position in input string
|
||||
corresponding to copy_start */
|
||||
SSize_t whilem_seen; /* number of WHILEM in this expr */
|
||||
@@ -229,6 +231,7 @@ struct RExC_state_t {
|
||||
#define RExC_precomp (pRExC_state->precomp)
|
||||
#define RExC_copy_start_in_input (pRExC_state->copy_start_in_input)
|
||||
#define RExC_copy_start_in_constructed (pRExC_state->copy_start)
|
||||
+#define RExC_save_copy_start_in_constructed (pRExC_state->save_copy_start)
|
||||
#define RExC_precomp_end (pRExC_state->precomp_end)
|
||||
#define RExC_rx_sv (pRExC_state->rx_sv)
|
||||
#define RExC_rx (pRExC_state->rx)
|
||||
@@ -821,8 +824,13 @@ static const scan_data_t zero_scan_data = {
|
||||
} STMT_END
|
||||
|
||||
/* Setting this to NULL is a signal to not output warnings */
|
||||
-#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE RExC_copy_start_in_constructed = NULL
|
||||
-#define RESTORE_WARNINGS RExC_copy_start_in_constructed = RExC_precomp
|
||||
+#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE \
|
||||
+ STMT_START { \
|
||||
+ RExC_save_copy_start_in_constructed = RExC_copy_start_in_constructed;\
|
||||
+ RExC_copy_start_in_constructed = NULL; \
|
||||
+ } STMT_END
|
||||
+#define RESTORE_WARNINGS \
|
||||
+ RExC_copy_start_in_constructed = RExC_save_copy_start_in_constructed
|
||||
|
||||
/* Since a warning can be generated multiple times as the input is reparsed, we
|
||||
* output it the first time we come to that point in the parse, but suppress it
|
||||
diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t
|
||||
index c5c79f0323..d10fa2c09a 100644
|
||||
--- a/t/re/reg_mesg.t
|
||||
+++ b/t/re/reg_mesg.t
|
||||
@@ -318,6 +318,7 @@ my @death =
|
||||
'/\p{Is_Other_Alphabetic=F}/ ' => 'Can\'t find Unicode property definition "Is_Other_Alphabetic=F" {#} m/\p{Is_Other_Alphabetic=F}{#}/',
|
||||
'/\x{100}(?(/' => 'Unknown switch condition (?(...)) {#} m/\\x{100}(?({#}/', # [perl #133896]
|
||||
'/(?[\N{KEYCAP DIGIT NINE}/' => '\N{} in inverted character class or as a range end-point is restricted to one character {#} m/(?[\\N{U+39.FE0F.20E3{#}}/', # [perl #133988]
|
||||
+ '/0000000000000000[\N{U+0.00}0000/' => 'Unmatched [ {#} m/0000000000000000[{#}\N{U+0.00}0000/', # [perl #134059]
|
||||
);
|
||||
|
||||
# These are messages that are death under 'use re "strict"', and may or may
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,49 @@
|
||||
From 89f69032d6a71f41b96ae6becbf3df4e2f9509a5 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 27 Apr 2019 13:56:39 -0600
|
||||
Subject: [PATCH] S_scan_const() Properly test if need to grow
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
As we parse the input, creating a string constant, we may have to grow
|
||||
the destination if it fills up as we go along. It allocates space in an
|
||||
SV and populates the string, but it doesn' update the SvCUR until the
|
||||
end, so in single stepping the debugger through the code, the SV looks
|
||||
empty until the end. It turns out that as a result SvEND also doesn't
|
||||
get updated and still points to the beginning of the string until SvCUR
|
||||
is finally set. That means that the test changed by this commit was
|
||||
always succeeding, because it was using SvEND that didn't get updated,
|
||||
so it would attempt to grow each time through the loop. By moving a
|
||||
couple of statements earlier, and using SvLEN instead, which does always
|
||||
have the correct value, those extra growth attempts are avoided.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
toke.c | 10 ++++++----
|
||||
1 file changed, 6 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 68eea0cae6..03c4f2ba26 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -4097,10 +4097,12 @@ S_scan_const(pTHX_ char *start)
|
||||
goto default_action; /* Redo, having upgraded so both are UTF-8 */
|
||||
}
|
||||
else { /* UTF8ness matters: convert this non-UTF8 source char to
|
||||
- UTF-8 for output. It will occupy 2 bytes */
|
||||
- if (d + 2 >= SvEND(sv)) {
|
||||
- const STRLEN extra = 2 + (send - s - 1) + 1;
|
||||
- const STRLEN off = d - SvPVX_const(sv);
|
||||
+ UTF-8 for output. It will occupy 2 bytes, but don't include
|
||||
+ the input byte since we haven't incremented 's' yet. See
|
||||
+ Note on sizing above. */
|
||||
+ const STRLEN off = d - SvPVX(sv);
|
||||
+ const STRLEN extra = 2 + (send - s - 1) + 1;
|
||||
+ if (off + extra > SvLEN(sv)) {
|
||||
d = off + SvGROW(sv, off + extra);
|
||||
}
|
||||
*d++ = UTF8_EIGHT_BIT_HI(*s);
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,70 @@
|
||||
From 35608a1658fe75c79ca53d96aea6cf7cb2a98615 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 9 May 2019 09:52:30 +1000
|
||||
Subject: [PATCH] (perl #122112) a simpler fix for pclose() aborted by a signal
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This change results in a zombie child process for the lifetime of
|
||||
the process, but I think that's the responsibility of the signal
|
||||
handler that aborted pclose().
|
||||
|
||||
We could add some magic to retry (and retry and retry) waiting on
|
||||
child process as we rewind (since there's no other way to remove
|
||||
the zombie), but the program has chosen implicitly to abort the
|
||||
wait() done by pclose() and it's best to honor that.
|
||||
|
||||
If we do choose to retry the wait() we might be blocking an attempt
|
||||
by the process to terminate, whether by exit() or die().
|
||||
|
||||
If a program does need more flexible handling there's always
|
||||
pipe()/fork()/exec() and/or the various event-driven frameworks on
|
||||
CPAN.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
doio.c | 12 +++++++++++-
|
||||
t/io/pipe.t | 2 --
|
||||
2 files changed, 11 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/doio.c b/doio.c
|
||||
index 0cc4e55404..05a06968dc 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -1779,7 +1779,17 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
|
||||
|
||||
if (IoIFP(io)) {
|
||||
if (IoTYPE(io) == IoTYPE_PIPE) {
|
||||
- const int status = PerlProc_pclose(IoIFP(io));
|
||||
+ PerlIO *fh = IoIFP(io);
|
||||
+ int status;
|
||||
+
|
||||
+ /* my_pclose() can propagate signals which might bypass any code
|
||||
+ after the call here if the signal handler throws an exception.
|
||||
+ This would leave the handle in the IO object and try to close it again
|
||||
+ when the SV is destroyed on unwind or global destruction.
|
||||
+ So NULL it early.
|
||||
+ */
|
||||
+ IoOFP(io) = IoIFP(io) = NULL;
|
||||
+ status = PerlProc_pclose(fh);
|
||||
if (not_implicit) {
|
||||
STATUS_NATIVE_CHILD_SET(status);
|
||||
retval = (STATUS_UNIX == 0);
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index 1d01db6af6..fc3071300d 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -255,9 +255,7 @@ close \$fh;
|
||||
PROG
|
||||
print $prog;
|
||||
my $out = fresh_perl($prog, {});
|
||||
- $::TODO = "not fixed yet";
|
||||
cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
- undef $::TODO;
|
||||
# checks that that program did something rather than failing to
|
||||
# compile
|
||||
cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,28 @@
|
||||
From 2fe0d7f40a94163d6c242c3e695fdcd19e387422 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 11 Jun 2019 14:59:23 +1000
|
||||
Subject: [PATCH] (perl #122112) remove some interfering debug output
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/io/pipe.t | 1 -
|
||||
1 file changed, 1 deletion(-)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index fc3071300d..9f5bb3bcf8 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -253,7 +253,6 @@ my \$cmd = qq(\$Perl -e "sleep 3");
|
||||
my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
|
||||
close \$fh;
|
||||
PROG
|
||||
- print $prog;
|
||||
my $out = fresh_perl($prog, {});
|
||||
cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
# checks that that program did something rather than failing to
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,54 @@
|
||||
From fb5e77103dd443cc2112ba14dc665aa5ec072ce6 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 30 May 2018 14:03:04 +1000
|
||||
Subject: [PATCH] (perl #122112) test for signal handler death in pclose
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/io/pipe.t | 23 ++++++++++++++++++++++-
|
||||
1 file changed, 22 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index f9ee65afe8..1d01db6af6 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -10,7 +10,7 @@ if (!$Config{'d_fork'}) {
|
||||
skip_all("fork required to pipe");
|
||||
}
|
||||
else {
|
||||
- plan(tests => 25);
|
||||
+ plan(tests => 27);
|
||||
}
|
||||
|
||||
my $Perl = which_perl();
|
||||
@@ -241,3 +241,24 @@ SKIP: {
|
||||
|
||||
is($child, -1, 'child reaped if piped program cannot be executed');
|
||||
}
|
||||
+
|
||||
+{
|
||||
+ # [perl #122112] refcnt: fd -1 < 0 when a signal handler dies
|
||||
+ # while a pipe close is waiting on a child process
|
||||
+ my $prog = <<PROG;
|
||||
+\$SIG{ALRM}=sub{die};
|
||||
+alarm 1;
|
||||
+\$Perl = "$Perl";
|
||||
+my \$cmd = qq(\$Perl -e "sleep 3");
|
||||
+my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
|
||||
+close \$fh;
|
||||
+PROG
|
||||
+ print $prog;
|
||||
+ my $out = fresh_perl($prog, {});
|
||||
+ $::TODO = "not fixed yet";
|
||||
+ cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
+ undef $::TODO;
|
||||
+ # checks that that program did something rather than failing to
|
||||
+ # compile
|
||||
+ cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
|
||||
+}
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,73 @@
|
||||
From 027471cf1095f75f273df40310e4647fe1e8a9df Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 20 Mar 2019 16:47:49 +1100
|
||||
Subject: [PATCH] (perl #133913) limit numeric format results to INT_MAX
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The return value of v?snprintf() is int, and we pay attention to that
|
||||
return value, so limit the expected size of numeric formats to
|
||||
INT_MAX.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perldiag.pod | 6 ++++++
|
||||
sv.c | 7 +++++++
|
||||
t/op/sprintf2.t | 7 +++++++
|
||||
3 files changed, 20 insertions(+)
|
||||
|
||||
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
|
||||
index 1037215d44..166d29b4bb 100644
|
||||
--- a/pod/perldiag.pod
|
||||
+++ b/pod/perldiag.pod
|
||||
@@ -4354,6 +4354,12 @@ the meantime, try using scientific notation (e.g. "1e6" instead of
|
||||
a number. This happens, for example with C<\o{}>, with no number between
|
||||
the braces.
|
||||
|
||||
+=item Numeric format result too large
|
||||
+
|
||||
+(F) The length of the result of a numeric format supplied to sprintf()
|
||||
+or printf() would have been too large for the underlying C function to
|
||||
+report. This limit is typically 2GB.
|
||||
+
|
||||
=item Octal number > 037777777777 non-portable
|
||||
|
||||
(W portable) The octal number you specified is larger than 2**32-1
|
||||
diff --git a/sv.c b/sv.c
|
||||
index 8fbca52eb2..8bc0af0c16 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -13085,6 +13085,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
|
||||
if (float_need < width)
|
||||
float_need = width;
|
||||
|
||||
+ if (float_need > INT_MAX) {
|
||||
+ /* snprintf() returns an int, and we use that return value,
|
||||
+ so die horribly if the expected size is too large for int
|
||||
+ */
|
||||
+ Perl_croak(aTHX_ "Numeric format result too large");
|
||||
+ }
|
||||
+
|
||||
if (PL_efloatsize <= float_need) {
|
||||
/* PL_efloatbuf should be at least 1 greater than
|
||||
* float_need to allow a trailing \0 to be returned by
|
||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
||||
index 84259a4afd..5fee8efede 100644
|
||||
--- a/t/op/sprintf2.t
|
||||
+++ b/t/op/sprintf2.t
|
||||
@@ -1153,4 +1153,11 @@ foreach(
|
||||
is sprintf("%.0f", $_), sprintf("%-.0f", $_), "special-case %.0f on $_";
|
||||
}
|
||||
|
||||
+# large uvsize needed so the large width is parsed properly
|
||||
+# large sizesize needed so the STRLEN check doesn't
|
||||
+if ($Config{intsize} == 4 && $Config{uvsize} > 4 && $Config{sizesize} > 4) {
|
||||
+ eval { my $x = sprintf("%7000000000E", 0) };
|
||||
+ like($@, qr/^Numeric format result too large at /,
|
||||
+ "croak for very large numeric format results");
|
||||
+}
|
||||
done_testing();
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,78 @@
|
||||
From 1d9630e7857d6fbae6fddd261fbb80c9c9a8cfd6 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 18 Mar 2019 16:02:33 +1100
|
||||
Subject: [PATCH] (perl #133936) document differences between IO::Socket::* and
|
||||
builtin
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 43 +++++++++++++++++++++++++++++++++++++---
|
||||
1 file changed, 40 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index da9e8c94d0..345ffd475d 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -434,9 +434,6 @@ corresponding built-in functions:
|
||||
bind
|
||||
listen
|
||||
accept
|
||||
- send
|
||||
- recv
|
||||
- peername (getpeername)
|
||||
sockname (getsockname)
|
||||
shutdown
|
||||
|
||||
@@ -517,6 +514,46 @@ SO_LINGER enabled with a zero timeout, then the peer's close() will generate
|
||||
a RST segment, upon receipt of which the local TCP transitions immediately to
|
||||
B<CLOSED>, and in that state, connected() I<will> return undef.
|
||||
|
||||
+=item send(MSG, [, FLAGS [, TO ] ])
|
||||
+
|
||||
+Like the built-in L<send()|perlfunc/send>, except that:
|
||||
+
|
||||
+=over
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+C<FLAGS> is optional and defaults to C<0>, and
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+after a successful send with C<TO>, further calls to send() without
|
||||
+C<TO> will send to the same address, and C<TO> will be used as the
|
||||
+result of peername().
|
||||
+
|
||||
+=back
|
||||
+
|
||||
+=item recv(BUF, LEN, [,FLAGS])
|
||||
+
|
||||
+Like the built-in L<recv()|perlfunc/recv>, except that:
|
||||
+
|
||||
+=over
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+C<FLAGS> is optional and defaults to C<0>, and
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+the cached value returned by peername() is updated with the result of
|
||||
+recv().
|
||||
+
|
||||
+=back
|
||||
+
|
||||
+=item peername
|
||||
+
|
||||
+Returns the cached peername, possibly set by recv() or send() above.
|
||||
+If not otherwise set returns (and caches) the result of getpeername().
|
||||
+
|
||||
=item protocol
|
||||
|
||||
Returns the numerical number for the protocol being used on the socket, if
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,107 @@
|
||||
From f1000aa2d58fbed2741dbb2887b668f872ef0cb8 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 18 Mar 2019 15:05:32 +1100
|
||||
Subject: [PATCH] (perl #133936) ensure TO is honoured for UDP $sock->send()
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 7 ++++---
|
||||
dist/IO/t/io_udp.t | 31 +++++++++++++++++++++++++++----
|
||||
2 files changed, 31 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index 1bf57ab826..a34a10b232 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -282,9 +282,10 @@ sub send {
|
||||
croak 'send: Cannot determine peer address'
|
||||
unless(defined $peer);
|
||||
|
||||
- my $r = defined(getpeername($sock))
|
||||
- ? send($sock, $_[1], $flags)
|
||||
- : send($sock, $_[1], $flags, $peer);
|
||||
+ my $type = $sock->socktype;
|
||||
+ my $r = $type == SOCK_DGRAM || $type == SOCK_RAW
|
||||
+ ? send($sock, $_[1], $flags, $peer)
|
||||
+ : send($sock, $_[1], $flags);
|
||||
|
||||
# remember who we send to, if it was successful
|
||||
${*$sock}{'io_socket_peername'} = $peer
|
||||
diff --git a/dist/IO/t/io_udp.t b/dist/IO/t/io_udp.t
|
||||
index d7e95a8829..571e4303bb 100644
|
||||
--- a/dist/IO/t/io_udp.t
|
||||
+++ b/dist/IO/t/io_udp.t
|
||||
@@ -15,6 +15,8 @@ BEGIN {
|
||||
skip_all($reason) if $reason;
|
||||
}
|
||||
|
||||
+use strict;
|
||||
+
|
||||
sub compare_addr {
|
||||
no utf8;
|
||||
my $a = shift;
|
||||
@@ -36,18 +38,18 @@ sub compare_addr {
|
||||
"$a[0]$a[1]" eq "$b[0]$b[1]";
|
||||
}
|
||||
|
||||
-plan(7);
|
||||
+plan(15);
|
||||
watchdog(15);
|
||||
|
||||
use Socket;
|
||||
use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
|
||||
|
||||
-$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+my $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
|| IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
ok(1);
|
||||
|
||||
-$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+my $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
|| IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
ok(1);
|
||||
@@ -56,6 +58,7 @@ $udpa->send('BORK', 0, $udpb->sockname);
|
||||
|
||||
ok(compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname'));
|
||||
|
||||
+my $buf;
|
||||
my $where = $udpb->recv($buf="", 4);
|
||||
is($buf, 'BORK');
|
||||
|
||||
@@ -69,7 +72,27 @@ $udpb->send('FOObar', @xtra);
|
||||
$udpa->recv($buf="", 6);
|
||||
is($buf, 'FOObar');
|
||||
|
||||
-ok(! $udpa->connected);
|
||||
+{
|
||||
+ # check the TO parameter passed to $sock->send() is honoured for UDP sockets
|
||||
+ # [perl #133936]
|
||||
+ my $udpc = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+ || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
+ or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
+ pass("created C socket");
|
||||
+
|
||||
+ ok($udpc->connect($udpa->sockname), "connect C to A");
|
||||
+
|
||||
+ ok($udpc->connected, "connected a UDP socket");
|
||||
+
|
||||
+ ok($udpc->send("fromctoa"), "send to a");
|
||||
+
|
||||
+ ok($udpa->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctoa", "check value received");
|
||||
+
|
||||
+ ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
+ ok($udpb->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctob", "check value received");
|
||||
+}
|
||||
|
||||
exit(0);
|
||||
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,93 @@
|
||||
From bc26d2e6b287cc6693f41e1a2d48b0dd77d2e427 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 18 Jun 2019 14:59:00 +1000
|
||||
Subject: [PATCH] (perl #133936) make send() a bit saner
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This undoes some of the effect of f1000aa2d in that TO will always
|
||||
be supplied to CORE::send() if it's supplied, otherwise whether
|
||||
TO is supplied to CORE::send() is based on whether the socket is
|
||||
connected.
|
||||
|
||||
On Linux you appear to be able to sendto() to a different address on
|
||||
a connected UDP socket, but this doesn't appear to be portable,
|
||||
failing on darwin, and presumably on other BSDs.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 25 +++++++++++++++++--------
|
||||
dist/IO/t/io_udp.t | 11 ++++++++---
|
||||
2 files changed, 25 insertions(+), 11 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index 345ffd475d..28fa1ec149 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -277,13 +277,22 @@ sub send {
|
||||
@_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
|
||||
my $sock = $_[0];
|
||||
my $flags = $_[2] || 0;
|
||||
- my $peer = $_[3] || $sock->peername;
|
||||
+ my $peer;
|
||||
|
||||
- croak 'send: Cannot determine peer address'
|
||||
- unless(defined $peer);
|
||||
+ if ($_[3]) {
|
||||
+ # the caller explicitly requested a TO, so use it
|
||||
+ # this is non-portable for "connected" UDP sockets
|
||||
+ $peer = $_[3];
|
||||
+ }
|
||||
+ elsif (!defined getpeername($sock)) {
|
||||
+ # we're not connected, so we require a peer from somewhere
|
||||
+ $peer = $sock->peername;
|
||||
+
|
||||
+ croak 'send: Cannot determine peer address'
|
||||
+ unless(defined $peer);
|
||||
+ }
|
||||
|
||||
- my $type = $sock->socktype;
|
||||
- my $r = $type == SOCK_DGRAM || $type == SOCK_RAW
|
||||
+ my $r = $peer
|
||||
? send($sock, $_[1], $flags, $peer)
|
||||
: send($sock, $_[1], $flags);
|
||||
|
||||
@@ -526,9 +535,9 @@ C<FLAGS> is optional and defaults to C<0>, and
|
||||
|
||||
=item *
|
||||
|
||||
-after a successful send with C<TO>, further calls to send() without
|
||||
-C<TO> will send to the same address, and C<TO> will be used as the
|
||||
-result of peername().
|
||||
+after a successful send with C<TO>, further calls to send() on an
|
||||
+unconnected socket without C<TO> will send to the same address, and
|
||||
+C<TO> will be used as the result of peername().
|
||||
|
||||
=back
|
||||
|
||||
diff --git a/dist/IO/t/io_udp.t b/dist/IO/t/io_udp.t
|
||||
index 571e4303bb..2adc6a4a69 100644
|
||||
--- a/dist/IO/t/io_udp.t
|
||||
+++ b/dist/IO/t/io_udp.t
|
||||
@@ -89,9 +89,14 @@ is($buf, 'FOObar');
|
||||
ok($udpa->recv($buf = "", 8), "recv it");
|
||||
is($buf, "fromctoa", "check value received");
|
||||
|
||||
- ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
- ok($udpb->recv($buf = "", 8), "recv it");
|
||||
- is($buf, "fromctob", "check value received");
|
||||
+ SKIP:
|
||||
+ {
|
||||
+ $^O eq "linux"
|
||||
+ or skip "This is non-portable, known to 'work' on Linux", 3;
|
||||
+ ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
+ ok($udpb->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctob", "check value received");
|
||||
+ }
|
||||
}
|
||||
|
||||
exit(0);
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,28 @@
|
||||
From 9dfe0a3438ae69872b71b98e4fb4f4bef084983d Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 3 Jun 2019 14:34:17 +1000
|
||||
Subject: [PATCH 2/2] (perl #134008) an alternative test
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/sprintf2.t | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
||||
index 569bd8053d..84259a4afd 100644
|
||||
--- a/t/op/sprintf2.t
|
||||
+++ b/t/op/sprintf2.t
|
||||
@@ -840,6 +840,7 @@ SKIP: {
|
||||
|
||||
# [rt.perl.org #134008]
|
||||
is(sprintf("%.*a", -99999, 1.03125), "0x1.08p+0", "[rt.perl.org #134008]");
|
||||
+ is(sprintf("%.*a", -100000,0), "0x0p+0", "negative precision ignored by format_hexfp");
|
||||
|
||||
# [rt.perl.org #128890]
|
||||
is(sprintf("%a", 0x1.18p+0), "0x1.18p+0");
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,84 @@
|
||||
From 40258daf9899686d934c460ba3630431312d7694 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 15 May 2019 15:59:49 +1000
|
||||
Subject: [PATCH] (perl #134072) allow \&foo = \&bar to work in main::
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
subs in main:: are stored as a RV referring to a CV as a space
|
||||
optimization, but the pp_refassign code expected to find a glob,
|
||||
which made the assignment a no-op.
|
||||
|
||||
Fix this by upgrading the reference to a glob in the refassign check
|
||||
function.
|
||||
|
||||
Note that this would be an issue in other packages if 1e2cfe157ca
|
||||
was reverted (allowing the space savings in other packages too.)
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 9 +++++++++
|
||||
t/op/lvref.t | 15 ++++++++++++++-
|
||||
2 files changed, 23 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index f63eeadc36..6ad192307f 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -12462,7 +12462,16 @@ Perl_ck_refassign(pTHX_ OP *o)
|
||||
OP * const kid = cUNOPx(kidparent)->op_first;
|
||||
o->op_private |= OPpLVREF_CV;
|
||||
if (kid->op_type == OP_GV) {
|
||||
+ SV *sv = (SV*)cGVOPx_gv(kid);
|
||||
varop = kidparent;
|
||||
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
|
||||
+ /* a CVREF here confuses pp_refassign, so make sure
|
||||
+ it gets a GV */
|
||||
+ CV *const cv = (CV*)SvRV(sv);
|
||||
+ SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
|
||||
+ (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
|
||||
+ assert(SvTYPE(sv) == SVt_PVGV);
|
||||
+ }
|
||||
goto detach_and_stack;
|
||||
}
|
||||
if (kid->op_type != OP_PADCV) goto bad;
|
||||
diff --git a/t/op/lvref.t b/t/op/lvref.t
|
||||
index 3d5e952fb0..3991a53780 100644
|
||||
--- a/t/op/lvref.t
|
||||
+++ b/t/op/lvref.t
|
||||
@@ -1,10 +1,11 @@
|
||||
+#!perl
|
||||
BEGIN {
|
||||
chdir 't';
|
||||
require './test.pl';
|
||||
set_up_inc("../lib");
|
||||
}
|
||||
|
||||
-plan 164;
|
||||
+plan 167;
|
||||
|
||||
eval '\$x = \$y';
|
||||
like $@, qr/^Experimental aliasing via reference not enabled/,
|
||||
@@ -291,6 +292,18 @@ package CodeTest {
|
||||
my sub bs;
|
||||
\(&cs) = expect_list_cx;
|
||||
is \&cs, \&ThatSub, '\(&statesub)';
|
||||
+
|
||||
+ package main {
|
||||
+ # this is only a problem in main:: due to 1e2cfe157ca
|
||||
+ sub sx { "x" }
|
||||
+ sub sy { "y" }
|
||||
+ is sx(), "x", "check original";
|
||||
+ my $temp = \&sx;
|
||||
+ \&sx = \&sy;
|
||||
+ is sx(), "y", "aliased";
|
||||
+ \&sx = $temp;
|
||||
+ is sx(), "x", "and restored";
|
||||
+ }
|
||||
}
|
||||
|
||||
# Mixed List Assignments
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,59 @@
|
||||
From 22f05786af0b7f963440e47908cd5f35cf074c12 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 13 Jun 2019 10:05:15 +1000
|
||||
Subject: [PATCH] (perl #134193) allow %{^CAPTURE} to work when @{^CAPTURE}
|
||||
comes first
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
gv_magicalize() is called when the GV is created, so when the array
|
||||
was mentioned first, the hash wouldn't reach this code and the magic
|
||||
wouldn't be added to the hash.
|
||||
|
||||
This also fixes a similar problem with (%|@){^CAPTURE_ALL}, though
|
||||
@{^CAPTURE_ALL} is unused at this point.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/Tie-Hash-NamedCapture/t/tiehash.t | 3 +++
|
||||
gv.c | 6 ++----
|
||||
2 files changed, 5 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/t/tiehash.t b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
index 962754085f..cca05278f4 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
+++ b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
@@ -3,6 +3,9 @@ use strict;
|
||||
|
||||
use Test::More;
|
||||
|
||||
+# this would break the hash magic setup [perl #134193]
|
||||
+my ($ca, $c) = ( \@{^CAPTURE_ALL}, \@{^CAPTURE} );
|
||||
+
|
||||
my %hashes = (
|
||||
'+' => \%+,
|
||||
'-' => \%-,
|
||||
diff --git a/gv.c b/gv.c
|
||||
index 46a32dcc20..2b83680898 100644
|
||||
--- a/gv.c
|
||||
+++ b/gv.c
|
||||
@@ -2032,13 +2032,11 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
|
||||
sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
|
||||
SvREADONLY_on(av);
|
||||
|
||||
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
|
||||
- require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
|
||||
} else /* %{^CAPTURE_ALL} */
|
||||
if (memEQs(name, len, "\003APTURE_ALL")) {
|
||||
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
|
||||
- require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
}
|
||||
break;
|
||||
case '\005': /* $^ENCODING */
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,36 @@
|
||||
From d8422270033e0728e6a9cecb24cdbd123656e367 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 17 Jun 2019 11:46:00 +1000
|
||||
Subject: [PATCH] (perl #134193) make the varname match the %[+-] names
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
when loading Tie/Hash/NamedCapture.pm for the long name variants
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
gv.c | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/gv.c b/gv.c
|
||||
index 2b83680898..652f5e737d 100644
|
||||
--- a/gv.c
|
||||
+++ b/gv.c
|
||||
@@ -2032,11 +2032,11 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
|
||||
sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
|
||||
SvREADONLY_on(av);
|
||||
|
||||
- require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
|
||||
} else /* %{^CAPTURE_ALL} */
|
||||
if (memEQs(name, len, "\003APTURE_ALL")) {
|
||||
- require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
}
|
||||
break;
|
||||
case '\005': /* $^ENCODING */
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,65 @@
|
||||
From 28eabf1185634216ca335b3a24e1131b0f392ca1 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Wed, 10 Jul 2019 12:59:06 +0100
|
||||
Subject: [PATCH] avoid SEGV with uninit warning with multideref
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
RT #134275
|
||||
|
||||
When the 'uninitialized warning' code in S_find_uninit_var() comes
|
||||
across an OP_MULTIDEREF node, it scans it to see if any part of that op
|
||||
(e.g. the indices or the returned value) could have been the source of
|
||||
the uninitialized value which triggered the warning. Unfortunately when
|
||||
getting an AV or HV from a GV, it wasn't checking whether gp_av/gp_hv
|
||||
contained a NULL value. If so, it would SEGV.
|
||||
|
||||
The test code is a bit contrived; you have to "pull the rug" from under
|
||||
the GV at just the right moment with *foo = *bar, then trigger an uninit
|
||||
warning on an op whose subtree includes an OP_MULTIDEREF.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
sv.c | 5 ++++-
|
||||
t/lib/warnings/9uninit | 10 ++++++++++
|
||||
2 files changed, 14 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/sv.c b/sv.c
|
||||
index 83de536ad7..4315fe9b64 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -16662,8 +16662,11 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
|
||||
|
||||
if (agg_targ)
|
||||
sv = PAD_SV(agg_targ);
|
||||
- else if (agg_gv)
|
||||
+ else if (agg_gv) {
|
||||
sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
|
||||
+ if (!sv)
|
||||
+ break;
|
||||
+ }
|
||||
else
|
||||
break;
|
||||
|
||||
diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
|
||||
index 774c6ee432..5c173fdb2a 100644
|
||||
--- a/t/lib/warnings/9uninit
|
||||
+++ b/t/lib/warnings/9uninit
|
||||
@@ -2206,3 +2206,13 @@ use warnings 'uninitialized';
|
||||
undef $0;
|
||||
EXPECT
|
||||
Use of uninitialized value in undef operator at - line 5.
|
||||
+########
|
||||
+# RT #134275
|
||||
+# This was SEGVing due to the multideref code in S_find_uninit_var not
|
||||
+# handling a GV with a null gp_hv slot.
|
||||
+use warnings 'uninitialized';
|
||||
+"" =~ /$foo{a}${*foo=*bar}$x/;
|
||||
+EXPECT
|
||||
+Use of uninitialized value in regexp compilation at - line 5.
|
||||
+Use of uninitialized value in regexp compilation at - line 5.
|
||||
+Use of uninitialized value $x in regexp compilation at - line 5.
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,39 @@
|
||||
From 293a533c53d9c0fe939e23c439f4dfc47a5736dc Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 25 Jun 2019 15:47:57 +1000
|
||||
Subject: [PATCH] (perl #122112) make sure SIGPIPE is delivered if we test it
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/io/pipe.t | 12 ++++++++++++
|
||||
1 file changed, 12 insertions(+)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index 9f5bb3bcf8..bdf743c26c 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -125,6 +125,18 @@ wait; # Collect from $pid
|
||||
pipe(READER,WRITER) || die "Can't open pipe";
|
||||
close READER;
|
||||
|
||||
+eval {
|
||||
+ # one platform at least appears to block SIGPIPE by default (see #122112)
|
||||
+ # so make sure it's unblocked.
|
||||
+ # The eval wrapper should ensure this does nothing if these aren't
|
||||
+ # implemented.
|
||||
+ require POSIX;
|
||||
+ my $mask = POSIX::SigSet->new(POSIX::SIGPIPE());
|
||||
+ my $old = POSIX::SigSet->new();
|
||||
+ POSIX::sigprocmask(POSIX::SIG_UNBLOCK(), $mask, $old);
|
||||
+ note "Yes, SIGPIPE was blocked" if $old->ismember(POSIX::SIGPIPE());
|
||||
+};
|
||||
+
|
||||
$SIG{'PIPE'} = 'broken_pipe';
|
||||
|
||||
sub broken_pipe {
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,128 @@
|
||||
From 74b421cc877e412c4eda06757396a1e19fc756ba Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 15 Jul 2019 11:53:23 +1000
|
||||
Subject: [PATCH 3/3] (perl #134221) support O_APPEND for open ..., undef on
|
||||
VMS
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
VMS doesn't allow you to delete an open file like POSIXish systems
|
||||
do, but you can mark a file to be deleted once it's closed, but
|
||||
only when you open it.
|
||||
|
||||
Since VMS doesn't (yet) have mkostemp() we can add our own flag to
|
||||
our mkostemp() emulation to pass the necessary magic to open() call
|
||||
to delete the file on close.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perlio.c | 10 ++++++----
|
||||
util.c | 15 ++++++++++++++-
|
||||
util.h | 11 +++++++++++
|
||||
3 files changed, 31 insertions(+), 5 deletions(-)
|
||||
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index 81ebc156ad..805959f840 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -5062,7 +5062,7 @@ PerlIO_tmpfile_flags(int imode)
|
||||
const int fd = win32_tmpfd_mode(imode);
|
||||
if (fd >= 0)
|
||||
f = PerlIO_fdopen(fd, "w+b");
|
||||
-#elif ! defined(VMS) && ! defined(OS2)
|
||||
+#elif ! defined(OS2)
|
||||
int fd = -1;
|
||||
char tempname[] = "/tmp/PerlIO_XXXXXX";
|
||||
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
|
||||
@@ -5073,19 +5073,19 @@ PerlIO_tmpfile_flags(int imode)
|
||||
/* if TMPDIR is set and not empty, we try that first */
|
||||
sv = newSVpv(tmpdir, 0);
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
if (fd < 0) {
|
||||
SvREFCNT_dec(sv);
|
||||
sv = NULL;
|
||||
/* else we try /tmp */
|
||||
- fd = Perl_my_mkostemp_cloexec(tempname, imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
if (fd < 0) {
|
||||
/* Try cwd */
|
||||
sv = newSVpvs(".");
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
umask(old_umask);
|
||||
if (fd >= 0) {
|
||||
@@ -5096,7 +5096,9 @@ PerlIO_tmpfile_flags(int imode)
|
||||
f = PerlIO_fdopen(fd, mode);
|
||||
if (f)
|
||||
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
|
||||
+# ifndef VMS
|
||||
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
|
||||
+# endif
|
||||
}
|
||||
SvREFCNT_dec(sv);
|
||||
#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
|
||||
diff --git a/util.c b/util.c
|
||||
index e6863f6dfe..165d13a39e 100644
|
||||
--- a/util.c
|
||||
+++ b/util.c
|
||||
@@ -5712,6 +5712,11 @@ S_my_mkostemp(char *templte, int flags) {
|
||||
STRLEN len = strlen(templte);
|
||||
int fd;
|
||||
int attempts = 0;
|
||||
+#ifdef VMS
|
||||
+ int delete_on_close = flags & O_VMS_DELETEONCLOSE;
|
||||
+
|
||||
+ flags &= ~O_VMS_DELETEONCLOSE;
|
||||
+#endif
|
||||
|
||||
if (len < 6 ||
|
||||
templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
|
||||
@@ -5725,7 +5730,15 @@ S_my_mkostemp(char *templte, int flags) {
|
||||
for (i = 1; i <= 6; ++i) {
|
||||
templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
|
||||
}
|
||||
- fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
|
||||
+#ifdef VMS
|
||||
+ if (delete_on_close) {
|
||||
+ fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt");
|
||||
+ }
|
||||
+ else
|
||||
+#endif
|
||||
+ {
|
||||
+ fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
|
||||
+ }
|
||||
} while (fd == -1 && errno == EEXIST && ++attempts <= 100);
|
||||
|
||||
return fd;
|
||||
diff --git a/util.h b/util.h
|
||||
index d8fa3e8396..d9df7b39c6 100644
|
||||
--- a/util.h
|
||||
+++ b/util.h
|
||||
@@ -248,6 +248,17 @@ means arg not present, 1 is empty string/null byte */
|
||||
int mkstemp(char*);
|
||||
#endif
|
||||
|
||||
+#ifdef PERL_CORE
|
||||
+# if defined(VMS)
|
||||
+/* only useful for calls to our mkostemp() emulation */
|
||||
+# define O_VMS_DELETEONCLOSE 0x40000000
|
||||
+# ifdef HAS_MKOSTEMP
|
||||
+# error 134221 will need a new solution for VMS
|
||||
+# endif
|
||||
+# else
|
||||
+# define O_VMS_DELETEONCLOSE 0
|
||||
+# endif
|
||||
+#endif
|
||||
#if defined(HAS_MKOSTEMP) && defined(PERL_CORE)
|
||||
# define Perl_my_mkostemp(templte, flags) mkostemp(templte, flags)
|
||||
#endif
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,76 @@
|
||||
From 0424723402ef153af8ee44222315d9b6a818d1ba Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 2 Jul 2019 15:22:26 +1000
|
||||
Subject: [PATCH 2/3] (perl #134221) support append mode temp files on Win32
|
||||
too
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perlio.c | 2 +-
|
||||
win32/win32.c | 10 +++++++++-
|
||||
win32/win32iop.h | 1 +
|
||||
3 files changed, 11 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index a737e79e02..81ebc156ad 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -5059,7 +5059,7 @@ PerlIO_tmpfile_flags(int imode)
|
||||
#endif
|
||||
PerlIO *f = NULL;
|
||||
#ifdef WIN32
|
||||
- const int fd = win32_tmpfd();
|
||||
+ const int fd = win32_tmpfd_mode(imode);
|
||||
if (fd >= 0)
|
||||
f = PerlIO_fdopen(fd, "w+b");
|
||||
#elif ! defined(VMS) && ! defined(OS2)
|
||||
diff --git a/win32/win32.c b/win32/win32.c
|
||||
index 8104d864c2..91fdffe09b 100644
|
||||
--- a/win32/win32.c
|
||||
+++ b/win32/win32.c
|
||||
@@ -2907,10 +2907,18 @@ win32_rewind(FILE *pf)
|
||||
|
||||
DllExport int
|
||||
win32_tmpfd(void)
|
||||
+{
|
||||
+ return win32_tmpfd_mode(0);
|
||||
+}
|
||||
+
|
||||
+DllExport int
|
||||
+win32_tmpfd_mode(int mode)
|
||||
{
|
||||
char prefix[MAX_PATH+1];
|
||||
char filename[MAX_PATH+1];
|
||||
DWORD len = GetTempPath(MAX_PATH, prefix);
|
||||
+ mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
|
||||
+ mode |= O_RDWR;
|
||||
if (len && len < MAX_PATH) {
|
||||
if (GetTempFileName(prefix, "plx", 0, filename)) {
|
||||
HANDLE fh = CreateFile(filename,
|
||||
@@ -2922,7 +2930,7 @@ win32_tmpfd(void)
|
||||
| FILE_FLAG_DELETE_ON_CLOSE,
|
||||
NULL);
|
||||
if (fh != INVALID_HANDLE_VALUE) {
|
||||
- int fd = win32_open_osfhandle((intptr_t)fh, 0);
|
||||
+ int fd = win32_open_osfhandle((intptr_t)fh, mode);
|
||||
if (fd >= 0) {
|
||||
PERL_DEB(dTHX;)
|
||||
DEBUG_p(PerlIO_printf(Perl_debug_log,
|
||||
diff --git a/win32/win32iop.h b/win32/win32iop.h
|
||||
index 53330e5951..559e1f9cd2 100644
|
||||
--- a/win32/win32iop.h
|
||||
+++ b/win32/win32iop.h
|
||||
@@ -64,6 +64,7 @@ DllExport int win32_fgetpos(FILE *pf,fpos_t *p);
|
||||
DllExport int win32_fsetpos(FILE *pf,const fpos_t *p);
|
||||
DllExport void win32_rewind(FILE *pf);
|
||||
DllExport int win32_tmpfd(void);
|
||||
+DllExport int win32_tmpfd_mode(int mode);
|
||||
DllExport FILE* win32_tmpfile(void);
|
||||
DllExport void win32_abort(void);
|
||||
DllExport int win32_fstat(int fd,Stat_t *sbufptr);
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,38 @@
|
||||
From 12e1284a67e5e3404c704c3f864749fd9f04c7c4 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 7 Aug 2019 14:58:14 +1000
|
||||
Subject: [PATCH] PerlIO::Via: check arg is non-NULL before using it.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
I can't find any code in core that ends up calling the _pushed handler
|
||||
with arg == NULL, but PerlIO_push() is API, and there might be
|
||||
CPAN or DarkPAN code out there that does, escpecially since there's
|
||||
a check for arg being non-NULL further down.
|
||||
|
||||
CID 169261.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/PerlIO-via/via.xs | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
|
||||
index d91c6855fc..8456242bc0 100644
|
||||
--- a/ext/PerlIO-via/via.xs
|
||||
+++ b/ext/PerlIO-via/via.xs
|
||||
@@ -134,8 +134,8 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
|
||||
{
|
||||
IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
|
||||
|
||||
- if (SvTYPE(arg) >= SVt_PVMG
|
||||
- && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
|
||||
+ if (arg && SvTYPE(arg) >= SVt_PVMG
|
||||
+ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
|
||||
return code;
|
||||
}
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,30 @@
|
||||
From 665ac6aded4b9694283d373a0f127f32a3e75b26 Mon Sep 17 00:00:00 2001
|
||||
From: James E Keenan <jkeenan@cpan.org>
|
||||
Date: Wed, 7 Aug 2019 09:39:56 -0400
|
||||
Subject: [PATCH] Run tests in ext/File-Find/t in series
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
For: RT # 133771
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/harness | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/harness b/t/harness
|
||||
index caa2a318b8..b9857fa022 100644
|
||||
--- a/t/harness
|
||||
+++ b/t/harness
|
||||
@@ -189,7 +189,7 @@ if (@ARGV) {
|
||||
# directory containing such files should be tested in serial order.
|
||||
#
|
||||
# Add exceptions to the above rule
|
||||
- for (qw(ext/Pod-Html/t cpan/IO-Zlib/t)) {
|
||||
+ for (qw(ext/Pod-Html/t cpan/IO-Zlib/t ext/File-Find/t)) {
|
||||
$serials{$_} = 1;
|
||||
}
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,37 @@
|
||||
From 1d84a25665013f389ffc6fad7dd133f1c6287a08 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Tue, 6 Aug 2019 14:36:45 +0100
|
||||
Subject: [PATCH] include a trailing \0 in SVs holding trie info
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
RT #13427
|
||||
|
||||
TRIE_STORE_REVCHAR() was creating SvPV()s with no trailing '\0'. This
|
||||
doesn't really matter given the specialised use these are put to, but
|
||||
it upset valgrind et al when perl was run with -Drv which printf("%s")'s
|
||||
the contents of the string.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 3 ++-
|
||||
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 370221f72e..1117998fc8 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -2526,7 +2526,8 @@ is the recommended Unicode-aware way of saying
|
||||
if (UTF) { \
|
||||
SV *zlopp = newSV(UTF8_MAXBYTES); \
|
||||
unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \
|
||||
- unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
|
||||
+ unsigned char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
|
||||
+ *kapow = '\0'; \
|
||||
SvCUR_set(zlopp, kapow - flrbbbbb); \
|
||||
SvPOK_on(zlopp); \
|
||||
SvUTF8_on(zlopp); \
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,48 @@
|
||||
From 21dce8f4eb9136875a886371016aa25788f5144f Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue, 6 Aug 2019 21:29:22 -0600
|
||||
Subject: [PATCH] locale.c: Stop Coverity warning
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Coverity is right, so re-order these clauses. This code is executed
|
||||
only if some very strange error occurs.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
locale.c | 11 ++++++-----
|
||||
1 file changed, 6 insertions(+), 5 deletions(-)
|
||||
|
||||
diff --git a/locale.c b/locale.c
|
||||
index db83d993de..af7af60038 100644
|
||||
--- a/locale.c
|
||||
+++ b/locale.c
|
||||
@@ -4349,11 +4349,6 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
|
||||
return xbuf;
|
||||
|
||||
bad:
|
||||
- Safefree(xbuf);
|
||||
- if (s != input_string) {
|
||||
- Safefree(s);
|
||||
- }
|
||||
- *xlen = 0;
|
||||
|
||||
# ifdef DEBUGGING
|
||||
|
||||
@@ -4363,6 +4358,12 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
|
||||
|
||||
# endif
|
||||
|
||||
+ Safefree(xbuf);
|
||||
+ if (s != input_string) {
|
||||
+ Safefree(s);
|
||||
+ }
|
||||
+ *xlen = 0;
|
||||
+
|
||||
return NULL;
|
||||
}
|
||||
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,54 @@
|
||||
From 85d4e0a35b2d44cf06a9343d23a2f84b8ebb9024 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 17 Jul 2019 11:32:50 +1000
|
||||
Subject: [PATCH] (perl #134291) propagate non-PVs in $@ in bare die()
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp_sys.c | 2 +-
|
||||
t/op/die.t | 6 +++++-
|
||||
2 files changed, 6 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pp_sys.c b/pp_sys.c
|
||||
index 0214367ea6..251527785e 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -498,7 +498,7 @@ PP(pp_die)
|
||||
}
|
||||
}
|
||||
}
|
||||
- else if (SvPOK(errsv) && SvCUR(errsv)) {
|
||||
+ else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) {
|
||||
exsv = sv_mortalcopy(errsv);
|
||||
sv_catpvs(exsv, "\t...propagated");
|
||||
}
|
||||
diff --git a/t/op/die.t b/t/op/die.t
|
||||
index ef2b85f8f5..d6d7daffa5 100644
|
||||
--- a/t/op/die.t
|
||||
+++ b/t/op/die.t
|
||||
@@ -6,7 +6,7 @@ BEGIN {
|
||||
set_up_inc('../lib');
|
||||
}
|
||||
|
||||
-plan tests => 20;
|
||||
+plan tests => 21;
|
||||
|
||||
eval {
|
||||
eval {
|
||||
@@ -94,6 +94,10 @@ like($@, qr/\.{3}propagated at/, '... and appends a phrase');
|
||||
local $SIG{__WARN__} = sub { $ok = 0 };
|
||||
eval { undef $@; die };
|
||||
is( $ok, 1, 'no warnings if $@ is undef' );
|
||||
+
|
||||
+ eval { $@ = 100; die };
|
||||
+ like($@."", qr/100\t\.{3}propagated at/,
|
||||
+ 'check non-PVs in $@ are propagated');
|
||||
}
|
||||
|
||||
TODO: {
|
||||
--
|
||||
2.20.1
|
||||
|
||||
@ -0,0 +1,118 @@
|
||||
From 8b4b30c5d389983c3df51b7ff3b38e5608c7c2e2 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 3 Aug 2019 09:17:43 -0600
|
||||
Subject: [PATCH] perlapi: 5.30 promise not met; change to 5.32
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
We delayed this change, but I forgot to change this documentation
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
handy.h | 24 ++++++++++++------------
|
||||
1 file changed, 12 insertions(+), 12 deletions(-)
|
||||
|
||||
diff --git a/handy.h b/handy.h
|
||||
index 24c028a638..2dfbc86125 100644
|
||||
--- a/handy.h
|
||||
+++ b/handy.h
|
||||
@@ -609,13 +609,13 @@ future releases.
|
||||
Variant C<isI<FOO>_utf8> is like C<isI<FOO>_utf8_safe>, but takes just a single
|
||||
parameter, C<p>, which has the same meaning as the corresponding parameter does
|
||||
in C<isI<FOO>_utf8_safe>. The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take a second
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take a second
|
||||
parameter, becoming a synonym for C<isI<FOO>_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<isI<FOO>_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<isI<FOO>_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
Variant C<isI<FOO>_LC> is like the C<isI<FOO>_A> and C<isI<FOO>_L1> variants, but the
|
||||
@@ -649,13 +649,13 @@ future releases.
|
||||
Variant C<isI<FOO>_LC_utf8> is like C<isI<FOO>_LC_utf8_safe>, but takes just a single
|
||||
parameter, C<p>, which has the same meaning as the corresponding parameter does
|
||||
in C<isI<FOO>_LC_utf8_safe>. The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take a second
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take a second
|
||||
parameter, becoming a synonym for C<isI<FOO>_LC_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<isI<FOO>_LC_utf8> from each call point in
|
||||
the program will raise a deprecation warning, enabled by default. You can
|
||||
convert your program now to use C<isI<FOO>_LC_utf8_safe>, and avoid the warnings,
|
||||
-and get an extra measure of protection, or you can wait until v5.30, when
|
||||
+and get an extra measure of protection, or you can wait until v5.32, when
|
||||
you'll be forced to add the C<e> parameter.
|
||||
|
||||
=for apidoc Am|bool|isALPHA|char ch
|
||||
@@ -897,13 +897,13 @@ implementation, and subject to change in future releases.
|
||||
=for apidoc Am|UV|toUPPER_utf8|U8* p|U8* s|STRLEN* lenp
|
||||
This is like C<L</toUPPER_utf8_safe>>, but doesn't have the C<e>
|
||||
parameter The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take the C<e>
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take the C<e>
|
||||
parameter, becoming a synonym for C<toUPPER_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<toUPPER_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<toUPPER_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
=for apidoc Am|U8|toFOLD|U8 ch
|
||||
@@ -944,13 +944,13 @@ implementation, and subject to change in future releases.
|
||||
=for apidoc Am|UV|toFOLD_utf8|U8* p|U8* s|STRLEN* lenp
|
||||
This is like C<L</toFOLD_utf8_safe>>, but doesn't have the C<e>
|
||||
parameter The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take the C<e>
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take the C<e>
|
||||
parameter, becoming a synonym for C<toFOLD_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<toFOLD_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<toFOLD_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
=for apidoc Am|U8|toLOWER|U8 ch
|
||||
@@ -999,13 +999,13 @@ implementation, and subject to change in future releases.
|
||||
=for apidoc Am|UV|toLOWER_utf8|U8* p|U8* s|STRLEN* lenp
|
||||
This is like C<L</toLOWER_utf8_safe>>, but doesn't have the C<e>
|
||||
parameter The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take the C<e>
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take the C<e>
|
||||
parameter, becoming a synonym for C<toLOWER_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<toLOWER_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<toLOWER_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
=for apidoc Am|U8|toTITLE|U8 ch
|
||||
@@ -1047,13 +1047,13 @@ implementation, and subject to change in future releases.
|
||||
=for apidoc Am|UV|toTITLE_utf8|U8* p|U8* s|STRLEN* lenp
|
||||
This is like C<L</toLOWER_utf8_safe>>, but doesn't have the C<e>
|
||||
parameter The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take the C<e>
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take the C<e>
|
||||
parameter, becoming a synonym for C<toTITLE_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<toTITLE_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<toTITLE_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
=cut
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,36 @@
|
||||
From 31532982b04c20a43aa9c3d26780e3591c524fbc Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Thu, 27 Jun 2019 15:39:11 -0600
|
||||
Subject: [PATCH] regcomp.c: Don't read off the end of buffer
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Until this commit, it was possible that \p{nv=3/} would cause the right
|
||||
brace to be considered part of the property name.
|
||||
|
||||
Spotted by Hugo van der Sanden
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 4 +++-
|
||||
1 file changed, 3 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 1117998fc8..cf9246473f 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -23092,7 +23092,9 @@ Perl_parse_uniprop_string(pTHX_
|
||||
}
|
||||
|
||||
/* Store the first real character in the denominator */
|
||||
- lookup_name[j++] = name[i];
|
||||
+ if (i < name_len) {
|
||||
+ lookup_name[j++] = name[i];
|
||||
+ }
|
||||
}
|
||||
}
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,30 @@
|
||||
From 425077e4b85509df2907be6c103d54c0687c7647 Mon Sep 17 00:00:00 2001
|
||||
From: Florian Weimer <fweimer@redhat.com>
|
||||
Date: Mon, 9 Sep 2019 19:35:47 +0200
|
||||
Subject: [PATCH 1/2] Configure: Include <stdlib.h> in futimes check
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Needed for the exit function.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
Configure | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/Configure b/Configure
|
||||
index 818deb8378..7aa03d6aed 100755
|
||||
--- a/Configure
|
||||
+++ b/Configure
|
||||
@@ -14091,6 +14091,7 @@ $cat >try.c <<EOCP
|
||||
#include <sys/time.h>
|
||||
#include <errno.h>
|
||||
#include <fcntl.h>
|
||||
+#include <stdlib.h>
|
||||
|
||||
int main ()
|
||||
{
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,28 @@
|
||||
From da006e4432402cea01c9018743467314377e3c1e Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 10 Sep 2019 10:44:10 +1000
|
||||
Subject: [PATCH 2/2] Florian Weimer is now a perl author
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
AUTHORS | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/AUTHORS b/AUTHORS
|
||||
index a2b6d8c15a..a554cfc045 100644
|
||||
--- a/AUTHORS
|
||||
+++ b/AUTHORS
|
||||
@@ -418,6 +418,7 @@ Fergal Daly <fergal@esatclear.ie>
|
||||
Fingle Nark <finglenark@gmail.com>
|
||||
Florent Guillaume
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
+Florian Weimer <fweimer@redhat.com>
|
||||
François Désarménien <desar@club-internet.fr>
|
||||
François Perrad <francois.perrad@gadz.org>
|
||||
Frank Crawford
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,31 @@
|
||||
From 7ea7c4bb61d23965a7ad7041fe9c58b5075aac85 Mon Sep 17 00:00:00 2001
|
||||
From: James E Keenan <jkeenan@cpan.org>
|
||||
Date: Sat, 31 Aug 2019 19:18:36 -0400
|
||||
Subject: [PATCH] Supply missing right brace in regex example
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
As suggested by Jim Avera in RT 134395.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perlrebackslash.pod | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/pod/perlrebackslash.pod b/pod/perlrebackslash.pod
|
||||
index cfd182a7e1..4a8717346d 100644
|
||||
--- a/pod/perlrebackslash.pod
|
||||
+++ b/pod/perlrebackslash.pod
|
||||
@@ -446,7 +446,7 @@ Mnemonic: I<g>roup.
|
||||
=head3 Relative referencing
|
||||
|
||||
C<\g-I<N>> (starting in Perl 5.10.0) is used for relative addressing. (It can
|
||||
-be written as C<\g{-I<N>>.) It refers to the I<N>th group before the
|
||||
+be written as C<\g{-I<N>}>.) It refers to the I<N>th group before the
|
||||
C<\g{-I<N>}>.
|
||||
|
||||
The big advantage of this form is that it makes it much easier to write
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,57 @@
|
||||
From 14d26b44a1d7eee67837ec0ea8fb0368ac6fe33e Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 20 Aug 2019 15:43:05 +1000
|
||||
Subject: [PATCH] (perl #134230) don't interpret 0x, 0b when numifying strings
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
numeric.c | 9 +++++++++
|
||||
t/op/int.t | 5 ++++-
|
||||
2 files changed, 13 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/numeric.c b/numeric.c
|
||||
index f5eadc8173..fae2eb3c6d 100644
|
||||
--- a/numeric.c
|
||||
+++ b/numeric.c
|
||||
@@ -1551,6 +1551,15 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
|
||||
if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
|
||||
return endp;
|
||||
|
||||
+ /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
|
||||
+ 0b-prefixed binary numbers, which is backward incompatible
|
||||
+ */
|
||||
+ if ((len == 0 || len >= 2) && *s == '0' &&
|
||||
+ (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
|
||||
+ *value = 0;
|
||||
+ return (char *)s+1;
|
||||
+ }
|
||||
+
|
||||
/* If the length is passed in, the input string isn't NUL-terminated,
|
||||
* and in it turns out the function below assumes it is; therefore we
|
||||
* create a copy and NUL-terminate that */
|
||||
diff --git a/t/op/int.t b/t/op/int.t
|
||||
index 7e936da68d..b730ab2672 100644
|
||||
--- a/t/op/int.t
|
||||
+++ b/t/op/int.t
|
||||
@@ -7,7 +7,7 @@ BEGIN {
|
||||
require Config;
|
||||
}
|
||||
|
||||
-plan 17;
|
||||
+plan 19;
|
||||
|
||||
# compile time evaluation
|
||||
|
||||
@@ -83,3 +83,6 @@ SKIP:
|
||||
cmp_ok($x, "==", int($x), "check $x == int($x)");
|
||||
}
|
||||
}
|
||||
+
|
||||
+is(1+"0x10", 1, "check string '0x' prefix not treated as hex");
|
||||
+is(1+"0b10", 1, "check string '0b' prefix not treated as binary");
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,31 @@
|
||||
From 8d3e0237887e7149be56d17a9448cb465edc5f76 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Thu, 22 Aug 2019 10:16:14 -0600
|
||||
Subject: [PATCH] regcomp.c: Fix wrong limit test
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Spotted by Hugo van der Sanden in code reading.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index aba6648da5..d61fd434fe 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -23132,7 +23132,7 @@ Perl_parse_uniprop_string(pTHX_
|
||||
|
||||
/* If the original input began with 'In' or 'Is', it could be a subroutine
|
||||
* call to a user-defined property instead of a Unicode property name. */
|
||||
- if ( non_pkg_begin + name_len > 2
|
||||
+ if ( name_len - non_pkg_begin > 2
|
||||
&& name[non_pkg_begin+0] == 'I'
|
||||
&& (name[non_pkg_begin+1] == 'n' || name[non_pkg_begin+1] == 's'))
|
||||
{
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,237 @@
|
||||
From 01aed385e6bdbdcfd13bb66e9d8b7c55d2cfc34a Mon Sep 17 00:00:00 2001
|
||||
From: James E Keenan <jkeenan@cpan.org>
|
||||
Date: Thu, 19 Sep 2019 23:02:54 -0400
|
||||
Subject: [PATCH] Handle undefined values correctly
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
As reported by Henrik Pauli in RT 134441, the documentation's claim that
|
||||
|
||||
$dv->dumpValue([$x, $y]);
|
||||
|
||||
and
|
||||
|
||||
$dv->dumpValues($x, $y);
|
||||
|
||||
was not being sustained in the case where one of the elements in the
|
||||
array (or array ref) was undefined. This was due to an insufficiently
|
||||
precise specification within the dumpValues() method for determining
|
||||
when the value "undef\n" should be printed.
|
||||
|
||||
Tests for previously untested cases have been provided in
|
||||
t/rt-134441-dumpvalue.t. They were not appended to t/Dumpvalue.t (as
|
||||
would normally have been the case) because the tests in that file have
|
||||
accreted over the years in a sub-optimal manner: changes in attributes
|
||||
of the Dumpvalue object are tested but those changes are not zeroed-out
|
||||
(by, e.g., use of 'local $self->{attribute} = undef')
|
||||
before additional attributes are modified and tested. As a consequence,
|
||||
it's difficult to determine the state of the Dumpvalue object at any
|
||||
particular point and interactions between attributes cannot be ruled
|
||||
out.
|
||||
|
||||
Package TieOut, used to capture STDOUT during testing, has been
|
||||
extracted to its own file so that it can be used by all test files.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 2 +
|
||||
dist/Dumpvalue/lib/Dumpvalue.pm | 4 +-
|
||||
dist/Dumpvalue/t/Dumpvalue.t | 20 +-----
|
||||
dist/Dumpvalue/t/lib/TieOut.pm | 20 ++++++
|
||||
dist/Dumpvalue/t/rt-134441-dumpvalue.t | 86 ++++++++++++++++++++++++++
|
||||
5 files changed, 112 insertions(+), 20 deletions(-)
|
||||
create mode 100644 dist/Dumpvalue/t/lib/TieOut.pm
|
||||
create mode 100644 dist/Dumpvalue/t/rt-134441-dumpvalue.t
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 7bf62d8479..8159ac8cc1 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -3455,6 +3455,8 @@ dist/Devel-SelfStubber/lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
|
||||
dist/Devel-SelfStubber/t/Devel-SelfStubber.t See if Devel::SelfStubber works
|
||||
dist/Dumpvalue/lib/Dumpvalue.pm Screen dump of perl values
|
||||
dist/Dumpvalue/t/Dumpvalue.t See if Dumpvalue works
|
||||
+dist/Dumpvalue/t/lib/TieOut.pm Helper module for Dumpvalue tests
|
||||
+dist/Dumpvalue/t/rt-134441-dumpvalue.t See if Dumpvalue works
|
||||
dist/encoding-warnings/lib/encoding/warnings.pm warn on implicit encoding conversions
|
||||
dist/encoding-warnings/t/1-warning.t tests for encoding::warnings
|
||||
dist/encoding-warnings/t/2-fatal.t tests for encoding::warnings
|
||||
diff --git a/dist/Dumpvalue/lib/Dumpvalue.pm b/dist/Dumpvalue/lib/Dumpvalue.pm
|
||||
index eef9b27157..3faf829538 100644
|
||||
--- a/dist/Dumpvalue/lib/Dumpvalue.pm
|
||||
+++ b/dist/Dumpvalue/lib/Dumpvalue.pm
|
||||
@@ -1,7 +1,7 @@
|
||||
use 5.006_001; # for (defined ref) and $#$v and our
|
||||
package Dumpvalue;
|
||||
use strict;
|
||||
-our $VERSION = '1.18';
|
||||
+our $VERSION = '1.19';
|
||||
our(%address, $stab, @stab, %stab, %subs);
|
||||
|
||||
sub ASCII { return ord('A') == 65; }
|
||||
@@ -79,7 +79,7 @@ sub dumpValues {
|
||||
my $self = shift;
|
||||
local %address;
|
||||
local $^W=0;
|
||||
- (print "undef\n"), return unless defined $_[0];
|
||||
+ (print "undef\n"), return if (@_ == 1 and not defined $_[0]);
|
||||
$self->unwrap(\@_,0);
|
||||
}
|
||||
|
||||
diff --git a/dist/Dumpvalue/t/Dumpvalue.t b/dist/Dumpvalue/t/Dumpvalue.t
|
||||
index 7063dd984c..ba8775126e 100644
|
||||
--- a/dist/Dumpvalue/t/Dumpvalue.t
|
||||
+++ b/dist/Dumpvalue/t/Dumpvalue.t
|
||||
@@ -16,6 +16,8 @@ BEGIN {
|
||||
|
||||
our ( $foo, @bar, %baz );
|
||||
|
||||
+use lib ("./t/lib");
|
||||
+use TieOut;
|
||||
use Test::More tests => 88;
|
||||
|
||||
use_ok( 'Dumpvalue' );
|
||||
@@ -278,21 +280,3 @@ is( $out->read, "0 0..0 'two'\n", 'dumpValues worked on array ref' );
|
||||
$d->dumpValues('one', 'two');
|
||||
is( $out->read, "0..1 'one' 'two'\n", 'dumpValues worked on multiple values' );
|
||||
|
||||
-
|
||||
-package TieOut;
|
||||
-use overload '"' => sub { "overloaded!" };
|
||||
-
|
||||
-sub TIEHANDLE {
|
||||
- my $class = shift;
|
||||
- bless(\( my $ref), $class);
|
||||
-}
|
||||
-
|
||||
-sub PRINT {
|
||||
- my $self = shift;
|
||||
- $$self .= join('', @_);
|
||||
-}
|
||||
-
|
||||
-sub read {
|
||||
- my $self = shift;
|
||||
- return substr($$self, 0, length($$self), '');
|
||||
-}
|
||||
diff --git a/dist/Dumpvalue/t/lib/TieOut.pm b/dist/Dumpvalue/t/lib/TieOut.pm
|
||||
new file mode 100644
|
||||
index 0000000000..568caedf9c
|
||||
--- /dev/null
|
||||
+++ b/dist/Dumpvalue/t/lib/TieOut.pm
|
||||
@@ -0,0 +1,20 @@
|
||||
+package TieOut;
|
||||
+use overload '"' => sub { "overloaded!" };
|
||||
+
|
||||
+sub TIEHANDLE {
|
||||
+ my $class = shift;
|
||||
+ bless(\( my $ref), $class);
|
||||
+}
|
||||
+
|
||||
+sub PRINT {
|
||||
+ my $self = shift;
|
||||
+ $$self .= join('', @_);
|
||||
+}
|
||||
+
|
||||
+sub read {
|
||||
+ my $self = shift;
|
||||
+ return substr($$self, 0, length($$self), '');
|
||||
+}
|
||||
+
|
||||
+1;
|
||||
+
|
||||
diff --git a/dist/Dumpvalue/t/rt-134441-dumpvalue.t b/dist/Dumpvalue/t/rt-134441-dumpvalue.t
|
||||
new file mode 100644
|
||||
index 0000000000..cc9f270f5a
|
||||
--- /dev/null
|
||||
+++ b/dist/Dumpvalue/t/rt-134441-dumpvalue.t
|
||||
@@ -0,0 +1,86 @@
|
||||
+BEGIN {
|
||||
+ require Config;
|
||||
+ if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
|
||||
+ print "1..0 # Skip -- Perl configured without List::Util module\n";
|
||||
+ exit 0;
|
||||
+ }
|
||||
+
|
||||
+ # `make test` in the CPAN version of this module runs us with -w, but
|
||||
+ # Dumpvalue.pm relies on all sorts of things that can cause warnings. I
|
||||
+ # don't think that's worth fixing, so we just turn off all warnings
|
||||
+ # during testing.
|
||||
+ $^W = 0;
|
||||
+}
|
||||
+
|
||||
+use lib ("./t/lib");
|
||||
+use TieOut;
|
||||
+use Test::More tests => 17;
|
||||
+
|
||||
+use_ok( 'Dumpvalue' );
|
||||
+
|
||||
+my $d;
|
||||
+ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' );
|
||||
+
|
||||
+my $out = tie *OUT, 'TieOut';
|
||||
+select(OUT);
|
||||
+
|
||||
+my (@foobar, $x, $y);
|
||||
+
|
||||
+@foobar = ('foo', 'bar');
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 'foo'\n1 'bar'\n", 'dumpValue worked on array ref' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 'foo'\n1 'bar'\n", 'dumpValues worked on array' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref");
|
||||
+
|
||||
+@foobar = (undef, 'bar');
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 undef\n1 'bar'\n",
|
||||
+ 'dumpValue worked on array ref, first element undefined' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 undef\n1 'bar'\n",
|
||||
+ 'dumpValues worked on array, first element undefined' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref, first element undefined");
|
||||
+
|
||||
+@foobar = ('bar', undef);
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 'bar'\n1 undef\n",
|
||||
+ 'dumpValue worked on array ref, last element undefined' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 'bar'\n1 undef\n",
|
||||
+ 'dumpValues worked on array, last element undefined' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref, last element undefined");
|
||||
+
|
||||
+@foobar = ('', 'bar');
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 ''\n1 'bar'\n",
|
||||
+ 'dumpValue worked on array ref, first element empty string' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 ''\n1 'bar'\n",
|
||||
+ 'dumpValues worked on array, first element empty string' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref, first element empty string");
|
||||
+
|
||||
+@foobar = ('bar', '');
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 'bar'\n1 ''\n",
|
||||
+ 'dumpValue worked on array ref, last element empty string' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 'bar'\n1 ''\n",
|
||||
+ 'dumpValues worked on array, last element empty string' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref, last element empty string");
|
||||
+
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,109 @@
|
||||
From 913582217c96512015fd60f270f0e262824579b7 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Tue, 12 Nov 2019 09:19:18 +0100
|
||||
Subject: [PATCH] Adapt Configure to GCC version 10
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
I got a notice from Jeff Law <law@redhat.com>:
|
||||
|
||||
Your particular package fails its testsuite. This was ultimately
|
||||
tracked down to a Configure problem. The perl configure script treated
|
||||
gcc-10 as gcc-1 and turned on -fpcc-struct-return. This is an ABI
|
||||
changing flag and caused Perl to not be able to interact properly with
|
||||
the dbm libraries on the system leading to a segfault.
|
||||
|
||||
His proposed patch corrected only this one instance of the version
|
||||
mismatch. Reading the Configure script revealed more issues. This
|
||||
patch fixes all of them I found.
|
||||
|
||||
Please note I did not test it because I don't have GCC 10 available.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
Configure | 14 +++++++-------
|
||||
cflags.SH | 2 +-
|
||||
2 files changed, 8 insertions(+), 8 deletions(-)
|
||||
|
||||
diff --git a/Configure b/Configure
|
||||
index fad1c9f2b1..706c0b64ed 100755
|
||||
--- a/Configure
|
||||
+++ b/Configure
|
||||
@@ -4701,7 +4701,7 @@ else
|
||||
fi
|
||||
$rm -f try try.*
|
||||
case "$gccversion" in
|
||||
-1*) cpp=`./loc gcc-cpp $cpp $pth` ;;
|
||||
+1.*) cpp=`./loc gcc-cpp $cpp $pth` ;;
|
||||
esac
|
||||
case "$gccversion" in
|
||||
'') gccosandvers='' ;;
|
||||
@@ -4741,7 +4741,7 @@ esac
|
||||
# gcc 3.* complain about adding -Idirectories that they already know about,
|
||||
# so we will take those off from locincpth.
|
||||
case "$gccversion" in
|
||||
-3*)
|
||||
+3.*)
|
||||
echo "main(){}">try.c
|
||||
for incdir in $locincpth; do
|
||||
warn=`$cc $ccflags -I$incdir -c try.c 2>&1 | \
|
||||
@@ -5467,13 +5467,13 @@ fi
|
||||
case "$hint" in
|
||||
default|recommended)
|
||||
case "$gccversion" in
|
||||
- 1*) dflt="$dflt -fpcc-struct-return" ;;
|
||||
+ 1.*) dflt="$dflt -fpcc-struct-return" ;;
|
||||
esac
|
||||
case "$optimize:$DEBUGGING" in
|
||||
*-g*:old) dflt="$dflt -DDEBUGGING";;
|
||||
esac
|
||||
case "$gccversion" in
|
||||
- 2*) if $test -d /etc/conf/kconfig.d &&
|
||||
+ 2.*) if $test -d /etc/conf/kconfig.d &&
|
||||
$contains _POSIX_VERSION $usrinc/sys/unistd.h >/dev/null 2>&1
|
||||
then
|
||||
# Interactive Systems (ISC) POSIX mode.
|
||||
@@ -5482,7 +5482,7 @@ default|recommended)
|
||||
;;
|
||||
esac
|
||||
case "$gccversion" in
|
||||
- 1*) ;;
|
||||
+ 1.*) ;;
|
||||
2.[0-8]*) ;;
|
||||
?*) set strict-aliasing -fno-strict-aliasing
|
||||
eval $checkccflag
|
||||
@@ -5600,7 +5600,7 @@ case "$cppflags" in
|
||||
;;
|
||||
esac
|
||||
case "$gccversion" in
|
||||
-1*) cppflags="$cppflags -D__GNUC__"
|
||||
+1.*) cppflags="$cppflags -D__GNUC__"
|
||||
esac
|
||||
case "$mips_type" in
|
||||
'');;
|
||||
@@ -23103,7 +23103,7 @@ fi
|
||||
|
||||
: add -D_FORTIFY_SOURCE if feasible and not already there
|
||||
case "$gccversion" in
|
||||
-[456789].*) case "$optimize$ccflags" in
|
||||
+[456789].*|[1-9][0-9]*) case "$optimize$ccflags" in
|
||||
*-O*) case "$ccflags$cppsymbols" in
|
||||
*_FORTIFY_SOURCE=*) # Don't add it again.
|
||||
echo "You seem to have -D_FORTIFY_SOURCE already, not adding it." >&4
|
||||
diff --git a/cflags.SH b/cflags.SH
|
||||
index e60742fed1..f1bcd6c38e 100755
|
||||
--- a/cflags.SH
|
||||
+++ b/cflags.SH
|
||||
@@ -156,7 +156,7 @@ esac
|
||||
|
||||
case "$gccversion" in
|
||||
'') ;;
|
||||
-[12]*) ;; # gcc versions 1 (gasp!) and 2 are not good for this.
|
||||
+[12].*) ;; # gcc versions 1 (gasp!) and 2 are not good for this.
|
||||
Intel*) ;; # # Is that you, Intel C++?
|
||||
#
|
||||
# NOTE 1: the -std=c89 without -pedantic is a bit pointless.
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,32 @@
|
||||
From a1c1fa25b1b25efb11cc8f987e007d4dd20056bc Mon Sep 17 00:00:00 2001
|
||||
From: Dave Cross <dave@dave.org.uk>
|
||||
Date: Wed, 23 Oct 2019 12:50:01 +0100
|
||||
Subject: [PATCH] Be clearer about taint's effect on @INC.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perlsec.pod | 5 +++--
|
||||
1 file changed, 3 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pod/perlsec.pod b/pod/perlsec.pod
|
||||
index 0682674143..a631981ba5 100644
|
||||
--- a/pod/perlsec.pod
|
||||
+++ b/pod/perlsec.pod
|
||||
@@ -269,8 +269,9 @@ problem will be reported:
|
||||
Insecure dependency in require while running with -T switch
|
||||
|
||||
On versions of Perl before 5.26, activating taint mode will also remove
|
||||
-the current directory (".") from C<@INC>. Since version 5.26, the
|
||||
-current directory isn't included in C<@INC>.
|
||||
+the current directory (".") from the default value of C<@INC>. Since
|
||||
+version 5.26, the current directory isn't included in C<@INC> by
|
||||
+default.
|
||||
|
||||
=head2 Cleaning Up Your Path
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,45 @@
|
||||
From f73351928dfa1d1d564d3f7b8e63c5281ed835ee Mon Sep 17 00:00:00 2001
|
||||
From: Dave Cross <dave@dave.org.uk>
|
||||
Date: Tue, 22 Oct 2019 14:24:13 +0100
|
||||
Subject: [PATCH] Fix taint mode @INC documentation
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Explain that -T no longer removes '.' from @INC because, since
|
||||
5.26, '.' isn't in @INC to start with.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perlsec.pod | 8 ++++++--
|
||||
1 file changed, 6 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pod/perlsec.pod b/pod/perlsec.pod
|
||||
index b210445685..0682674143 100644
|
||||
--- a/pod/perlsec.pod
|
||||
+++ b/pod/perlsec.pod
|
||||
@@ -245,8 +245,8 @@ Unix-like environments that support #! and setuid or setgid scripts.)
|
||||
|
||||
=head2 Taint mode and @INC
|
||||
|
||||
-When the taint mode (C<-T>) is in effect, the "." directory is removed
|
||||
-from C<@INC>, and the environment variables C<PERL5LIB> and C<PERLLIB>
|
||||
+When the taint mode (C<-T>) is in effect, the environment variables
|
||||
+C<PERL5LIB> and C<PERLLIB>
|
||||
are ignored by Perl. You can still adjust C<@INC> from outside the
|
||||
program by using the C<-I> command line option as explained in
|
||||
L<perlrun>. The two environment variables are ignored because
|
||||
@@ -268,6 +268,10 @@ problem will be reported:
|
||||
|
||||
Insecure dependency in require while running with -T switch
|
||||
|
||||
+On versions of Perl before 5.26, activating taint mode will also remove
|
||||
+the current directory (".") from C<@INC>. Since version 5.26, the
|
||||
+current directory isn't included in C<@INC>.
|
||||
+
|
||||
=head2 Cleaning Up Your Path
|
||||
|
||||
For "Insecure C<$ENV{PATH}>" messages, you need to set C<$ENV{'PATH'}> to
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,30 @@
|
||||
From 0463f3a19af7afac8b402655ad66e5b05c095bcc Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Fri, 15 Nov 2019 15:01:15 -0700
|
||||
Subject: [PATCH] PATCH: gh#17218 memory leak
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Indeed, a variable's ref count was not getting decremented.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 076ea350b5..7b9bf6ba7d 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -18180,6 +18180,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
|
||||
|
||||
/* Likewise for 'posixes' */
|
||||
_invlist_union(posixes, cp_list, &cp_list);
|
||||
+ SvREFCNT_dec(posixes);
|
||||
|
||||
/* Likewise for anything else in the range that matched only
|
||||
* under UTF-8 */
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,77 @@
|
||||
From a4e94e39cfa6852b1d57e61ee122c8083ab9d82e Mon Sep 17 00:00:00 2001
|
||||
From: Hauke D <haukex@zero-g.net>
|
||||
Date: Mon, 20 Nov 2017 15:31:57 +0100
|
||||
Subject: [PATCH] Tie::StdHandle::BINMODE: handle layer argument
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Fixes #16262
|
||||
|
||||
BINMODE was not handling the LAYER argument.
|
||||
Also bump the version number.
|
||||
|
||||
(cherry picked from commit 479d04b98e5b747e5c9ead7368d3e132f524a2b7)
|
||||
Signed-off-by: Nicolas R <atoomic@cpan.org>
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
lib/Tie/Handle/stdhandle.t | 13 ++++++++++++-
|
||||
lib/Tie/StdHandle.pm | 4 ++--
|
||||
2 files changed, 14 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/lib/Tie/Handle/stdhandle.t b/lib/Tie/Handle/stdhandle.t
|
||||
index d2f04bcc5c..6c20d90f2b 100644
|
||||
--- a/lib/Tie/Handle/stdhandle.t
|
||||
+++ b/lib/Tie/Handle/stdhandle.t
|
||||
@@ -5,7 +5,7 @@ BEGIN {
|
||||
@INC = '../lib';
|
||||
}
|
||||
|
||||
-use Test::More tests => 27;
|
||||
+use Test::More tests => 29;
|
||||
|
||||
use_ok('Tie::StdHandle');
|
||||
|
||||
@@ -72,6 +72,17 @@ is($b, "rhubarbX\n", "b eq rhubarbX");
|
||||
$b = <$f>;
|
||||
is($b, "89\n", "b eq 89");
|
||||
|
||||
+# binmode should pass through layer argument
|
||||
+
|
||||
+binmode $f, ':raw';
|
||||
+ok !grep( $_ eq 'utf8', PerlIO::get_layers(tied(*$f)) ),
|
||||
+ 'no utf8 in layers after binmode :raw';
|
||||
+binmode $f, ':utf8';
|
||||
+ok grep( $_ eq 'utf8', PerlIO::get_layers(tied(*$f)) ),
|
||||
+ 'utf8 is in layers after binmode :utf8';
|
||||
+
|
||||
+# finish up
|
||||
+
|
||||
ok(eof($f), "eof");
|
||||
ok(close($f), "close");
|
||||
|
||||
diff --git a/lib/Tie/StdHandle.pm b/lib/Tie/StdHandle.pm
|
||||
index dfb86634f0..fb79a986c6 100644
|
||||
--- a/lib/Tie/StdHandle.pm
|
||||
+++ b/lib/Tie/StdHandle.pm
|
||||
@@ -4,7 +4,7 @@ use strict;
|
||||
|
||||
use Tie::Handle;
|
||||
our @ISA = 'Tie::Handle';
|
||||
-our $VERSION = '4.5';
|
||||
+our $VERSION = '4.6';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
@@ -48,7 +48,7 @@ sub TELL { tell($_[0]) }
|
||||
sub FILENO { fileno($_[0]) }
|
||||
sub SEEK { seek($_[0],$_[1],$_[2]) }
|
||||
sub CLOSE { close($_[0]) }
|
||||
-sub BINMODE { binmode($_[0]) }
|
||||
+sub BINMODE { &CORE::binmode(shift, @_) }
|
||||
|
||||
sub OPEN
|
||||
{
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,48 @@
|
||||
From 7c3f362035dec9b7eaec388b1f7f1619c1bd96a3 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 4 Nov 2019 09:52:22 +1100
|
||||
Subject: [PATCH] prevent a race between name-based stat and an open modifying
|
||||
atime
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Most linux systems rarely update atime, so it's very unlikely
|
||||
for this issue to trigger there, but on a system with classic atime
|
||||
behaviour this was a race between open modifying atime and time()
|
||||
ticking over.
|
||||
|
||||
gh #17234
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
lib/File/stat.t | 6 ++++--
|
||||
1 file changed, 4 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/lib/File/stat.t b/lib/File/stat.t
|
||||
index c403fc4498..fc9bb12cef 100644
|
||||
--- a/lib/File/stat.t
|
||||
+++ b/lib/File/stat.t
|
||||
@@ -133,6 +133,9 @@ SKIP: {
|
||||
test_X_ops($^X, "for $^X", qr/A/);
|
||||
}
|
||||
|
||||
+# open early so atime is consistent with the name based call
|
||||
+local *STAT;
|
||||
+my $canopen = open(STAT, '<', $file);
|
||||
|
||||
my $stat = File::stat::stat($file);
|
||||
isa_ok($stat, 'File::stat', 'should build a stat object');
|
||||
@@ -143,8 +146,7 @@ for (split //, "tTB") {
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
- local *STAT;
|
||||
- skip("Could not open file: $!", 2) unless open(STAT, '<', $file);
|
||||
+ skip("Could not open file: $!", 2) unless $canopen;
|
||||
isa_ok(File::stat::stat('STAT'), 'File::stat',
|
||||
'... should be able to find filehandle');
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,78 @@
|
||||
From 0c311b7c345769239f38d0139ea7738feec5ca4d Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 2 Nov 2019 13:59:38 -0600
|
||||
Subject: [PATCH] toke.c: Fix bug tr/// upgrading to UTF-8 in middle
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Consider tr/\x{ff}-\x{100}/AB/.
|
||||
|
||||
While parsing, the code keeps an offset from the beginning of the output
|
||||
to the beginning of the second number in the range. This is purely for
|
||||
speed so that it wouldn't have to re-find the beginning of that value,
|
||||
when it already knew it.
|
||||
|
||||
But the example above shows the folly of this shortcut. The second
|
||||
number in the range causes the output to be upgraded to UTF-8, which
|
||||
makes that offset invalid in general. Change to re-find the beginning.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/tr.t | 12 +++++++++++-
|
||||
toke.c | 4 +++-
|
||||
2 files changed, 14 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/t/op/tr.t b/t/op/tr.t
|
||||
index 47d603d4fd..25125c5bc7 100644
|
||||
--- a/t/op/tr.t
|
||||
+++ b/t/op/tr.t
|
||||
@@ -13,7 +13,7 @@ BEGIN {
|
||||
|
||||
use utf8;
|
||||
|
||||
-plan tests => 301;
|
||||
+plan tests => 304;
|
||||
|
||||
# Test this first before we extend the stack with other operations.
|
||||
# This caused an asan failure due to a bad write past the end of the stack.
|
||||
@@ -1145,4 +1145,14 @@ for ("", nullrocow) {
|
||||
'RT #133880 illegal \N{}');
|
||||
}
|
||||
|
||||
+{
|
||||
+ my $c = "\xff";
|
||||
+ my $d = "\x{104}";
|
||||
+ eval '$c =~ tr/\x{ff}-\x{104}/\x{100}-\x{105}/';
|
||||
+ is($@, "", 'tr/\x{ff}-\x{104}/\x{100}-\x{105}/ compiled');
|
||||
+ is($c, "\x{100}", 'ff -> 100');
|
||||
+ eval '$d =~ tr/\x{ff}-\x{104}/\x{100}-\x{105}/';
|
||||
+ is($d, "\x{105}", '104 -> 105');
|
||||
+}
|
||||
+
|
||||
1;
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 2995737af2..28f305c62c 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -3044,7 +3044,7 @@ S_scan_const(pTHX_ char *start)
|
||||
* 'offset_to_max' is the offset in 'sv' at which the character
|
||||
* (the range's maximum end point) before 'd' begins.
|
||||
*/
|
||||
- char * max_ptr = SvPVX(sv) + offset_to_max;
|
||||
+ char * max_ptr;
|
||||
char * min_ptr;
|
||||
IV range_min;
|
||||
IV range_max; /* last character in range */
|
||||
@@ -3056,6 +3056,8 @@ S_scan_const(pTHX_ char *start)
|
||||
IV real_range_max = 0;
|
||||
#endif
|
||||
/* Get the code point values of the range ends. */
|
||||
+ max_ptr = (d_is_utf8) ? (char *) utf8_hop( (U8*) d, -1) : d - 1;
|
||||
+ offset_to_max = max_ptr - SvPVX_const(sv);
|
||||
if (d_is_utf8) {
|
||||
/* We know the utf8 is valid, because we just constructed
|
||||
* it ourselves in previous loop iterations */
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -0,0 +1,48 @@
|
||||
From d7f7b0e39a10a6e3e0bd81d15473ee522a064016 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 4 Nov 2019 21:55:53 -0700
|
||||
Subject: [PATCH] toke.c: comment changes
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
These should have been included in
|
||||
0c311b7c345769239f38d0139ea7738feec5ca4d
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
toke.c | 11 ++---------
|
||||
1 file changed, 2 insertions(+), 9 deletions(-)
|
||||
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 3f376640ef..9c1e77f9db 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -3032,13 +3032,8 @@ S_scan_const(pTHX_ char *start)
|
||||
s++; /* Skip past the hyphen */
|
||||
|
||||
/* d now points to where the end-range character will be
|
||||
- * placed. Save it so won't have to go finding it later,
|
||||
- * and drop down to get that character. (Actually we
|
||||
- * instead save the offset, to handle the case where a
|
||||
- * realloc in the meantime could change the actual
|
||||
- * pointer). We'll finish processing the range the next
|
||||
- * time through the loop */
|
||||
- offset_to_max = d - SvPVX_const(sv);
|
||||
+ * placed. Drop down to get that character. We'll finish
|
||||
+ * processing the range the next time through the loop */
|
||||
|
||||
if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
|
||||
has_above_latin1 = TRUE;
|
||||
@@ -3055,8 +3050,6 @@ S_scan_const(pTHX_ char *start)
|
||||
* are the range start and range end, in order.
|
||||
* 'd' points to just beyond the range end in the 'sv' string,
|
||||
* where we would next place something
|
||||
- * 'offset_to_max' is the offset in 'sv' at which the character
|
||||
- * (the range's maximum end point) before 'd' begins.
|
||||
*/
|
||||
char * max_ptr;
|
||||
char * min_ptr;
|
||||
--
|
||||
2.21.0
|
||||
|
||||
@ -1,175 +0,0 @@
|
||||
From bafffe7f2ca587960177ed03216e2d5692fe6143 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Wed, 19 Aug 2020 11:57:17 -0600
|
||||
Subject: [PATCH] Add av_count()
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This returns the number of elements in an array in a clearly named
|
||||
function.
|
||||
|
||||
av_top_index(), av_tindex() are clearly named, but are less than ideal,
|
||||
and came about because no one back then thought of this one, until now
|
||||
Paul Evans did.
|
||||
|
||||
Petr Písař: Port 87306e0674dfe3af29804b4641347cd5ac9b0521 to 5.32.0.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
av.c | 17 ++++++++++++++---
|
||||
av.h | 3 ++-
|
||||
embed.fnc | 3 ++-
|
||||
embed.h | 2 +-
|
||||
inline.h | 16 ++++++++++++----
|
||||
proto.h | 11 ++++++++---
|
||||
6 files changed, 39 insertions(+), 13 deletions(-)
|
||||
|
||||
diff --git a/av.c b/av.c
|
||||
index 27b2f12..b5ddaca 100644
|
||||
--- a/av.c
|
||||
+++ b/av.c
|
||||
@@ -814,9 +814,10 @@ The Perl equivalent for this is C<$#myarray>.
|
||||
=for apidoc av_len
|
||||
|
||||
Same as L</av_top_index>. Note that, unlike what the name implies, it returns
|
||||
-the highest index in the array, so to get the size of the array you need to use
|
||||
-S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
|
||||
-expect.
|
||||
+the highest index in the array. This is unlike L</sv_len>, which returns what
|
||||
+you would expect.
|
||||
+
|
||||
+B<To get the true number of elements in the array, instead use C<L</av_count>>>.
|
||||
|
||||
=cut
|
||||
*/
|
||||
@@ -1089,6 +1090,16 @@ Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
|
||||
return sv;
|
||||
}
|
||||
|
||||
+SSize_t
|
||||
+Perl_av_top_index(pTHX_ AV *av)
|
||||
+{
|
||||
+ PERL_ARGS_ASSERT_AV_TOP_INDEX;
|
||||
+ assert(SvTYPE(av) == SVt_PVAV);
|
||||
+
|
||||
+ return AvFILL(av);
|
||||
+}
|
||||
+
|
||||
+
|
||||
/*
|
||||
* ex: set ts=8 sts=4 sw=4 et:
|
||||
*/
|
||||
diff --git a/av.h b/av.h
|
||||
index 5e39c42..90ebfff 100644
|
||||
--- a/av.h
|
||||
+++ b/av.h
|
||||
@@ -81,7 +81,8 @@ Same as C<av_top_index()>.
|
||||
|
||||
#define AvFILL(av) ((SvRMAGICAL((const SV *) (av))) \
|
||||
? mg_size(MUTABLE_SV(av)) : AvFILLp(av))
|
||||
-#define av_tindex(av) av_top_index(av)
|
||||
+#define av_top_index(av) AvFILL(av)
|
||||
+#define av_tindex(av) av_top_index(av)
|
||||
|
||||
/* Note that it doesn't make sense to do this:
|
||||
* SvGETMAGIC(av); IV x = av_tindex_nomg(av);
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index 589ab1a..789cd3c 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -541,7 +541,8 @@ Apd |void |av_push |NN AV *av|NN SV *val
|
||||
EXp |void |av_reify |NN AV *av
|
||||
ApdR |SV* |av_shift |NN AV *av
|
||||
Apd |SV** |av_store |NN AV *av|SSize_t key|NULLOK SV *val
|
||||
-AidRp |SSize_t|av_top_index |NN AV *av
|
||||
+AMdRp |SSize_t|av_top_index |NN AV *av
|
||||
+AidRp |Size_t |av_count |NN AV *av
|
||||
AmdR |SSize_t|av_tindex |NN AV *av
|
||||
Apd |void |av_undef |NN AV *av
|
||||
Apdoex |SV** |av_create_and_unshift_one|NN AV **const avp|NN SV *const val
|
||||
diff --git a/embed.h b/embed.h
|
||||
index 182b12a..329ac40 100644
|
||||
--- a/embed.h
|
||||
+++ b/embed.h
|
||||
@@ -48,6 +48,7 @@
|
||||
#define atfork_lock Perl_atfork_lock
|
||||
#define atfork_unlock Perl_atfork_unlock
|
||||
#define av_clear(a) Perl_av_clear(aTHX_ a)
|
||||
+#define av_count(a) Perl_av_count(aTHX_ a)
|
||||
#define av_delete(a,b,c) Perl_av_delete(aTHX_ a,b,c)
|
||||
#define av_exists(a,b) Perl_av_exists(aTHX_ a,b)
|
||||
#define av_extend(a,b) Perl_av_extend(aTHX_ a,b)
|
||||
@@ -59,7 +60,6 @@
|
||||
#define av_push(a,b) Perl_av_push(aTHX_ a,b)
|
||||
#define av_shift(a) Perl_av_shift(aTHX_ a)
|
||||
#define av_store(a,b,c) Perl_av_store(aTHX_ a,b,c)
|
||||
-#define av_top_index(a) Perl_av_top_index(aTHX_ a)
|
||||
#define av_undef(a) Perl_av_undef(aTHX_ a)
|
||||
#define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b)
|
||||
#define block_end(a,b) Perl_block_end(aTHX_ a,b)
|
||||
diff --git a/inline.h b/inline.h
|
||||
index 27005d2..35af18a 100644
|
||||
--- a/inline.h
|
||||
+++ b/inline.h
|
||||
@@ -39,13 +39,21 @@ SOFTWARE.
|
||||
|
||||
/* ------------------------------- av.h ------------------------------- */
|
||||
|
||||
-PERL_STATIC_INLINE SSize_t
|
||||
-Perl_av_top_index(pTHX_ AV *av)
|
||||
+/*
|
||||
+=for apidoc av_count
|
||||
+Returns the number of elements in the array C<av>. This is the true length of
|
||||
+the array, including any undefined elements. It is always the same as
|
||||
+S<C<av_top_index(av) + 1>>.
|
||||
+
|
||||
+=cut
|
||||
+*/
|
||||
+PERL_STATIC_INLINE Size_t
|
||||
+Perl_av_count(pTHX_ AV *av)
|
||||
{
|
||||
- PERL_ARGS_ASSERT_AV_TOP_INDEX;
|
||||
+ PERL_ARGS_ASSERT_AV_COUNT;
|
||||
assert(SvTYPE(av) == SVt_PVAV);
|
||||
|
||||
- return AvFILL(av);
|
||||
+ return AvFILL(av) + 1;
|
||||
}
|
||||
|
||||
/* ------------------------------- cv.h ------------------------------- */
|
||||
diff --git a/proto.h b/proto.h
|
||||
index 02ef4ed..83ba098 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -219,6 +219,13 @@ PERL_CALLCONV SV** Perl_av_arylen_p(pTHX_ AV *av);
|
||||
PERL_CALLCONV void Perl_av_clear(pTHX_ AV *av);
|
||||
#define PERL_ARGS_ASSERT_AV_CLEAR \
|
||||
assert(av)
|
||||
+#ifndef PERL_NO_INLINE_FUNCTIONS
|
||||
+PERL_STATIC_INLINE Size_t Perl_av_count(pTHX_ AV *av)
|
||||
+ __attribute__warn_unused_result__;
|
||||
+#define PERL_ARGS_ASSERT_AV_COUNT \
|
||||
+ assert(av)
|
||||
+#endif
|
||||
+
|
||||
PERL_CALLCONV void Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val);
|
||||
#define PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH \
|
||||
assert(avp); assert(val)
|
||||
@@ -284,12 +291,10 @@ PERL_CALLCONV SV** Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val);
|
||||
__attribute__warn_unused_result__; */
|
||||
#define PERL_ARGS_ASSERT_AV_TINDEX
|
||||
|
||||
-#ifndef PERL_NO_INLINE_FUNCTIONS
|
||||
-PERL_STATIC_INLINE SSize_t Perl_av_top_index(pTHX_ AV *av)
|
||||
+PERL_CALLCONV SSize_t Perl_av_top_index(pTHX_ AV *av)
|
||||
__attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_AV_TOP_INDEX \
|
||||
assert(av)
|
||||
-#endif
|
||||
|
||||
PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av);
|
||||
#define PERL_ARGS_ASSERT_AV_UNDEF \
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,196 +0,0 @@
|
||||
From d7504df2a5d8985f2a8b04f17acff5e324572c39 Mon Sep 17 00:00:00 2001
|
||||
From: Richard Leach <richardleach@users.noreply.github.com>
|
||||
Date: Sun, 11 Oct 2020 12:26:27 +0100
|
||||
Subject: [PATCH] pp_split: no SWITCHSTACK in @ary = split(...) optimisation
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Petr Písař: 607eaf26a99ff76ab48877e68f1d7b005dc51575 ported to 5.32.0.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp.c | 89 +++++++++++++++++++++++++++++-----------------------
|
||||
t/op/split.t | 23 +++++++++++++-
|
||||
2 files changed, 72 insertions(+), 40 deletions(-)
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index df80830..e4863d3 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -5985,6 +5985,7 @@ PP(pp_split)
|
||||
|
||||
/* handle @ary = split(...) optimisation */
|
||||
if (PL_op->op_private & OPpSPLIT_ASSIGN) {
|
||||
+ realarray = 1;
|
||||
if (!(PL_op->op_flags & OPf_STACKED)) {
|
||||
if (PL_op->op_private & OPpSPLIT_LEX) {
|
||||
if (PL_op->op_private & OPpLVAL_INTRO)
|
||||
@@ -6007,26 +6008,10 @@ PP(pp_split)
|
||||
oldsave = PL_savestack_ix;
|
||||
}
|
||||
|
||||
- realarray = 1;
|
||||
- PUTBACK;
|
||||
- av_extend(ary,0);
|
||||
- (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
|
||||
- av_clear(ary);
|
||||
- SPAGAIN;
|
||||
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
|
||||
- }
|
||||
- else {
|
||||
- if (!AvREAL(ary)) {
|
||||
- I32 i;
|
||||
- AvREAL_on(ary);
|
||||
- AvREIFY_off(ary);
|
||||
- for (i = AvFILLp(ary); i >= 0; i--)
|
||||
- AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
|
||||
- }
|
||||
- /* temporarily switch stacks */
|
||||
- SAVESWITCHSTACK(PL_curstack, ary);
|
||||
+ } else {
|
||||
make_mortal = 0;
|
||||
}
|
||||
}
|
||||
@@ -6358,29 +6343,56 @@ PP(pp_split)
|
||||
LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
|
||||
SPAGAIN;
|
||||
if (realarray) {
|
||||
- if (!mg) {
|
||||
- if (SvSMAGICAL(ary)) {
|
||||
- PUTBACK;
|
||||
+ if (!mg) {
|
||||
+ PUTBACK;
|
||||
+ if(AvREAL(ary)) {
|
||||
+ if (av_count(ary) > 0)
|
||||
+ av_clear(ary);
|
||||
+ } else {
|
||||
+ AvREAL_on(ary);
|
||||
+ AvREIFY_off(ary);
|
||||
+
|
||||
+ if (AvMAX(ary) > -1) {
|
||||
+ /* don't free mere refs */
|
||||
+ Zero(AvARRAY(ary), AvMAX(ary), SV*);
|
||||
+ }
|
||||
+ }
|
||||
+ if(AvMAX(ary) < iters)
|
||||
+ av_extend(ary,iters);
|
||||
+ SPAGAIN;
|
||||
+
|
||||
+ /* Need to copy the SV*s from the stack into ary */
|
||||
+ Copy(SP + 1 - iters, AvARRAY(ary), iters, SV*);
|
||||
+ AvFILLp(ary) = iters - 1;
|
||||
+
|
||||
+ if (SvSMAGICAL(ary)) {
|
||||
+ PUTBACK;
|
||||
mg_set(MUTABLE_SV(ary));
|
||||
SPAGAIN;
|
||||
- }
|
||||
- if (gimme == G_ARRAY) {
|
||||
- EXTEND(SP, iters);
|
||||
- Copy(AvARRAY(ary), SP + 1, iters, SV*);
|
||||
- SP += iters;
|
||||
- RETURN;
|
||||
- }
|
||||
+ }
|
||||
+
|
||||
+ if (gimme != G_ARRAY) {
|
||||
+ /* SP points to the final SV* pushed to the stack. But the SV* */
|
||||
+ /* are not going to be used from the stack. Point SP to below */
|
||||
+ /* the first of these SV*. */
|
||||
+ SP -= iters;
|
||||
+ PUTBACK;
|
||||
+ }
|
||||
}
|
||||
else {
|
||||
- PUTBACK;
|
||||
- ENTER_with_name("call_PUSH");
|
||||
- call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
|
||||
- LEAVE_with_name("call_PUSH");
|
||||
- SPAGAIN;
|
||||
+ PUTBACK;
|
||||
+ av_extend(ary,iters);
|
||||
+ av_clear(ary);
|
||||
+
|
||||
+ ENTER_with_name("call_PUSH");
|
||||
+ call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
|
||||
+ LEAVE_with_name("call_PUSH");
|
||||
+ SPAGAIN;
|
||||
+
|
||||
if (gimme == G_ARRAY) {
|
||||
SSize_t i;
|
||||
/* EXTEND should not be needed - we just popped them */
|
||||
- EXTEND(SP, iters);
|
||||
+ EXTEND_SKIP(SP, iters);
|
||||
for (i=0; i < iters; i++) {
|
||||
SV **svp = av_fetch(ary, i, FALSE);
|
||||
PUSHs((svp) ? *svp : &PL_sv_undef);
|
||||
@@ -6389,13 +6401,12 @@ PP(pp_split)
|
||||
}
|
||||
}
|
||||
}
|
||||
- else {
|
||||
- if (gimme == G_ARRAY)
|
||||
- RETURN;
|
||||
- }
|
||||
|
||||
- GETTARGET;
|
||||
- XPUSHi(iters);
|
||||
+ if (gimme != G_ARRAY) {
|
||||
+ GETTARGET;
|
||||
+ XPUSHi(iters);
|
||||
+ }
|
||||
+
|
||||
RETURN;
|
||||
}
|
||||
|
||||
diff --git a/t/op/split.t b/t/op/split.t
|
||||
index 14f9158..7f37512 100644
|
||||
--- a/t/op/split.t
|
||||
+++ b/t/op/split.t
|
||||
@@ -7,7 +7,7 @@ BEGIN {
|
||||
set_up_inc('../lib');
|
||||
}
|
||||
|
||||
-plan tests => 176;
|
||||
+plan tests => 182;
|
||||
|
||||
$FS = ':';
|
||||
|
||||
@@ -648,6 +648,19 @@ is "@a", '1 2 3', 'assignment to split-to-array (stacked)';
|
||||
is (+@a, 0, "empty utf8 string");
|
||||
}
|
||||
|
||||
+# correct stack adjustments (gh#18232)
|
||||
+{
|
||||
+ sub foo { return @_ }
|
||||
+ my @a = foo(1, scalar split " ", "a b");
|
||||
+ is(join('', @a), "12", "Scalar split to a sub parameter");
|
||||
+}
|
||||
+
|
||||
+{
|
||||
+ sub foo { return @_ }
|
||||
+ my @a = foo(1, scalar(@x = split " ", "a b"));
|
||||
+ is(join('', @a), "12", "Split to @x then use scalar result as a sub parameter");
|
||||
+}
|
||||
+
|
||||
fresh_perl_is(<<'CODE', '', {}, "scalar split stack overflow");
|
||||
map{int"";split//.0>60for"0000000000000000"}split// for"00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
|
||||
CODE
|
||||
@@ -667,3 +680,11 @@ CODE
|
||||
ok(eq_array(\@result,['a','b']), "Resulting in ('a','b')");
|
||||
}
|
||||
}
|
||||
+
|
||||
+# check that the (@ary = split) optimisation survives @ary being modified
|
||||
+
|
||||
+fresh_perl_is('my @ary; @ary = split(/\w(?{ @ary[1000] = 1 })/, "abc");',
|
||||
+ '',{},'(@ary = split ...) survives @ary being Renew()ed');
|
||||
+fresh_perl_is('my @ary; @ary = split(/\w(?{ undef @ary })/, "abc");',
|
||||
+ '',{},'(@ary = split ...) survives an (undef @ary)');
|
||||
+
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,34 +0,0 @@
|
||||
From ab72b7bd043df0f0ad6090a4c95f378624fad9fc Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 7 Mar 2020 12:54:19 -0700
|
||||
Subject: [PATCH] DynaLoader: use PerlEnv_getenv()
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Doing so invokes thread-safe guards
|
||||
|
||||
Petr Písař: Ported from b0312014d6c1804920d2b687a5fa5645b445ce9f to
|
||||
5.32.1.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/DynaLoader/dlutils.c | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c
|
||||
index 8584f89..1a27fbd 100644
|
||||
--- a/ext/DynaLoader/dlutils.c
|
||||
+++ b/ext/DynaLoader/dlutils.c
|
||||
@@ -115,7 +115,7 @@ dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */
|
||||
#endif
|
||||
|
||||
#if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS)
|
||||
- if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL
|
||||
+ if ( (perl_dl_nonlazy = PerlEnv_getenv("PERL_DL_NONLAZY")) != NULL
|
||||
&& grok_atoUV(perl_dl_nonlazy, &uv, NULL)
|
||||
&& uv <= INT_MAX
|
||||
) {
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,44 +0,0 @@
|
||||
From 2ce7bf1ad5fd7aee21975b3dd1c8dceef3aab7e4 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Tue, 9 Mar 2021 16:42:11 +0000
|
||||
Subject: [PATCH] Perl_do_sv_dump(): handle PL_strtab
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
When dumping this special hash, the values in the HE entry are refcounts
|
||||
rather than SV pointers. sv_dump() used to crash here.
|
||||
|
||||
Petr Písař: Ported to 5.32.1 from upstream
|
||||
a9bb6a62ae45bb372a5cca98a76d1a79edd89ccb.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dump.c | 11 +++++++++--
|
||||
1 file changed, 9 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/dump.c b/dump.c
|
||||
index f03c3f6..0f15d77 100644
|
||||
--- a/dump.c
|
||||
+++ b/dump.c
|
||||
@@ -2224,8 +2224,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
|
||||
PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
|
||||
if (HvEITER_get(hv) == he)
|
||||
PerlIO_printf(file, "[CURRENT] ");
|
||||
- PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
|
||||
- do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
|
||||
+ PerlIO_printf(file, "HASH = 0x%" UVxf, (UV) hash);
|
||||
+
|
||||
+ if (sv == (SV*)PL_strtab)
|
||||
+ PerlIO_printf(file, " REFCNT = 0x%" UVxf "\n",
|
||||
+ (UV)he->he_valu.hent_refcount );
|
||||
+ else {
|
||||
+ (void)PerlIO_putc(file, '\n');
|
||||
+ do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
|
||||
+ }
|
||||
}
|
||||
}
|
||||
DONEHV:;
|
||||
--
|
||||
2.26.3
|
||||
|
||||
@ -1,53 +0,0 @@
|
||||
From c5eed6e541fe27d9e9dfd31f42c43f4dfa1f486b Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Sat, 11 Jul 2020 09:26:21 +0200
|
||||
Subject: [PATCH] hv.c: add a guard clause to prevent the number of buckets in
|
||||
a hash from getting too large
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This caps it at 1<<28 buckets, eg, ~268M. In theory without a guard clause like
|
||||
this we could grow to the point of possibly wrapping around in terms of size,
|
||||
not to mention being ridiculously wasteful of memory at larger sizes.
|
||||
Even this cap is probably too high. It should probably be something like 1<<24.
|
||||
|
||||
Petr Písař: Ported to 5.32.1 from
|
||||
aae087f7cec022be14a17deb95cb2208e16b7891.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
hv.c | 10 +++++++++-
|
||||
1 file changed, 9 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/hv.c b/hv.c
|
||||
index eccae62..32dbd19 100644
|
||||
--- a/hv.c
|
||||
+++ b/hv.c
|
||||
@@ -38,7 +38,13 @@ holds the key and hash value.
|
||||
* NOTE if you change this formula so we split earlier than previously
|
||||
* you MUST change the logic in hv_ksplit()
|
||||
*/
|
||||
-#define DO_HSPLIT(xhv) ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1)) > (xhv)->xhv_max )
|
||||
+
|
||||
+/* MAX_BUCKET_MAX is the maximum max bucket index, at which point we stop growing the
|
||||
+ * number of buckets,
|
||||
+ */
|
||||
+#define MAX_BUCKET_MAX ((1<<26)-1)
|
||||
+#define DO_HSPLIT(xhv) ( ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1)) > (xhv)->xhv_max ) && \
|
||||
+ ((xhv)->xhv_max < MAX_BUCKET_MAX) )
|
||||
#define HV_FILL_THRESHOLD 31
|
||||
|
||||
static const char S_strtab_error[]
|
||||
@@ -1426,6 +1432,8 @@ S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
|
||||
);
|
||||
|
||||
PERL_ARGS_ASSERT_HSPLIT;
|
||||
+ if (newsize > MAX_BUCKET_MAX+1)
|
||||
+ return;
|
||||
|
||||
PL_nomemok = TRUE;
|
||||
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,30 +0,0 @@
|
||||
From 3c53c6179afbdbef748c110abdb849cb463c2727 Mon Sep 17 00:00:00 2001
|
||||
From: Todd Rinaldo <toddr@cpan.org>
|
||||
Date: Thu, 30 Jul 2020 17:42:47 -0500
|
||||
Subject: [PATCH] Add missing MANIFEST entry from fix for debugger
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Add on fix to #17901
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 990a75ad52..12601e46b4 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -4826,6 +4826,7 @@ lib/perl5db/t/symbol-table-bug Tests for the Perl debugger
|
||||
lib/perl5db/t/taint Tests for the Perl debugger
|
||||
lib/perl5db/t/test-a-statement-1 Tests for the Perl debugger
|
||||
lib/perl5db/t/test-a-statement-2 Tests for the Perl debugger
|
||||
+lib/perl5db/t/test-a-statement-3 Tests for the Perl debugger
|
||||
lib/perl5db/t/test-dieLevel-option-1 Tests for the Perl debugger
|
||||
lib/perl5db/t/test-frame-option-1 Tests for the Perl debugger
|
||||
lib/perl5db/t/test-l-statement-1 Tests for the Perl debugger
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,90 +0,0 @@
|
||||
From b248789b64d6bd277c52bfe608ed3192023af1bd Mon Sep 17 00:00:00 2001
|
||||
From: "E. Choroba" <choroba@matfyz.cz>
|
||||
Date: Fri, 26 Jun 2020 21:19:24 +0200
|
||||
Subject: [PATCH] After running an action in the debugger, turn it off
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
When running with "c", there was no problem, but when running with "n"
|
||||
or "s", once the action was executed, it kept executing on the
|
||||
following lines, which wasn't expected. Clearing $action here prevents
|
||||
this unwanted behaviour.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
lib/perl5db.pl | 3 ++-
|
||||
lib/perl5db.t | 22 ++++++++++++++++++++++
|
||||
lib/perl5db/t/test-a-statement-3 | 6 ++++++
|
||||
3 files changed, 30 insertions(+), 1 deletion(-)
|
||||
create mode 100644 lib/perl5db/t/test-a-statement-3
|
||||
|
||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
|
||||
index 69a9bb6e64..e04a0e17fa 100644
|
||||
--- a/lib/perl5db.pl
|
||||
+++ b/lib/perl5db.pl
|
||||
@@ -529,7 +529,7 @@ BEGIN {
|
||||
use vars qw($VERSION $header);
|
||||
|
||||
# bump to X.XX in blead, only use X.XX_XX in maint
|
||||
-$VERSION = '1.57';
|
||||
+$VERSION = '1.58';
|
||||
|
||||
$header = "perl5db.pl version $VERSION";
|
||||
|
||||
@@ -2708,6 +2708,7 @@ If there are any preprompt actions, execute those as well.
|
||||
# The &-call is here to ascertain the mutability of @_.
|
||||
&DB::eval;
|
||||
}
|
||||
+ undef $action;
|
||||
|
||||
# Are we nested another level (e.g., did we evaluate a function
|
||||
# that had a breakpoint in it at the debugger prompt)?
|
||||
diff --git a/lib/perl5db.t b/lib/perl5db.t
|
||||
index 421229a54a..913a301d98 100644
|
||||
--- a/lib/perl5db.t
|
||||
+++ b/lib/perl5db.t
|
||||
@@ -2799,6 +2799,28 @@ SKIP:
|
||||
);
|
||||
}
|
||||
|
||||
+{
|
||||
+ # GitHub #17901
|
||||
+ my $wrapper = DebugWrap->new(
|
||||
+ {
|
||||
+ cmds =>
|
||||
+ [
|
||||
+ 'a 4 $s++',
|
||||
+ ('s') x 5,
|
||||
+ 'x $s',
|
||||
+ 'q'
|
||||
+ ],
|
||||
+ prog => '../lib/perl5db/t/test-a-statement-3',
|
||||
+ switches => [ '-d' ],
|
||||
+ stderr => 0,
|
||||
+ }
|
||||
+ );
|
||||
+ $wrapper->contents_like(
|
||||
+ qr/^0 +2$/m,
|
||||
+ 'Test that the a command runs only on the given lines.',
|
||||
+ );
|
||||
+}
|
||||
+
|
||||
{
|
||||
# perl 5 RT #126735 regression bug.
|
||||
local $ENV{PERLDB_OPTS} = "NonStop=0 RemotePort=non-existent-host.tld:9001";
|
||||
diff --git a/lib/perl5db/t/test-a-statement-3 b/lib/perl5db/t/test-a-statement-3
|
||||
new file mode 100644
|
||||
index 0000000000..b188c1c5c5
|
||||
--- /dev/null
|
||||
+++ b/lib/perl5db/t/test-a-statement-3
|
||||
@@ -0,0 +1,6 @@
|
||||
+use strict; use warnings;
|
||||
+
|
||||
+for my $x (1 .. 2) {
|
||||
+ my $y = $x + 1;
|
||||
+ my $x = $x - 1;
|
||||
+}
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,33 +0,0 @@
|
||||
From 589464a875768e4b4a609d972488e3b592103097 Mon Sep 17 00:00:00 2001
|
||||
From: "E. Choroba" <choroba@matfyz.cz>
|
||||
Date: Mon, 27 Jul 2020 11:32:51 +0200
|
||||
Subject: [PATCH] Clearing DB::action at the end is no longer needed
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
as it's cleared right after it's been run.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
lib/perl5db.pl | 4 ----
|
||||
1 file changed, 4 deletions(-)
|
||||
|
||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
|
||||
index e04a0e17fa..af3b972da0 100644
|
||||
--- a/lib/perl5db.pl
|
||||
+++ b/lib/perl5db.pl
|
||||
@@ -3347,10 +3347,6 @@ use B<o> I<inhibit_exit> to avoid stopping after program termination,
|
||||
B<h q>, B<h R> or B<h o> to get additional info.
|
||||
EOP
|
||||
|
||||
- # Set the DB::eval context appropriately.
|
||||
- # At program termination disable any user actions.
|
||||
- $DB::action = undef;
|
||||
-
|
||||
$DB::package = 'main';
|
||||
$DB::usercontext = DB::_calc_usercontext($DB::package);
|
||||
} ## end elsif ($package eq 'DB::fake')
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,74 +0,0 @@
|
||||
From 8a2562bec7cd9f8eff6812f340f99dddd028bb33 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Thu, 6 Aug 2020 10:51:56 +0200
|
||||
Subject: [PATCH] IO::Handle: Fix a spurious error reported for regular file
|
||||
handles
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
89341f87 fix for GH #6799 introduced a regression when calling error()
|
||||
on an IO::Handle object that was opened for reading a regular file:
|
||||
|
||||
$ perl -e 'open my $f, q{<}, q{/etc/hosts} or die; print qq{error\n} if $f->error'
|
||||
error
|
||||
|
||||
In case of a regular file opened for reading, IoOFP() returns NULL and
|
||||
PerlIO_error(NULL) reports -1. Compare to the case of a file opened
|
||||
for writing when both IoIFP() and IoOFP() return non-NULL, equaled
|
||||
pointer.
|
||||
|
||||
This patch fixes handling the case of the NULL output stream.
|
||||
|
||||
GH #18019
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/IO.xs | 4 ++--
|
||||
dist/IO/t/io_xs.t | 10 +++++++++-
|
||||
2 files changed, 11 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
|
||||
index 9158106416..fb009774c4 100644
|
||||
--- a/dist/IO/IO.xs
|
||||
+++ b/dist/IO/IO.xs
|
||||
@@ -397,9 +397,9 @@ ferror(handle)
|
||||
CODE:
|
||||
if (in)
|
||||
#ifdef PerlIO
|
||||
- RETVAL = PerlIO_error(in) || (in != out && PerlIO_error(out));
|
||||
+ RETVAL = PerlIO_error(in) || (out && in != out && PerlIO_error(out));
|
||||
#else
|
||||
- RETVAL = ferror(in) || (in != out && ferror(out));
|
||||
+ RETVAL = ferror(in) || (out && in != out && ferror(out));
|
||||
#endif
|
||||
else {
|
||||
RETVAL = -1;
|
||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t
|
||||
index a8833b0651..4657088629 100644
|
||||
--- a/dist/IO/t/io_xs.t
|
||||
+++ b/dist/IO/t/io_xs.t
|
||||
@@ -11,7 +11,7 @@ BEGIN {
|
||||
}
|
||||
}
|
||||
|
||||
-use Test::More tests => 8;
|
||||
+use Test::More tests => 10;
|
||||
use IO::File;
|
||||
use IO::Seekable;
|
||||
|
||||
@@ -69,3 +69,11 @@ SKIP: {
|
||||
ok(!$fh->error, "check clearerr removed the error");
|
||||
close $fh; # silently ignore the error
|
||||
}
|
||||
+
|
||||
+{
|
||||
+ # [GH #18019] IO::Handle->error misreported an error after successully
|
||||
+ # opening a regular file for reading. It was a regression in GH #6799 fix.
|
||||
+ ok(open(my $fh, '<', __FILE__), "a regular file opened for reading");
|
||||
+ ok(!$fh->error, "no spurious error reported by error()");
|
||||
+ close $fh;
|
||||
+}
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,80 +0,0 @@
|
||||
From fc5f3468dcbee38eb202cfd552a5b8dbff990c7b Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 12 May 2020 10:59:08 +1000
|
||||
Subject: [PATCH 2/2] IO::Handle: clear the error on both input and output
|
||||
streams
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Similarly to GH #6799 clearerr() only cleared the error status
|
||||
of the input stream, so clear both.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/IO.xs | 14 +++++++++++---
|
||||
dist/IO/t/io_xs.t | 8 +++++---
|
||||
2 files changed, 16 insertions(+), 6 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
|
||||
index 99d523d2c1..9158106416 100644
|
||||
--- a/dist/IO/IO.xs
|
||||
+++ b/dist/IO/IO.xs
|
||||
@@ -410,13 +410,21 @@ ferror(handle)
|
||||
|
||||
int
|
||||
clearerr(handle)
|
||||
- InputStream handle
|
||||
+ SV * handle
|
||||
+ PREINIT:
|
||||
+ IO *io = sv_2io(handle);
|
||||
+ InputStream in = IoIFP(io);
|
||||
+ OutputStream out = IoOFP(io);
|
||||
CODE:
|
||||
if (handle) {
|
||||
#ifdef PerlIO
|
||||
- PerlIO_clearerr(handle);
|
||||
+ PerlIO_clearerr(in);
|
||||
+ if (in != out)
|
||||
+ PerlIO_clearerr(out);
|
||||
#else
|
||||
- clearerr(handle);
|
||||
+ clearerr(in);
|
||||
+ if (in != out)
|
||||
+ clearerr(out);
|
||||
#endif
|
||||
RETVAL = 0;
|
||||
}
|
||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t
|
||||
index f890e92558..a8833b0651 100644
|
||||
--- a/dist/IO/t/io_xs.t
|
||||
+++ b/dist/IO/t/io_xs.t
|
||||
@@ -11,7 +11,7 @@ BEGIN {
|
||||
}
|
||||
}
|
||||
|
||||
-use Test::More tests => 7;
|
||||
+use Test::More tests => 8;
|
||||
use IO::File;
|
||||
use IO::Seekable;
|
||||
|
||||
@@ -58,12 +58,14 @@ SKIP: {
|
||||
# This isn't really a Linux/BSD specific test, but /dev/full is (I
|
||||
# hope) reasonably well defined on these. Patches welcome if your platform
|
||||
# also supports it (or something like it)
|
||||
- skip "no /dev/full or not a /dev/full platform", 2
|
||||
+ skip "no /dev/full or not a /dev/full platform", 3
|
||||
unless $^O =~ /^(linux|netbsd|freebsd)$/ && -c "/dev/full";
|
||||
open my $fh, ">", "/dev/full"
|
||||
- or skip "Could not open /dev/full: $!", 2;
|
||||
+ or skip "Could not open /dev/full: $!", 3;
|
||||
$fh->print("a" x 1024);
|
||||
ok(!$fh->flush, "should fail to flush");
|
||||
ok($fh->error, "stream should be in error");
|
||||
+ $fh->clearerr;
|
||||
+ ok(!$fh->error, "check clearerr removed the error");
|
||||
close $fh; # silently ignore the error
|
||||
}
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,61 +0,0 @@
|
||||
From c6439962c995d4d7052af9fb3f92da93c1584b84 Mon Sep 17 00:00:00 2001
|
||||
From: vividsnow <vividsnow@gmail.com>
|
||||
Date: Fri, 31 Jul 2020 00:37:58 +0300
|
||||
Subject: [PATCH] IO::Socket::UNIX: synchronize behavior with module
|
||||
documentation (#17787)
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
* synchronize behavior with module documentation
|
||||
|
||||
IO::Socket docs states that passing Blocking => 0 will be set socket to non-blocking mode
|
||||
|
||||
* Update AUTHORS
|
||||
* bump version
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
AUTHORS | 1 +
|
||||
dist/IO/lib/IO/Socket/UNIX.pm | 6 +++++-
|
||||
2 files changed, 6 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/AUTHORS b/AUTHORS
|
||||
index 577ba7d0ee..299fdec8a8 100644
|
||||
--- a/AUTHORS
|
||||
+++ b/AUTHORS
|
||||
@@ -1293,6 +1293,7 @@ Ville Skyttä <scop@cs132170.pp.htv.fi>
|
||||
Vincent Pit <perl@profvince.com>
|
||||
Vishal Bhatia <vishal@deja.com>
|
||||
Vitali Peil <vitali.peil@uni-bielefeld.de>
|
||||
+vividsnow <vividsnow@gmail.com>
|
||||
Vlad Harchev <hvv@hippo.ru>
|
||||
Vladimir Alexiev <vladimir@cs.ualberta.ca>
|
||||
Vladimir Marek <vlmarek@volny.cz>
|
||||
diff --git a/dist/IO/lib/IO/Socket/UNIX.pm b/dist/IO/lib/IO/Socket/UNIX.pm
|
||||
index 04b36eaf74..14d0b27a8c 100644
|
||||
--- a/dist/IO/lib/IO/Socket/UNIX.pm
|
||||
+++ b/dist/IO/lib/IO/Socket/UNIX.pm
|
||||
@@ -11,7 +11,7 @@ use IO::Socket;
|
||||
use Carp;
|
||||
|
||||
our @ISA = qw(IO::Socket);
|
||||
-our $VERSION = "1.41";
|
||||
+our $VERSION = "1.42";
|
||||
|
||||
IO::Socket::UNIX->register_domain( AF_UNIX );
|
||||
|
||||
@@ -30,6 +30,10 @@ sub configure {
|
||||
$sock->socket(AF_UNIX, $type, 0) or
|
||||
return undef;
|
||||
|
||||
+ if(exists $arg->{Blocking}) {
|
||||
+ $sock->blocking($arg->{Blocking}) or
|
||||
+ return undef;
|
||||
+ }
|
||||
if(exists $arg->{Local}) {
|
||||
my $addr = sockaddr_un($arg->{Local});
|
||||
$sock->bind($addr) or
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,32 +0,0 @@
|
||||
From 6c2255e0e80e0dc00c7fd96e073f1f524bbaa3e0 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 29 Jun 2020 09:21:24 -0600
|
||||
Subject: [PATCH] MUTABLE_PTR() Rmv non-standard syntax
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Variables in C are beginning with an underscore are reserved for use by
|
||||
the C implementation. Change this non-conformant usage.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
handy.h | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/handy.h b/handy.h
|
||||
index 287e2e206d..890b2b11a2 100644
|
||||
--- a/handy.h
|
||||
+++ b/handy.h
|
||||
@@ -54,7 +54,7 @@ Null SV pointer. (No longer available when C<PERL_CORE> is defined.)
|
||||
*/
|
||||
|
||||
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
|
||||
-# define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
|
||||
+# define MUTABLE_PTR(p) ({ void *p_ = (p); p_; })
|
||||
#else
|
||||
# define MUTABLE_PTR(p) ((void *) (p))
|
||||
#endif
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,33 +0,0 @@
|
||||
From b26a606d84ae1a6da560c7cd71d1a33c0dc7178e Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sun, 14 Jun 2020 12:26:02 -0600
|
||||
Subject: [PATCH] Update pod for SvTRUE, to indicate single param evaluation
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
5.32 changed this macro into an inline function so that 'sv' only gets
|
||||
evaluated once, but didn't update the documentation to reflect that.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
sv.h | 3 ++-
|
||||
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/sv.h b/sv.h
|
||||
index 3721b2fb1b..ad8accbf1a 100644
|
||||
--- a/sv.h
|
||||
+++ b/sv.h
|
||||
@@ -1607,7 +1607,8 @@ false. See C<L</SvOK>> for a defined/undefined test. Handles 'get' magic
|
||||
unless the scalar is already C<SvPOK>, C<SvIOK> or C<SvNOK> (the public, not the
|
||||
private flags).
|
||||
|
||||
-See C<L</SvTRUEx>> for a version which guarantees to evaluate C<sv> only once.
|
||||
+As of Perl 5.32, this is guaranteed to evaluate C<sv> only once. Prior to that
|
||||
+release, use C<L</SvTRUEx>> for single evaluation.
|
||||
|
||||
=for apidoc Am|bool|SvTRUE_nomg|SV* sv
|
||||
Returns a boolean indicating whether Perl would evaluate the SV as true or
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,45 +0,0 @@
|
||||
From 313464947382fab07299af0061f419a55540356a Mon Sep 17 00:00:00 2001
|
||||
From: Tomasz Konojacki <me@xenu.pl>
|
||||
Date: Mon, 27 Apr 2020 08:31:47 +0200
|
||||
Subject: [PATCH] XSUB.h: fix MARK and items variables inside BOOT XSUBs
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
ax was incremented by Perl_xs_handshake() and because of that
|
||||
MARK and items were off by one inside BOOT XSUBs.
|
||||
|
||||
fixes #17755
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
XSUB.h | 6 +++---
|
||||
1 file changed, 3 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/XSUB.h b/XSUB.h
|
||||
index e3147ce9fb..5f17a5acde 100644
|
||||
--- a/XSUB.h
|
||||
+++ b/XSUB.h
|
||||
@@ -160,16 +160,16 @@ is a lexical C<$_> in scope.
|
||||
PL_xsubfilename. */
|
||||
#define dXSBOOTARGSXSAPIVERCHK \
|
||||
I32 ax = XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \
|
||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS
|
||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS
|
||||
#define dXSBOOTARGSAPIVERCHK \
|
||||
I32 ax = XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \
|
||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS
|
||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS
|
||||
/* dXSBOOTARGSNOVERCHK has no API in xsubpp to choose it so do
|
||||
#undef dXSBOOTARGSXSAPIVERCHK
|
||||
#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK */
|
||||
#define dXSBOOTARGSNOVERCHK \
|
||||
I32 ax = XS_SETXSUBFN_POPMARK; \
|
||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS
|
||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS
|
||||
|
||||
#define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
|
||||
? PAD_SV(PL_op->op_targ) : sv_newmortal())
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,38 +0,0 @@
|
||||
From 73b535d23d98bd3bdc31a27da26222e2e56166ac Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue, 30 Jun 2020 13:58:50 -0600
|
||||
Subject: [PATCH] ext/XS-APItest/t/utf8_warn_base.pl: Fix a couple tests
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
These had invalid values, which didn't show up execpt on EBCDIC
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/XS-APItest/t/utf8_warn_base.pl | 2 --
|
||||
1 file changed, 2 deletions(-)
|
||||
|
||||
diff --git a/ext/XS-APItest/t/utf8_warn_base.pl b/ext/XS-APItest/t/utf8_warn_base.pl
|
||||
index d86871cd0f..a0f732282e 100644
|
||||
--- a/ext/XS-APItest/t/utf8_warn_base.pl
|
||||
+++ b/ext/XS-APItest/t/utf8_warn_base.pl
|
||||
@@ -486,7 +486,6 @@ my @tests;
|
||||
: I8_to_native(
|
||||
"\xff\xa7\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"),
|
||||
0x7FFFFFFFFFFFFFFF,
|
||||
- (isASCII) ? 1 : 2,
|
||||
],
|
||||
[ "first 64 bit code point",
|
||||
(isASCII)
|
||||
@@ -525,7 +524,6 @@ my @tests;
|
||||
I8_to_native(
|
||||
"\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
|
||||
0x800000000,
|
||||
- 40000000
|
||||
],
|
||||
[ "requires at least 32 bits",
|
||||
I8_to_native(
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,193 +0,0 @@
|
||||
From b334474a337421c6643b872388245fb2c11bf995 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 30 Mar 2020 16:32:46 +1100
|
||||
Subject: [PATCH] fix C<i $obj> where $obj is a lexical
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
the DB::eval function depends on the special behaviour of eval ""
|
||||
within the DB package, which evaluates the string within the context
|
||||
of the first non-DB sub or eval scope, working up the call stack.
|
||||
|
||||
The debugger refactor moved handling for the 'i' command from the
|
||||
DB package to the DB::Obj package, so the eval in DB::eval was
|
||||
working in the context of the DB::Obj::cmd_i function, not in the
|
||||
calling scope.
|
||||
|
||||
Fixed by moving the handling for the i command back to DB.
|
||||
|
||||
Fixes #17661.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 1 +
|
||||
lib/perl5db.pl | 65 +++++++++++++++++++++---------------------
|
||||
lib/perl5db.t | 20 +++++++++++++
|
||||
lib/perl5db/t/gh-17661 | 14 +++++++++
|
||||
4 files changed, 68 insertions(+), 32 deletions(-)
|
||||
create mode 100644 lib/perl5db/t/gh-17661
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 8c71995174..96af3618bd 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -4808,6 +4808,7 @@ lib/perl5db/t/eval-line-bug Tests for the Perl debugger
|
||||
lib/perl5db/t/fact Tests for the Perl debugger
|
||||
lib/perl5db/t/filename-line-breakpoint Tests for the Perl debugger
|
||||
lib/perl5db/t/gh-17660 Tests for the Perl debugger
|
||||
+lib/perl5db/t/gh-17661 Tests for the Perl debugger
|
||||
lib/perl5db/t/load-modules Tests for the Perl debugger
|
||||
lib/perl5db/t/lsub-n Test script used by perl5db.t
|
||||
lib/perl5db/t/lvalue-bug Tests for the Perl debugger
|
||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
|
||||
index 96e56d559f..b647d24fb8 100644
|
||||
--- a/lib/perl5db.pl
|
||||
+++ b/lib/perl5db.pl
|
||||
@@ -2512,6 +2512,37 @@ EOP
|
||||
return;
|
||||
}
|
||||
|
||||
+=head3 C<_DB__handle_i_command> - inheritance display
|
||||
+
|
||||
+Display the (nested) parentage of the module or object given.
|
||||
+
|
||||
+=cut
|
||||
+
|
||||
+sub _DB__handle_i_command {
|
||||
+ my $self = shift;
|
||||
+
|
||||
+ my $line = $self->cmd_args;
|
||||
+ require mro;
|
||||
+ foreach my $isa ( split( /\s+/, $line ) ) {
|
||||
+ $evalarg = "$isa";
|
||||
+ # The &-call is here to ascertain the mutability of @_.
|
||||
+ ($isa) = &DB::eval;
|
||||
+ no strict 'refs';
|
||||
+ print join(
|
||||
+ ', ',
|
||||
+ map {
|
||||
+ "$_"
|
||||
+ . (
|
||||
+ defined( ${"$_\::VERSION"} )
|
||||
+ ? ' ' . ${"$_\::VERSION"}
|
||||
+ : undef )
|
||||
+ } @{mro::get_linear_isa(ref($isa) || $isa)}
|
||||
+ );
|
||||
+ print "\n";
|
||||
+ }
|
||||
+ next CMD;
|
||||
+}
|
||||
+
|
||||
# 't' is type.
|
||||
# 'm' is method.
|
||||
# 'v' is the value (i.e: method name or subroutine ref).
|
||||
@@ -2531,6 +2562,7 @@ BEGIN
|
||||
'W' => { t => 'm', v => '_handle_W_command', },
|
||||
'c' => { t => 's', v => \&_DB__handle_c_command, },
|
||||
'f' => { t => 's', v => \&_DB__handle_f_command, },
|
||||
+ 'i' => { t => 's', v => \&_DB__handle_i_command, },
|
||||
'm' => { t => 's', v => \&_DB__handle_m_command, },
|
||||
'n' => { t => 'm', v => '_handle_n_command', },
|
||||
'p' => { t => 'm', v => '_handle_p_command', },
|
||||
@@ -2551,7 +2583,7 @@ BEGIN
|
||||
{ t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
|
||||
} qw(R rerun)),
|
||||
(map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
|
||||
- qw(a A b B e E h i l L M o O v w W)),
|
||||
+ qw(a A b B e E h l L M o O v w W)),
|
||||
);
|
||||
};
|
||||
|
||||
@@ -5468,37 +5500,6 @@ sub cmd_h {
|
||||
}
|
||||
} ## end sub cmd_h
|
||||
|
||||
-=head3 C<cmd_i> - inheritance display
|
||||
-
|
||||
-Display the (nested) parentage of the module or object given.
|
||||
-
|
||||
-=cut
|
||||
-
|
||||
-sub cmd_i {
|
||||
- my $cmd = shift;
|
||||
- my $line = shift;
|
||||
-
|
||||
- require mro;
|
||||
-
|
||||
- foreach my $isa ( split( /\s+/, $line ) ) {
|
||||
- $evalarg = $isa;
|
||||
- # The &-call is here to ascertain the mutability of @_.
|
||||
- ($isa) = &DB::eval;
|
||||
- no strict 'refs';
|
||||
- print join(
|
||||
- ', ',
|
||||
- map {
|
||||
- "$_"
|
||||
- . (
|
||||
- defined( ${"$_\::VERSION"} )
|
||||
- ? ' ' . ${"$_\::VERSION"}
|
||||
- : undef )
|
||||
- } @{mro::get_linear_isa(ref($isa) || $isa)}
|
||||
- );
|
||||
- print "\n";
|
||||
- }
|
||||
-} ## end sub cmd_i
|
||||
-
|
||||
=head3 C<cmd_l> - list lines (command)
|
||||
|
||||
Most of the command is taken up with transforming all the different line
|
||||
diff --git a/lib/perl5db.t b/lib/perl5db.t
|
||||
index 913a301d98..ffa659a215 100644
|
||||
--- a/lib/perl5db.t
|
||||
+++ b/lib/perl5db.t
|
||||
@@ -2946,6 +2946,26 @@ SKIP:
|
||||
);
|
||||
}
|
||||
|
||||
+{
|
||||
+ # gh #17661
|
||||
+ my $wrapper = DebugWrap->new(
|
||||
+ {
|
||||
+ cmds =>
|
||||
+ [
|
||||
+ 'c',
|
||||
+ 'i $obj',
|
||||
+ 'q',
|
||||
+ ],
|
||||
+ prog => '../lib/perl5db/t/gh-17661',
|
||||
+ }
|
||||
+ );
|
||||
+
|
||||
+ $wrapper->output_like(
|
||||
+ qr/C5, C1, C2, C3, C4/,
|
||||
+ q/check for reasonable result/,
|
||||
+ );
|
||||
+}
|
||||
+
|
||||
SKIP:
|
||||
{
|
||||
$Config{usethreads}
|
||||
diff --git a/lib/perl5db/t/gh-17661 b/lib/perl5db/t/gh-17661
|
||||
new file mode 100644
|
||||
index 0000000000..0d85977b35
|
||||
--- /dev/null
|
||||
+++ b/lib/perl5db/t/gh-17661
|
||||
@@ -0,0 +1,14 @@
|
||||
+use v5.10.0;
|
||||
+
|
||||
+{ package C1; sub c1 { } our @ISA = qw(C2) }
|
||||
+{ package C2; sub c2 { } our @ISA = qw(C3) }
|
||||
+{ package C3; sub c3 { } our @ISA = qw( ) }
|
||||
+{ package C4; sub c4 { } our @ISA = qw( ) }
|
||||
+{ package C5; sub c5 { } our @ISA = qw(C1 C4) }
|
||||
+
|
||||
+my $obj = bless {}, 'C5';
|
||||
+$main::global = bless {}, 'C5';
|
||||
+
|
||||
+$DB::single = 1;
|
||||
+
|
||||
+say "Done.";
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,87 +0,0 @@
|
||||
From 89341f87f9fc65c4d7133e497bb04586e86b8052 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 12 May 2020 10:29:17 +1000
|
||||
Subject: [PATCH 1/2] make $fh->error report errors from both input and output
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
For character devices and sockets perl uses separate PerlIO objects
|
||||
for input and output so they can be buffered separately.
|
||||
|
||||
The IO::Handle::error() method only checked the input stream, so
|
||||
if a write error occurs error() would still returned false.
|
||||
|
||||
Change this so both the input and output streams are checked.
|
||||
|
||||
fixes #6799
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/IO.xs | 12 ++++++++----
|
||||
dist/IO/t/io_xs.t | 19 ++++++++++++++++++-
|
||||
2 files changed, 26 insertions(+), 5 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
|
||||
index 68b7352c38..99d523d2c1 100644
|
||||
--- a/dist/IO/IO.xs
|
||||
+++ b/dist/IO/IO.xs
|
||||
@@ -389,13 +389,17 @@ ungetc(handle, c)
|
||||
|
||||
int
|
||||
ferror(handle)
|
||||
- InputStream handle
|
||||
+ SV * handle
|
||||
+ PREINIT:
|
||||
+ IO *io = sv_2io(handle);
|
||||
+ InputStream in = IoIFP(io);
|
||||
+ OutputStream out = IoOFP(io);
|
||||
CODE:
|
||||
- if (handle)
|
||||
+ if (in)
|
||||
#ifdef PerlIO
|
||||
- RETVAL = PerlIO_error(handle);
|
||||
+ RETVAL = PerlIO_error(in) || (in != out && PerlIO_error(out));
|
||||
#else
|
||||
- RETVAL = ferror(handle);
|
||||
+ RETVAL = ferror(in) || (in != out && ferror(out));
|
||||
#endif
|
||||
else {
|
||||
RETVAL = -1;
|
||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t
|
||||
index 1e3c49a4a7..f890e92558 100644
|
||||
--- a/dist/IO/t/io_xs.t
|
||||
+++ b/dist/IO/t/io_xs.t
|
||||
@@ -11,7 +11,7 @@ BEGIN {
|
||||
}
|
||||
}
|
||||
|
||||
-use Test::More tests => 5;
|
||||
+use Test::More tests => 7;
|
||||
use IO::File;
|
||||
use IO::Seekable;
|
||||
|
||||
@@ -50,3 +50,20 @@ SKIP:
|
||||
ok($fh->sync, "sync to a read only handle")
|
||||
or diag "sync(): ", $!;
|
||||
}
|
||||
+
|
||||
+
|
||||
+SKIP: {
|
||||
+ # gh 6799
|
||||
+ #
|
||||
+ # This isn't really a Linux/BSD specific test, but /dev/full is (I
|
||||
+ # hope) reasonably well defined on these. Patches welcome if your platform
|
||||
+ # also supports it (or something like it)
|
||||
+ skip "no /dev/full or not a /dev/full platform", 2
|
||||
+ unless $^O =~ /^(linux|netbsd|freebsd)$/ && -c "/dev/full";
|
||||
+ open my $fh, ">", "/dev/full"
|
||||
+ or skip "Could not open /dev/full: $!", 2;
|
||||
+ $fh->print("a" x 1024);
|
||||
+ ok(!$fh->flush, "should fail to flush");
|
||||
+ ok($fh->error, "stream should be in error");
|
||||
+ close $fh; # silently ignore the error
|
||||
+}
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,58 +0,0 @@
|
||||
From 81169c06a76f62ff987ed990ac910c2ae08b3f91 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue, 10 Mar 2020 15:19:57 -0600
|
||||
Subject: [PATCH] reentr.c: Buffer sizes for asctime_r,ctime_r are small
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The needed sizes of these are stated in the man pages, and are much
|
||||
smaller than were being allocated.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
reentr.c | 4 ++--
|
||||
regen/reentr.pl | 5 ++++-
|
||||
2 files changed, 6 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/reentr.c b/reentr.c
|
||||
index 8ddda7bfc0..8438c8f90f 100644
|
||||
--- a/reentr.c
|
||||
+++ b/reentr.c
|
||||
@@ -52,14 +52,14 @@ Perl_reentrant_size(pTHX) {
|
||||
# define REENTRANTUSUALSIZE 4096 /* Make something up. */
|
||||
|
||||
# ifdef HAS_ASCTIME_R
|
||||
- PL_reentrant_buffer->_asctime_size = REENTRANTSMALLSIZE;
|
||||
+ PL_reentrant_buffer->_asctime_size = 26;
|
||||
# endif /* HAS_ASCTIME_R */
|
||||
|
||||
# ifdef HAS_CRYPT_R
|
||||
# endif /* HAS_CRYPT_R */
|
||||
|
||||
# ifdef HAS_CTIME_R
|
||||
- PL_reentrant_buffer->_ctime_size = REENTRANTSMALLSIZE;
|
||||
+ PL_reentrant_buffer->_ctime_size = 26;
|
||||
# endif /* HAS_CTIME_R */
|
||||
|
||||
# ifdef HAS_GETGRNAM_R
|
||||
diff --git a/regen/reentr.pl b/regen/reentr.pl
|
||||
index f5788c7ad9..94721e9dec 100644
|
||||
--- a/regen/reentr.pl
|
||||
+++ b/regen/reentr.pl
|
||||
@@ -495,8 +495,11 @@ for my $func (@seenf) {
|
||||
char* _${func}_buffer;
|
||||
size_t _${func}_size;
|
||||
EOF
|
||||
+ my $size = ($func =~ /^(asctime|ctime)$/)
|
||||
+ ? 26
|
||||
+ : "REENTRANTSMALLSIZE";
|
||||
push @size, <<EOF;
|
||||
- PL_reentrant_buffer->_${func}_size = REENTRANTSMALLSIZE;
|
||||
+ PL_reentrant_buffer->_${func}_size = $size;
|
||||
EOF
|
||||
pushinitfree $func;
|
||||
pushssif $endif;
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,46 +0,0 @@
|
||||
From 981fbfc16220a15e72457d8ece4e014988746946 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Thu, 12 Mar 2020 12:48:47 -0600
|
||||
Subject: [PATCH] reentr.c: Prevent infinite looping
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This is an easy, though paranoid hedge to prevent something that should
|
||||
never happen from causing an infinite loop if it were to happen.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
reentr.c | 2 +-
|
||||
regen/reentr.pl | 2 +-
|
||||
2 files changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/reentr.c b/reentr.c
|
||||
index 8438c8f90f..2429aa2f5d 100644
|
||||
--- a/reentr.c
|
||||
+++ b/reentr.c
|
||||
@@ -36,7 +36,7 @@
|
||||
|
||||
#define RenewDouble(data_pointer, size_pointer, type) \
|
||||
STMT_START { \
|
||||
- const size_t size = *(size_pointer) * 2; \
|
||||
+ const size_t size = MAX(*(size_pointer), 1) * 2; \
|
||||
Renew((data_pointer), (size), type); \
|
||||
*(size_pointer) = size; \
|
||||
} STMT_END
|
||||
diff --git a/regen/reentr.pl b/regen/reentr.pl
|
||||
index 94721e9dec..ba2e1c8fa6 100644
|
||||
--- a/regen/reentr.pl
|
||||
+++ b/regen/reentr.pl
|
||||
@@ -818,7 +818,7 @@ print $c <<"EOF";
|
||||
|
||||
#define RenewDouble(data_pointer, size_pointer, type) \\
|
||||
STMT_START { \\
|
||||
- const size_t size = *(size_pointer) * 2; \\
|
||||
+ const size_t size = MAX(*(size_pointer), 1) * 2; \\
|
||||
Renew((data_pointer), (size), type); \\
|
||||
*(size_pointer) = size; \\
|
||||
} STMT_END
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,31 +0,0 @@
|
||||
From 530e9296a21b673d7e4c2b42f18d0d52d00f35c4 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sun, 28 Jun 2020 12:03:54 -0600
|
||||
Subject: [PATCH] sv.h: Wanted UOK, but said IOK
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
I don't know the consequences of this bug
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
sv.h | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/sv.h b/sv.h
|
||||
index 2f6431a826..3721b2fb1b 100644
|
||||
--- a/sv.h
|
||||
+++ b/sv.h
|
||||
@@ -1711,7 +1711,7 @@ Like C<sv_catsv> but doesn't process magic.
|
||||
#define SvNV(sv) (SvNOK_nog(sv) ? SvNVX(sv) : sv_2nv(sv))
|
||||
|
||||
#define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0))
|
||||
-#define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
|
||||
+#define SvUV_nomg(sv) (SvUOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
|
||||
#define SvNV_nomg(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv_flags(sv, 0))
|
||||
|
||||
/* ----*/
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,77 +0,0 @@
|
||||
From 390fe0c0d09aadc66f644e9eee4aa1245221188c Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Tue, 25 Aug 2020 13:15:25 +0100
|
||||
Subject: [PATCH] sort { return foo() } ...
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
GH #18081
|
||||
|
||||
A sub call via return in a sort block was called in void rather than
|
||||
scalar context, causing the comparison result to be discarded.
|
||||
|
||||
This because when a sort block is called it is not a real function
|
||||
call, even though a sort block can be returned from. Instead, a
|
||||
CXt_NULL is pushed on the context stack. Because this isn't a sub-ish
|
||||
context type (unlike CXt_SUB, CXt_EVAL etc) there is no 'caller sub'
|
||||
on the context stack to be found to retrieve the caller's context
|
||||
(i.e. cx->cx_gimme).
|
||||
|
||||
This commit fixes it by special-casing Perl_gimme_V().
|
||||
|
||||
Ideally at some future point, a new context type, CXt_SORT, should be
|
||||
added. This would be used instead of CXt_NULL when a sort BLOCK is
|
||||
called. Like other sub-ish context types, it would have an old_cxsubix
|
||||
field and PL_curstackinfo->si_cxsubix would point to it. This would
|
||||
eliminate needing special-case handling in places like Perl_gimme_V().
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
inline.h | 2 +-
|
||||
t/op/sort.t | 12 +++++++++++-
|
||||
2 files changed, 12 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/inline.h b/inline.h
|
||||
index a8240efb9c..6fbd5abfea 100644
|
||||
--- a/inline.h
|
||||
+++ b/inline.h
|
||||
@@ -2086,7 +2086,7 @@ Perl_gimme_V(pTHX)
|
||||
return gimme;
|
||||
cxix = PL_curstackinfo->si_cxsubix;
|
||||
if (cxix < 0)
|
||||
- return G_VOID;
|
||||
+ return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
|
||||
assert(cxstack[cxix].blk_gimme & G_WANT);
|
||||
return (cxstack[cxix].blk_gimme & G_WANT);
|
||||
}
|
||||
diff --git a/t/op/sort.t b/t/op/sort.t
|
||||
index f2e139dff0..8e387fb90d 100644
|
||||
--- a/t/op/sort.t
|
||||
+++ b/t/op/sort.t
|
||||
@@ -7,7 +7,7 @@ BEGIN {
|
||||
set_up_inc('../lib');
|
||||
}
|
||||
use warnings;
|
||||
-plan(tests => 203);
|
||||
+plan(tests => 204);
|
||||
use Tie::Array; # we need to test sorting tied arrays
|
||||
|
||||
# these shouldn't hang
|
||||
@@ -1202,3 +1202,13 @@ SKIP:
|
||||
$fillb = undef;
|
||||
is $act, "01[sortb]2[fillb]";
|
||||
}
|
||||
+
|
||||
+# GH #18081
|
||||
+# sub call via return in sort block was called in void rather than scalar
|
||||
+# context
|
||||
+
|
||||
+{
|
||||
+ sub sort18081 { $a + 1 <=> $b + 1 }
|
||||
+ my @a = sort { return &sort18081 } 6,1,2;
|
||||
+ is "@a", "1 2 6", "GH #18081";
|
||||
+}
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,77 +0,0 @@
|
||||
From bd5fa06648085e8c17efd55abeb6424aeeb1018e Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue, 29 Sep 2020 00:48:19 -0600
|
||||
Subject: [PATCH] Remove Perl_av_top_index
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
I created this in 87306e0674dfe3af29804b4641347cd5ac9b0521, thinking it
|
||||
was needed to preserve backward compatibility if someone were using this
|
||||
instead of the macro. But it turned out that there never was such a
|
||||
function, it was inlined, and the name was S_av_top_index, so there is
|
||||
no reason to create a new function that no one has ever been able to
|
||||
call. So just remove it, and let all accesses go through the macro
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
av.c | 10 ----------
|
||||
embed.fnc | 2 +-
|
||||
proto.h | 7 +++----
|
||||
3 files changed, 4 insertions(+), 15 deletions(-)
|
||||
|
||||
diff --git a/av.c b/av.c
|
||||
index ada09cde9a..ad2429f90d 100644
|
||||
--- a/av.c
|
||||
+++ b/av.c
|
||||
@@ -1095,16 +1095,6 @@ Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
|
||||
return sv;
|
||||
}
|
||||
|
||||
-SSize_t
|
||||
-Perl_av_top_index(pTHX_ AV *av)
|
||||
-{
|
||||
- PERL_ARGS_ASSERT_AV_TOP_INDEX;
|
||||
- assert(SvTYPE(av) == SVt_PVAV);
|
||||
-
|
||||
- return AvFILL(av);
|
||||
-}
|
||||
-
|
||||
-
|
||||
/*
|
||||
* ex: set ts=8 sts=4 sw=4 et:
|
||||
*/
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index a6b4d0350f..f5c5b29c2d 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -637,7 +637,7 @@ Apd |void |av_push |NN AV *av|NN SV *val
|
||||
EXp |void |av_reify |NN AV *av
|
||||
ApdR |SV* |av_shift |NN AV *av
|
||||
Apd |SV** |av_store |NN AV *av|SSize_t key|NULLOK SV *val
|
||||
-AMdRp |SSize_t|av_top_index |NN AV *av
|
||||
+AmdR |SSize_t|av_top_index |NN AV *av
|
||||
AidRp |Size_t |av_count |NN AV *av
|
||||
AmdR |SSize_t|av_tindex |NN AV *av
|
||||
Apd |void |av_undef |NN AV *av
|
||||
diff --git a/proto.h b/proto.h
|
||||
index c4490fc46e..2da1a07761 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -291,10 +291,9 @@ PERL_CALLCONV SV** Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val);
|
||||
__attribute__warn_unused_result__; */
|
||||
#define PERL_ARGS_ASSERT_AV_TINDEX
|
||||
|
||||
-PERL_CALLCONV SSize_t Perl_av_top_index(pTHX_ AV *av)
|
||||
- __attribute__warn_unused_result__;
|
||||
-#define PERL_ARGS_ASSERT_AV_TOP_INDEX \
|
||||
- assert(av)
|
||||
+/* PERL_CALLCONV SSize_t av_top_index(pTHX_ AV *av)
|
||||
+ __attribute__warn_unused_result__; */
|
||||
+#define PERL_ARGS_ASSERT_AV_TOP_INDEX
|
||||
|
||||
PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av);
|
||||
#define PERL_ARGS_ASSERT_AV_UNDEF \
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,31 +0,0 @@
|
||||
From fa353c3d2833fc326233e0eb583753b4d7887a63 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sun, 4 Oct 2020 11:07:19 -0600
|
||||
Subject: [PATCH] mro.xs: Fix compiler warning
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Fixes GH #18155
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/mro/mro.xs | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs
|
||||
index f21216af6e..8ce5844904 100644
|
||||
--- a/ext/mro/mro.xs
|
||||
+++ b/ext/mro/mro.xs
|
||||
@@ -253,7 +253,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
|
||||
hierarchy is not C3-incompatible */
|
||||
if(!winner) {
|
||||
SV *errmsg;
|
||||
- I32 i;
|
||||
+ Size_t i;
|
||||
|
||||
errmsg = newSVpvf(
|
||||
"Inconsistent hierarchy during C3 merge of class '%" HEKf "':\n\t"
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,32 +0,0 @@
|
||||
From 5777cf812c2812ea45eeb45e48979bab544d71af Mon Sep 17 00:00:00 2001
|
||||
From: TAKAI Kousuke <62541129+t-a-k@users.noreply.github.com>
|
||||
Date: Thu, 8 Oct 2020 19:02:10 +0900
|
||||
Subject: [PATCH] sv.c: Added missing braces in Perl_sv_inc_nomg().
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
sv.c | 3 ++-
|
||||
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/sv.c b/sv.c
|
||||
index 82248e3b1f..57fd65a5b8 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -8944,9 +8944,10 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv)
|
||||
if (SvIsUV(sv)) {
|
||||
if (SvUVX(sv) == UV_MAX)
|
||||
sv_setnv(sv, UV_MAX_P1);
|
||||
- else
|
||||
+ else {
|
||||
(void)SvIOK_only_UV(sv);
|
||||
SvUV_set(sv, SvUVX(sv) + 1);
|
||||
+ }
|
||||
} else {
|
||||
if (SvIVX(sv) == IV_MAX)
|
||||
sv_setuv(sv, (UV)IV_MAX + 1);
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,36 +0,0 @@
|
||||
From e17dadf36f7b4348e59076240c880d0c78b33fa9 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue, 22 Sep 2020 08:47:52 -0600
|
||||
Subject: [PATCH] sv.h: sv_collxfrm didn't work properly
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
It is supposed to be a wrapper for sv_collxfrm_flags, but it was just
|
||||
calling sv_cmp_flags instead. The consequences are none except under
|
||||
'use locale' in which case you always got the C locale. I did not add
|
||||
tests, because it is really a pain to write portable locale tests, and
|
||||
this doesn't seem to be much used. In core the '_flags' form was always
|
||||
used.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
sv.h | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/sv.h b/sv.h
|
||||
index 19ce718ac3..44414b35a9 100644
|
||||
--- a/sv.h
|
||||
+++ b/sv.h
|
||||
@@ -2045,7 +2045,7 @@ Like C<sv_catsv> but doesn't process magic.
|
||||
#define sv_eq(sv1, sv2) sv_eq_flags(sv1, sv2, SV_GMAGIC)
|
||||
#define sv_cmp(sv1, sv2) sv_cmp_flags(sv1, sv2, SV_GMAGIC)
|
||||
#define sv_cmp_locale(sv1, sv2) sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC)
|
||||
-#define sv_collxfrm(sv, nxp) sv_cmp_flags(sv, nxp, SV_GMAGIC)
|
||||
+#define sv_collxfrm(sv, nxp) sv_collxfrm_flags(sv, nxp, SV_GMAGIC)
|
||||
#define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC)
|
||||
#define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0)
|
||||
#define sv_insert(bigstr, offset, len, little, littlelen) \
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,76 +0,0 @@
|
||||
From e050064b67c501e9fdc7bc3f513ba2b8b9e795f8 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Fri, 30 Oct 2020 20:50:58 +0000
|
||||
Subject: [PATCH] Perl_custom_op_get_field(): remove undef behaviour
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Thus function has a couple a switches with
|
||||
|
||||
default:
|
||||
NOT_REACHED; /* NOTREACHED */
|
||||
|
||||
but clang is complaining that the value returned by the function is
|
||||
undefined if those default branches are taken, since the 'any' variable
|
||||
doesn't get set in that path.
|
||||
|
||||
Replace the NOTREACHED with a croak("panic: ..."). It's possible (albeit
|
||||
not intended) for Perl_custom_op_get_field() to be called with a 'field'
|
||||
arg which triggers the default case. So if this ever happens, make it
|
||||
clear that something has gone wrong, rather than just silently
|
||||
continuing on non-debugging builds.
|
||||
|
||||
In any case, this shuts up clang.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 14 ++++++--------
|
||||
1 file changed, 6 insertions(+), 8 deletions(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index c30c6b7c8f..2933e2ed7d 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -18100,6 +18100,7 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
|
||||
else
|
||||
xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
|
||||
}
|
||||
+
|
||||
{
|
||||
XOPRETANY any;
|
||||
if(field == XOPe_xop_ptr) {
|
||||
@@ -18121,7 +18122,10 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
|
||||
any.xop_peep = xop->xop_peep;
|
||||
break;
|
||||
default:
|
||||
- NOT_REACHED; /* NOTREACHED */
|
||||
+ field_panic:
|
||||
+ Perl_croak(aTHX_
|
||||
+ "panic: custom_op_get_field(): invalid field %d\n",
|
||||
+ (int)field);
|
||||
break;
|
||||
}
|
||||
} else {
|
||||
@@ -18139,17 +18143,11 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
|
||||
any.xop_peep = XOPd_xop_peep;
|
||||
break;
|
||||
default:
|
||||
- NOT_REACHED; /* NOTREACHED */
|
||||
+ goto field_panic;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
- /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
|
||||
- * op.c: In function 'Perl_custom_op_get_field':
|
||||
- * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
|
||||
- * This is because on those platforms (with -DEBUGGING) NOT_REACHED
|
||||
- * expands to assert(0), which expands to ((0) ? (void)0 :
|
||||
- * __assert(...)), and gcc doesn't know that __assert can never return. */
|
||||
return any;
|
||||
}
|
||||
}
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,57 +0,0 @@
|
||||
From f877e124a20d4f94c82c36e6b7a99b4e9663e204 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 10 Nov 2020 15:50:27 +1100
|
||||
Subject: [PATCH] fetch magic on the first stacked filetest, not the last
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
fixes #18293
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp_sys.c | 2 +-
|
||||
t/op/filetest.t | 10 +++++++++-
|
||||
2 files changed, 10 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pp_sys.c b/pp_sys.c
|
||||
index 66c5d9aade..5c9f768eaf 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -3067,7 +3067,7 @@ S_try_amagic_ftest(pTHX_ char chr) {
|
||||
SV *const arg = *PL_stack_sp;
|
||||
|
||||
assert(chr != '?');
|
||||
- if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
|
||||
+ if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg);
|
||||
|
||||
if (SvAMAGIC(arg))
|
||||
{
|
||||
diff --git a/t/op/filetest.t b/t/op/filetest.t
|
||||
index fe9724c59a..7c471c050c 100644
|
||||
--- a/t/op/filetest.t
|
||||
+++ b/t/op/filetest.t
|
||||
@@ -9,7 +9,7 @@ BEGIN {
|
||||
set_up_inc(qw '../lib ../cpan/Perl-OSType/lib');
|
||||
}
|
||||
|
||||
-plan(tests => 57 + 27*14);
|
||||
+plan(tests => 58 + 27*14);
|
||||
|
||||
if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) {
|
||||
require Win32; # for IsAdminUser()
|
||||
@@ -385,3 +385,11 @@ SKIP: {
|
||||
ok(!-f "TEST\0-", '-f on name with \0');
|
||||
ok(!-r "TEST\0-", '-r on name with \0');
|
||||
}
|
||||
+
|
||||
+{
|
||||
+ # github #18293
|
||||
+ "" =~ /(.*)/;
|
||||
+ my $x = $1; # call magic on $1, setting the pv to ""
|
||||
+ "test.pl" =~ /(.*)/;
|
||||
+ ok(-f -r $1, "stacked handles on a name with magic");
|
||||
+}
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,54 +0,0 @@
|
||||
From ab307de390c3459badcc89b3d77542b5b871b2e8 Mon Sep 17 00:00:00 2001
|
||||
From: Richard Leach <richardleach@users.noreply.github.com>
|
||||
Date: Tue, 20 Oct 2020 18:16:38 +0100
|
||||
Subject: [PATCH 2/2] pp_split: add TonyC's stack-not-refcounted-suggestion and
|
||||
tests
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp.c | 5 ++++-
|
||||
t/op/split.t | 5 +++++
|
||||
2 files changed, 9 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index ce16c56e63..5b5e163011 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -6034,6 +6034,9 @@ PP(pp_split)
|
||||
oldsave = PL_savestack_ix;
|
||||
}
|
||||
|
||||
+ /* Some defence against stack-not-refcounted bugs */
|
||||
+ (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary));
|
||||
+
|
||||
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
|
||||
@@ -6356,7 +6359,7 @@ PP(pp_split)
|
||||
}
|
||||
|
||||
PUTBACK;
|
||||
- LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
|
||||
+ LEAVE_SCOPE(oldsave);
|
||||
SPAGAIN;
|
||||
if (realarray) {
|
||||
if (!mg) {
|
||||
diff --git a/t/op/split.t b/t/op/split.t
|
||||
index 1d78a45bde..7a321645ac 100644
|
||||
--- a/t/op/split.t
|
||||
+++ b/t/op/split.t
|
||||
@@ -703,3 +703,8 @@ fresh_perl_is('my @ary; @ary = split(/\w(?{ @ary[1000] = 1 })/, "abc");',
|
||||
fresh_perl_is('my @ary; @ary = split(/\w(?{ undef @ary })/, "abc");',
|
||||
'',{},'(@ary = split ...) survives an (undef @ary)');
|
||||
|
||||
+# check the (@ary = split) optimisation survives stack-not-refcounted bugs
|
||||
+fresh_perl_is('our @ary; @ary = split(/\w(?{ *ary = 0 })/, "abc");',
|
||||
+ '',{},'(@ary = split ...) survives @ary destruction via typeglob');
|
||||
+fresh_perl_is('my $ary = []; @$ary = split(/\w(?{ $ary = [] })/, "abc");',
|
||||
+ '',{},'(@ary = split ...) survives @ary destruction via reassignment');
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,71 +0,0 @@
|
||||
From b52b6c4029b51818442d64c6104d26e12e140f09 Mon Sep 17 00:00:00 2001
|
||||
From: TAKAI Kousuke <62541129+t-a-k@users.noreply.github.com>
|
||||
Date: Thu, 5 Nov 2020 22:06:16 +0900
|
||||
Subject: [PATCH] t/op/inc.t, t/op/hexfp.t, t/op/sprintf2.t: Add missing d_
|
||||
prefixes for Config variable names.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/hexfp.t | 2 +-
|
||||
t/op/inc.t | 4 ++--
|
||||
t/op/sprintf2.t | 4 ++--
|
||||
3 files changed, 5 insertions(+), 5 deletions(-)
|
||||
|
||||
diff --git a/t/op/hexfp.t b/t/op/hexfp.t
|
||||
index b0c85cfdc6..5fb80d3d74 100644
|
||||
--- a/t/op/hexfp.t
|
||||
+++ b/t/op/hexfp.t
|
||||
@@ -246,7 +246,7 @@ SKIP: {
|
||||
skip("non-80-bit-long-double", 4)
|
||||
unless ($Config{uselongdouble} &&
|
||||
($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
|
||||
- ($Config{long_double_style_ieee_extended}));
|
||||
+ ($Config{d_long_double_style_ieee_extended}));
|
||||
is(0x1p-1074, 4.94065645841246544e-324);
|
||||
is(0x1p-1075, 2.47032822920623272e-324, '[perl #128919]');
|
||||
is(0x1p-1076, 1.23516411460311636e-324);
|
||||
diff --git a/t/op/inc.t b/t/op/inc.t
|
||||
index 0bb8b85b13..3d5cc024d3 100644
|
||||
--- a/t/op/inc.t
|
||||
+++ b/t/op/inc.t
|
||||
@@ -188,10 +188,10 @@ cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double");
|
||||
|
||||
SKIP: {
|
||||
if ($Config{uselongdouble} &&
|
||||
- ($Config{long_double_style_ieee_doubledouble})) {
|
||||
+ ($Config{d_long_double_style_ieee_doubledouble})) {
|
||||
skip "the double-double format is weird", 1;
|
||||
}
|
||||
- unless ($Config{double_style_ieee}) {
|
||||
+ unless ($Config{d_double_style_ieee}) {
|
||||
skip "the doublekind $Config{doublekind} is not IEEE", 1;
|
||||
}
|
||||
|
||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
||||
index bbc12ccd0a..38a550c281 100644
|
||||
--- a/t/op/sprintf2.t
|
||||
+++ b/t/op/sprintf2.t
|
||||
@@ -701,7 +701,7 @@ SKIP: {
|
||||
skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef')
|
||||
. " longdblkind=$Config{longdblkind} os=$^O", 6)
|
||||
unless ($Config{uselongdouble} &&
|
||||
- ($Config{long_double_style_ieee_doubledouble})
|
||||
+ ($Config{d_long_double_style_ieee_doubledouble})
|
||||
# Gating on 'linux' (ppc) here is due to the differing
|
||||
# double-double implementations: other (also big-endian)
|
||||
# double-double platforms (e.g. AIX on ppc or IRIX on mips)
|
||||
@@ -892,7 +892,7 @@ SKIP: {
|
||||
skip("non-80-bit-long-double", 17)
|
||||
unless ($Config{uselongdouble} &&
|
||||
($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
|
||||
- ($Config{long_double_style_ieee_extended}));
|
||||
+ ($Config{d_long_double_style_ieee_extended}));
|
||||
|
||||
{
|
||||
# The last normal for this format.
|
||||
--
|
||||
2.25.4
|
||||
|
||||
@ -1,32 +0,0 @@
|
||||
From 9289d4dc7a3d24b20c6e25045e687321ee3e8faf Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 30 Nov 2020 09:25:52 -0700
|
||||
Subject: [PATCH] locale.c: Fix typo in #ifdef
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This misspelling led to the code assuming that the platform didn't have
|
||||
a feature that, if used, would result in faster execution.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
locale.c | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/locale.c b/locale.c
|
||||
index 9500ab7960..5970423404 100644
|
||||
--- a/locale.c
|
||||
+++ b/locale.c
|
||||
@@ -2621,7 +2621,7 @@ S_my_nl_langinfo(const int item, bool toggle)
|
||||
#if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */
|
||||
# if ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \
|
||||
|| ! defined(HAS_POSIX_2008_LOCALE) \
|
||||
- || ! defined(DUPLOCALE)
|
||||
+ || ! defined(HAS_DUPLOCALE)
|
||||
|
||||
/* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC
|
||||
* for those items dependent on it. This must be copied to a buffer before
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,140 +0,0 @@
|
||||
From 4cfbe5474a5c5f852a6dbf0138dc796c2800be93 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Wed, 30 Dec 2020 05:55:08 -0700
|
||||
Subject: [PATCH] Fix buggy fc() in Turkish locale
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
When Turkish handling was added, fc() wasn't properly updated
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp.c | 12 +++++++++---
|
||||
t/op/lc.t | 23 ++++++++++++++++-------
|
||||
2 files changed, 25 insertions(+), 10 deletions(-)
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index 5e1706346d..23cc6c8adb 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -4813,7 +4813,7 @@ PP(pp_fc)
|
||||
do {
|
||||
extra++;
|
||||
|
||||
- s_peek = (U8 *) memchr(s_peek + 1, 'i',
|
||||
+ s_peek = (U8 *) memchr(s_peek + 1, 'I',
|
||||
send - (s_peek + 1));
|
||||
} while (s_peek != NULL);
|
||||
}
|
||||
@@ -4828,8 +4828,14 @@ PP(pp_fc)
|
||||
+ 1 /* Trailing NUL */ );
|
||||
d = (U8*)SvPVX(dest) + len;
|
||||
|
||||
- *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
|
||||
- *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
|
||||
+ if (*s == 'I') {
|
||||
+ *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
|
||||
+ *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
|
||||
+ }
|
||||
+ else {
|
||||
+ *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
|
||||
+ *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
|
||||
+ }
|
||||
s++;
|
||||
|
||||
for (; s < send; s++) {
|
||||
diff --git a/t/op/lc.t b/t/op/lc.t
|
||||
index fce77f3d34..812c41d6b6 100644
|
||||
--- a/t/op/lc.t
|
||||
+++ b/t/op/lc.t
|
||||
@@ -17,7 +17,7 @@ BEGIN {
|
||||
|
||||
use feature qw( fc );
|
||||
|
||||
-plan tests => 139 + 2 * (4 * 256) + 15;
|
||||
+plan tests => 139 + 2 * (5 * 256) + 17;
|
||||
|
||||
is(lc(undef), "", "lc(undef) is ''");
|
||||
is(lcfirst(undef), "", "lcfirst(undef) is ''");
|
||||
@@ -352,13 +352,14 @@ foreach my $turkic (0 .. 1) {
|
||||
my $locale = ($turkic) ? $turkic_locale : $non_turkic_locale;
|
||||
|
||||
SKIP: {
|
||||
- skip "Can't find a $type UTF-8 locale", 4*256 unless defined $locale;
|
||||
+ skip "Can't find a $type UTF-8 locale", 5*256 unless defined $locale;
|
||||
|
||||
use feature qw( unicode_strings );
|
||||
|
||||
no locale;
|
||||
|
||||
my @unicode_lc;
|
||||
+ my @unicode_fc;
|
||||
my @unicode_uc;
|
||||
my @unicode_lcfirst;
|
||||
my @unicode_ucfirst;
|
||||
@@ -366,6 +367,7 @@ foreach my $turkic (0 .. 1) {
|
||||
# Get all the values outside of 'locale'
|
||||
for my $i (0 .. 255) {
|
||||
push @unicode_lc, lc(chr $i);
|
||||
+ push @unicode_fc, fc(chr $i);
|
||||
push @unicode_uc, uc(chr $i);
|
||||
push @unicode_lcfirst, lcfirst(chr $i);
|
||||
push @unicode_ucfirst, ucfirst(chr $i);
|
||||
@@ -373,6 +375,7 @@ foreach my $turkic (0 .. 1) {
|
||||
|
||||
if ($turkic) {
|
||||
$unicode_lc[ord 'I'] = chr 0x131;
|
||||
+ $unicode_fc[ord 'I'] = chr 0x131;
|
||||
$unicode_lcfirst[ord 'I'] = chr 0x131;
|
||||
$unicode_uc[ord 'i'] = chr 0x130;
|
||||
$unicode_ucfirst[ord 'i'] = chr 0x130;
|
||||
@@ -384,6 +387,7 @@ foreach my $turkic (0 .. 1) {
|
||||
for my $i (0 .. 255) {
|
||||
is(lc(chr $i), $unicode_lc[$i], "In a $type UTF-8 locale, lc(chr $i) is the same as official Unicode");
|
||||
is(uc(chr $i), $unicode_uc[$i], "In a $type UTF-8 locale, uc(chr $i) is the same as official Unicode");
|
||||
+ is(fc(chr $i), $unicode_fc[$i], "In a $type UTF-8 locale, fc(chr $i) is the same as official Unicode");
|
||||
is(lcfirst(chr $i), $unicode_lcfirst[$i], "In a $type UTF-8 locale, lcfirst(chr $i) is the same as official Unicode");
|
||||
is(ucfirst(chr $i), $unicode_ucfirst[$i], "In a $type UTF-8 locale, ucfirst(chr $i) is the same as official Unicode");
|
||||
}
|
||||
@@ -391,27 +395,32 @@ foreach my $turkic (0 .. 1) {
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
- skip "Can't find a turkic UTF-8 locale", 15 unless defined $turkic_locale;
|
||||
+ skip "Can't find a turkic UTF-8 locale", 17 unless defined $turkic_locale;
|
||||
|
||||
# These are designed to stress the calculation of space needed for the
|
||||
# strings. $filler contains a variety of characters that have special
|
||||
# handling in the casing functions, and some regular chars as well.
|
||||
+ # (0x49 = 'I')
|
||||
my $filler_length = 10000;
|
||||
- my $filler = uni_to_native("\x{df}\x{b5}\x{e0}\x{c1}\x{b6}\x{ff}") x $filler_length;
|
||||
+ my $filler = uni_to_native("\x{df}\x{49}\x{69}\x{b5}\x{e0}\x{c1}\x{b6}\x{ff}") x $filler_length;
|
||||
|
||||
# These are the correct answers to what should happen when the given
|
||||
# casing function is called on $filler;
|
||||
- my $filler_lc = uni_to_native("\x{df}\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}") x $filler_length;
|
||||
- my $filler_fc = ("ss" . uni_to_native("\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}")) x $filler_length;
|
||||
- my $filler_uc = ("SS" . uni_to_native("\x{39c}\x{c0}\x{c1}\x{b6}\x{178}")) x $filler_length;
|
||||
+ my $filler_lc = uni_to_native("\x{df}\x{131}\x{69}\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}") x $filler_length;
|
||||
+ my $filler_fc = ("ss" . uni_to_native("\x{131}\x{69}\x{3bc}\x{e0}\x{e1}\x{b6}\x{ff}")) x $filler_length;
|
||||
+ my $filler_uc = ("SS" . uni_to_native("\x{49}\x{130}\x{39c}\x{c0}\x{c1}\x{b6}\x{178}")) x $filler_length;
|
||||
|
||||
use locale;
|
||||
setlocale(&POSIX::LC_CTYPE, $turkic_locale);
|
||||
|
||||
is (lc "IIIIIII$filler", "\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc",
|
||||
"lc non-UTF-8, in Turkic locale, beginning with a bunch of I's");
|
||||
+ is (fc "IIIIIII$filler", "\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_fc",
|
||||
+ "fc non-UTF-8, in Turkic locale, beginning with a bunch of I's");
|
||||
is (lc "${filler}IIIIIII$filler", "$filler_lc\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc",
|
||||
"lc non-UTF-8, in Turkic locale, a bunch of I's, but not at the beginning");
|
||||
+ is (fc "${filler}IIIIIII$filler", "$filler_fc\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_fc",
|
||||
+ "fc non-UTF-8, in Turkic locale, a bunch of I's, but not at the beginning");
|
||||
is (lc "${filler}I\x{307}$filler", "${filler_lc}i$filler_lc",
|
||||
"lc in Turkic locale with DOT ABOVE immediately following I");
|
||||
is (lc "${filler}I\x{307}IIIIII$filler", "${filler_lc}i\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc",
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,43 +0,0 @@
|
||||
From 036189b0a003875df7bf09c7f7fd702267f549e5 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 26 Dec 2020 08:44:08 -0700
|
||||
Subject: [PATCH] Use perl.h versions of PERL_UNUSED_foo in XSUB.h
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This commit was applied to perl.h, but not to XSUB.h:
|
||||
|
||||
commit a730e3f230f364cffe49370f816f975ae7c9c403
|
||||
Author: Jarkko Hietaniemi <jhi@iki.fi>
|
||||
Date: Thu Sep 4 09:08:33 2014 -0400
|
||||
|
||||
Use sizeof() in UNUSED_ARG and UNUSED_VAR to avoid accessing the values.
|
||||
|
||||
The values might even be uninitialized in the case of PERL_UNUSED_VAR.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
XSUB.h | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/XSUB.h b/XSUB.h
|
||||
index 616d813840..c1e3959885 100644
|
||||
--- a/XSUB.h
|
||||
+++ b/XSUB.h
|
||||
@@ -108,10 +108,10 @@ is a lexical C<$_> in scope.
|
||||
*/
|
||||
|
||||
#ifndef PERL_UNUSED_ARG
|
||||
-# define PERL_UNUSED_ARG(x) ((void)x)
|
||||
+# define PERL_UNUSED_ARG(x) ((void)sizeof(x))
|
||||
#endif
|
||||
#ifndef PERL_UNUSED_VAR
|
||||
-# define PERL_UNUSED_VAR(x) ((void)x)
|
||||
+# define PERL_UNUSED_VAR(x) ((void)sizeof(x))
|
||||
#endif
|
||||
|
||||
#define ST(off) PL_stack_base[ax + (off)]
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,78 +0,0 @@
|
||||
From 07319fdbb283f93cb655c3106b5237cbc7272038 Mon Sep 17 00:00:00 2001
|
||||
From: Tomasz Konojacki <me@xenu.pl>
|
||||
Date: Wed, 30 Dec 2020 14:03:02 +0100
|
||||
Subject: [PATCH] op.c: croak on "my $_" when "use utf8" is in effect
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Fixes #18449
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 16 +++++++++-------
|
||||
t/op/mydef.t | 11 +++++++++--
|
||||
2 files changed, 18 insertions(+), 9 deletions(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index b2e12dd0c0..dce844d297 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -730,6 +730,7 @@ PADOFFSET
|
||||
Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
|
||||
{
|
||||
PADOFFSET off;
|
||||
+ bool is_idfirst, is_default;
|
||||
const bool is_our = (PL_parser->in_my == KEY_our);
|
||||
|
||||
PERL_ARGS_ASSERT_ALLOCMY;
|
||||
@@ -738,14 +739,15 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
|
||||
Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
|
||||
(UV)flags);
|
||||
|
||||
+ is_idfirst = flags & SVf_UTF8
|
||||
+ ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
|
||||
+ : isIDFIRST_A(name[1]);
|
||||
+
|
||||
+ /* $_, @_, etc. */
|
||||
+ is_default = len == 2 && name[1] == '_';
|
||||
+
|
||||
/* complain about "my $<special_var>" etc etc */
|
||||
- if ( len
|
||||
- && !( is_our
|
||||
- || isALPHA(name[1])
|
||||
- || ( (flags & SVf_UTF8)
|
||||
- && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
|
||||
- || (name[1] == '_' && len > 2)))
|
||||
- {
|
||||
+ if (!is_our && (!is_idfirst || is_default)) {
|
||||
const char * const type =
|
||||
PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
|
||||
PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
|
||||
diff --git a/t/op/mydef.t b/t/op/mydef.t
|
||||
index 42a81d9ab0..225ce98e51 100644
|
||||
--- a/t/op/mydef.t
|
||||
+++ b/t/op/mydef.t
|
||||
@@ -6,10 +6,17 @@ BEGIN {
|
||||
set_up_inc('../lib');
|
||||
}
|
||||
|
||||
-plan tests => 1;
|
||||
-
|
||||
use strict;
|
||||
|
||||
eval 'my $_';
|
||||
like $@, qr/^Can't use global \$_ in "my" at /;
|
||||
|
||||
+{
|
||||
+ # using utf8 allows $_ to be declared with 'my'
|
||||
+ # GH #18449
|
||||
+ use utf8;
|
||||
+ eval 'my $_;';
|
||||
+ like $@, qr/^Can't use global \$_ in "my" at /;
|
||||
+}
|
||||
+
|
||||
+done_testing;
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,100 +0,0 @@
|
||||
From cac138107138a9814b32c4de74426225628f1646 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sun, 17 Jan 2021 21:45:20 -0700
|
||||
Subject: [PATCH] Add missing entries to perldiag; GH #18276
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The ticket mentions yet another message, not addressed in this
|
||||
commit, "Insecure private-use override". That message is part of a
|
||||
hook for a so-far unimplemented module, so it actually doesn't ever get
|
||||
raised.
|
||||
|
||||
Committer: One correction per Grinnz comment in
|
||||
https://github.com/Perl/perl5/pull/18491
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perldiag.pod | 45 +++++++++++++++++++++++++++++++++++++++++++++
|
||||
1 file changed, 45 insertions(+)
|
||||
|
||||
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
|
||||
index 9c91630d39..63f57f220e 100644
|
||||
--- a/pod/perldiag.pod
|
||||
+++ b/pod/perldiag.pod
|
||||
@@ -2195,6 +2195,20 @@ single form when it must operate on them directly. Either you've passed
|
||||
an invalid file specification to Perl, or you've found a case the
|
||||
conversion routines don't handle. Drat.
|
||||
|
||||
+=item Error %s in expansion of %s
|
||||
+
|
||||
+(F) An error was encountered in handling a user-defined property
|
||||
+(L<perlunicode/User-Defined Character Properties>). These are
|
||||
+programmer written subroutines, hence subject to errors that may
|
||||
+prevent them from compiling or running. The calls to these subs are
|
||||
+C<eval>'d, and if there is a failure, this message is raised, using the
|
||||
+contents of C<$@> from the failed C<eval>.
|
||||
+
|
||||
+Another possibility is that tainted data was encountered somewhere in
|
||||
+the chain of expanding the property. If so, the message wording will
|
||||
+indicate that this is the problem. See L</Insecure user-defined
|
||||
+property %s>.
|
||||
+
|
||||
=item Eval-group in insecure regular expression
|
||||
|
||||
(F) Perl detected tainted data when trying to compile a regular
|
||||
@@ -2836,6 +2850,16 @@ not match 8 spaces.
|
||||
text. You should check the pattern to ensure that recursive patterns
|
||||
either consume text or fail.
|
||||
|
||||
+=item Infinite recursion in user-defined property
|
||||
+
|
||||
+(F) A user-defined property (L<perlunicode/User-Defined Character
|
||||
+Properties>) can depend on the definitions of other user-defined
|
||||
+properties. If the chain of dependencies leads back to this property,
|
||||
+infinite recursion would occur, were it not for the check that raised
|
||||
+this error.
|
||||
+
|
||||
+Restructure your property definitions to avoid this.
|
||||
+
|
||||
=item Infinite recursion via empty pattern
|
||||
|
||||
(F) You tried to use the empty pattern inside of a regex code block,
|
||||
@@ -6273,6 +6297,20 @@ lexicals that are initialized only once (see L<feature>):
|
||||
This use of C<my()> in a false conditional was deprecated beginning in
|
||||
Perl 5.10 and became a fatal error in Perl 5.30.
|
||||
|
||||
+=item Timeout waiting for another thread to define \p{%s}
|
||||
+
|
||||
+(F) The first time a user-defined property
|
||||
+(L<perlunicode/User-Defined Character Properties>) is used, its
|
||||
+definition is looked up and converted into an internal form for more
|
||||
+efficient handling in subsequent uses. There could be a race if two or
|
||||
+more threads tried to do this processing nearly simultaneously.
|
||||
+Instead, a critical section is created around this task, locking out all
|
||||
+but one thread from doing it. This message indicates that the thread
|
||||
+that is doing the conversion is taking an unexpectedly long time. The
|
||||
+timeout exists solely to prevent deadlock; it's long enough that the
|
||||
+system was likely thrashing and about to crash. There is no real remedy but
|
||||
+rebooting.
|
||||
+
|
||||
=item times not implemented
|
||||
|
||||
(F) Your version of the C library apparently doesn't do times(). I
|
||||
@@ -6846,6 +6884,13 @@ for the list of known options.
|
||||
L<perlrun|perlrun/-C [numberE<sol>list]> documentation of the C<-C> switch
|
||||
for the list of known options.
|
||||
|
||||
+=item Unknown user-defined property name \p{%s}
|
||||
+
|
||||
+(F) You specified to use a property within the C<\p{...}> which was a
|
||||
+syntactically valid user-defined property, but no definition was found
|
||||
+for it by the time one was required to proceed. Check your spelling.
|
||||
+See L<perlunicode/User-Defined Character Properties>.
|
||||
+
|
||||
=item Unknown verb pattern '%s' in regex; marked by S<<-- HERE> in m/%s/
|
||||
|
||||
(F) You either made a typo or have incorrectly put a C<*> quantifier
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,32 +0,0 @@
|
||||
From a2f57b06b018b254bee93e1a1265cfc09833366f Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue, 9 Feb 2021 11:32:15 -0700
|
||||
Subject: [PATCH] t/run/locale.t: Rmv LANGUAGE from environment
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This could cause interference with our tests on some platforms that have
|
||||
this environment variable.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/run/locale.t | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/run/locale.t b/t/run/locale.t
|
||||
index 8a04d1aea6..0f2a2ba457 100644
|
||||
--- a/t/run/locale.t
|
||||
+++ b/t/run/locale.t
|
||||
@@ -38,7 +38,7 @@ if (defined $ARGV[0] && $ARGV[0] ne "") {
|
||||
}
|
||||
|
||||
# reset the locale environment
|
||||
-delete local @ENV{'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};
|
||||
+delete local @ENV{'LANGUAGE', 'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};
|
||||
|
||||
# If user wants this to happen, they set the environment variable AND use
|
||||
# 'debug'
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,74 +0,0 @@
|
||||
From 5f41fa466a67b5535aa8bcf4b814f242545ac7bd Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 27 Feb 2021 11:43:41 -0700
|
||||
Subject: [PATCH] regcomp.c: Remove memory leak
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This fixes GH #18604. There was a path through the code where a
|
||||
particular SV did not get its reference count decremented.
|
||||
|
||||
I did an audit of the function and came up with several other
|
||||
possiblities that are included in this commit.
|
||||
|
||||
Further, there would be leaks for some instances of finding syntax
|
||||
errors in the input pattern, or when warnings are fatalized. Those
|
||||
would require mortalizing some SVs, but that is beyond the scope of this
|
||||
commit.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 7 +++++++
|
||||
t/op/svleak.t | 3 ++-
|
||||
2 files changed, 9 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index e44c7a37e5..f5e5f581dc 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -18765,6 +18765,12 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
|
||||
RExC_end = save_end;
|
||||
RExC_in_multi_char_class = 0;
|
||||
SvREFCNT_dec_NN(multi_char_matches);
|
||||
+ SvREFCNT_dec(properties);
|
||||
+ SvREFCNT_dec(cp_list);
|
||||
+ SvREFCNT_dec(simple_posixes);
|
||||
+ SvREFCNT_dec(posixes);
|
||||
+ SvREFCNT_dec(nposixes);
|
||||
+ SvREFCNT_dec(cp_foldable_list);
|
||||
return ret;
|
||||
}
|
||||
|
||||
@@ -20122,6 +20128,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
|
||||
RExC_parse - orig_parse);;
|
||||
SvREFCNT_dec(cp_list);;
|
||||
SvREFCNT_dec(only_utf8_locale_list);
|
||||
+ SvREFCNT_dec(upper_latin1_only_utf8_matches);
|
||||
return ret;
|
||||
}
|
||||
|
||||
diff --git a/t/op/svleak.t b/t/op/svleak.t
|
||||
index 6acc298c3d..3df4838be8 100644
|
||||
--- a/t/op/svleak.t
|
||||
+++ b/t/op/svleak.t
|
||||
@@ -15,7 +15,7 @@ BEGIN {
|
||||
|
||||
use Config;
|
||||
|
||||
-plan tests => 150;
|
||||
+plan tests => 151;
|
||||
|
||||
# run some code N times. If the number of SVs at the end of loop N is
|
||||
# greater than (N-1)*delta at the end of loop 1, we've got a leak
|
||||
@@ -278,6 +278,7 @@ eleak(2,0,'/[[:ascii:]]/');
|
||||
eleak(2,0,'/[[.zog.]]/');
|
||||
eleak(2,0,'/[.zog.]/');
|
||||
eleak(2,0,'/|\W/', '/|\W/ [perl #123198]');
|
||||
+eleak(2,0,'/a\sb/', '/a\sb/ [GH #18604]');
|
||||
eleak(2,0,'no warnings; /(?[])/');
|
||||
eleak(2,0,'no warnings; /(?[[a]+[b]])/');
|
||||
eleak(2,0,'no warnings; /(?[[a]-[b]])/');
|
||||
--
|
||||
2.26.2
|
||||
|
||||
@ -1,62 +0,0 @@
|
||||
From 4e82c85b1c9c9b30253b8624470da6f20a6c0604 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 15 Mar 2021 21:01:47 -0600
|
||||
Subject: [PATCH] Fix broken left shift of IV_MIN under 'use integer'
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This fixes GH 18639
|
||||
|
||||
When I wrote this code, I conflated casting and complementing.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp.c | 3 ---
|
||||
t/op/bop.t | 9 ++++++++-
|
||||
2 files changed, 8 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index d365afea4c..baf0777a47 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -2007,9 +2007,6 @@ static IV S_iv_shift(IV iv, int shift, bool left)
|
||||
* 18446744073709551552
|
||||
* */
|
||||
if (left) {
|
||||
- if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
|
||||
- return 0;
|
||||
- }
|
||||
return (IV) (((UV) iv) << shift);
|
||||
}
|
||||
|
||||
diff --git a/t/op/bop.t b/t/op/bop.t
|
||||
index 07f057d0a9..31b6531a03 100644
|
||||
--- a/t/op/bop.t
|
||||
+++ b/t/op/bop.t
|
||||
@@ -18,7 +18,7 @@ BEGIN {
|
||||
# If you find tests are failing, please try adding names to tests to track
|
||||
# down where the failure is, and supply your new names as a patch.
|
||||
# (Just-in-time test naming)
|
||||
-plan tests => 502;
|
||||
+plan tests => 503;
|
||||
|
||||
# numerics
|
||||
ok ((0xdead & 0xbeef) == 0x9ead);
|
||||
@@ -33,6 +33,13 @@ ok ((33023 >> 7) == 257);
|
||||
# signed vs. unsigned
|
||||
ok ((~0 > 0 && do { use integer; ~0 } == -1));
|
||||
|
||||
+{ # GH #18639
|
||||
+ my $iv_min = -(~0 >> 1) - 1;
|
||||
+ my $shifted;
|
||||
+ { use integer; $shifted = $iv_min << 0 };
|
||||
+ is($shifted, $iv_min, "IV_MIN << 0 yields IV_MIN under 'use integer'");
|
||||
+}
|
||||
+
|
||||
my $bits = 0;
|
||||
for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
|
||||
my $cusp = 1 << ($bits - 1);
|
||||
--
|
||||
2.26.3
|
||||
|
||||
@ -1,39 +0,0 @@
|
||||
From 6d9d949fb4962e32636aee48a948081d8936d318 Mon Sep 17 00:00:00 2001
|
||||
From: Jitka Plesnikova <jplesnik@redhat.com>
|
||||
Date: Wed, 11 Jan 2023 09:12:18 +0100
|
||||
Subject: [PATCH] Add definition of OPTIMIZE to .ph files
|
||||
|
||||
The fortify.h header includes a test to ensure that -O is used when
|
||||
compiling with _FORTIFY_SOURCE, and the header looks for OPTIMIZE, which
|
||||
is set by the compiler whenever -O is used. Perl translates this test
|
||||
to the .ph file, but nothing ever sets OPTIMIZE. This causes a warning
|
||||
for anything that uses features.ph.
|
||||
|
||||
_FORTIFY_SOURCE is defined in /usr/lib64/perl5/_h2ph_pre.ph which is
|
||||
generated by h2ph. It uses value of @Config{'ccsymbols', 'cppsymbols',
|
||||
'cppccsymbols'} which does not contain definition for OPTIMIZE.
|
||||
|
||||
The patch updated h2ph to add OPTIMIZE if -O is used.
|
||||
---
|
||||
utils/h2ph.PL | 5 +++++
|
||||
1 file changed, 5 insertions(+)
|
||||
|
||||
diff --git a/utils/h2ph.PL b/utils/h2ph.PL
|
||||
index afa53c2..3950d11 100644
|
||||
--- a/utils/h2ph.PL
|
||||
+++ b/utils/h2ph.PL
|
||||
@@ -865,6 +865,11 @@ sub _extract_cc_defines
|
||||
my $allsymbols = join " ",
|
||||
@Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
|
||||
|
||||
+ # If optimizing -O2 is used, add the definition
|
||||
+ if ($Config{'ccflags'} =~ /(?:\s+|^)-O([\d]+)(?:\s+|$)/) {
|
||||
+ $allsymbols .= " __OPTIMIZE__=$1";
|
||||
+ }
|
||||
+
|
||||
# Split compiler pre-definitions into 'key=value' pairs:
|
||||
while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
|
||||
$define{$1} = $2;
|
||||
--
|
||||
2.39.0
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in new issue