rpms
/
perl
2
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

5.32.0 bump

This commit is contained in:
Jitka Plesnikova 2020-06-22 11:32:52 +02:00
parent 70b9a5a3e1
commit 2b10142afc
61 changed files with 418 additions and 5092 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -34,3 +34,4 @@ perl-5.12.1.tar.gz
/perl-5.30.1.tar.xz
/perl-5.30.2.tar.xz
/perl-5.30.3.tar.xz
/perl-5.32.0.tar.xz

669
gendep.macros
View File

File diff suppressed because it is too large Load Diff

75
perl-5.30.0-Remove-undefined-behavior-from-IV-shifting.patch
View File

@ -1,75 +0,0 @@
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

191
perl-5.30.0-perl-134221-support-append-mode-for-open-.-undef.patch
View File

@ -1,191 +0,0 @@
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

102
perl-5.30.0-perl-134266-make-sure-is-writable-when-we-write-to-i.patch
View File

@ -1,102 +0,0 @@
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

42
perl-5.30.0-pp.c-Add-two-UNLIKELY-s.patch
View File

@ -1,42 +0,0 @@
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

47
perl-5.30.1-handle-s-being-updated-without-len-being-updated.patch
View File

@ -1,47 +0,0 @@
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

116
perl-5.30.1-perl-125557-correctly-handle-overload-for-bin-oct-fl.patch
View File

@ -1,116 +0,0 @@
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

272
perl-5.30.2-Loading-IO-is-now-threadsafe-avoiding-the-core-bug-r.patch
View File

@ -1,272 +0,0 @@
From 1c8a3be06814f8b86459ad53b2f903fd50c4c4d8 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Mon, 4 Nov 2019 16:58:03 +0100
Subject: [PATCH] Loading IO is now threadsafe, avoiding the core bug reported
as GH #14816.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Re-implement getline() and getlines() as XS code.
The underlying problem that we're trying to solve here is making
getline() and getlines() in IO::Handle respect the open pragma.
That bug was first addressed in Sept 2011 by commit 986a805c4b258067:
Make IO::Handle::getline(s) respect the open pragma
However, that fix introduced a more subtle bug, hence this reworking.
Including the entirety of the rest of that commit message because it
explains both the bug the previous approach:
See <https://rt.cpan.org/Ticket/Display.html?id=66474>. Also, this
came up in <https://rt.perl.org/rt3/Ticket/Display.html?id=92728>.
The <> operator, when reading from the magic ARGV handle, automatic-
ally opens the next file. Layers set by the lexical open pragma are
applied, if they are in scope at the point where <> is used.
This works almost all the time, because the common convention is:
use open ":utf8";
while(<>) {
...
}
IO::Handle’s getline and getlines methods are Perl subroutines
that call <> themselves. But that happens within the scope of
IO/Handle.pm, so the caller’s I/O layer settings are ignored. That
means that these two expressions are not equivalent within in a
‘use open’ scope:
<>
*ARGV->getline
The latter will open the next file with no layers applied.
This commit solves that by putting PL_check hooks in place in
IO::Handle before compiling the getline and getlines subroutines.
Those hooks cause every state op (nextstate, or dbstate under the
debugger) to have a custom pp function that saves the previous value
of PL_curcop, calls the default pp function, and then restores
PL_curcop.
That means that getline and getlines run with the caller’s compile-
time hints. Another way to see it is that getline and getlines’s own
lexical hints are never activated.
(A state op carries all the lexical pragmata. Every statement
has one. When any op executes, it’s ‘pp’ function is called.
pp_nextstate and pp_dbstate both set PL_curcop to the op itself. Any
code that checks hints looks at PL_curcop, which contains the current
run-time hints.)
The problem with this approach is that the (current) design and implementation
of PL_check hooks is actually not threadsafe. There's one array (as a global),
which is used by all interpreters in the process. But as the code added to
IO.xs demonstrates, realistically it needs to be possible to change the hook
just for this interpreter.
GH #14816 has a fix for that bug for blead. However, it will be tricky (to
impossible) to backport to earlier perl versions.
Hence it's also worthwhile to change IO.xs to use a different approach to
solve the original bug. As described above, the bug is fixed by having the
readline OP (that implements getline() and getlines()) see the caller's
lexical state, not their "own". Unlike Perl subroutines, XS subroutines don't
have any lexical hints of their own. getline() and getlines() are very
simple, mostly parameter checking, ending with a one line that maps to
a single core OP, whose values are directly returned.
Hence "all" we need to do re-implement the Perl code as XS. This might look
easy, but turns out to be trickier than expected. There isn't any API to be
called for the OP in question, pp_readline(). The body of the OP inspects
interpreter state, it directly calls pp_rv2gv() which also inspects state,
and then it tail calls Perl_do_readline(), which inspects state.
The easiest approach seems to be to set up enough state, and then call
pp_readline() directly. This leaves us very tightly coupled to the
internals, but so do all other approaches to try to tackle this bug.
The current implementation of PL_check (and possibly other arrays) still
needs to be addressed.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
META.json | 1 +
META.yml | 1 +
dist/IO/IO.xs | 93 +++++++++++++++++++++++++++-------------
dist/IO/lib/IO/Handle.pm | 20 ---------
4 files changed, 66 insertions(+), 49 deletions(-)
diff --git a/META.json b/META.json
index e023606..53c1e79 100644
--- a/META.json
+++ b/META.json
@@ -86,6 +86,7 @@
"dist/IO/t/io_dup.t",
"dist/IO/t/io_file.t",
"dist/IO/t/io_file_export.t",
+ "dist/IO/t/io_getline.t",
"dist/IO/t/io_leak.t",
"dist/IO/t/io_linenum.t",
"dist/IO/t/io_multihomed.t",
diff --git a/META.yml b/META.yml
index 85fb097..f71108e 100644
--- a/META.yml
+++ b/META.yml
@@ -83,6 +83,7 @@ no_index:
- dist/IO/t/io_dup.t
- dist/IO/t/io_file.t
- dist/IO/t/io_file_export.t
+ - dist/IO/t/io_getline.t
- dist/IO/t/io_leak.t
- dist/IO/t/io_linenum.t
- dist/IO/t/io_multihomed.t
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 8e857f8..68b7352 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -185,26 +185,6 @@ io_blocking(pTHX_ InputStream f, int block)
#endif
}
-static OP *
-io_pp_nextstate(pTHX)
-{
- dVAR;
- COP *old_curcop = PL_curcop;
- OP *next = PL_ppaddr[PL_op->op_type](aTHX);
- PL_curcop = old_curcop;
- return next;
-}
-
-static OP *
-io_ck_lineseq(pTHX_ OP *o)
-{
- OP *kid = cBINOPo->op_first;
- for (; kid; kid = OpSIBLING(kid))
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
- kid->op_ppaddr = io_pp_nextstate;
- return o;
-}
-
MODULE = IO PACKAGE = IO::Seekable PREFIX = f
@@ -558,16 +538,71 @@ fsync(arg)
OUTPUT:
RETVAL
-SV *
-_create_getline_subs(const char *code)
- CODE:
- OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
- PL_check[OP_LINESEQ] = io_ck_lineseq;
- RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
- PL_check[OP_LINESEQ] = io_old_ck_lineseq;
- OUTPUT:
- RETVAL
+# To make these two work correctly with the open pragma, the readline op
+# needs to pick up the lexical hints at the method's callsite. This doesn't
+# work in pure Perl, because the hints are read from the most recent nextstate,
+# and the nextstate of the Perl subroutines show *here* hold the lexical state
+# for the IO package.
+#
+# There's no clean way to implement this - this approach, while complex, seems
+# to be the most robust, and avoids manipulating external state (ie op checkers)
+#
+# sub getline {
+# @_ == 1 or croak 'usage: $io->getline()';
+# my $this = shift;
+# return scalar <$this>;
+# }
+#
+# sub getlines {
+# @_ == 1 or croak 'usage: $io->getlines()';
+# wantarray or
+# croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
+# my $this = shift;
+# return <$this>;
+# }
+
+# If this is deprecated, should it warn, and should it be removed at some point?
+# *gets = \&getline; # deprecated
+void
+getlines(...)
+ALIAS:
+ IO::Handle::getline = 1
+ IO::Handle::gets = 2
+INIT:
+ UNOP myop;
+ SV *io;
+ OP *was = PL_op;
+PPCODE:
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: $io->%s()", ix ? "getline" : "getlines");
+ if (!ix && GIMME_V != G_ARRAY)
+ Perl_croak(aTHX_ "Can't call $io->getlines in a scalar context, use $io->getline");
+ Zero(&myop, 1, UNOP);
+ myop.op_flags = (ix ? OPf_WANT_SCALAR : OPf_WANT_LIST ) | OPf_STACKED;
+ myop.op_ppaddr = PL_ppaddr[OP_READLINE];
+ myop.op_type = OP_READLINE;
+ /* I don't know if we need this, but it's correct as far as the control flow
+ goes. However, if we *do* need it, do we need to set anything else up? */
+ myop.op_next = PL_op->op_next;
+ /* Sigh, because pp_readline calls pp_rv2gv, and *it* has this wonderful
+ state check for PL_op->op_type == OP_READLINE */
+ PL_op = (OP *) &myop;
+ io = ST(0);
+ /* Our target (which we need to provide, as we don't have a pad entry.
+ I think that this is only needed for G_SCALAR - maybe we can get away
+ with NULL for list context? */
+ PUSHs(sv_newmortal());
+ XPUSHs(io);
+ PUTBACK;
+ /* And effectively we get away with tail calling pp_readline, as it stacks
+ exactly the return value(s) we need to return. */
+ PL_ppaddr[OP_READLINE](aTHX);
+ PL_op = was;
+ /* And we don't want to reach the line
+ PL_stack_sp = sp;
+ that xsubpp adds after our body becase PL_stack_sp is correct, not sp */
+ return;
MODULE = IO PACKAGE = IO::Socket
diff --git a/dist/IO/lib/IO/Handle.pm b/dist/IO/lib/IO/Handle.pm
index a257024..d48a4d1 100644
--- a/dist/IO/lib/IO/Handle.pm
+++ b/dist/IO/lib/IO/Handle.pm
@@ -431,26 +431,6 @@ sub say {
print $this @_;
}
-# Special XS wrapper to make them inherit lexical hints from the caller.
-_create_getline_subs( <<'END' ) or die $@;
-sub getline {
- @_ == 1 or croak 'usage: $io->getline()';
- my $this = shift;
- return scalar <$this>;
-}
-
-sub getlines {
- @_ == 1 or croak 'usage: $io->getlines()';
- wantarray or
- croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
- my $this = shift;
- return <$this>;
-}
-1; # return true for error checking
-END
-
-*gets = \&getline; # deprecated
-
sub truncate {
@_ == 2 or croak 'usage: $io->truncate(LEN)';
truncate($_[0], $_[1]);
--
2.21.1

114
perl-5.30.2-toke.c-fix-Multidimensional-array-heuristic-to-ignor.patch
View File

@ -1,114 +0,0 @@
From bb3b785585fde69384a8581957368ca235d0016e Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Fri, 31 Jan 2020 15:02:46 +0100
Subject: [PATCH] toke.c: fix Multidimensional array heuristic to ignore
function calls
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Fix issue #16535 - $t[index $x, $y] should not throw Multidimensional
array warnings.
The heuristic for detecting lists in array subscripts is implemented
in toke.c, which means it is not particularly reliable. There are
lots of ways that code might return a list in an array subscript.
So for instance $t[do{ $x, $y }] should throw a warning but doesn't.
On the other hand, we can make this warning less likely to happen
by being a touch more careful about how we parse the inside of the
square brackets so we do not throw an exception from $t[index $x,$y].
Really this should be moved to the parser so we do not need to rely
on fallable heuristics, and also into the runtime so that if we have
$t[f()]
and f() returns a list we can also warn there. But for now this
improves things somewhat.
Petr Písař: Ported from 41eecd54c335a0342b04dbea635695db80579946 to
5.30.2.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/lib/warnings/toke | 13 +++++++++++++
toke.c | 39 +++++++++++++++++++++++++++++++++------
2 files changed, 46 insertions(+), 6 deletions(-)
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
index 83641e5..e36e116 100644
--- a/t/lib/warnings/toke
+++ b/t/lib/warnings/toke
@@ -1691,3 +1691,16 @@ EXPECT
OPTION regex
Malformed UTF-8 character: .*non-continuation.*
The eval did not crash the program
+########
+# NAME Check that our Multidimensional array heuristic doesn't false positive on function calls
+use warnings;
+my $str= "rst";
+my $substr= "s";
+my @array="A".."C";
+# force a numeric warning, but we should NOT see a Multidimensional warning here
+my $trigger_num_warn= $array[index $str,$substr] + 1;
+# this should trigger a Multidimensional warning
+my $should_warn_multi= $array[0x1,0x2];
+EXPECT
+Multidimensional syntax $array[0x1,0x2] not supported at - line 8.
+Argument "B" isn't numeric in addition (+) at - line 6.
diff --git a/toke.c b/toke.c
index 10849f8..ede6f63 100644
--- a/toke.c
+++ b/toke.c
@@ -6784,13 +6784,40 @@ Perl_yylex(pTHX)
if (ckWARN(WARN_SYNTAX)) {
char *t = s+1;
- while ( isSPACE(*t)
- || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)
- || *t == '$')
- {
- t += UTF ? UTF8SKIP(t) : 1;
+ while ( t < PL_bufend ) {
+ if (isSPACE(*t)) {
+ do { t += UTF ? UTF8SKIP(t) : 1; } while (t < PL_bufend && isSPACE(*t));
+ /* consumed one or more space chars */
+ } else if (*t == '$' || *t == '@') {
+ /* could be more than one '$' like $$ref or @$ref */
+ do { t++; } while (t < PL_bufend && *t == '$');
+
+ /* could be an abigail style identifier like $ foo */
+ while (t < PL_bufend && *t == ' ') t++;
+
+ /* strip off the name of the var */
+ while (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
+ t += UTF ? UTF8SKIP(t) : 1;
+ /* consumed a varname */
+ } else if (isDIGIT(*t)) {
+ /* deal with hex constants like 0x11 */
+ if (t[0] == '0' && t[1] == 'x') {
+ t += 2;
+ while (t < PL_bufend && isXDIGIT(*t)) t++;
+ } else {
+ /* deal with decimal/octal constants like 1 and 0123 */
+ do { t++; } while (isDIGIT(*t));
+ if (t<PL_bufend && *t == '.') {
+ do { t++; } while (isDIGIT(*t));
+ }
+ }
+ /* consumed a number */
+ } else {
+ /* not a var nor a space nor a number */
+ break;
+ }
}
- if (*t++ == ',') {
+ if (t < PL_bufend && *t++ == ',') {
PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
while (t < PL_bufend && *t != ']')
t++;
--
2.21.1

85
perl-5.31.0-CAPTURE_ALL-was-intended-to-be-an-alias-for-make-it-.patch
View File

@ -1,85 +0,0 @@
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

181
perl-5.31.0-Create-fcn-for-lossless-conversion-of-NV-to-IV.patch
View File

@ -1,181 +0,0 @@
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

87
perl-5.31.0-Don-t-use-PL_check-op_type-to-check-for-filetets-ops.patch
View File

@ -1,87 +0,0 @@
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

49
perl-5.31.0-S_scan_const-Properly-test-if-need-to-grow.patch
View File

@ -1,49 +0,0 @@
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

70
perl-5.31.0-perl-122112-a-simpler-fix-for-pclose-aborted-by-a-si.patch
View File

@ -1,70 +0,0 @@
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

28
perl-5.31.0-perl-122112-remove-some-interfering-debug-output.patch
View File

@ -1,28 +0,0 @@
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

54
perl-5.31.0-perl-122112-test-for-signal-handler-death-in-pclose.patch
View File

@ -1,54 +0,0 @@
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

76
perl-5.31.0-perl-133913-limit-numeric-format-results-to-INT_MAX.patch
View File

@ -1,76 +0,0 @@
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,6 +1153,14 @@ 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");
+}
+
{
# gh #17221
my ($off1, $off2);
--
2.20.1

78
perl-5.31.0-perl-133936-document-differences-between-IO-Socket-a.patch
View File

@ -1,78 +0,0 @@
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

107
perl-5.31.0-perl-133936-ensure-TO-is-honoured-for-UDP-sock-send.patch
View File

@ -1,107 +0,0 @@
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

93
perl-5.31.0-perl-133936-make-send-a-bit-saner.patch
View File

@ -1,93 +0,0 @@
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

28
perl-5.31.0-perl-134008-an-alternative-test.patch
View File

@ -1,28 +0,0 @@
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

84
perl-5.31.0-perl-134072-allow-foo-bar-to-work-in-main.patch
View File

@ -1,84 +0,0 @@
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

59
perl-5.31.0-perl-134193-allow-CAPTURE-to-work-when-CAPTURE-comes.patch
View File

@ -1,59 +0,0 @@
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

36
perl-5.31.0-perl-134193-make-the-varname-match-the-names.patch
View File

@ -1,36 +0,0 @@
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

65
perl-5.31.1-avoid-SEGV-with-uninit-warning-with-multideref.patch
View File

@ -1,65 +0,0 @@
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

39
perl-5.31.1-perl-122112-make-sure-SIGPIPE-is-delivered-if-we-tes.patch
View File

@ -1,39 +0,0 @@
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

128
perl-5.31.1-perl-134221-support-O_APPEND-for-open-.-undef-on-VMS.patch
View File

@ -1,128 +0,0 @@
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

76
perl-5.31.1-perl-134221-support-append-mode-temp-files-on-Win32-.patch
View File

@ -1,76 +0,0 @@
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

38
perl-5.31.2-PerlIO-Via-check-arg-is-non-NULL-before-using-it.patch
View File

@ -1,38 +0,0 @@
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

30
perl-5.31.2-Run-tests-in-ext-File-Find-t-in-series.patch
View File

@ -1,30 +0,0 @@
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

37
perl-5.31.2-include-a-trailing-0-in-SVs-holding-trie-info.patch
View File

@ -1,37 +0,0 @@
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

48
perl-5.31.2-locale.c-Stop-Coverity-warning.patch
View File

@ -1,48 +0,0 @@
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

54
perl-5.31.2-perl-134291-propagate-non-PVs-in-in-bare-die.patch
View File

@ -1,54 +0,0 @@
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

118
perl-5.31.2-perlapi-5.30-promise-not-met-change-to-5.32.patch
View File

@ -1,118 +0,0 @@
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

36
perl-5.31.2-regcomp.c-Don-t-read-off-the-end-of-buffer.patch
View File

@ -1,36 +0,0 @@
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

30
perl-5.31.3-Configure-Include-stdlib.h-in-futimes-check.patch
View File

@ -1,30 +0,0 @@
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

28
perl-5.31.3-Florian-Weimer-is-now-a-perl-author.patch
View File

@ -1,28 +0,0 @@
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

31
perl-5.31.3-Supply-missing-right-brace-in-regex-example.patch
View File

@ -1,31 +0,0 @@
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

57
perl-5.31.3-perl-134230-don-t-interpret-0x-0b-when-numifying-str.patch
View File

@ -1,57 +0,0 @@
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

31
perl-5.31.3-regcomp.c-Fix-wrong-limit-test.patch
View File

@ -1,31 +0,0 @@
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

237
perl-5.31.4-Handle-undefined-values-correctly.patch
View File

@ -1,237 +0,0 @@
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

32
perl-5.31.5-Be-clearer-about-taint-s-effect-on-INC.patch
View File

@ -1,32 +0,0 @@
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

45
perl-5.31.5-Fix-taint-mode-INC-documentation.patch
View File

@ -1,45 +0,0 @@
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

77
perl-5.31.5-Tie-StdHandle-BINMODE-handle-layer-argument.patch
View File

@ -1,77 +0,0 @@
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

48
perl-5.31.5-prevent-a-race-between-name-based-stat-and-an-open-m.patch
View File

@ -1,48 +0,0 @@
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

78
perl-5.31.5-toke.c-Fix-bug-tr-upgrading-to-UTF-8-in-middle.patch
View File

@ -1,78 +0,0 @@
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

48
perl-5.31.5-toke.c-comment-changes.patch
View File

@ -1,48 +0,0 @@
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

105
perl-5.31.6-PATCH-GH-17081-Workaround-glibc-bug-with-LC_MESSAGES.patch
View File

@ -1,105 +0,0 @@
From 45cef8fb80248a6318f90219499ff2dbd953ae8c Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Wed, 27 Nov 2019 19:15:11 -0700
Subject: [PATCH] PATCH: GH #17081: Workaround glibc bug with LC_MESSAGES
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Please see the ticket for a full explanation. This bug has been
submitted to glibc, without any real action forthcoming so far.
This invalidates the message cache each time the locale of LC_MESSAGES
is changed, as glibc should be doing this when uselocale changes that,
but glibc fails to do so.
This patch is an extension to the one submitted by Niko Tyni++.
I don't know how to test it, since a test would rely on several
different locales in different languages being available, and that
depends on what's installed on the platform. I suppose that one could
go through the available locales, and try to find three with different
wording for the same message. Doing so however would trigger the bug,
and at the end, if we didn't get three that differed, we wouldn't know
we wouldn't know if it is because of the bug, or that they just didn't
exist on the system.
However, below is a perl program that demonstrated the patch worked.
You could adjust it to the available locales. The buggy code shows the
same text for all locales. The fixed shows three different languages.
use strict;
use Locale::gettext;
use POSIX;
$ENV{LANG} = 'C.UTF-8';
for my $lang (qw(fi_FI fr_FR en_US)) {
$ENV{LANGUAGE} = $lang;
setlocale(LC_MESSAGES, '');
my $d = Locale::gettext->domain("bash");
print $d->get('syntax error'), "\n";
}
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
locale.c | 21 +++++++++++++++++++++
1 file changed, 21 insertions(+)
diff --git a/locale.c b/locale.c
index cdf125cee5..7ce7b3ed4c 100644
--- a/locale.c
+++ b/locale.c
@@ -402,6 +402,7 @@ S_category_name(const int category)
* known at compile time; "do_setlocale_r", not known until run time */
# define do_setlocale_c(cat, locale) my_setlocale(cat, locale)
# define do_setlocale_r(cat, locale) my_setlocale(cat, locale)
+# define FIX_GLIBC_LC_MESSAGES_BUG(i)
#else /* Below uses POSIX 2008 */
@@ -415,6 +416,22 @@ S_category_name(const int category)
emulate_setlocale(cat, locale, cat ## _INDEX, TRUE)
# define do_setlocale_r(cat, locale) emulate_setlocale(cat, locale, 0, FALSE)
+# if ! defined(__GLIBC__) || ! defined(USE_LOCALE_MESSAGES)
+
+# define FIX_GLIBC_LC_MESSAGES_BUG(i)
+
+# else /* Invalidate glibc cache of loaded translations, see [perl #134264] */
+
+# include <libintl.h>
+# define FIX_GLIBC_LC_MESSAGES_BUG(i) \
+ STMT_START { \
+ if ((i) == LC_MESSAGES_INDEX) { \
+ textdomain(textdomain(NULL)); \
+ } \
+ } STMT_END
+
+# endif
+
/* A third array, parallel to the ones above to map from category to its
* equivalent mask */
const int category_masks[] = {
@@ -1158,6 +1175,8 @@ S_emulate_setlocale(const int category,
Safefree(PL_curlocales[i]);
PL_curlocales[i] = savepv(locale);
}
+
+ FIX_GLIBC_LC_MESSAGES_BUG(LC_MESSAGES_INDEX);
}
else {
@@ -1172,6 +1191,8 @@ S_emulate_setlocale(const int category,
/* Then update the category's record */
Safefree(PL_curlocales[index]);
PL_curlocales[index] = savepv(locale);
+
+ FIX_GLIBC_LC_MESSAGES_BUG(index);
}
# endif
--
2.21.1

200
perl-5.31.7-Add-tests-for-IO-Handle-getline-and-getlines.patch
View File

@ -1,200 +0,0 @@
From 7a992ccc8be4ce4c27268e1980edb4701f9948d9 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 3 Nov 2019 11:06:59 +0100
Subject: [PATCH] Add tests for IO::Handle getline() and getlines().
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Extend the tests for <> and the open pragma to verify that the behaviour
changes with/without the open pragma.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
dist/IO/README | 1 -
dist/IO/t/io_getline.t | 117 ++++++++++++++++++++++++++++++++++++++++
dist/IO/t/io_utf8argv.t | 13 +++--
4 files changed, 128 insertions(+), 4 deletions(-)
create mode 100644 dist/IO/t/io_getline.t
diff --git a/MANIFEST b/MANIFEST
index cb5c0bb1b4..85d3283231 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3676,6 +3676,7 @@ dist/IO/t/io_dir.t See if directory-related methods from IO work
dist/IO/t/io_dup.t See if dup()-related methods from IO work
dist/IO/t/io_file.t See if binmode()-related methods on IO::File work
dist/IO/t/io_file_export.t Test IO::File exports
+dist/IO/t/io_getline.t Test getline and getlines
dist/IO/t/io_leak.t See if IO leaks SVs (only run in core)
dist/IO/t/io_linenum.t See if I/O line numbers are tracked correctly
dist/IO/t/io_multihomed.t See if INET sockets work with multi-homed hosts
diff --git a/dist/IO/README b/dist/IO/README
index 3783750c89..5457a632c2 100644
--- a/dist/IO/README
+++ b/dist/IO/README
@@ -24,4 +24,3 @@ To build, test and install this distribution type:
Share and Enjoy!
Graham Barr <gbarr@pobox.com>
-
diff --git a/dist/IO/t/io_getline.t b/dist/IO/t/io_getline.t
new file mode 100644
index 0000000000..22361e6b7e
--- /dev/null
+++ b/dist/IO/t/io_getline.t
@@ -0,0 +1,117 @@
+#!./perl -w
+use strict;
+
+use Test::More tests => 37;
+
+my $File = 'README';
+
+use IO::File;
+
+my $io = IO::File->new($File);
+isa_ok($io, 'IO::File', "Opening $File");
+
+my $line = $io->getline();
+like($line, qr/^This is the/, "Read first line");
+
+my ($list, $context) = $io->getline();
+is($list, "\n", "Read second line");
+is($context, undef, "Did not read third line with getline() in list context");
+
+$line = $io->getline();
+like($line, qr/^This distribution/, "Read third line");
+
+my @lines = $io->getlines();
+cmp_ok(@lines, '>', 3, "getlines reads lots of lines");
+like($lines[-2], qr/^Share and Enjoy!/, "Share and Enjoy!");
+
+$line = $io->getline();
+is($line, undef, "geline reads no more at EOF");
+
+@lines = $io->getlines();
+is(@lines, 0, "gelines reads no more at EOF");
+
+# And again
+$io = IO::File->new($File);
+isa_ok($io, 'IO::File', "Opening $File");
+
+$line = $io->getline();
+like($line, qr/^This is the/, "Read first line again");
+
+is(eval {
+ $line = $io->getline("Boom");
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^usage.*getline\(\) at .*\bio_getline\.t line /, 'getline usage');
+like($line, qr/^This is the/, '$line unchanged');
+
+is(eval {
+ ($list, $context) = $io->getlines("Boom");
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^usage.*getlines\(\) at .*\bio_getline\.t line /, 'getlines usage');
+is($list, "\n", '$list unchanged');
+
+is(eval {
+ $line = $io->getlines();
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^Can't call .*getlines in a scalar context.* at .*\bio_getline\.t line /,
+ 'getlines in scalar context croaks');
+like($line, qr/^This is the/, '$line unchanged');
+
+is(eval {
+ $io->getlines();
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^Can't call .*getlines in a scalar context.* at .*\bio_getline\.t line /,
+ 'getlines in void context croaks');
+like($line, qr/^This is the/, '$line unchanged');
+
+($list, $context) = $io->getlines();
+is($list, "\n", "Read second line");
+like($context, qr/^This distribution/, "Read third line");
+
+{
+ package TiedHandle;
+
+ sub TIEHANDLE {
+ return bless ["Tick", "tick", "tick"];
+ }
+
+ sub READLINE {
+ my $fh = shift;
+ die "Boom!"
+ unless @$fh;
+ return shift @$fh
+ unless wantarray;
+ return splice @$fh;
+ }
+}
+
+tie *FH, 'TiedHandle';
+
+is(*FH->getline(), "Tick", "tied handle read works");
+($list, $context) = *FH->getline();
+is($list, "tick", "tied handle read works in list context 0");
+is($context, undef, "tied handle read works in list context 1");
+is(*FH->getline(), "tick", "tied handle read works again");
+is(eval {
+ $line = *FH->getline();
+ 1;
+ }, undef, "eval on tied handle caught an exception");
+like($@, qr/^Boom!/,
+ 'getline on tied handle propagates exception');
+like($line, qr/^This is the/, '$line unchanged');
+
+tie *FH, 'TiedHandle';
+
+($list, $context) = *FH->getlines();
+is($list, "Tick", "tied handle read works in list context 2");
+is($context, "tick", "tied handle read works in list context 3");
+is(eval {
+ ($list, $context) = *FH->getlines();
+ 1;
+ }, undef, "eval on tied handle caught an exception again");
+like($@, qr/^Boom!/,
+ 'getlines on tied handle propagates exception');
+is($list, "Tick", '$line unchanged');
diff --git a/dist/IO/t/io_utf8argv.t b/dist/IO/t/io_utf8argv.t
index 89f726a7a7..adc95d999c 100644
--- a/dist/IO/t/io_utf8argv.t
+++ b/dist/IO/t/io_utf8argv.t
@@ -13,7 +13,7 @@ use utf8;
skip_all("EBCDIC platform; testing not core")
if $::IS_EBCDIC && ! $ENV{PERL_CORE};
-plan(tests => 2);
+plan(tests => 4);
my $bytes =
"\xce\x9c\xe1\xbd\xb7\xce\xb1\x20\xcf\x80\xe1\xbd\xb1\xcf\x80\xce".
@@ -31,10 +31,17 @@ print $fh $bytes;
close $fh or die "close: $!";
-use open ":std", ":utf8";
-
use IO::Handle;
+@ARGV = ('io_utf8argv') x 2;
+is *ARGV->getline, $bytes,
+ 'getline (no open pragma) when magically opening ARGV';
+
+is join('',*ARGV->getlines), $bytes,
+ 'getlines (no open pragma) when magically opening ARGV';
+
+use open ":std", ":utf8";
+
@ARGV = ('io_utf8argv') x 2;
is *ARGV->getline, "Μία πάπια, μὰ ποιὰ πάπια;\n",
'getline respects open pragma when magically opening ARGV';
--
2.21.1

60
perl-5.31.7-POSIX.pod-Update-setlocale-docs.patch
View File

@ -1,60 +0,0 @@
From 06283613f8e6e81053444fea0cfc441db9c776a9 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Fri, 20 Dec 2019 14:40:47 -0700
Subject: [PATCH] POSIX.pod: Update setlocale() docs
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This should have been updated in 5.28, but was overlooked.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/POSIX/lib/POSIX.pod | 24 +++++++++++++++---------
1 file changed, 15 insertions(+), 9 deletions(-)
diff --git a/ext/POSIX/lib/POSIX.pod b/ext/POSIX/lib/POSIX.pod
index cab1501dab..d0b7f5ade2 100644
--- a/ext/POSIX/lib/POSIX.pod
+++ b/ext/POSIX/lib/POSIX.pod
@@ -1451,14 +1451,18 @@ see L<perlfunc/eval>.
=item C<setlocale>
-WARNING! Do NOT use this function in a L<thread|threads>. The locale
-will change in all other threads at the same time, and should your
-thread get paused by the operating system, and another started, that
-thread will not have the locale it is expecting. On some platforms,
-there can be a race leading to segfaults if two threads call this
-function nearly simultaneously.
-
-Modifies and queries the program's underlying locale. Users of this
+WARNING! Prior to Perl 5.28 or on a system that does not support
+thread-safe locale operations, do NOT use this function in a
+L<thread|threads>. The locale will change in all other threads at the
+same time, and should your thread get paused by the operating system,
+and another started, that thread will not have the locale it is
+expecting. On some platforms, there can be a race leading to segfaults
+if two threads call this function nearly simultaneously. On unthreaded
+builds, or on Perl 5.28 and later on thread-safe systems, this warning
+does not apply.
+
+This function
+modifies and queries the program's underlying locale. Users of this
function should read L<perllocale>, whch provides a comprehensive
discussion of Perl locale handling, knowledge of which is necessary to
properly use this function. It contains
@@ -1466,7 +1470,9 @@ L<a section devoted to this function|perllocale/The setlocale function>.
The discussion here is merely a summary reference for C<setlocale()>.
Note that Perl itself is almost entirely unaffected by the locale
except within the scope of S<C<"use locale">>. (Exceptions are listed
-in L<perllocale/Not within the scope of "use locale">.)
+in L<perllocale/Not within the scope of "use locale">, and
+locale-dependent functions within the POSIX module ARE always affected
+by the current locale.)
The following examples assume
--
2.21.1

47
perl-5.31.7-Skip-the-new-open-pragma-tests-for-no-utf8-under-PER.patch
View File

@ -1,47 +0,0 @@
From 61e73f5d988b2ee25b2d90ea5570337398309e84 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 19 Jan 2020 21:56:02 +0100
Subject: [PATCH] Skip the new open pragma tests for no ":utf8" under
PERL_UNICODE.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
PERL_UNICODE can implement an implicit use open ":utf8", which defeats the
intent of what we're testing here.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
dist/IO/t/io_utf8argv.t | 15 ++++++++++-----
1 file changed, 10 insertions(+), 5 deletions(-)
diff --git a/dist/IO/t/io_utf8argv.t b/dist/IO/t/io_utf8argv.t
index adc95d999c..b6370709f1 100644
--- a/dist/IO/t/io_utf8argv.t
+++ b/dist/IO/t/io_utf8argv.t
@@ -33,12 +33,17 @@ close $fh or die "close: $!";
use IO::Handle;
-@ARGV = ('io_utf8argv') x 2;
-is *ARGV->getline, $bytes,
- 'getline (no open pragma) when magically opening ARGV';
+SKIP: {
+ skip("PERL_UNICODE set", 2)
+ if exists $ENV{PERL_UNICODE};
+
+ @ARGV = ('io_utf8argv') x 2;
+ is *ARGV->getline, $bytes,
+ 'getline (no open pragma) when magically opening ARGV';
-is join('',*ARGV->getlines), $bytes,
- 'getlines (no open pragma) when magically opening ARGV';
+ is join('',*ARGV->getlines), $bytes,
+ 'getlines (no open pragma) when magically opening ARGV';
+}
use open ":std", ":utf8";
--
2.21.1

86
perl-5.31.7-error-check-the-calls-to-sigaddset-in-POSIX-SigSet-n.patch
View File

@ -1,86 +0,0 @@
From 3a5c73f344d9d5d89b2881b2c3569cac3ca89ad9 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 25 Nov 2019 09:27:16 +1100
Subject: [PATCH] error check the calls to sigaddset in POSIX::SigSet->new
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Coverity complained that SvIV() could return negative numbers,
but doesn't complain about the similar call in the sigaddset()
method, which is error checked.
So error check sigaddset() and throw an error if it fails.
CID 244386.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/POSIX/POSIX.xs | 7 +++++--
ext/POSIX/lib/POSIX.pod | 3 +++
ext/POSIX/t/sigset.t | 19 +++++++++++++++++++
3 files changed, 27 insertions(+), 2 deletions(-)
diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index 42c4d0f4b5..03342c3ea4 100644
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -1844,8 +1844,11 @@ new(packname = "POSIX::SigSet", ...)
sizeof(sigset_t),
packname);
sigemptyset(s);
- for (i = 1; i < items; i++)
- sigaddset(s, SvIV(ST(i)));
+ for (i = 1; i < items; i++) {
+ IV sig = SvIV(ST(i));
+ if (sigaddset(s, sig) < 0)
+ croak("POSIX::Sigset->new: failed to add signal %" IVdf, sig);
+ }
XSRETURN(1);
}
diff --git a/ext/POSIX/lib/POSIX.pod b/ext/POSIX/lib/POSIX.pod
index 10e12e88db..923198477d 100644
--- a/ext/POSIX/lib/POSIX.pod
+++ b/ext/POSIX/lib/POSIX.pod
@@ -2267,6 +2267,9 @@ Create a set with C<SIGUSR1>.
$sigset = POSIX::SigSet->new( &POSIX::SIGUSR1 );
+Throws an error if any of the signals supplied cannot be added to the
+set.
+
=item C<addset>
Add a signal to a SigSet object.
diff --git a/ext/POSIX/t/sigset.t b/ext/POSIX/t/sigset.t
index e65e4076b4..807aa3a1fd 100644
--- a/ext/POSIX/t/sigset.t
+++ b/ext/POSIX/t/sigset.t
@@ -93,4 +93,23 @@ foreach ([$signo[0]],
expected_signals($sigset, "new(@$_)", @$_);
}
+SKIP:
+{
+ # CID 244386
+ # linux and freebsd do validate for positive and very large signal numbers
+ # darwin uses a macro that simply ignores large signals and shifts by
+ # a negative number for negative signals, always succeeding
+ #
+ # since the idea is to validate our code rather than the implementation
+ # of sigaddset, just test the platforms we know can fail
+ skip "Not all systems validate the signal number", 2
+ unless $^O =~ /^(linux|freebsd)$/;
+ my $badsig = -1;
+ note "badsig $badsig";
+ ok(!eval{ POSIX::SigSet->new($badsig); 1 },
+ "POSIX::SigSet->new should throw on large signal number");
+ like($@."", qr/POSIX::Sigset->new: failed to add signal $badsig/,
+ "check message");
+}
+
done_testing();
--
2.21.1

37
perl-5.31.8-only-install-ExtUtils-XSSymSet-man-page-on-VMS.patch
View File

@ -1,37 +0,0 @@
From a04fd069805e872c2784733b5dbb94c872ef73d9 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 20 Jan 2020 14:47:38 +1100
Subject: [PATCH] only install ExtUtils::XSSymSet man page on VMS
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This module is only installed on VMS, so there's not much point in
installing the man page.
An alternative would be to install the module on VMS, but it tries
to use configuration only set on VMS.
fixes #17424
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
Porting/pod_lib.pl | 2 ++
1 file changed, 2 insertions(+)
diff --git a/Porting/pod_lib.pl b/Porting/pod_lib.pl
index f2d854408e..1098074f32 100644
--- a/Porting/pod_lib.pl
+++ b/Porting/pod_lib.pl
@@ -330,6 +330,8 @@ sub pods_to_install {
# manpages not to be installed
my %do_not_install = map { ($_ => 1) }
qw(Pod::Functions XS::APItest XS::Typemap);
+ $do_not_install{"ExtUtils::XSSymSet"} = 1
+ unless $^O eq "VMS";
my (%done, %found);
--
2.21.1

29
perl-5.31.8-perlio.c-make-unix-close-method-call-underlaying-lay.patch
View File

@ -1,29 +0,0 @@
From d55a14617a40beb0dfda90ca2decc55918c0810c Mon Sep 17 00:00:00 2001
From: Leon Timmermans <fawaka@gmail.com>
Date: Sat, 25 Jan 2020 00:51:44 +0100
Subject: [PATCH] perlio.c: make :unix close method call underlaying layers as
well
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 | 1 +
1 file changed, 1 insertion(+)
diff --git a/perlio.c b/perlio.c
index e6e4312949..39481eeb10 100644
--- a/perlio.c
+++ b/perlio.c
@@ -2818,6 +2818,7 @@ PerlIOUnix_close(pTHX_ PerlIO *f)
const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
int code = 0;
if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
+ code = PerlIOBase_close(aTHX_ f);
if (PerlIOUnix_refcnt_dec(fd) > 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
return 0;
--
2.21.1

67
perl-5.31.8-perltie.pod-rework-example-code-so-EXTEND-is-a-no-op.patch
View File

@ -1,67 +0,0 @@
From 3eb35b099f783db0ec40f0ca9f20fd1666c54cdb Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Thu, 30 Jan 2020 09:36:37 +0100
Subject: [PATCH] perltie.pod: rework example code so EXTEND is a no-op
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Most tied array implementations can and should NO-OP the EXTEND
method, and the sample code should not conflate EXTEND with STORESIZE.
EXTEND is actually less usefully used by the core than it could be
as AvMAX() does not have an equivalent tied method. So we cannot
check if we need to extend for a tied array.
This is related to [rt.cpan.org #39196] / Issue #17496.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pod/perltie.pod | 18 +++++++++++++-----
1 file changed, 13 insertions(+), 5 deletions(-)
diff --git a/pod/perltie.pod b/pod/perltie.pod
index 2d433e8204..1bb220691b 100644
--- a/pod/perltie.pod
+++ b/pod/perltie.pod
@@ -301,7 +301,7 @@ spaces so we have a little more work to do here:
croak "length of $value is greater than $self->{ELEMSIZE}";
}
# fill in the blanks
- $self->EXTEND( $index ) if $index > $self->FETCHSIZE();
+ $self->STORESIZE( $index ) if $index > $self->FETCHSIZE();
# right justify to keep element size for smaller elements
$self->{ARRAY}->[$index] = sprintf "%$self->{ELEMSIZE}s", $value;
}
@@ -351,16 +351,24 @@ X<EXTEND>
Informative call that array is likely to grow to have I<count> entries.
Can be used to optimize allocation. This method need do nothing.
-In our example, we want to make sure there are no blank (C<undef>)
-entries, so C<EXTEND> will make use of C<STORESIZE> to fill elements
-as needed:
+In our example there is no reason to implement this method, so we leave
+it as a no-op. This method is only relevant to tied array implementations
+where there is the possibility of having the allocated size of the array
+be larger than is visible to a perl programmer inspecting the size of the
+array. Many tied array implementations will have no reason to implement it.
sub EXTEND {
my $self = shift;
my $count = shift;
- $self->STORESIZE( $count );
+ # nothing to see here, move along.
}
+B<NOTE:> It is generally an error to make this equivalent to STORESIZE.
+Perl may from time to time call EXTEND without wanting to actually change
+the array size directly. Any tied array should function correctly if this
+method is a no-op, even if perhaps they might not be as efficient as they
+would if this method was implemented.
+
=item EXISTS this, key
X<EXISTS>
--
2.21.1

142
perl-5.31.8-pp_sort.c-fix-fencepost-error-in-call-to-av_extend.patch
View File

@ -1,142 +0,0 @@
From 2b301921ff7682e54ab74ad30dbf2ce1c9fc24b1 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Fri, 31 Jan 2020 15:34:48 +0100
Subject: [PATCH] pp_sort.c: fix fencepost error in call to av_extend()
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
In [rt.cpan.org #39196] issue #17496 there is a report
that Tie::File produced spurious blank lines in the file
after
@tied= sort @tied;
it turns out that this is because Tie::File treats
EXTEND similarly to STORESIZE (which is arguably not
entirely correct, but also not that weird) coupled
with an off by one error in the calls to av_extend()
in pp_sort.
This patch fixes the fencepost error, adds some comments
to av_extend() to make it clear what it is doing, and
adds a test that EXTEND is called by this code with
correct argument.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
av.c | 18 ++++++++++++++++--
pp_sort.c | 5 +++--
t/op/sort.t | 23 +++++++++++++++++++++--
3 files changed, 40 insertions(+), 6 deletions(-)
diff --git a/av.c b/av.c
index 918844c376..27b2f12032 100644
--- a/av.c
+++ b/av.c
@@ -55,8 +55,13 @@ Perl_av_reify(pTHX_ AV *av)
/*
=for apidoc av_extend
-Pre-extend an array. The C<key> is the index to which the array should be
-extended.
+Pre-extend an array so that it is capable of storing values at indexes
+C<0..key>. Thus C<av_extend(av,99)> guarantees that the array can store 100
+elements, i.e. that C<av_store(av, 0, sv)> through C<av_store(av, 99, sv)>
+on a plain array will work without any further memory allocation.
+
+If the av argument is a tied array then will call the C<EXTEND> tied
+array method with an argument of C<(key+1)>.
=cut
*/
@@ -72,6 +77,15 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key)
mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
if (mg) {
SV *arg1 = sv_newmortal();
+ /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND.
+ *
+ * The C function takes an *index* (assumes 0 indexed arrays) and ensures
+ * that the array is at least as large as the index provided.
+ *
+ * The tied array method EXTEND takes a *count* and ensures that the array
+ * is at least that many elements large. Thus we have to +1 the key when
+ * we call the tied method.
+ */
sv_setiv(arg1, (IV)(key + 1));
Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
arg1);
diff --git a/pp_sort.c b/pp_sort.c
index 0c5efb0869..4f81aaab7e 100644
--- a/pp_sort.c
+++ b/pp_sort.c
@@ -1067,7 +1067,8 @@ PP(pp_sort)
for (i = 0; i < max; i++)
base[i] = newSVsv(base[i]);
av_clear(av);
- av_extend(av, max);
+ if (max)
+ av_extend(av, max-1);
for (i=0; i < max; i++) {
SV * const sv = base[i];
SV ** const didstore = av_store(av, i, sv);
@@ -1094,7 +1095,7 @@ PP(pp_sort)
}
av_clear(av);
if (max > 0) {
- av_extend(av, max);
+ av_extend(av, max-1);
Copy(base, AvARRAY(av), max, SV*);
}
AvFILLp(av) = max - 1;
diff --git a/t/op/sort.t b/t/op/sort.t
index d201f00afd..f2e139dff0 100644
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -7,7 +7,8 @@ BEGIN {
set_up_inc('../lib');
}
use warnings;
-plan(tests => 199);
+plan(tests => 203);
+use Tie::Array; # we need to test sorting tied arrays
# these shouldn't hang
{
@@ -433,7 +434,6 @@ cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other ar
@a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0];
is "$$r1-$$r2-@a", "c-c-c b a", "inplace sort with function of lexical";
- use Tie::Array;
my @t;
tie @t, 'Tie::StdArray';
@@ -494,6 +494,25 @@ cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other ar
is ("@a", "3 4 5", "RT #128340");
}
+{
+ @Tied_Array_EXTEND_Test::ISA= 'Tie::StdArray';
+ my $extend_count;
+ sub Tied_Array_EXTEND_Test::EXTEND {
+ $extend_count= $_[1];
+ return;
+ }
+ my @t;
+ tie @t, "Tied_Array_EXTEND_Test";
+ is($extend_count, undef, "test that EXTEND has not been called prior to initialization");
+ $t[0]=3;
+ $t[1]=1;
+ $t[2]=2;
+ is($extend_count, undef, "test that EXTEND has not been called during initialization");
+ @t= sort @t;
+ is($extend_count, 3, "test that EXTEND was called with an argument of 3 by pp_sort()");
+ is("@t","1 2 3","test that sorting the tied array worked even though EXTEND is a no-op");
+}
+
# Test optimisations of reversed sorts. As we now guarantee stability by
# default, # optimisations which do not provide this are bogus.
--
2.21.1

66
perl-5.31.9-B-Deparse-fixup-uninitialized-error-in-deparsing-wei.patch
View File

@ -1,66 +0,0 @@
From fbe6adf2e4213395a34c891a7568c6e3c7812645 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Thu, 6 Feb 2020 07:11:20 +0100
Subject: [PATCH] B::Deparse fixup uninitialized error in deparsing weird glob
statement
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This fixes issue #17537, and adds tests
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
lib/B/Deparse.pm | 2 +-
lib/B/Deparse.t | 15 +++++++++++++++
2 files changed, 16 insertions(+), 1 deletion(-)
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index ee126b1552..aa6e6de4e4 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -3393,7 +3393,7 @@ sub pp_glob {
my $kid = $op->first->sibling; # skip pushmark
my $keyword =
$op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
- my $text = $self->deparse($kid);
+ my $text = $self->deparse($kid, $cx);
return $cx >= 5 || $self->{'parens'}
? "$keyword($text)"
: "$keyword $text";
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index 07c915067e..e06ef6e966 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -20,6 +20,8 @@ my $deparse = B::Deparse->new();
isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object');
my %deparse;
+sub dummy_sub {42}
+
$/ = "\n####\n";
while (<DATA>) {
chomp;
@@ -679,6 +681,19 @@ readline $foo;
glob $foo;
glob $foo;
####
+# more <>
+no warnings;
+no strict;
+my $fh;
+if (dummy_sub < $fh > /bar/g) { 1 }
+>>>>
+no warnings;
+no strict;
+my $fh;
+if (dummy_sub(glob((' ' . $fh . ' ')) / 'bar' / 'g')) {
+ 1;
+}
+####
# readline
readline 'FH';
readline *$_;
--
2.21.1

2
perl-USE_MM_LD_RUN_PATH.patch
View File

@ -19,7 +19,7 @@ diff -up perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm.usem perl
@@ -317,7 +317,7 @@ sub full_setup {
PERM_DIR PERM_RW PERM_RWX MAGICXS
PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ PUREPERL_ONLY
- SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS
+ SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST USE_MM_LD_RUN_PATH VERSION VERSION_FROM XS
XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION

512
perl.spec
View File

File diff suppressed because it is too large Load Diff

2
sources
View File

@ -1 +1 @@
SHA512 (perl-5.30.3.tar.xz) = 0ea62cf17532ee99217a218c39aa530472857c7a1982494f3a01693683062b4cdebe383a79f7b64452c713337b554ed5e0fd6eda018ea29e83c3538a13c24f3c
SHA512 (perl-5.32.0.tar.xz) = 1540247415893bbd94dfeede7b4fba6052688dc0bf27ced817f448246fcdc6e9a6486abc34577dec5b00bf02ed607b2d24ccd4977c3b3c51e8e6edfc0b81c760