Compare commits

...

55 Commits
master ... f24

Author SHA1 Message Date
Jitka Plesnikova e5b8656035 5.22.4 bump 2017-07-17 15:08:09 +02:00
Petr Písař fc0d45e3f8 Provide perl-interpreter RPM dependency symbol
The perl-interpreter will turn into a normal package in the future.
2017-06-26 14:11:52 +02:00
Petr Písař 274d3944a9 Fix handling backslashes in PATH environment variable when executing "perl -S" 2017-06-26 13:50:37 +02:00
Petr Písař 5b60fc1457 Fix checks for tainted directory in $ENV{PATH} if a backslash escape presents 2017-06-26 13:47:36 +02:00
Petr Písař 78cf160884 Fix a buffer overflow in my_atof2() 2017-06-26 13:34:22 +02:00
Petr Písař 2d50691c83 Fix UTF-8 flag on a glob reassignment 2017-06-26 13:29:11 +02:00
Petr Písař 72e436423c Fix cloning :via handles on thread creation 2017-06-26 13:21:13 +02:00
Petr Písař c9dfb72cde Fix improper casting of a negative interger to unsigned eith-bit type 2017-06-26 12:51:40 +02:00
Petr Písař 1fc5049a79 Fix a crash when calling a subroutine from a stash 2017-06-26 11:57:50 +02:00
Petr Písař 76e6db566f Fix a memory wrap in sv_vcatpvfn_flags() 2017-06-26 11:55:33 +02:00
Petr Písař 0ef0d6cb42 Make File::Glob more resistant against degenerative matching 2017-06-26 11:51:48 +02:00
Petr Písař b79c21226a Fix a heap-use-after-free in four-arguments substr call 2017-03-08 17:59:41 +01:00
Petr Písař 7d019df066 Fix an invalid memory read when parsing a loop variable 2017-03-08 17:59:18 +01:00
Petr Písař dd252f70bc Fix a memory leak leak in Perl_reg_named_buff_fetch() 2017-03-08 17:55:06 +01:00
Petr Písař 484f119f04 Fix an use-after-free in substr() that modifies a magic variable 2017-03-08 17:50:14 +01:00
Petr Písař 80911529e5 Fix a null-pointer dereference on malformed code 2017-03-08 17:41:24 +01:00
Petr Písař 1c39f84025 Fix a buffer overflow when studying some regexps repeatedly 2017-02-17 15:20:03 +01:00
Petr Písař 2b73452532 Fix a buffer overrun with format and "use bytes" 2017-02-17 15:12:44 +01:00
Petr Písař fcbf7bd51a Fix a crash when compiling a regexp with impossible quantifiters 2017-02-17 15:05:55 +01:00
Petr Písař a05a3a16f9 Fix a heap overlow in parsing $# 2017-01-26 15:47:08 +01:00
Petr Písař 9692f34557 Fix parsing goto statements in multicalled subroutine 2017-01-26 15:43:33 +01:00
Petr Písař e8b0bf4b5c Fix recreation of *:: 2017-01-26 15:29:32 +01:00
Petr Písař bcc35dc4f4 Fix UTF-8 string handling in & operator 2017-01-26 15:23:47 +01:00
Petr Písař 962c5141e2 Fix out-of-bound read in case of unmatched regexp backreference 2017-01-20 13:10:52 +01:00
Petr Písař 1db7a9786c Fix a heap overflow if invalid octal or hexadecimal number is used in transliteration expression 2017-01-20 13:01:42 +01:00
Petr Písař 628397ebd0 Fix a use-after-free when processing scalar variables in forms 2017-01-20 12:59:04 +01:00
Petr Písař 60c6ffd4a1 Fix a heap overflow with pack "W" 2017-01-20 12:55:53 +01:00
Petr Písař c23879e98f Fix a buffer overflow in split in scalar context 2017-01-20 12:52:17 +01:00
Jitka Plesnikova e7934ed5ac 5.22.3 bump 2017-01-16 14:10:48 +01:00
Petr Písař 79b8edddae Fix regular expression matching 2016-12-19 15:45:55 +01:00
Petr Písař a3871a6bc0 Fix a memory leak in IO::Poll 2016-12-19 15:38:30 +01:00
Petr Písař 807139eab9 Fix a crash in optimized evaluation of "or ((0) x 0))" 2016-12-19 15:32:10 +01:00
Petr Písař 1d4a4ab82f Fix const correctness in hv_func.h 2016-12-19 15:25:12 +01:00
Petr Písař d31c571d9b Fix assigning split() return values to an array 2016-12-19 15:08:10 +01:00
Petr Písař 37bcef5aed Tighten dependencies between architecture specific sub-packages to ISA 2016-12-19 15:05:14 +01:00
Petr Písař 82a2a484bc Fix crash in Storable when deserializing malformed code reference 2016-12-19 14:55:16 +01:00
Petr Písař eda9660722 Document perl-129130-make-chdir-allocate-the-stack-it-needs.patch patch 2016-12-19 14:50:49 +01:00
Petr Písař c7d9a35fb8 Tie perl-Errno release to interpreter build because of kernel version check
If user updates the his system only partially so that perl-Errno does
not match perl-libs and the two were built on different kernel, using
Errno will fail:

Errno architecture (x86_64-linux-thread-multi-4.7.9-200.fc24.x86_64) does not match executable architecture (x86_64-linux-thread-multi-4.6.4-301.fc24.x86_64) at /usr/lib64/perl5/Errno.pm line 11.
2016-11-09 16:13:13 +01:00
Petr Písař fb5031caa5 Fix stack handling when calling chdir without an argument 2016-11-04 14:41:24 +01:00
Petr Písař c104251b47 Avoid infinite loop in h2xs tool if enum and type have the same name 2016-11-04 14:36:01 +01:00
Petr Písař 296892300c Fix firstchar bitmap under UTF-8 with prefix optimization 2016-11-04 14:34:00 +01:00
Petr Písař 2bcc96be96 Fix parsing perl options in shell bang line 2016-11-04 13:42:33 +01:00
Petr Písař 04a7dad8a7 Fix crash when matching UTF-8 string with non-UTF-8 substrings 2016-11-04 13:40:34 +01:00
Petr Písař be3f0bf7eb Fix string overrun in Perl_gv_fetchmethod_pvn_flags 2016-11-04 13:33:28 +01:00
Petr Písař c97f38aed9 Fix crash in splice 2016-11-04 13:24:13 +01:00
Petr Písař 5d6a5ae819 Fix crash in "evalbytes S" 2016-11-04 13:15:49 +01:00
Petr Písař a8fc8833db perl-Unicode-Collate license corrected to ((GPL+ or Artistic) and Unicode)
The file links to <http://www.unicode.org/terms_of_use.html> that
mathcces "Unicode" license (except the (c) paragraph).
2016-11-04 13:15:12 +01:00
Petr Písař f5a25d6db2 Add Artistic 2.0 into perl-Encode license tag because of encguess tool 2016-11-04 13:15:12 +01:00
Petr Písař bf1e935711 Do not mangle errno from failed socket call 2016-11-04 13:15:02 +01:00
Petr Písař a0f4e270b1 Fix a crash in lexical scope warnings 2016-11-04 12:42:50 +01:00
Jitka Plesnikova 91d3c16704 Avoid loading of modules from current directory, CVE-2016-1238, (bug #1360425) 2016-08-03 15:29:29 +02:00
Petr Písař 0f54b8ef65 RT#115808 is known as CVE-2016-6185 2016-07-11 12:33:50 +02:00
Jitka Plesnikova aad2faf3c0 Do not let XSLoader load relative paths (bz #1353238) 2016-07-07 14:34:02 +02:00
Petr Písař 2c07853b1d Fix duplicating PerlIO::encoding when spawning threads 2016-06-13 10:11:01 +02:00
Jitka Plesnikova bedaf21285 5.22.2 bump 2016-05-02 12:38:35 +02:00
62 changed files with 4843 additions and 62 deletions

3
.gitignore vendored
View File

@ -20,3 +20,6 @@ perl-5.12.1.tar.gz
/perl-5.20.2.tar.bz2
/perl-5.22.0.tar.bz2
/perl-5.22.1.tar.bz2
/perl-5.22.2.tar.bz2
/perl-5.22.3.tar.bz2
/perl-5.22.4.tar.bz2

View File

@ -5,8 +5,8 @@ diff -up perl-5.10.0/Configure.didi perl-5.10.0/Configure
: set usesocks on the Configure command line to enable socks.
: List of libraries we want.
: If anyone needs extra -lxxx, put those in a hint file.
-libswanted="cl pthread socket bind inet nsl nm ndbm gdbm dbm db malloc dl ld"
+libswanted="cl pthread socket resolv inet nsl nm ndbm gdbm dbm db malloc dl ld"
-libswanted="cl pthread socket bind inet nsl ndbm gdbm dbm db malloc dl ld"
+libswanted="cl pthread socket resolv inet nsl ndbm gdbm dbm db malloc dl ld"
libswanted="$libswanted sun m crypt sec util c cposix posix ucb bsd BSD"
: We probably want to search /usr/shlib before most other libraries.
: This is only used by the lib/ExtUtils/MakeMaker.pm routine extliblist.

View File

@ -1,38 +0,0 @@
From 73949fca082fe50bf47755c5ffa328259057ae36 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 8 Jun 2015 09:15:17 +0100
Subject: [PATCH] make PadlistNAMES() lvalue again.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
The PadlistNAMES() macro was introduced with v5.17.3-69-g86d2498.
This macro happened to be lvalue-capable, although it wasn't documented
as such.
v5.21.6-163-g9b7476d as a side effect, broke the lvalueness, which broke
Coro.
This commit restores the lvalueness.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pad.h | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/pad.h b/pad.h
index 1f86248..31b8715 100644
--- a/pad.h
+++ b/pad.h
@@ -295,7 +295,7 @@ Restore the old pad saved into the local variable opad by PAD_SAVE_LOCAL()
#define PadlistARRAY(pl) (pl)->xpadl_alloc
#define PadlistMAX(pl) (pl)->xpadl_max
-#define PadlistNAMES(pl) ((PADNAMELIST *)*PadlistARRAY(pl))
+#define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY(pl))
#define PadlistNAMESARRAY(pl) PadnamelistARRAY(PadlistNAMES(pl))
#define PadlistNAMESMAX(pl) PadnamelistMAX(PadlistNAMES(pl))
#define PadlistREFCNT(pl) 1 /* reserved for future use */
--
2.1.0

View File

@ -0,0 +1,126 @@
From fb211db6cbcf25bbdeaa39b6685fae7228c92b3a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Thu, 24 Nov 2016 16:34:09 +0100
Subject: [PATCH] Fix const correctness in hv_func.h
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Building an XS code with -Wcast-qual yielded warnings about discarding
const qualifiers from pointer targets like:
$ printf '#include "EXTERN.h"\n#include "perl.h"\n' | gcc -Wcast-qual -I/usr/lib64/perl5/CORE -c -x c -
In file included from /usr/lib64/perl5/CORE/hv.h:629:0,
from /usr/lib64/perl5/CORE/perl.h:3740,
from <stdin>:2:
/usr/lib64/perl5/CORE/hv_func.h: In function S_perl_hash_siphash_2_4:
/usr/lib64/perl5/CORE/hv_func.h:213:17: warning: cast discards const qualifier from pointer target type [-Wcast-qual]
U64TYPE k0 = ((U64TYPE*)seed)[0];
^
Petr Písař: Ported to 5.22.2.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
hv_func.h | 22 +++++++++++-----------
1 file changed, 11 insertions(+), 11 deletions(-)
diff --git a/hv_func.h b/hv_func.h
index 49a677e..e64d21f 100644
--- a/hv_func.h
+++ b/hv_func.h
@@ -118,7 +118,7 @@
#if (BYTEORDER == 0x1234 || BYTEORDER == 0x12345678) && U32SIZE == 4
/* CPU endian matches murmurhash algorithm, so read 32-bit word directly */
- #define U8TO32_LE(ptr) (*((U32*)(ptr)))
+ #define U8TO32_LE(ptr) (*((const U32*)(ptr)))
#elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
/* TODO: Add additional cases below where a compiler provided bswap32 is available */
#if defined(__GNUC__) && (__GNUC__>4 || (__GNUC__==4 && __GNUC_MINOR__>=3))
@@ -210,8 +210,8 @@ S_perl_hash_siphash_2_4(const unsigned char * const seed, const unsigned char *i
U64TYPE v3 = UINT64_C(0x7465646279746573);
U64TYPE b;
- U64TYPE k0 = ((U64TYPE*)seed)[0];
- U64TYPE k1 = ((U64TYPE*)seed)[1];
+ U64TYPE k0 = ((const U64TYPE*)seed)[0];
+ U64TYPE k1 = ((const U64TYPE*)seed)[1];
U64TYPE m;
const int left = inlen & 7;
const U8 *end = in + inlen - left;
@@ -269,7 +269,7 @@ S_perl_hash_siphash_2_4(const unsigned char * const seed, const unsigned char *i
PERL_STATIC_INLINE U32
S_perl_hash_superfast(const unsigned char * const seed, const unsigned char *str, STRLEN len) {
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((const U32*)seed) + (U32)len;
U32 tmp;
int rem= len & 3;
len >>= 2;
@@ -373,7 +373,7 @@ S_perl_hash_superfast(const unsigned char * const seed, const unsigned char *str
/* now we create the hash function */
PERL_STATIC_INLINE U32
S_perl_hash_murmur3(const unsigned char * const seed, const unsigned char *ptr, STRLEN len) {
- U32 h1 = *((U32*)seed);
+ U32 h1 = *((const U32*)seed);
U32 k1;
U32 carry = 0;
@@ -467,7 +467,7 @@ S_perl_hash_murmur3(const unsigned char * const seed, const unsigned char *ptr,
PERL_STATIC_INLINE U32
S_perl_hash_djb2(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((const U32*)seed) + (U32)len;
while (str < end) {
hash = ((hash << 5) + hash) + *str++;
}
@@ -477,7 +477,7 @@ S_perl_hash_djb2(const unsigned char * const seed, const unsigned char *str, con
PERL_STATIC_INLINE U32
S_perl_hash_sdbm(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((const U32*)seed) + (U32)len;
while (str < end) {
hash = (hash << 6) + (hash << 16) - hash + *str++;
}
@@ -503,7 +503,7 @@ S_perl_hash_sdbm(const unsigned char * const seed, const unsigned char *str, con
PERL_STATIC_INLINE U32
S_perl_hash_one_at_a_time(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((const U32*)seed) + (U32)len;
while (str < end) {
hash += *str++;
hash += (hash << 10);
@@ -518,7 +518,7 @@ S_perl_hash_one_at_a_time(const unsigned char * const seed, const unsigned char
PERL_STATIC_INLINE U32
S_perl_hash_one_at_a_time_hard(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((const U32*)seed) + (U32)len;
while (str < end) {
hash += (hash << 10);
@@ -553,7 +553,7 @@ S_perl_hash_one_at_a_time_hard(const unsigned char * const seed, const unsigned
PERL_STATIC_INLINE U32
S_perl_hash_old_one_at_a_time(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed);
+ U32 hash = *((const U32*)seed);
while (str < end) {
hash += *str++;
hash += (hash << 10);
@@ -581,7 +581,7 @@ S_perl_hash_murmur_hash_64a (const unsigned char * const seed, const unsigned ch
{
const U64TYPE m = 0xc6a4a7935bd1e995;
const int r = 47;
- U64TYPE h = *((U64TYPE*)seed) ^ len;
+ U64TYPE h = *((const U64TYPE*)seed) ^ len;
const U64TYPE * data = (const U64TYPE *)str;
const U64TYPE * end = data + (len/8);
const unsigned char * data2;
--
2.7.4

View File

@ -0,0 +1,73 @@
From fdee5b4a06f183a26f897e1ea8825da3577b74fd Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 5 Dec 2016 14:54:44 +0000
Subject: [PATCH] assertion failure in ... or ((0) x 0))
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Pisar: Ported to 5.22.2:
commit 5aa240eab7dbaa91f98c2fee1f04b6c0b5a9b9e3
Author: David Mitchell <davem@iabyn.com>
Date: Mon Dec 5 14:54:44 2016 +0000
assertion failure in ... or ((0) x 0))
[perl #130247] Perl_rpeep(OP *): Assertion `oldop' failed
the 'x 0' optimising code in rpeep didn't expect the repeat expression
to occur on the op_other side of an op_next chain.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
op.c | 4 ++--
t/op/repeat.t | 11 ++++++++++-
2 files changed, 12 insertions(+), 3 deletions(-)
diff --git a/op.c b/op.c
index e92de57..48b1130 100644
--- a/op.c
+++ b/op.c
@@ -13297,10 +13297,10 @@ Perl_rpeep(pTHX_ OP *o)
&& kid->op_next->op_type == OP_REPEAT
&& kid->op_next->op_private & OPpREPEAT_DOLIST
&& (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
- && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
+ && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
+ && oldop)
{
o = kid->op_next; /* repeat */
- assert(oldop);
oldop->op_next = o;
op_free(cBINOPo->op_first);
op_free(cBINOPo->op_last );
diff --git a/t/op/repeat.t b/t/op/repeat.t
index 8df5241..2bd3c62 100644
--- a/t/op/repeat.t
+++ b/t/op/repeat.t
@@ -6,7 +6,7 @@ BEGIN {
}
require './test.pl';
-plan(tests => 47);
+plan(tests => 48);
# compile time
@@ -173,3 +173,12 @@ for(($#that_array)x2) {
$_ *= 2;
}
is($#that_array, 28, 'list repetition propagates lvalue cx to its lhs');
+
+# [perl #130247] Perl_rpeep(OP *): Assertion `oldop' failed
+#
+# the 'x 0' optimising code in rpeep didn't expect the repeat expression
+# to occur on the op_other side of an op_next chain.
+# This used to give an assertion failure
+
+eval q{() = (() or ((0) x 0)); 1};
+is($@, "", "RT #130247");
--
2.7.4

View File

@ -0,0 +1,101 @@
From 31321d9c337d50cc8ead96ffacc82c90999ecef0 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Mon, 11 Jul 2016 14:49:17 -0700
Subject: [PATCH] Crash from gp_free/ckWARN_d
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.2:
commit a2637ca0a3fec01b80d7ea5ba62802354fd5e6f3
Author: Father Chrysostomos <sprout@cpan.org>
Date: Mon Jul 11 14:49:17 2016 -0700
[perl #128597] Crash from gp_free/ckWARN_d
See the explanation in the test added and in the RT ticket.
The solution is to make the warn macros check that PL_curcop
is non-null.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regen/warnings.pl | 6 ++++--
t/op/gv.t | 18 +++++++++++++++++-
warnings.h | 6 ++++--
3 files changed, 25 insertions(+), 5 deletions(-)
diff --git a/regen/warnings.pl b/regen/warnings.pl
index 694cb03..85e6d5a 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -362,8 +362,10 @@ EOM
print $warn <<'EOM';
-#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
-#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
+#define isLEXWARN_on \
+ (PL_curcop && PL_curcop->cop_warnings != pWARN_STD)
+#define isLEXWARN_off \
+ (!PL_curcop || PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
diff --git a/t/op/gv.t b/t/op/gv.t
index 2c9cc64..0cb8ebe 100644
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
use warnings;
-plan(tests => 276 );
+plan(tests => 277 );
# type coercion on assignment
$foo = 'foo';
@@ -1150,6 +1150,22 @@ pass "No crash due to CvGV pointing to glob copy in the stash";
is($c_125840, 1, 'RT #125840: $c=$d');
}
+# [perl #128597] Crash when gp_free calls ckWARN_d
+# I am not sure this test even belongs in this file, as the crash was the
+# result of various features interacting. But a call to ckWARN_d from
+# gv.c:gp_free triggered the crash, so this seems as good a place as any.
+# die (or any abnormal scope exit) can cause the current cop to be freed,
+# if the subroutine containing the die gets freed as a result. That
+# causes PL_curcop to be set to NULL. If a writable handle gets freed
+# while PL_curcop is NULL, then gp_free will call ckWARN_d while that con-
+# dition still holds, so ckWARN_d needs to know about PL_curcop possibly
+# being NULL.
+SKIP: {
+ skip_if_miniperl("No PerlIO::scalar on miniperl", 1);
+ runperl(prog => 'open my $fh, q|>|, \$buf;'
+ .'my $sub = eval q|sub {exit 0}|; $sub->()');
+ is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
+}
__END__
Perl
diff --git a/warnings.h b/warnings.h
index 24fe243..b0a0eb4 100644
--- a/warnings.h
+++ b/warnings.h
@@ -117,8 +117,10 @@
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
-#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
-#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
+#define isLEXWARN_on \
+ (PL_curcop && PL_curcop->cop_warnings != pWARN_STD)
+#define isLEXWARN_off \
+ (!PL_curcop || PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
--
2.7.4

View File

@ -0,0 +1,66 @@
From 36dc786e5ea4a6d3e85f1f55251b8538fabb8321 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 5 Sep 2016 15:40:11 +1000
Subject: [PATCH] (perl #129130) make chdir allocate the stack it needs
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.2:
commit 92c843fb4b4e1a1e0ac7ec0fe198dc77266838da
Author: Tony Cook <tony@develop-help.com>
Date: Mon Sep 5 15:40:11 2016 +1000
(perl #129130) make chdir allocate the stack it needs
chdir with no argument didn't ensure there was stack space available
for its result.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_sys.c | 1 +
t/op/chdir.t | 8 +++++++-
2 files changed, 8 insertions(+), 1 deletion(-)
diff --git a/pp_sys.c b/pp_sys.c
index 1285c75..2171a1a 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3580,6 +3580,7 @@ PP(pp_chdir)
HV * const table = GvHVn(PL_envgv);
SV **svp;
+ EXTEND(SP, 1);
if ( (svp = hv_fetchs(table, "HOME", FALSE))
|| (svp = hv_fetchs(table, "LOGDIR", FALSE))
#ifdef VMS
diff --git a/t/op/chdir.t b/t/op/chdir.t
index 813b0ed..f16be41 100644
--- a/t/op/chdir.t
+++ b/t/op/chdir.t
@@ -10,7 +10,7 @@ BEGIN {
# possibilities into @INC.
unshift @INC, qw(t . lib ../lib);
require "./test.pl";
- plan(tests => 48);
+ plan(tests => 49);
}
use Config;
@@ -176,6 +176,12 @@ WARNING
}
}
+fresh_perl_is(<<'EOP', '', { stderr => 1 }, "check stack handling");
+for $x (map $_+1, 1 .. 100) {
+ map chdir, 1 .. $x;
+}
+EOP
+
my %Saved_Env = ();
sub clean_env {
foreach my $env (@magic_envs) {
--
2.7.4

View File

@ -0,0 +1,79 @@
From 5114cc26ed8a68debf3e4ed357f205ddaf99ef15 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 11 Sep 2016 21:29:56 -0700
Subject: [PATCH] Crash with splice
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.2:
commit 92b69f6501b4d7351e09c8b1ddd386aa7e1c9cd1
Author: Father Chrysostomos <sprout@cpan.org>
Date: Sun Sep 11 21:29:56 2016 -0700
[perl #129164] Crash with splice
This fixes #129166 and #129167 as well.
splice needs to take into account that arrays can hold NULLs and
return &PL_sv_undef in those cases where it would have returned a
NULL element.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp.c | 4 ++++
t/op/array.t | 17 +++++++++++++++++
2 files changed, 21 insertions(+)
diff --git a/pp.c b/pp.c
index 3173c5a..996b346 100644
--- a/pp.c
+++ b/pp.c
@@ -5325,6 +5325,8 @@ PP(pp_splice)
for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
SvREFCNT_dec(*dst++); /* free them now */
}
+ if (!*MARK)
+ *MARK = &PL_sv_undef;
}
AvFILLp(ary) += diff;
@@ -5421,6 +5423,8 @@ PP(pp_splice)
while (length-- > 0)
SvREFCNT_dec(tmparyval[length]);
}
+ if (!*MARK)
+ *MARK = &PL_sv_undef;
}
else
*MARK = &PL_sv_undef;
diff --git a/t/op/array.t b/t/op/array.t
index 7239d48..bbdf86c 100644
--- a/t/op/array.t
+++ b/t/op/array.t
@@ -549,4 +549,21 @@ is "@ary", 'b a',
for(scalar $#foo) { $_ = 3 }
is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)';
+# [perl #129164], [perl #129166], [perl #129167]
+# splice() with null array entries
+# These used to crash.
+$#a = -1; $#a++;
+() = 0-splice @a; # subtract
+$#a = -1; $#a++;
+() = -splice @a; # negate
+$#a = -1; $#a++;
+() = 0+splice @a; # add
+# And with array expansion, too
+$#a = -1; $#a++;
+() = 0-splice @a, 0, 1, 1, 1;
+$#a = -1; $#a++;
+() = -splice @a, 0, 1, 1, 1;
+$#a = -1; $#a++;
+() = 0+splice @a, 0, 1, 1, 1;
+
"We're included by lib/Tie/Array/std.t so we need to return something true";
--
2.7.4

View File

@ -0,0 +1,56 @@
From 23628ae4896040e64261a925d06d8003c61d8bbd Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Tue, 4 Oct 2016 14:40:11 +0100
Subject: [PATCH] anchored/floating substrings must be utf8 if target is
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.2:
commit 2814f4b3549f665a6f9203ac9e890ae1e415e0dc
Author: Hugo van der Sanden <hv@crypt.org>
Date: Tue Oct 4 14:40:11 2016 +0100
[perl #129350] anchored/floating substrings must be utf8 if target is
If the target is utf8 and either the anchored or floating substrings
are not, we need to create utf8 copies to check against. The state
of the two substrings may not be the same, but we were only testing
whichever we planned to check first.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regexec.c | 3 ++-
t/re/re_tests | 1 +
2 files changed, 3 insertions(+), 1 deletion(-)
diff --git a/regexec.c b/regexec.c
index e38c6ca..98df35d 100644
--- a/regexec.c
+++ b/regexec.c
@@ -694,7 +694,8 @@ Perl_re_intuit_start(pTHX_
reginfo->poscache_maxiter = 0;
if (utf8_target) {
- if (!prog->check_utf8 && prog->check_substr)
+ if ((!prog->anchored_utf8 && prog->anchored_substr)
+ || (!prog->float_utf8 && prog->float_substr))
to_utf8_substr(prog);
check = prog->check_utf8;
} else {
diff --git a/t/re/re_tests b/t/re/re_tests
index 85ce7f4..c65bcce 100644
--- a/t/re/re_tests
+++ b/t/re/re_tests
@@ -1941,6 +1941,7 @@ A+(*PRUNE)BC(?{}) AAABC y $& AAABC
.{1}?? - c - Nested quantifiers
.{1}?+ - c - Nested quantifiers
(?:.||)(?|)000000000@ 000000000@ y $& 000000000@ # [perl #126405]
+\b\z0*\x{100} .\x{100} n - - # [perl #129350] crashed in intuit_start
# Keep these lines at the end of the file
# vim: softtabstop=0 noexpandtab
--
2.7.4

View File

@ -0,0 +1,134 @@
From 5ae12482f66b0062e89b661641647aa99c2b9ad9 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 25 Oct 2016 16:17:18 +1100
Subject: [PATCH] (perl #129788) IO::Poll: fix memory leak
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Pisar: Ported to 5.22.2:
commit 6de2dd46140d0d3ab6813e26940d7b74418b0260
Author: Tony Cook <tony@develop-help.com>
Date: Tue Oct 25 16:17:18 2016 +1100
(perl #129788) IO::Poll: fix memory leak
Whenever a magical/tied scalar which dies upon read was passed to _poll()
temporary buffer for events was not freed.
Adapted from a patch by Sergey Aleynikov <sergey.aleynikov@gmail.com>
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
META.json | 1 +
META.yml | 1 +
dist/IO/IO.xs | 3 +--
dist/IO/t/io_leak.t | 37 +++++++++++++++++++++++++++++++++++++
5 files changed, 41 insertions(+), 2 deletions(-)
create mode 100644 dist/IO/t/io_leak.t
diff --git a/MANIFEST b/MANIFEST
index 4cc6433..110d4f9 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3129,6 +3129,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_export.t Test IO::File exports
dist/IO/t/io_file.t See if binmode()-related methods on IO::File work
+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
dist/IO/t/io_pipe.t See if pipe()-related methods from IO work
diff --git a/META.json b/META.json
index f639e6d..55838a7 100644
--- a/META.json
+++ b/META.json
@@ -85,6 +85,7 @@
"dist/IO/t/io_dup.t",
"dist/IO/t/io_file.t",
"dist/IO/t/io_file_export.t",
+ "dist/IO/t/io_leak.t",
"dist/IO/t/io_linenum.t",
"dist/IO/t/io_multihomed.t",
"dist/IO/t/io_pipe.t",
diff --git a/META.yml b/META.yml
index 4b525a4..7ab17f9 100644
--- a/META.yml
+++ b/META.yml
@@ -82,6 +82,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_leak.t
- dist/IO/t/io_linenum.t
- dist/IO/t/io_multihomed.t
- dist/IO/t/io_pipe.t
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 1f546b9..b6b6ae9 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -318,7 +318,7 @@ PPCODE:
{
#ifdef HAS_POLL
const int nfd = (items - 1) / 2;
- SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
+ SV *tmpsv = sv_2mortal(NEWSV(999,nfd * sizeof(struct pollfd)));
struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
int i,j,ret;
for(i=1, j=0 ; j < nfd ; j++) {
@@ -334,7 +334,6 @@ PPCODE:
sv_setiv(ST(i), fds[j].revents); i++;
}
}
- SvREFCNT_dec(tmpsv);
XSRETURN_IV(ret);
#else
not_here("IO::Poll::poll");
diff --git a/dist/IO/t/io_leak.t b/dist/IO/t/io_leak.t
new file mode 100644
index 0000000..08cbe2b
--- /dev/null
+++ b/dist/IO/t/io_leak.t
@@ -0,0 +1,37 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use Test::More;
+
+eval { require XS::APItest; XS::APItest->import('sv_count'); 1 }
+ or plan skip_all => "No XS::APItest::sv_count() available";
+
+plan tests => 1;
+
+sub leak {
+ my ($n, $delta, $code, $name) = @_;
+ my $sv0 = 0;
+ my $sv1 = 0;
+ for my $i (1..$n) {
+ &$code();
+ $sv1 = sv_count();
+ $sv0 = $sv1 if $i == 1;
+ }
+ cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, $name);
+}
+
+# [perl #129788] IO::Poll shouldn't leak on errors
+{
+ package io_poll_leak;
+ use IO::Poll;
+
+ sub TIESCALAR { bless {} }
+ sub FETCH { die }
+
+ tie(my $a, __PACKAGE__);
+ sub f {eval { IO::Poll::_poll(0, $a, 1) }}
+
+ ::leak(5, 0, \&f, q{IO::Poll::_poll shouldn't leak});
+}
--
2.7.4

View File

@ -0,0 +1,53 @@
From 5d9b0550a63f6b1e20a69ea9f60d2fffaca0af74 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Mon, 12 Dec 2016 15:15:06 +0000
Subject: [PATCH] Correctly unwind on cache hit
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Pisar: Ported to 5.22.2:
commit d3c48e81594c1d64ba9833495e45d8951b42027c
Author: Hugo van der Sanden <hv@crypt.org>
Date: Mon Dec 12 15:15:06 2016 +0000
[perl #130307] Correctly unwind on cache hit
We've already incremented curlyx.count in the WHILEM branch before
we check for a hit in the super-linear cache, so must reverse that
on the sayNO.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regexec.c | 1 +
t/re/re_tests | 1 +
2 files changed, 2 insertions(+)
diff --git a/regexec.c b/regexec.c
index 98df35d..ff1d5d8 100644
--- a/regexec.c
+++ b/regexec.c
@@ -6867,6 +6867,7 @@ NULL
"%*s whilem: (cache) already tried at this position...\n",
REPORT_CODE_OFF+depth*2, "")
);
+ cur_curlyx->u.curlyx.count--;
sayNO; /* cache records failure */
}
ST.cache_offset = offset;
diff --git a/t/re/re_tests b/t/re/re_tests
index c65bcce..41fc458 100644
--- a/t/re/re_tests
+++ b/t/re/re_tests
@@ -1942,6 +1942,7 @@ A+(*PRUNE)BC(?{}) AAABC y $& AAABC
.{1}?+ - c - Nested quantifiers
(?:.||)(?|)000000000@ 000000000@ y $& 000000000@ # [perl #126405]
\b\z0*\x{100} .\x{100} n - - # [perl #129350] crashed in intuit_start
+(X{2,}[-X]{1,4}){3,}X{2,} XXX-XXX-XXX-- n - - # [perl #130307]
# Keep these lines at the end of the file
# vim: softtabstop=0 noexpandtab
--
2.7.4

View File

@ -0,0 +1,97 @@
From e40804ef8d2f49e588498bcc4bc0ba8e108ac648 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Thu, 27 Oct 2016 13:52:24 +0200
Subject: [PATCH] regcomp.c: fix perl #129950 - fix firstchar bitmap under utf8
with prefix optimisation
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.2:
commit da42332b10691ba7af7550035ffc7f46c87e4e66
Author: Yves Orton <demerphq@gmail.com>
Date: Thu Oct 27 13:52:24 2016 +0200
regcomp.c: fix perl #129950 - fix firstchar bitmap under utf8 with prefix optimisation
The trie code contains a number of sub optimisations, one of which
extracts common prefixes from alternations, and another which isa
bitmap of the possible matching first chars.
The bitmap needs to contain the possible first octets of the string
which the trie can match, and for codepoints which might have a different
first octet under utf8 or non-utf8 need to register BOTH codepoints.
So for instance in the pattern (?:a|a\x{E4}) we should restructure this
as a(|\x{E4), and the bitmap for the trie should contain both \x{E4} AND
\x{C3} as \x{C3} is the first byte of \x{EF} expressed as utf8.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 14 ++++++++++++++
t/re/pat.t | 9 ++++++++-
2 files changed, 22 insertions(+), 1 deletion(-)
diff --git a/regcomp.c b/regcomp.c
index 9332dea..fcb5147 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -2965,6 +2965,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
TRIE_BITMAP_SET(trie,*ch);
if ( folder )
TRIE_BITMAP_SET(trie, folder[ *ch ]);
+ if ( !UTF ) {
+ /* store first byte of utf8 representation of
+ variant codepoints */
+ if (! UVCHR_IS_INVARIANT(*ch)) {
+ TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(*ch));
+ }
+ }
DEBUG_OPTIMISE_r(
PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
);
@@ -2973,6 +2980,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
TRIE_BITMAP_SET(trie,*ch);
if ( folder )
TRIE_BITMAP_SET(trie,folder[ *ch ]);
+ if ( !UTF ) {
+ /* store first byte of utf8 representation of
+ variant codepoints */
+ if (! UVCHR_IS_INVARIANT(*ch)) {
+ TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(*ch));
+ }
+ }
DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
}
idx = ofs;
diff --git a/t/re/pat.t b/t/re/pat.t
index 3377b19..2f18aa8 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -23,7 +23,7 @@ BEGIN {
skip_all_without_unicode_tables();
}
-plan tests => 775; # Update this when adding/deleting tests.
+plan tests => 777; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1708,6 +1708,13 @@ EOP
like($error, qr{Reference to nonexistent group},
'gave appropriate error for qr{()(?1)}n');
}
+
+ {
+ my $str = "a\xE4";
+ ok( $str =~ m{^(a|a\x{e4})$}, "fix [perl #129950] - latin1 case" );
+ utf8::upgrade($str);
+ ok( $str =~ m{^(a|a\x{e4})$}, "fix [perl #129950] - utf8 case" );
+ }
} # End of sub run_tests
1;
--
2.7.4

View File

@ -0,0 +1,93 @@
From de94c50b9dc29fcb2184347cb709c9fdeaaf5a7c Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Fri, 27 Jan 2017 10:18:51 +0100
Subject: [PATCH] fix RT #130561 - recursion and optimising away impossible
quantifiers are not friends
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.3:
commit 31fc93954d1f379c7a49889d91436ce99818e1f6
Author: Yves Orton <demerphq@gmail.com>
Date: Fri Jan 27 10:18:51 2017 +0100
fix RT #130561 - recursion and optimising away impossible quantifiers are not friends
Instead of optimising away impossible quantifiers like (foo){1,0} treat them
as unquantified, and guard them with an OPFAIL. Thus /(foo){1,0}/ is treated
the same as /(*FAIL)(foo)/ this is important in patterns like /(foo){1,0}|(?1)/
where the (?1) needs to be able to recurse into the (foo) even though the
(foo){1,0} can never match. It also resolves various issues (SEGVs) with patterns
like /((?1)){1,0}/.
This patch would have been easier if S_reginsert() documented that it is
the callers responsibility to properly set up the NEXT_OFF() of the inserted
node (if the node has a NEXT_OFF())
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 14 +++-----------
t/re/pat_rt_report.t | 11 ++++++++++-
2 files changed, 13 insertions(+), 12 deletions(-)
diff --git a/regcomp.c b/regcomp.c
index fcb5147..e9c84b3 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -10882,19 +10882,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
nextchar(pRExC_state);
if (max < min) { /* If can't match, warn and optimize to fail
unconditionally */
- if (SIZE_ONLY) {
-
- /* We can't back off the size because we have to reserve
- * enough space for all the things we are about to throw
- * away, but we can shrink it by the ammount we are about
- * to re-use here */
- RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
- }
- else {
+ if (PASS2) {
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
- RExC_emit = orig_emit;
}
- ret = reg_node(pRExC_state, OPFAIL);
+ reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
+ NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
return ret;
}
else if (min == max && RExC_parse < RExC_end && *RExC_parse == '?')
diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
index ed8fafc..19d41df 100644
--- a/t/re/pat_rt_report.t
+++ b/t/re/pat_rt_report.t
@@ -20,7 +20,7 @@ use warnings;
use 5.010;
use Config;
-plan tests => 2532; # Update this when adding/deleting tests.
+plan tests => 2534; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1181,6 +1181,15 @@ EOP
ok($s =~ /.\C+/, "CANY pointer wrap");
}
}
+ {
+ # rt
+ fresh_perl_is(
+ '"foo"=~/((?1)){8,0}/; print "ok"',
+ "ok", {}, 'RT #130561 - allowing impossible quantifier should not cause SEGVs');
+ my $s= "foo";
+ ok($s=~/(foo){1,0}|(?1)/,
+ "RT #130561 - allowing impossible quantifier should not break recursion");
+ }
} # End of sub run_tests
1;
--
2.7.4

View File

@ -0,0 +1,79 @@
From e70566d418a424aef71fa277a3c93240659790af Mon Sep 17 00:00:00 2001
From: Zefram <zefram@fysh.org>
Date: Sun, 22 Jan 2017 07:26:34 +0000
Subject: [PATCH] fix special-case recreation of *::
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.3:
commit 120921acd4cf27bb932a725a8cf5c957652b22eb
Author: Zefram <zefram@fysh.org>
Date: Sun Jan 22 07:26:34 2017 +0000
fix special-case recreation of *::
If *:: is called for then as a special case it is looked up as
$::{"main::"}. If $::{"main::"} has been deleted, then that hash entry
is recreated. But formerly it was only recreated as an undef scalar,
which broke things relying on glob lookup returning a glob. Now in
that special case the recreated hash entry is initialised as a glob,
and populated with the customary recursive reference to the main stash.
Fixes [perl #129869].
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
gv.c | 11 +++++++++--
t/op/stash.t | 9 ++++++++-
2 files changed, 17 insertions(+), 3 deletions(-)
diff --git a/gv.c b/gv.c
index 47a5407..ba7516b 100644
--- a/gv.c
+++ b/gv.c
@@ -1637,8 +1637,15 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
name_cursor++;
*name = name_cursor+1;
if (*name == name_end) {
- if (!*gv)
- *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+ if (!*gv) {
+ *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+ if (SvTYPE(*gv) != SVt_PVGV) {
+ gv_init_pvn(*gv, PL_defstash, "main::", 6,
+ GV_ADDMULTI);
+ GvHV(*gv) =
+ MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
+ }
+ }
return TRUE;
}
}
diff --git a/t/op/stash.t b/t/op/stash.t
index af218ad..0433c9d 100644
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
BEGIN { require "./test.pl"; }
-plan( tests => 51 );
+plan( tests => 52 );
# Used to segfault (bug #15479)
fresh_perl_like(
@@ -334,3 +334,10 @@ is runperl(
),
"ok\n",
'[perl #123847] no crash from *foo::=*bar::=*glob_with_hash';
+
+is runperl(
+ prog => '%:: = (); print *{q|::|}, qq|\n|',
+ stderr => 1,
+ ),
+ "*main::main::\n",
+ "[perl #129869] lookup %:: by name after clearing %::";
--
2.7.4

View File

@ -0,0 +1,46 @@
From abcd833284abc4feae9dae25a3a28134db1b42fa Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Fri, 27 Jan 2017 16:57:40 +0100
Subject: [PATCH] only mess with NEXT_OFF() when we are in PASS2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.3:
commit bb78386f13c18a1a7dae932b9b36e977056b13c7
Author: Yves Orton <demerphq@gmail.com>
Date: Fri Jan 27 16:57:40 2017 +0100
only mess with NEXT_OFF() when we are in PASS2
In 31fc93954d1f379c7a49889d91436ce99818e1f6 I added code that would modify
NEXT_OFF() when we were not in PASS2, when we should not do so. Strangly this
did not segfault when I tested, but this fix is required.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/regcomp.c b/regcomp.c
index e9c84b3..50081aa 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -10882,11 +10882,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
nextchar(pRExC_state);
if (max < min) { /* If can't match, warn and optimize to fail
unconditionally */
+ reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
if (PASS2) {
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
+ NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
}
- reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
- NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
return ret;
}
else if (min == max && RExC_parse < RExC_end && *RExC_parse == '?')
--
2.7.4

View File

@ -0,0 +1,70 @@
From 34fd995c20ab8049eadd63b0bfaca732e4cdb4bd Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 24 Jan 2017 11:14:28 +1100
Subject: [PATCH] (perl #129274) avoid treating the # in $# as a comment intro
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Písař: Ported to 5.22.3:
commit 71776ae4fad9a7659deefe0c2376d45b873ffd6a
Author: Tony Cook <tony@develop-help.com>
Date: Tue Jan 24 11:14:28 2017 +1100
(perl #129274) avoid treating the # in $# as a comment intro
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/op/lex.t | 15 ++++++++++++++-
toke.c | 4 +++-
2 files changed, 17 insertions(+), 2 deletions(-)
diff --git a/t/op/lex.t b/t/op/lex.t
index a58beb5..2f29e85 100644
--- a/t/op/lex.t
+++ b/t/op/lex.t
@@ -7,7 +7,7 @@ use warnings;
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 26);
+plan(tests => 27);
{
no warnings 'deprecated';
@@ -216,3 +216,16 @@ fresh_perl_like(
{},
'[perl #129336] - #!perl -i argument handling'
);
+
+# probably only failed under ASAN
+fresh_perl_is(
+ "stat\tt\$#0",
+ <<'EOM',
+$# is no longer supported at - line 1.
+Number found where operator expected at - line 1, near "$#0"
+ (Missing operator before 0?)
+Can't call method "t" on an undefined value at - line 1.
+EOM
+ {},
+ "[perl #129273] heap use after free or overflow"
+);
diff --git a/toke.c b/toke.c
index c8c14d5..999eb2c 100644
--- a/toke.c
+++ b/toke.c
@@ -3895,7 +3895,9 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
isUPPER(*PL_tokenbuf))
return 0;
- s = skipspace(s);
+ /* this could be $# */
+ if (isSPACE(*s))
+ s = skipspace(s);
PL_bufptr = start;
PL_expect = XREF;
return *s == '(' ? FUNCMETH : METHOD;
--
2.7.4

View File

@ -0,0 +1,49 @@
From c1423633ac24ca51dd0fb0b51f03221816245f74 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 10 Oct 2016 10:46:46 +1100
Subject: [PATCH] (perl #129281) test for buffer overflow issue
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.3:
commit d2ba660af00f1bf2e7012741615eff7c19f29707
Author: Tony Cook <tony@develop-help.com>
Date: Mon Oct 10 10:46:46 2016 +1100
(perl #129281) test for buffer overflow issue
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/re/pat.t | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/t/re/pat.t b/t/re/pat.t
index b274100..f305320 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -23,7 +23,7 @@ BEGIN {
skip_all_without_unicode_tables();
}
-plan tests => 778; # Update this when adding/deleting tests.
+plan tests => 779; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1729,6 +1729,11 @@ EOP
}msx, { stderr => 1 }, "Offsets in debug output are not negative");
}
}
+ {
+ # [perl #129281] buffer write overflow, detected by ASAN, valgrind
+ local $::TODO = "whilem_c bumped too much";
+ fresh_perl_is('/0(?0)|^*0(?0)|^*(^*())0|/', '', {}, "don't bump whilem_c too much");
+ }
} # End of sub run_tests
1;
--
2.7.4

View File

@ -0,0 +1,72 @@
From be269dd17b2c617ae66d9bf8e185fa2cc8ac9407 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 18 Sep 2016 20:17:08 -0700
Subject: [PATCH] Make UTF8 & append null
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Písař: Ported to 5.22.3:
commit b43665fffa48dd179eba1b5616d4ca35b4def876
Author: Father Chrysostomos <sprout@cpan.org>
Date: Sun Sep 18 20:17:08 2016 -0700
[perl #129287] Make UTF8 & append null
The & and &. operators were not appending a null byte to the string
in utf8 mode.
(The internal function that they use is the same. I used &. in the
test just because its intent is clearer.)
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
doop.c | 1 +
t/op/bop.t | 14 +++++++++++++-
2 files changed, 14 insertions(+), 1 deletion(-)
diff --git a/doop.c b/doop.c
index c6ee847..ca122b4 100644
--- a/doop.c
+++ b/doop.c
@@ -1086,6 +1086,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
if (sv == left || sv == right)
(void)sv_usepvn(sv, dcorig, needlen);
SvCUR_set(sv, dc - dcorig);
+ *SvEND(sv) = 0;
break;
case OP_BIT_XOR:
while (lulen && rulen) {
diff --git a/t/op/bop.t b/t/op/bop.t
index 09f2be9..0de7f0b 100644
--- a/t/op/bop.t
+++ b/t/op/bop.t
@@ -15,7 +15,7 @@ BEGIN {
# If you find tests are failing, please try adding names to tests to track
# down where the failure is, and supply your new names as a patch.
# (Just-in-time test naming)
-plan tests => 194 + (10*13*2) + 5;
+plan tests => 194 + (10*13*2) + 6;
# numerics
ok ((0xdead & 0xbeef) == 0x9ead);
@@ -620,3 +620,15 @@ $^A .= new version ~$_ for eval sprintf('"\\x%02x"', 0xff - ord("1")),
$::IS_EBCDIC ? v13 : v205, # 255 - ord('2')
eval sprintf('"\\x%02x"', 0xff - ord("3"));
is $^A, "123", '~v0 clears vstring magic on retval';
+
+# [perl #129287] UTF8 & was not providing a trailing null byte.
+# This test is a bit convoluted, as we want to make sure that the string
+# allocated for &s target contains memory initialised to something other
+# than a null byte. Uninitialised memory does not make for a reliable
+# test. So we do &. on a longer non-utf8 string first.
+for (["aaa","aaa"],[substr ("a\x{100}",0,1), "a"]) {
+ use feature "bitwise";
+ no warnings "experimental::bitwise", "pack";
+ $byte = substr unpack("P2", pack "P", $$_[0] &. $$_[1]), -1;
+}
+is $byte, "\0", "utf8 &. appends null byte";
--
2.7.4

View File

@ -0,0 +1,104 @@
From ee45d0c2ef62617f75c7f99aaaa44ab1225864af Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 20 Feb 2017 11:02:21 +1100
Subject: [PATCH] (perl #129340) copy the source when inside the dest in
sv_insert_flags()
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.3:
commit e7a8a8aac45d42d72d1586227ca51771f193f5dc
Author: Tony Cook <tony@develop-help.com>
Date: Mon Feb 20 11:02:21 2017 +1100
(perl #129340) copy the source when inside the dest in sv_insert_flags()
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
embed.fnc | 2 +-
proto.h | 2 +-
sv.c | 12 +++++++++++-
t/op/substr.t | 5 ++++-
4 files changed, 17 insertions(+), 4 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index b26ba18..3dbf9e8 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1442,7 +1442,7 @@ Amdb |void |sv_insert |NN SV *const bigstr|const STRLEN offset \
|const STRLEN len|NN const char *const little \
|const STRLEN littlelen
Apd |void |sv_insert_flags|NN SV *const bigstr|const STRLEN offset|const STRLEN len \
- |NN const char *const little|const STRLEN littlelen|const U32 flags
+ |NN const char *little|const STRLEN littlelen|const U32 flags
Apd |int |sv_isa |NULLOK SV* sv|NN const char *const name
Apd |int |sv_isobject |NULLOK SV* sv
Apd |STRLEN |sv_len |NULLOK SV *const sv
diff --git a/proto.h b/proto.h
index ab78202..f82c62e 100644
--- a/proto.h
+++ b/proto.h
@@ -4373,7 +4373,7 @@ PERL_CALLCONV void Perl_sv_inc_nomg(pTHX_ SV *const sv);
#define PERL_ARGS_ASSERT_SV_INSERT \
assert(bigstr); assert(little)
-PERL_CALLCONV void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
+PERL_CALLCONV void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *little, const STRLEN littlelen, const U32 flags);
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_4);
#define PERL_ARGS_ASSERT_SV_INSERT_FLAGS \
diff --git a/sv.c b/sv.c
index 263d27b..5329f9e 100644
--- a/sv.c
+++ b/sv.c
@@ -6301,7 +6301,7 @@ C<SvPV_force_flags> that applies to C<bigstr>.
*/
void
-Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
+Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *little, const STRLEN littlelen, const U32 flags)
{
char *big;
char *mid;
@@ -6314,6 +6314,16 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l
SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
+
+ if (little >= SvPVX(bigstr) &&
+ little < SvPVX(bigstr) + (SvLEN(bigstr) ? SvLEN(bigstr) : SvCUR(bigstr))) {
+ /* little is a pointer to within bigstr, since we can reallocate bigstr,
+ or little...little+littlelen might overlap offset...offset+len we make a copy
+ */
+ little = savepvn(little, littlelen);
+ SAVEFREEPV(little);
+ }
+
if (offset + len > curlen) {
SvGROW(bigstr, offset+len+1);
Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
diff --git a/t/op/substr.t b/t/op/substr.t
index 71e9e89..7d8f3e0 100644
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -22,7 +22,7 @@ $SIG{__WARN__} = sub {
}
};
-plan(388);
+plan(389);
run_tests() unless caller;
@@ -868,3 +868,6 @@ is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]");
}
+
+# failed with ASAN
+fresh_perl_is('$0 = "/usr/bin/perl"; substr($0, 0, 0, $0)', '', {}, "(perl #129340) substr() with source in target");
--
2.7.4

View File

@ -0,0 +1,106 @@
From 19b3bde41dc56af0d042139b1f3261a26bb3c339 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Wed, 5 Oct 2016 12:56:05 +0100
Subject: [PATCH] don't read past start of string for unmatched backref
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.3:
commit 2dfc11ec3af312f4fa3eb244077c79dbb5fc2d85
Author: Hugo van der Sanden <hv@crypt.org>
Date: Wed Oct 5 12:56:05 2016 +0100
[perl #129377] don't read past start of string for unmatched backref
We can have (start, end) == (0, -1) for an unmatched backref, we must
check for that.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regexec.c | 10 ++++++----
t/re/pat.t | 16 +++++++++++++++-
2 files changed, 21 insertions(+), 5 deletions(-)
diff --git a/regexec.c b/regexec.c
index ff1d5d8..b01368e 100644
--- a/regexec.c
+++ b/regexec.c
@@ -4830,6 +4830,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
regnode *next;
U32 n = 0; /* general value; init to avoid compiler warning */
SSize_t ln = 0; /* len or last; init to avoid compiler warning */
+ SSize_t endref = 0; /* offset of end of backref when ln is start */
char *locinput = startpos;
char *pushinput; /* where to continue after a PUSH */
I32 nextchr; /* is always set to UCHARAT(locinput) */
@@ -6090,10 +6091,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
do_nref_ref_common:
ln = rex->offs[n].start;
+ endref = rex->offs[n].end;
reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */
- if (rex->lastparen < n || ln == -1)
+ if (rex->lastparen < n || ln == -1 || endref == -1)
sayNO; /* Do not match unless seen CLOSEn. */
- if (ln == rex->offs[n].end)
+ if (ln == endref)
break;
s = reginfo->strbeg + ln;
@@ -6107,7 +6109,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
* not going off the end given by reginfo->strend, and
* returns in <limit> upon success, how much of the
* current input was matched */
- if (! foldEQ_utf8_flags(s, NULL, rex->offs[n].end - ln, utf8_target,
+ if (! foldEQ_utf8_flags(s, NULL, endref - ln, utf8_target,
locinput, &limit, 0, utf8_target, utf8_fold_flags))
{
sayNO;
@@ -6122,7 +6124,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
(type == REF ||
UCHARAT(s) != fold_array[nextchr]))
sayNO;
- ln = rex->offs[n].end - ln;
+ ln = endref - ln;
if (locinput + ln > reginfo->strend)
sayNO;
if (ln > 1 && (type == REF
diff --git a/t/re/pat.t b/t/re/pat.t
index 2f18aa8..b274100 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -23,7 +23,7 @@ BEGIN {
skip_all_without_unicode_tables();
}
-plan tests => 777; # Update this when adding/deleting tests.
+plan tests => 778; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1715,6 +1715,20 @@ EOP
utf8::upgrade($str);
ok( $str =~ m{^(a|a\x{e4})$}, "fix [perl #129950] - utf8 case" );
}
+ {
+ # [perl #129377] backref to an unmatched capture should not cause
+ # reading before start of string.
+ SKIP: {
+ skip "no re-debug under miniperl" if is_miniperl;
+ my $prog = <<'EOP';
+use re qw(Debug EXECUTE);
+"x" =~ m{ () y | () \1 }x;
+EOP
+ fresh_perl_like($prog, qr{
+ \A (?! .* ^ \s+ - )
+ }msx, { stderr => 1 }, "Offsets in debug output are not negative");
+ }
+ }
} # End of sub run_tests
1;
--
2.7.4

View File

@ -0,0 +1,50 @@
From 976900025e7327873d86550633c9c9a9200fa73d Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Sun, 19 Feb 2017 10:46:09 +0000
Subject: [PATCH] update pointer into PL_linestr after lookahead
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to: 5.22.3:
commit 90f2cc9a600117a49f8ee3e30cc681f062350c24
Author: Hugo van der Sanden <hv@crypt.org>
Date: Sun Feb 19 10:46:09 2017 +0000
[perl #130814] update pointer into PL_linestr after lookahead
Looking ahead for the "Missing $ on loop variable" diagnostic can reallocate
PL_linestr, invalidating our pointer. Save the offset so we can update it
in that case.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
toke.c | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/toke.c b/toke.c
index 999eb2c..da3ff73 100644
--- a/toke.c
+++ b/toke.c
@@ -7318,6 +7318,7 @@ Perl_yylex(pTHX)
s = skipspace(s);
if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
char *p = s;
+ SSize_t s_off = s - SvPVX(PL_linestr);
if ((PL_bufend - p) >= 3 &&
strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
@@ -7333,6 +7334,9 @@ Perl_yylex(pTHX)
}
if (*p != '$')
Perl_croak(aTHX_ "Missing $ on loop variable");
+
+ /* The buffer may have been reallocated, update s */
+ s = SvPVX(PL_linestr) + s_off;
}
OPERATOR(FOR);
--
2.7.4

View File

@ -0,0 +1,81 @@
From 9c27a78d1d66d355c5d7d1502d057667bb66deb3 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 21 Feb 2017 16:38:36 +1100
Subject: [PATCH] (perl #130822) fix an AV leak in Perl_reg_named_buff_fetch
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.3:
commit 853eb961c1a3b014b5a9510740abc15ccd4383b6
Author: Tony Cook <tony@develop-help.com>
Date: Tue Feb 21 16:38:36 2017 +1100
(perl #130822) fix an AV leak in Perl_reg_named_buff_fetch
Originally noted as a scoping issue by Andy Lester.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 5 +----
t/op/svleak.t | 12 +++++++++++-
2 files changed, 12 insertions(+), 5 deletions(-)
diff --git a/regcomp.c b/regcomp.c
index bf4011e..777b5cc 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -7478,21 +7478,18 @@ SV*
Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
const U32 flags)
{
- AV *retarray = NULL;
SV *ret;
struct regexp *const rx = ReANY(r);
PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
- if (flags & RXapif_ALL)
- retarray=newAV();
-
if (rx && RXp_PAREN_NAMES(rx)) {
HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
if (he_str) {
IV i;
SV* sv_dat=HeVAL(he_str);
I32 *nums=(I32*)SvPVX(sv_dat);
+ AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
for ( i=0; i<SvIVX(sv_dat); i++ ) {
if ((I32)(rx->nparens) >= nums[i]
&& rx->offs[nums[i]].start != -1
diff --git a/t/op/svleak.t b/t/op/svleak.t
index 076f2bf..2842aa7 100644
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
use Config;
-plan tests => 129;
+plan tests => 130;
# run some code N times. If the number of SVs at the end of loop N is
# greater than (N-1)*delta at the end of loop 1, we've got a leak
@@ -493,3 +493,13 @@ $x = $mdr::a[0]{foo}{$mdr::k}{$mdr::i};
$x = $mdr::h[0]{foo}{$mdr::k}{$mdr::i};
$x = $mdr::r->[0]{foo}{$mdr::k}{$mdr::i};
EOF
+
+{
+ # Perl_reg_named_buff_fetch() leaks an AV when called with an RE
+ # with no named captures
+ sub named {
+ "x" =~ /x/;
+ re::regname("foo", 1);
+ }
+ ::leak(2, 0, \&named, "Perl_reg_named_buff_fetch() on no-name RE");
+}
--
2.7.4

View File

@ -0,0 +1,295 @@
From 2501db6be20dce5e31432f8aecdff262e377390b Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 1 Jun 2017 15:11:27 +1000
Subject: [PATCH] improve duplication of :via handles
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.22.3:
commit 99b847695211f825df6299aa9da91f9494f741e2
Author: Tony Cook <tony@develop-help.com>
Date: Thu Jun 1 15:11:27 2017 +1000
[perl #131221] improve duplication of :via handles
Previously duplication (as with open ... ">&...") would fail
unless the user supplied a GETARG, which wasn't documented, and
resulted in an attempt to free and unreferened scalar if supplied.
Cloning on thread creation was simply broken.
We now handle GETARG correctly, and provide a useful default if it
returns nothing.
Cloning on thread creation now duplicates the appropriate parts of the
parent thread's handle.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
ext/PerlIO-via/t/thread.t | 73 +++++++++++++++++++++++++++++++++++++++++++++++
ext/PerlIO-via/t/via.t | 56 +++++++++++++++++++++++++++++++++++-
ext/PerlIO-via/via.xs | 55 +++++++++++++++++++++++++++++++----
4 files changed, 178 insertions(+), 7 deletions(-)
create mode 100644 ext/PerlIO-via/t/thread.t
diff --git a/MANIFEST b/MANIFEST
index c326d91..b2b78b0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3694,6 +3694,7 @@ ext/PerlIO-scalar/scalar.xs PerlIO layer for scalars
ext/PerlIO-scalar/t/scalar.t See if PerlIO::scalar works
ext/PerlIO-scalar/t/scalar_ungetc.t Tests for PerlIO layer for scalars
ext/PerlIO-via/hints/aix.pl Hint for PerlIO::via for named architecture
+ext/PerlIO-via/t/thread.t See if PerlIO::via works with threads
ext/PerlIO-via/t/via.t See if PerlIO::via works
ext/PerlIO-via/via.pm PerlIO layer for layers in perl
ext/PerlIO-via/via.xs PerlIO layer for layers in perl
diff --git a/ext/PerlIO-via/t/thread.t b/ext/PerlIO-via/t/thread.t
new file mode 100644
index 0000000..e4358f9
--- /dev/null
+++ b/ext/PerlIO-via/t/thread.t
@@ -0,0 +1,73 @@
+#!perl
+BEGIN {
+ unless (find PerlIO::Layer 'perlio') {
+ print "1..0 # Skip: not perlio\n";
+ exit 0;
+ }
+ require Config;
+ unless ($Config::Config{'usethreads'}) {
+ print "1..0 # Skip -- need threads for this test\n";
+ exit 0;
+ }
+ if (($Config::Config{'extensions'} !~ m!\bPerlIO/via\b!) ){
+ print "1..0 # Skip -- Perl configured without PerlIO::via module\n";
+ exit 0;
+ }
+}
+
+use strict;
+use warnings;
+use threads;
+
+my $tmp = "via$$";
+
+END {
+ 1 while unlink $tmp;
+}
+
+use Test::More tests => 2;
+
+our $push_count = 0;
+
+{
+ open my $fh, ">:via(Test1)", $tmp
+ or die "Cannot open $tmp: $!";
+ $fh->autoflush;
+
+ print $fh "AXAX";
+
+ # previously this would crash
+ threads->create(
+ sub {
+ print $fh "XZXZ";
+ })->join;
+
+ print $fh "BXBX";
+ close $fh;
+
+ open my $in, "<", $tmp;
+ my $line = <$in>;
+ close $in;
+
+ is($line, "AYAYYZYZBYBY", "check thread data delivered");
+
+ is($push_count, 1, "PUSHED not called for dup on thread creation");
+}
+
+package PerlIO::via::Test1;
+
+sub PUSHED {
+ my ($class) = @_;
+ ++$main::push_count;
+ bless {}, $class;
+}
+
+sub WRITE {
+ my ($self, $data, $fh) = @_;
+ $data =~ tr/X/Y/;
+ $fh->autoflush;
+ print $fh $data;
+ return length $data;
+}
+
+
diff --git a/ext/PerlIO-via/t/via.t b/ext/PerlIO-via/t/via.t
index 0619592..c390172 100644
--- a/ext/PerlIO-via/t/via.t
+++ b/ext/PerlIO-via/t/via.t
@@ -17,7 +17,7 @@ use warnings;
my $tmp = "via$$";
-use Test::More tests => 18;
+use Test::More tests => 26;
my $fh;
my $a = join("", map { chr } 0..255) x 10;
@@ -84,6 +84,60 @@ is( $obj, 'Foo', 'search for package Foo' );
open $fh, '<:via(Bar)', "bar";
is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' );
+{
+ # [perl #131221]
+ ok(open(my $fh1, ">", $tmp), "open $tmp");
+ ok(binmode($fh1, ":via(XXX)"), "binmode :via(XXX) onto it");
+ ok(open(my $fh2, ">&", $fh1), "dup it");
+ close $fh1;
+ close $fh2;
+
+ # make sure the old workaround still works
+ ok(open($fh1, ">", $tmp), "open $tmp");
+ ok(binmode($fh1, ":via(YYY)"), "binmode :via(YYY) onto it");
+ ok(open($fh2, ">&", $fh1), "dup it");
+ print $fh2 "XZXZ";
+ close $fh1;
+ close $fh2;
+
+ ok(open($fh1, "<", $tmp), "open $tmp for check");
+ { local $/; $b = <$fh1> }
+ close $fh1;
+ is($b, "XZXZ", "check result is from non-filtering class");
+
+ package PerlIO::via::XXX;
+
+ sub PUSHED {
+ my $class = shift;
+ bless {}, $class;
+ }
+
+ sub WRITE {
+ my ($self, $buffer, $handle) = @_;
+
+ print $handle $buffer;
+ return length($buffer);
+ }
+ package PerlIO::via::YYY;
+
+ sub PUSHED {
+ my $class = shift;
+ bless {}, $class;
+ }
+
+ sub WRITE {
+ my ($self, $buffer, $handle) = @_;
+
+ $buffer =~ tr/X/Y/;
+ print $handle $buffer;
+ return length($buffer);
+ }
+
+ sub GETARG {
+ "XXX";
+ }
+}
+
END {
1 while unlink $tmp;
}
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
index d7a037b..e86f655 100644
--- a/ext/PerlIO-via/via.xs
+++ b/ext/PerlIO-via/via.xs
@@ -38,6 +38,8 @@ typedef struct
CV *UTF8;
} PerlIOVia;
+static const MGVTBL PerlIOVia_tag = { 0, 0, 0, 0, 0, 0, 0, 0 };
+
#define MYMethod(x) #x,&s->x
CV *
@@ -131,8 +133,14 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
+
+ if (SvTYPE(arg) >= SVt_PVMG
+ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
+ return code;
+ }
+
if (code == 0) {
- PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
+ PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
if (!arg) {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER),
@@ -583,20 +591,55 @@ SV *
PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
{
PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
- PERL_UNUSED_ARG(param);
+ SV *arg;
PERL_UNUSED_ARG(flags);
- return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
+
+ /* During cloning, return an undef token object so that _pushed() knows
+ * that it should not call methods and wait for _dup() to actually dup the
+ * object. */
+ if (param) {
+ SV *sv = newSV(0);
+ sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOVia_tag, 0, 0);
+ return sv;
+ }
+
+ arg = PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
+ if (arg) {
+ /* arg is a temp, and PerlIOBase_dup() will explicitly free it */
+ SvREFCNT_inc(arg);
+ }
+ else {
+ arg = newSVpvn(HvNAME(s->stash), HvNAMELEN(s->stash));
+ }
+
+ return arg;
}
PerlIO *
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
int flags)
{
- if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
- /* Most of the fields will lazily set themselves up as needed
- stash and obj have been set up by the implied push
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)) && param) {
+ /* For a non-interpreter dup stash and obj have been set up
+ by the implied push.
+
+ But if this is a clone for a new interpreter we need to
+ translate the objects to their dups.
*/
+
+ PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
+ PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
+
+ fs->obj = sv_dup_inc(os->obj, param);
+ fs->stash = (HV*)sv_dup((SV*)os->stash, param);
+ fs->var = sv_dup_inc(os->var, param);
+ fs->cnt = os->cnt;
+
+ /* fh, io, cached CVs left as NULL, PerlIOVia_method()
+ will reinitialize them if needed */
}
+ /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
+
return f;
}
--
2.9.4

View File

@ -0,0 +1,94 @@
From 7778ccd83efc90dd4c0635d67184bcf9ace5b4ce Mon Sep 17 00:00:00 2001
From: Zefram <zefram@fysh.org>
Date: Mon, 23 Jan 2017 02:25:50 +0000
Subject: [PATCH] permit goto at top level of multicalled sub
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Písař: Ported to 5.22.3:
commit 3c157b3cf0631c69ffa5aa2d55b9199bf93b22a9
Author: Zefram <zefram@fysh.org>
Date: Mon Jan 23 02:25:50 2017 +0000
permit goto at top level of multicalled sub
A multicalled sub is reckoned to be a pseudo block, out of which it is
not permissible to goto. However, the test for a pseudo block was being
applied too early, preventing not just escape from a multicalled sub but
also a goto at the top level within the sub. This is a bug similar, but
not identical, to [perl #113938]. Now the test is deferred, permitting
goto at the sub's top level but still forbidding goto out of it.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_ctl.c | 11 ++++++-----
t/op/goto.t | 11 ++++++++++-
2 files changed, 16 insertions(+), 6 deletions(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index 74005a6..ad06186 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3023,6 +3023,7 @@ PP(pp_goto)
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
+ bool pseudo_block = FALSE;
PERL_CONTEXT *last_eval_cx = NULL;
/* find label */
@@ -3060,11 +3061,9 @@ PP(pp_goto)
gotoprobe = PL_main_root;
break;
case CXt_SUB:
- if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
- gotoprobe = CvROOT(cx->blk_sub.cv);
- break;
- }
- /* FALLTHROUGH */
+ gotoprobe = CvROOT(cx->blk_sub.cv);
+ pseudo_block = cBOOL(CxMULTICALL(cx));
+ break;
case CXt_FORMAT:
case CXt_NULL:
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
@@ -3093,6 +3092,8 @@ PP(pp_goto)
break;
}
}
+ if (pseudo_block)
+ DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
PL_lastgotoprobe = gotoprobe;
}
if (!retop)
diff --git a/t/op/goto.t b/t/op/goto.t
index ca48ac0..ca8fa08 100644
--- a/t/op/goto.t
+++ b/t/op/goto.t
@@ -10,7 +10,7 @@ BEGIN {
use warnings;
use strict;
-plan tests => 94;
+plan tests => 95;
our $TODO;
my $deprecated = 0;
@@ -702,3 +702,12 @@ sub FETCH { $_[0][0] }
tie my $t, "", sub { "cluck up porridge" };
is eval { sub { goto $t }->() }//$@, 'cluck up porridge',
'tied arg returning sub ref';
+
+sub revnumcmp ($$) {
+ goto FOO;
+ die;
+ FOO:
+ return $_[1] <=> $_[0];
+}
+is eval { join(":", sort revnumcmp (9,5,1,3,7)) }, "9:7:5:3:1",
+ "can goto at top level of multicalled sub";
--
2.7.4

View File

@ -0,0 +1,160 @@
From 0ee3fa26f660ac426e3e082f77d806c9d1471f93 Mon Sep 17 00:00:00 2001
From: Vincent Pit <perl@profvince.com>
Date: Fri, 28 Aug 2015 14:17:00 -0300
Subject: [PATCH] Properly duplicate PerlIO::encoding objects
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
PerlIO::encoding objects are usually initialized by calling Perl methods,
essentially from the pushed() and getarg() callbacks. During cloning, the
PerlIO API will by default call these methods to initialize the duplicate
struct when the PerlIOBase parent struct is itself duplicated. This does
not behave so well because the perl interpreter is not ready to call
methods at this point, for the stacks are not set up yet.
The proper way to duplicate the PerlIO::encoding object is to call sv_dup()
on its members from the dup() PerlIO callback. So the only catch is to make
the getarg() and pushed() calls implied by the duplication of the underlying
PerlIOBase object aware that they are called during cloning, and make them
wait that the control flow returns to the dup() callback. Fortunately,
getarg() knows since its param argument is then non-null, and its return
value is passed immediately to pushed(), so it is enough to tag this
returned value with a custom magic so that pushed() can see it is being
called during cloning.
This fixes [RT #31923].
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
ext/PerlIO-encoding/encoding.pm | 2 +-
ext/PerlIO-encoding/encoding.xs | 25 +++++++++++++++++++++++--
ext/PerlIO-encoding/t/threads.t | 35 +++++++++++++++++++++++++++++++++++
4 files changed, 60 insertions(+), 3 deletions(-)
create mode 100644 ext/PerlIO-encoding/t/threads.t
diff --git a/MANIFEST b/MANIFEST
index f79df00..34c2e24 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3753,6 +3753,7 @@ ext/PerlIO-encoding/encoding.xs PerlIO::encoding
ext/PerlIO-encoding/t/encoding.t See if PerlIO encoding conversion works
ext/PerlIO-encoding/t/fallback.t See if PerlIO fallbacks work
ext/PerlIO-encoding/t/nolooping.t Tests for PerlIO::encoding
+ext/PerlIO-encoding/t/threads.t Tests PerlIO::encoding and threads
ext/PerlIO-mmap/mmap.pm PerlIO layer for memory maps
ext/PerlIO-mmap/mmap.xs PerlIO layer for memory maps
ext/PerlIO-scalar/scalar.pm PerlIO layer for scalars
diff --git a/ext/PerlIO-encoding/encoding.pm b/ext/PerlIO-encoding/encoding.pm
index 4cff76d..97f05ec 100644
--- a/ext/PerlIO-encoding/encoding.pm
+++ b/ext/PerlIO-encoding/encoding.pm
@@ -1,7 +1,7 @@
package PerlIO::encoding;
use strict;
-our $VERSION = '0.21';
+our $VERSION = '0.22';
our $DEBUG = 0;
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs
index 03b8850..3575d72 100644
--- a/ext/PerlIO-encoding/encoding.xs
+++ b/ext/PerlIO-encoding/encoding.xs
@@ -49,13 +49,23 @@ typedef struct {
#define NEEDS_LINES 1
+static const MGVTBL PerlIOEncode_tag = { 0, 0, 0, 0, 0, 0, 0, 0 };
+
SV *
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
- SV *sv = &PL_sv_undef;
- PERL_UNUSED_ARG(param);
+ SV *sv;
PERL_UNUSED_ARG(flags);
+ /* During cloning, return an undef token object so that _pushed() knows
+ * that it should not call methods and wait for _dup() to actually dup the
+ * encoding object. */
+ if (param) {
+ sv = newSV(0);
+ sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOEncode_tag, 0, 0);
+ return sv;
+ }
+ sv = &PL_sv_undef;
if (e->enc) {
dSP;
/* Not 100% sure stack swap is right thing to do during dup ... */
@@ -85,6 +95,14 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *
IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
SV *result = Nullsv;
+ if (SvTYPE(arg) >= SVt_PVMG
+ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOEncode_tag)) {
+ e->enc = NULL;
+ e->chk = NULL;
+ e->inEncodeCall = 0;
+ return code;
+ }
+
PUSHSTACKi(PERLSI_MAGIC);
ENTER;
SAVETMPS;
@@ -566,6 +584,9 @@ PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
if (oe->enc) {
fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
}
+ if (oe->chk) {
+ fe->chk = PerlIO_sv_dup(aTHX_ oe->chk, params);
+ }
}
return f;
}
diff --git a/ext/PerlIO-encoding/t/threads.t b/ext/PerlIO-encoding/t/threads.t
new file mode 100644
index 0000000..64f0e55
--- /dev/null
+++ b/ext/PerlIO-encoding/t/threads.t
@@ -0,0 +1,35 @@
+#!perl
+
+use strict;
+use warnings;
+
+BEGIN {
+ use Config;
+ if ($Config{extensions} !~ /\bEncode\b/) {
+ print "1..0 # Skip: no Encode\n";
+ exit 0;
+ }
+ unless ($Config{useithreads}) {
+ print "1..0 # Skip: no threads\n";
+ exit 0;
+ }
+}
+
+use threads;
+
+use Test::More tests => 3 + 1;
+
+binmode *STDOUT, ':encoding(UTF-8)';
+
+SKIP: {
+ local $@;
+ my $ret = eval {
+ my $thread = threads->create(sub { pass 'in thread'; return 1 });
+ skip 'test thread could not be spawned' => 3 unless $thread;
+ $thread->join;
+ };
+ is $@, '', 'thread did not croak';
+ is $ret, 1, 'thread returned the right value';
+}
+
+pass 'passes at least one test';
--
2.5.5

View File

@ -0,0 +1,45 @@
From a51d828a6d402f30f37707c714de218f6b47dbd8 Mon Sep 17 00:00:00 2001
From: Dan Collins <dcollinsn@gmail.com>
Date: Sun, 4 Sep 2016 14:43:41 -0400
Subject: [PATCH] Regression test for RT #129196
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.0:
commit a6128716d2cc20147851e0a37768376647bd3242
Author: Dan Collins <dcollinsn@gmail.com>
Date: Sun Sep 4 14:43:41 2016 -0400
Regression test for RT #129196
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/op/evalbytes.t | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/t/op/evalbytes.t b/t/op/evalbytes.t
index cca7c04..5e2af76 100644
--- a/t/op/evalbytes.t
+++ b/t/op/evalbytes.t
@@ -6,7 +6,7 @@ BEGIN {
require './test.pl'; require './charset_tools.pl';
}
-plan(tests => 8);
+plan(tests => 9);
{
local $SIG{__WARN__} = sub {};
@@ -33,3 +33,7 @@ chop($upcode = "use utf8; $U_100" . chr 256);
is evalbytes $upcode, chr 256, 'use utf8 within evalbytes on utf8 string';
eval { evalbytes chr 256 };
like $@, qr/Wide character/, 'evalbytes croaks on non-bytes';
+
+eval 'evalbytes S';
+ok 1, '[RT #129196] evalbytes S should not segfault';
+
--
2.7.4

View File

@ -0,0 +1,94 @@
From af04cb4d2503c5c75d2229e232b8a0bd5c210084 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 13 Sep 2016 23:06:07 +0200
Subject: [PATCH] clean up gv_fetchmethod_pvn_flags: introduce name_end
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.0:
commit 65308f87d02a1900e59f0002fa94c855d4d4c5df
Author: Yves Orton <demerphq@gmail.com>
Date: Tue Sep 13 23:06:07 2016 +0200
clean up gv_fetchmethod_pvn_flags: introduce name_end
nend is used for too many things, this replaces various
uses of nend with name_end, which is constant.
this is a first step to fixing [perl #129267], which shouldnt
change any behavior
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
gv.c | 14 ++++++++------
1 file changed, 8 insertions(+), 6 deletions(-)
diff --git a/gv.c b/gv.c
index 28396de..d738bf0 100644
--- a/gv.c
+++ b/gv.c
@@ -1014,6 +1014,8 @@ Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
GV *
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
{
+ const char * const origname = name;
+ const char * const name_end = name + len;
const char *nend;
const char *nsplit = NULL;
GV* gv;
@@ -1034,7 +1036,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
the error reporting code. */
}
- for (nend = name; *nend || nend != (origname + len); nend++) {
+ for (nend = name; *nend || nend != name_end; nend++) {
if (*nend == '\'') {
nsplit = nend;
name = nend + 1;
@@ -1065,13 +1067,13 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
ostash = stash;
}
- gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
+ gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = MUTABLE_GV(&PL_sv_yes);
else if (autoload)
gv = gv_autoload_pvn(
- ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
+ ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
);
if (!gv && do_croak) {
/* Right now this is exclusively for the benefit of S_method_common
@@ -1087,14 +1089,14 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
HV_FETCH_ISEXISTS, NULL, 0)
) {
require_pv("IO/File.pm");
- gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
+ gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
if (gv)
return gv;
}
Perl_croak(aTHX_
"Can't locate object method \"%"UTF8f
"\" via package \"%"HEKf"\"",
- UTF8fARG(is_utf8, nend - name, name),
+ UTF8fARG(is_utf8, name_end - name, name),
HEKfARG(HvNAME_HEK(stash)));
}
else {
@@ -1111,7 +1113,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
"Can't locate object method \"%"UTF8f
"\" via package \"%"SVf"\""
" (perhaps you forgot to load \"%"SVf"\"?)",
- UTF8fARG(is_utf8, nend - name, name),
+ UTF8fARG(is_utf8, name_end - name, name),
SVfARG(packnamesv), SVfARG(packnamesv));
}
}
--
2.7.4

View File

@ -0,0 +1,92 @@
From 03fcc0c44bc7972f2c92736daae5b63d601b7c49 Mon Sep 17 00:00:00 2001
From: Dan Collins <dcollinsn@gmail.com>
Date: Fri, 23 Sep 2016 01:21:20 -0400
Subject: [PATCH] [rt #129336] #!perl -i u erroneously interpreted as -u
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.0:
commit f54cfdacff1f3744ef08fc70f1f3bc6c7d862e83
Author: Dan Collins <dcollinsn@gmail.com>
Date: Fri Sep 23 01:21:20 2016 -0400
[rt #129336] #!perl -i u erroneously interpreted as -u
Perl_moreswitches processes a single switch, and returns a pointer
to the start of the next switch. It can return either
the a pointer to the next flag itself:
#!perl -n -p
^ Can point here
Or, to the space before the next "arg":
#!perl -n -p
^ Can point here
(Where the next call to Perl_moreswitches will consume " -".)
In the case of -i[extension], the pointer is by default pointing at
the space after the end of the argument. The current code tries to
do the former, by unconditionally advancing the pointer, and then
advancing it again if it is on a '-'. But that is incorrect:
#!perl -i p
^ Will point here, but that isn't a flag
I could fix this by removing the unconditional s++, and having it
increment by 2 if *(s+1)=='-', but this work isn't actually
necessary - it's better to just leave it pointing at the space after
the argument.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
perl.c | 5 -----
t/op/lex.t | 9 ++++++++-
2 files changed, 8 insertions(+), 6 deletions(-)
diff --git a/perl.c b/perl.c
index 228a0d8..5cc7d0b 100644
--- a/perl.c
+++ b/perl.c
@@ -3306,11 +3306,6 @@ Perl_moreswitches(pTHX_ const char *s)
PL_inplace = savepvn(start, s - start);
}
- if (*s) {
- ++s;
- if (*s == '-') /* Additional switches on #! line. */
- s++;
- }
return s;
case 'I': /* -I handled both here and in parse_body() */
forbid_setid('I', FALSE);
diff --git a/t/op/lex.t b/t/op/lex.t
index c515449..9ada592 100644
--- a/t/op/lex.t
+++ b/t/op/lex.t
@@ -7,7 +7,7 @@ use warnings;
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 25);
+plan(tests => 26);
{
no warnings 'deprecated';
@@ -209,3 +209,10 @@ fresh_perl_is(
{ stderr => 1 },
's;@{<<a; [perl #123995]'
);
+
+fresh_perl_like(
+ "#!perl -i u\nprint 'OK'",
+ qr/OK/,
+ {},
+ '[perl #129336] - #!perl -i argument handling'
+);
--
2.7.4

View File

@ -0,0 +1,94 @@
From 27a8a9e2a55ccc148582006396a9c35bafa5f0b3 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Wed, 30 Nov 2016 08:59:01 +0000
Subject: [PATCH] split was leaving PL_sv_undef in unused ary slots
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Pisar: Ported to 5.24.0:
commit 71ca73e5fa9639ac33e9f2e74cd0c32288a5040d
Author: David Mitchell <davem@iabyn.com>
Date: Wed Nov 30 08:59:01 2016 +0000
split was leaving PL_sv_undef in unused ary slots
This:
@a = split(/-/,"-");
$a[1] = undef;
$a[0] = 0;
was giving
Modification of a read-only value attempted at foo line 3.
This is because:
1) unused slots in AvARRAY between AvFILL and AvMAX should always be
null; av_clear(), av_extend() etc do this; while av_store(), if storing
to a slot N somewhere between AvFILL and AvMAX, doesn't bother to clear
between (AvFILL+1)..(N-1) on the assumption that everyone else plays
nicely.
2) pp_split() when splitting directly to an array, sometimes over-splits
and has to null out the excess elements;
3) Since perl 5.19.4, unused AV slots are now marked with NULL rather than
&PL_sv_undef;
4) pp_split was still using &PL_sv_undef;
The fault was with (4), and is easily fixed.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp.c | 2 +-
t/op/split.t | 13 ++++++++++++-
2 files changed, 13 insertions(+), 2 deletions(-)
diff --git a/pp.c b/pp.c
index 4153482..70345ce 100644
--- a/pp.c
+++ b/pp.c
@@ -6212,7 +6212,7 @@ PP(pp_split)
while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
if (TOPs && !make_mortal)
sv_2mortal(TOPs);
- *SP-- = &PL_sv_undef;
+ *SP-- = NULL;
iters--;
}
}
diff --git a/t/op/split.t b/t/op/split.t
index fb73271..b7846a1 100644
--- a/t/op/split.t
+++ b/t/op/split.t
@@ -7,7 +7,7 @@ BEGIN {
set_up_inc('../lib');
}
-plan tests => 131;
+plan tests => 133;
$FS = ':';
@@ -523,3 +523,14 @@ is "@a", '1 2 3', 'assignment to split-to-array (pmtarget/package array)';
}
(@{\@a} = split //, "abc") = 1..10;
is "@a", '1 2 3', 'assignment to split-to-array (stacked)';
+
+# splitting directly to an array wasn't filling unused AvARRAY slots with
+# NULL
+
+{
+ my @a;
+ @a = split(/-/,"-");
+ $a[1] = 'b';
+ ok eval { $a[0] = 'a'; 1; }, "array split filling AvARRAY: assign 0";
+ is "@a", "a b", "array split filling AvARRAY: result";
+}
--
2.7.4

View File

@ -0,0 +1,70 @@
From 4e0fb37303b72ed9d38949139c304abdb73e223e Mon Sep 17 00:00:00 2001
From: Aaron Crane <arc@cpan.org>
Date: Tue, 24 Jan 2017 23:39:40 +0000
Subject: [PATCH] RT#130624: heap-use-after-free in 4-arg substr
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit 41b1e858a075694f88057b9514f5fc78c80b5355
Author: Aaron Crane <arc@cpan.org>
Date: Tue Jan 24 23:39:40 2017 +0000
RT#130624: heap-use-after-free in 4-arg substr
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp.c | 4 +++-
t/op/substr.t | 14 +++++++++++++-
2 files changed, 16 insertions(+), 2 deletions(-)
diff --git a/pp.c b/pp.c
index 334b353..aa6cff0 100644
--- a/pp.c
+++ b/pp.c
@@ -3462,8 +3462,10 @@ PP(pp_substr)
tmps = SvPV_force_nomg(sv, curlen);
if (DO_UTF8(repl_sv) && repl_len) {
if (!DO_UTF8(sv)) {
+ /* Upgrade the dest, and recalculate tmps in case the buffer
+ * got reallocated; curlen may also have been changed */
sv_utf8_upgrade_nomg(sv);
- curlen = SvCUR(sv);
+ tmps = SvPV_nomg(sv, curlen);
}
}
else if (DO_UTF8(sv))
diff --git a/t/op/substr.t b/t/op/substr.t
index 01c36a9..f9fee48 100644
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -22,7 +22,7 @@ $SIG{__WARN__} = sub {
}
};
-plan(389);
+plan(391);
run_tests() unless caller;
@@ -872,3 +872,15 @@ is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
# failed with ASAN
fresh_perl_is('$0 = "/usr/bin/perl"; substr($0, 0, 0, $0)', '', {}, "(perl #129340) substr() with source in target");
+
+
+# [perl #130624] - heap-use-after-free, observable under asan
+{
+ my $x = "\xE9zzzz";
+ my $y = "\x{100}";
+ my $z = substr $x, 0, 1, $y;
+ is $z, "\xE9", "RT#130624: heap-use-after-free in 4-arg substr (ret)";
+ is $x, "\x{100}zzzz", "RT#130624: heap-use-after-free in 4-arg substr (targ)";
+}
+
+
--
2.7.4

View File

@ -0,0 +1,93 @@
From fd25d49cae6409a4ce901fd4d899a197541604b3 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Sat, 4 Feb 2017 15:10:49 +0000
Subject: [PATCH] buffer overrun with format and 'use bytes'
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit e452bf1c9e9f30813b1f289188a6e8b0894575ba
Author: David Mitchell <davem@iabyn.com>
Date: Sat Feb 4 15:10:49 2017 +0000
buffer overrun with format and 'use bytes'
RT #130703
In the scope of 'use bytes', appending a string to a format where the
format is utf8 and the string is non-utf8 but contains lots of chars
with ords >= 128, the buffer could be overrun. This is due to all the
\x80-type chars going from being stored as 1 bytes to 2 bytes, without
growing PL_formtarget accordingly.
This commit contains a minimal fix; the next commit will more generally
tidy up the grow code in pp_formline.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_ctl.c | 3 +++
t/op/write.t | 18 +++++++++++++++++-
2 files changed, 20 insertions(+), 1 deletion(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index a1fc2f4..4d5ef2e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -505,6 +505,8 @@ PP(pp_formline)
SvTAINTED_on(PL_formtarget);
if (DO_UTF8(PL_formtarget))
targ_is_utf8 = TRUE;
+ /* this is an initial estimate of how much output buffer space
+ * to allocate. It may be exceeded later */
linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
t = SvGROW(PL_formtarget, len + linemax + 1);
/* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
@@ -766,6 +768,7 @@ PP(pp_formline)
if (targ_is_utf8 && !item_is_utf8) {
source = tmp = bytes_to_utf8(source, &to_copy);
+ grow = to_copy;
} else {
if (item_is_utf8 && !targ_is_utf8) {
U8 *s;
diff --git a/t/op/write.t b/t/op/write.t
index ab2733f..ae4ddb5 100644
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -98,7 +98,7 @@ for my $tref ( @NumTests ){
my $bas_tests = 21;
# number of tests in section 3
-my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 3;
+my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 4;
# number of tests in section 4
my $hmb_tests = 37;
@@ -1562,6 +1562,22 @@ ok defined *{$::{CmT}}{FORMAT}, "glob assign";
formline $format, $orig, 12345;
is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
+ # ...nor this (RT #130703).
+ # Under 'use bytes', the two bytes (c2, 80) making up each \x80 char
+ # each get expanded to two bytes (so four in total per \x80 char); the
+ # buffer growth wasn't accounting for this doubling in size
+
+ {
+ local $^A = '';
+ my $format = "X\n\x{100}" . ("\x80" x 200);
+ my $expected = $format;
+ utf8::encode($expected);
+ use bytes;
+ formline($format);
+ is $^A, $expected, "RT #130703";
+ }
+
+
# make sure it can cope with formats > 64k
$format = 'x' x 65537;
--
2.7.4

View File

@ -0,0 +1,107 @@
From 0c43d46cd570d2a19edfa54b9c637dea5c0a3514 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 19 Jan 2017 16:28:03 +1100
Subject: [PATCH] (perl #129125) copy form data if it might be freed
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit 86191aed6f092273950ebdd48f886d4ec0c5e85e
Author: Tony Cook <tony@develop-help.com>
Date: Thu Jan 19 16:28:03 2017 +1100
(perl #129125) copy form data if it might be freed
If the format SV also appeared as an argument, and the FF_CHOP
operator modified that argument, the magic and hence the compiled
format would be freed, and the next iteration of the processing
the compiled format would read freed memory.
Unlike my original patch this copies the formsv too, since
that is also stored in the magic, and is needed for presenting
literal text from the format.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_ctl.c | 18 ++++++++++++++++++
t/op/write.t | 19 ++++++++++++++++++-
2 files changed, 36 insertions(+), 1 deletion(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index b94c09a..e859e01 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -490,6 +490,7 @@ PP(pp_formline)
U8 *source; /* source of bytes to append */
STRLEN to_copy; /* how may bytes to append */
char trans; /* what chars to translate */
+ bool copied_form = false; /* have we duplicated the form? */
mg = doparseform(tmpForm);
@@ -687,6 +688,23 @@ PP(pp_formline)
case FF_CHOP: /* (for ^*) chop the current item */
if (sv != &PL_sv_no) {
const char *s = chophere;
+ if (!copied_form &&
+ ((sv == tmpForm || SvSMAGICAL(sv))
+ || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
+ /* sv and tmpForm are either the same SV, or magic might allow modification
+ of tmpForm when sv is modified, so copy */
+ SV *newformsv = sv_mortalcopy(formsv);
+ U32 *new_compiled;
+
+ f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
+ Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
+ memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
+ SAVEFREEPV(new_compiled);
+ fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
+ formsv = newformsv;
+
+ copied_form = true;
+ }
if (chopspace) {
while (isSPACE(*s))
s++;
diff --git a/t/op/write.t b/t/op/write.t
index 590d658..ab2733f 100644
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -98,7 +98,7 @@ for my $tref ( @NumTests ){
my $bas_tests = 21;
# number of tests in section 3
-my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 11 + 3;
+my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 3;
# number of tests in section 4
my $hmb_tests = 37;
@@ -1637,6 +1637,23 @@ printf ">%s<\n", ref $zamm;
print "$zamm->[0]\n";
EOP
+# [perl #129125] - detected by -fsanitize=address or valgrind
+# the compiled format would be freed when the format string was modified
+# by the chop operator
+fresh_perl_is(<<'EOP', "^", { stderr => 1 }, '#129125 - chop on format');
+my $x = '^@';
+formline$x=>$x;
+print $^A;
+EOP
+
+fresh_perl_is(<<'EOP', '<^< xx AA><xx ^<><>', { stderr => 1 }, '#129125 - chop on format, later values');
+my $x = '^< xx ^<';
+my $y = 'AA';
+formline $x => $x, $y;
+print "<$^A><$x><$y>";
+EOP
+
+
# [perl #73690]
select +(select(RT73690), do {
--
2.7.4

View File

@ -0,0 +1,73 @@
From a26907949ed561dccd661fc8600889eddc6664ea Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Wed, 5 Oct 2016 14:53:27 +0100
Subject: [PATCH] [perl #129342] ensure range-start is set after error in tr///
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
t 59143e29a717d67a61b869a6c5bb49574f1ef43f
Author: Tony Cook <tony@develop-help.com>
Date: Tue Jan 17 11:52:53 2017 +1100
(perl #129342) test for buffer overflow
commit 3dd4eaeb8ac39e08179145b86aedda36584a3509
Author: Hugo van der Sanden <hv@crypt.org>
Date: Wed Oct 5 14:53:27 2016 +0100
[perl #129342] ensure range-start is set after error in tr///
A parse error due to invalid octal or hex escape in the range of a
transliteration must still ensure some kind of start and end values
are captured, since we don't stop on the first such error. Failure
to do so can cause invalid reads after "Here we have parsed a range".
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/lib/croak/toke | 7 +++++++
toke.c | 4 ++--
2 files changed, 9 insertions(+), 2 deletions(-)
diff --git a/t/lib/croak/toke b/t/lib/croak/toke
index 18dfa24..578a6da 100644
--- a/t/lib/croak/toke
+++ b/t/lib/croak/toke
@@ -302,3 +302,10 @@ Execution of - aborted due to compilation errors.
BEGIN <>
EXPECT
Illegal declaration of subroutine BEGIN at - line 1.
+########
+# NAME tr/// handling of mis-formatted \o characters
+# may only fail with ASAN
+tr/\o-0//;
+EXPECT
+Missing braces on \o{} at - line 2, within string
+Execution of - aborted due to compilation errors.
diff --git a/toke.c b/toke.c
index 288f372..576ce72 100644
--- a/toke.c
+++ b/toke.c
@@ -3338,7 +3338,7 @@ S_scan_const(pTHX_ char *start)
UTF);
if (! valid) {
yyerror(error);
- continue;
+ uv = 0; /* drop through to ensure range ends are set */
}
goto NUM_ESCAPE_INSERT;
}
@@ -3356,7 +3356,7 @@ S_scan_const(pTHX_ char *start)
UTF);
if (! valid) {
yyerror(error);
- continue;
+ uv = 0; /* drop through to ensure range ends are set */
}
}
--
2.7.4

View File

@ -0,0 +1,62 @@
From 2bcb4a5888b1c26ee11bc447cc02b42290c707af Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 5 Dec 2016 11:48:14 +1100
Subject: [PATCH] (perl #130262) split scalar context stack overflow fix
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.14.1:
commit 02c161ef974f8f1efbb5632f741c1164adb6ca75
Author: Tony Cook <tony@develop-help.com>
Date: Mon Dec 5 11:48:14 2016 +1100
(perl #130262) split scalar context stack overflow fix
pp_split didn't ensure there was space for its return value
in scalar context.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp.c | 2 +-
t/op/split.t | 6 +++++-
2 files changed, 6 insertions(+), 2 deletions(-)
diff --git a/pp.c b/pp.c
index 70345ce..334b353 100644
--- a/pp.c
+++ b/pp.c
@@ -6259,7 +6259,7 @@ PP(pp_split)
}
GETTARGET;
- PUSHi(iters);
+ XPUSHi(iters);
RETURN;
}
diff --git a/t/op/split.t b/t/op/split.t
index b7846a1..3e08841 100644
--- a/t/op/split.t
+++ b/t/op/split.t
@@ -7,7 +7,7 @@ BEGIN {
set_up_inc('../lib');
}
-plan tests => 133;
+plan tests => 134;
$FS = ':';
@@ -534,3 +534,7 @@ is "@a", '1 2 3', 'assignment to split-to-array (stacked)';
ok eval { $a[0] = 'a'; 1; }, "array split filling AvARRAY: assign 0";
is "@a", "a b", "array split filling AvARRAY: result";
}
+
+fresh_perl_is(<<'CODE', '', {}, "scalar split stack overflow");
+map{int"";split//.0>60for"0000000000000000"}split// for"00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
+CODE
--
2.7.4

View File

@ -0,0 +1,72 @@
From be05b2f7a801ae1721641fd240e0d7d6fc018136 Mon Sep 17 00:00:00 2001
From: Aaron Crane <arc@cpan.org>
Date: Sun, 19 Feb 2017 12:26:54 +0000
Subject: [PATCH] fix ck_return null-pointer deref on malformed code
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit e5c165a0b7551ffb94661aa7f18aabadba257782
Author: Aaron Crane <arc@cpan.org>
Date: Sun Feb 19 12:26:54 2017 +0000
[perl #130815] fix ck_return null-pointer deref on malformed code
commit 9de2a80ffc0eefb4d60e13766baf4bad129e0a92
Author: David Mitchell <davem@iabyn.com>
Date: Sun Feb 19 12:36:58 2017 +0000
bump test count in t/comp/parser.t
(the previous commit forgot to)
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
op.c | 2 +-
t/comp/parser.t | 8 +++++++-
2 files changed, 8 insertions(+), 2 deletions(-)
diff --git a/op.c b/op.c
index 018d90c..9a61ea7 100644
--- a/op.c
+++ b/op.c
@@ -10695,7 +10695,7 @@ Perl_ck_return(pTHX_ OP *o)
PERL_ARGS_ASSERT_CK_RETURN;
kid = OpSIBLING(cLISTOPo->op_first);
- if (CvLVALUE(PL_compcv)) {
+ if (PL_compcv && CvLVALUE(PL_compcv)) {
for (; kid; kid = OpSIBLING(kid))
op_lvalue(kid, OP_LEAVESUBLV);
}
diff --git a/t/comp/parser.t b/t/comp/parser.t
index 50f601c..5016509 100644
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -8,7 +8,7 @@ BEGIN {
chdir 't' if -d 't';
}
-print "1..173\n";
+print "1..174\n";
sub failed {
my ($got, $expected, $name) = @_;
@@ -546,6 +546,12 @@ eval "grep+grep";
eval 'qq{@{0]}${}},{})';
is(1, 1, "RT #124207");
+# RT #130815: crash in ck_return for malformed code
+{
+ eval 'm(@{if(0){sub d{]]])}return';
+ like $@, qr/^syntax error at \(eval \d+\) line 1, near "\{\]"/,
+ 'RT #130815: null pointer deref';
+}
# Add new tests HERE (above this line)
--
2.7.4

View File

@ -0,0 +1,61 @@
From cba9aa759f7ce8a4a80e748eb451f679042cd74b Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Fri, 7 Apr 2017 14:08:02 -0700
Subject: [PATCH] Crash with sub-in-stash
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit 790acddeaa0d2c73524596048b129561225cf100
Author: Father Chrysostomos <sprout@cpan.org>
Date: Fri Apr 7 14:08:02 2017 -0700
[perl #131085] Crash with sub-in-stash
$ perl -e '$::{"A"} = sub {}; \&{"A"}'
Segmentation fault (core dumped)
The code that vivifies a typeglob out of a code ref assumed that the
CV had a name hek, which is always the case when perl itself puts the
code ref there (via sub A{}), but is not necessarily the case if
someone is insinuating other stuff into the stash.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
gv.c | 2 +-
t/op/gv.t | 4 ++++
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/gv.c b/gv.c
index 3fda9b9..6690b64 100644
--- a/gv.c
+++ b/gv.c
@@ -421,7 +421,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
/* Not actually a constant. Just a regular sub. */
CV * const cv = (CV *)has_constant;
GvCV_set(gv,cv);
- if (CvSTASH(cv) == stash && (
+ if (CvNAMED(cv) && CvSTASH(cv) == stash && (
CvNAME_HEK(cv) == GvNAME_HEK(gv)
|| ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
&& HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
diff --git a/t/op/gv.t b/t/op/gv.t
index 03ae46e..cdaaef5 100644
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -1170,6 +1170,10 @@ SKIP: {
is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
}
+# [perl #131085] This used to crash; no ok() necessary.
+$::{"A131085"} = sub {}; \&{"A131085"};
+
+
__END__
Perl
Rules
--
2.9.4

View File

@ -0,0 +1,266 @@
From 30cba075ecbb662b392b2c6e896dec287ea49aa8 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 25 Apr 2017 15:17:06 +0200
Subject: [PATCH] fixup File::Glob degenerate matching
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit 0db967b2e6a4093a6a5f649190159767e5d005e0
Author: Yves Orton <demerphq@gmail.com>
Date: Tue Apr 25 15:17:06 2017 +0200
[perl #131211] fixup File::Glob degenerate matching
The old code would go quadratic with recursion and backtracking
when doing patterns like "a*a*a*a*a*a*a*x" on a file like
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa".
This patch changes the code to not recurse, and to not backtrack,
as per this article from Russ Cox: https://research.swtch.com/glob
It also adds a micro-optimisation for M_ONE and M_SET under the new code.
Thanks to Avar and Russ Cox for helping with this patch, along with
Jilles Tjoelker and the rest of the FreeBSD community.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
ext/File-Glob/bsd_glob.c | 64 +++++++++++++++++++++++--------
ext/File-Glob/t/rt131211.t | 94 ++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 144 insertions(+), 15 deletions(-)
create mode 100644 ext/File-Glob/t/rt131211.t
diff --git a/MANIFEST b/MANIFEST
index fe045a7..be2a44f 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3678,6 +3678,7 @@ ext/File-Glob/t/case.t See if File::Glob works
ext/File-Glob/t/global.t See if File::Glob works
ext/File-Glob/TODO File::Glob extension todo list
ext/File-Glob/t/rt114984.t See if File::Glob works
+ext/File-Glob/t/rt131211.t See if File::Glob works
ext/File-Glob/t/taint.t See if File::Glob works
ext/File-Glob/t/threads.t See if File::Glob + threads works
ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
diff --git a/ext/File-Glob/bsd_glob.c b/ext/File-Glob/bsd_glob.c
index 821ef20..e96fb73 100644
--- a/ext/File-Glob/bsd_glob.c
+++ b/ext/File-Glob/bsd_glob.c
@@ -563,8 +563,12 @@ glob0(const Char *pattern, glob_t *pglob)
break;
case BG_STAR:
pglob->gl_flags |= GLOB_MAGCHAR;
- /* collapse adjacent stars to one,
- * to avoid exponential behavior
+ /* Collapse adjacent stars to one.
+ * This is required to ensure that a pattern like
+ * "a**" matches a name like "a", as without this
+ * check when the first star matched everything it would
+ * cause the second star to return a match fail.
+ * As long ** is folded here this does not happen.
*/
if (bufnext == patbuf || bufnext[-1] != M_ALL)
*bufnext++ = M_ALL;
@@ -909,35 +913,56 @@ globextend(const Char *path, glob_t *pglob, size_t *limitp)
/*
- * pattern matching function for filenames. Each occurrence of the *
- * pattern causes a recursion level.
+ * pattern matching function for filenames using state machine to avoid
+ * recursion. We maintain a "nextp" and "nextn" to allow us to backtrack
+ * without additional callframes, and to do cleanly prune the backtracking
+ * state when multiple '*' (start) matches are included in the patter.
+ *
+ * Thanks to Russ Cox for the improved state machine logic to avoid quadratic
+ * matching on failure.
+ *
+ * https://research.swtch.com/glob
+ *
+ * An example would be a pattern
+ * ("a*" x 100) . "y"
+ * against a file name like
+ * ("a" x 100) . "x"
+ *
*/
static int
match(Char *name, Char *pat, Char *patend, int nocase)
{
int ok, negate_range;
Char c, k;
+ Char *nextp = NULL;
+ Char *nextn = NULL;
+ loop:
while (pat < patend) {
c = *pat++;
switch (c & M_MASK) {
case M_ALL:
if (pat == patend)
return(1);
- do
- if (match(name, pat, patend, nocase))
- return(1);
- while (*name++ != BG_EOS)
- ;
- return(0);
+ if (*name == BG_EOS)
+ return 0;
+ nextn = name + 1;
+ nextp = pat - 1;
+ break;
case M_ONE:
+ /* since * matches leftmost-shortest first *
+ * if we encounter the EOS then backtracking *
+ * will not help, so we can exit early here. */
if (*name++ == BG_EOS)
- return(0);
+ return 0;
break;
case M_SET:
ok = 0;
+ /* since * matches leftmost-shortest first *
+ * if we encounter the EOS then backtracking *
+ * will not help, so we can exit early here. */
if ((k = *name++) == BG_EOS)
- return(0);
+ return 0;
if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS)
++pat;
while (((c = *pat++) & M_MASK) != M_END)
@@ -953,16 +978,25 @@ match(Char *name, Char *pat, Char *patend, int nocase)
} else if (nocase ? (tolower(c) == tolower(k)) : (c == k))
ok = 1;
if (ok == negate_range)
- return(0);
+ goto fail;
break;
default:
k = *name++;
if (nocase ? (tolower(k) != tolower(c)) : (k != c))
- return(0);
+ goto fail;
break;
}
}
- return(*name == BG_EOS);
+ if (*name == BG_EOS)
+ return 1;
+
+ fail:
+ if (nextn) {
+ pat = nextp;
+ name = nextn;
+ goto loop;
+ }
+ return 0;
}
/* Free allocated data belonging to a glob_t structure. */
diff --git a/ext/File-Glob/t/rt131211.t b/ext/File-Glob/t/rt131211.t
new file mode 100644
index 0000000..c1bcbe0
--- /dev/null
+++ b/ext/File-Glob/t/rt131211.t
@@ -0,0 +1,94 @@
+use strict;
+use warnings;
+use v5.16.0;
+use File::Temp 'tempdir';
+use File::Spec::Functions;
+use Test::More;
+use Time::HiRes qw(time);
+
+plan tests => 13;
+
+my $path = tempdir uc cleanup => 1;
+my @files= (
+ "x".("a" x 50)."b", # 0
+ "abbbbbbbbbbbbc", # 1
+ "abbbbbbbbbbbbd", # 2
+ "aaabaaaabaaaabc", # 3
+ "pq", # 4
+ "r", # 5
+ "rttiiiiiii", # 6
+ "wewewewewewe", # 7
+ "weeeweeeweee", # 8
+ "weewweewweew", # 9
+ "wewewewewewewewewewewewewewewewewq", # 10
+ "wtttttttetttttttwr", # 11
+);
+
+
+foreach (@files) {
+ open(my $f, ">", catfile $path, $_);
+}
+
+my $elapsed_fail= 0;
+my $elapsed_match= 0;
+my @got_files;
+my @no_files;
+my $count = 0;
+
+while (++$count < 10) {
+ $elapsed_match -= time;
+ @got_files= glob catfile $path, "x".("a*" x $count) . "b";
+ $elapsed_match += time;
+
+ $elapsed_fail -= time;
+ @no_files= glob catfile $path, "x".("a*" x $count) . "c";
+ $elapsed_fail += time;
+ last if $elapsed_fail > $elapsed_match * 100;
+}
+
+is $count,10,
+ "tried all the patterns without bailing out";
+
+cmp_ok $elapsed_fail/$elapsed_match,"<",2,
+ "time to fail less than twice the time to match";
+is "@got_files", catfile($path, $files[0]),
+ "only got the expected file for xa*..b";
+is "@no_files", "", "shouldnt have files for xa*..c";
+
+
+@got_files= glob catfile $path, "a*b*b*b*bc";
+is "@got_files", catfile($path, $files[1]),
+ "only got the expected file for a*b*b*b*bc";
+
+@got_files= sort glob catfile $path, "a*b*b*bc";
+is "@got_files", catfile($path, $files[3])." ".catfile($path,$files[1]),
+ "got the expected two files for a*b*b*bc";
+
+@got_files= sort glob catfile $path, "p*";
+is "@got_files", catfile($path, $files[4]),
+ "p* matches pq";
+
+@got_files= sort glob catfile $path, "r*???????";
+is "@got_files", catfile($path, $files[6]),
+ "r*??????? works as expected";
+
+@got_files= sort glob catfile $path, "w*e*w??e";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8)),
+ "w*e*w??e works as expected";
+
+@got_files= sort glob catfile $path, "w*e*we??";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)),
+ "w*e*we?? works as expected";
+
+@got_files= sort glob catfile $path, "w**e**w";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (9)),
+ "w**e**w works as expected";
+
+@got_files= sort glob catfile $path, "*wee*";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (8,9)),
+ "*wee* works as expected";
+
+@got_files= sort glob catfile $path, "we*";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)),
+ "we* works as expected";
+
--
2.9.4

View File

@ -0,0 +1,72 @@
From 064604f904546ae4ddada5a2aa30256faccee39c Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 7 Jun 2017 15:00:26 +1000
Subject: [PATCH] clear the UTF8 flag on a glob if it isn't UTF8
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit 1097da16b21fe0a2257dba9937e55c0cca18f7e1
Author: Tony Cook <tony@develop-help.com>
Date: Wed Jun 7 15:00:26 2017 +1000
[perl #131263] clear the UTF8 flag on a glob if it isn't UTF8
Previously sv_2pv_flags() would set the UTF8 flag on a glob if it
had a UTF8 name, but wouldn't clear tha flag if it didn't.
This meant a name change, eg. if assigned another glob, from a UTF8
name to a non-UTF8 name would leave the flag set.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
sv.c | 2 ++
t/op/gv.t | 10 +++++++++-
2 files changed, 11 insertions(+), 1 deletion(-)
diff --git a/sv.c b/sv.c
index 12cbb5f..05584a2 100644
--- a/sv.c
+++ b/sv.c
@@ -3162,6 +3162,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
assert(SvPOK(buffer));
if (SvUTF8(buffer))
SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
if (lp)
*lp = SvCUR(buffer);
return SvPVX(buffer);
diff --git a/t/op/gv.t b/t/op/gv.t
index cdaaef5..ea79e51 100644
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
use warnings;
-plan(tests => 277 );
+plan(tests => 279 );
# type coercion on assignment
$foo = 'foo';
@@ -1173,6 +1173,14 @@ SKIP: {
# [perl #131085] This used to crash; no ok() necessary.
$::{"A131085"} = sub {}; \&{"A131085"};
+{
+ # [perl #131263]
+ *sym = "\N{U+0080}";
+ ok(*sym eq "*main::\N{U+0080}", "utf8 flag properly set");
+ *sym = "\xC3\x80";
+ ok(*sym eq "*main::\xC3\x80", "utf8 flag properly cleared");
+}
+
__END__
Perl
--
2.9.4

View File

@ -0,0 +1,74 @@
From 08bc282a248b21c92ff45e49490fb95e24358213 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Tue, 9 May 2017 14:29:11 +0100
Subject: [PATCH] sprintf(): add memory wrap tests
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit d729f63cc94318c248eab95844cfbed5298a7ecd
Author: David Mitchell <davem@iabyn.com>
Date: Tue May 9 14:29:11 2017 +0100
sprintf(): add memory wrap tests
In various places Perl_sv_vcatpvfn_flags() does croak_memory_wrap()
(including a couple added by the previous commit to fix RT #131260),
but there don't appear to be any tests for them.
So this commit adds some tests.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/op/sprintf2.t | 29 ++++++++++++++++++++++++++++-
1 file changed, 28 insertions(+), 1 deletion(-)
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index 43ed919..ef8a743 100644
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -262,7 +262,7 @@ if ($Config{nvsize} == 8 &&
print "# no hexfloat tests\n";
}
-plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat + 12;
+plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat + 16;
use strict;
use Config;
@@ -749,3 +749,30 @@ SKIP: {
"non-canonical form");
}
}
+
+# check all calls to croak_memory_wrap()
+# RT #131260
+
+{
+ my $s = 8 * $Config{sizesize};
+ my $i = 1;
+ my $max;
+ while ($s--) { $max |= $i; $i <<= 1; }
+ my $max40 = $max - 40; # see the magic fudge factor in sv_vcatpvfn_flags()
+
+ my @tests = (
+ # format, arg
+ ["%.${max}a", 1.1 ],
+ ["%.${max40}a", 1.1 ],
+ ["%.${max}i", 1 ],
+ ["%.${max}i", -1 ],
+ );
+
+ for my $test (@tests) {
+ my ($fmt, $arg) = @$test;
+ eval { my $s = sprintf $fmt, $arg; };
+ like("$@", qr/panic: memory wrap/, qq{memory wrap: "$fmt", "$arg"});
+ }
+}
+
+
--
2.9.4

View File

@ -0,0 +1,73 @@
From 3f6b66c14467c0f8c7459e32c576618155ca89f3 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 16 Jun 2016 14:08:18 +1000
Subject: [PATCH] (perl #128316) preserve errno from failed system calls
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 | 4 ++--
t/io/socket.t | 22 ++++++++++++++++++++++
2 files changed, 24 insertions(+), 2 deletions(-)
diff --git a/pp_sys.c b/pp_sys.c
index 33cba46..3bf2673 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2497,7 +2497,6 @@ PP(pp_socket)
TAINT_PROPER("socket");
fd = PerlSock_socket(domain, type, protocol);
if (fd < 0) {
- SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
@@ -3531,8 +3530,9 @@ PP(pp_fttext)
}
PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
if (PL_laststatval < 0) {
+ dSAVE_ERRNO;
(void)PerlIO_close(fp);
- SETERRNO(EBADF,RMS_IFI);
+ RESTORE_ERRNO;
FT_RETURNUNDEF;
}
PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
diff --git a/t/io/socket.t b/t/io/socket.t
index b51079a..54e4438 100644
--- a/t/io/socket.t
+++ b/t/io/socket.t
@@ -128,6 +128,28 @@ SKIP: {
}
}
+SKIP:
+{
+ eval { require Errno; defined &Errno::EMFILE }
+ or skip "Can't load Errno or EMFILE not defined", 1;
+ my @socks;
+ my $sock_limit = 1000; # don't consume every file in the system
+ # Default limits on various systems I have:
+ # 65536 - Linux
+ # 256 - Solaris
+ # 128 - NetBSD
+ # 256 - Cygwin
+ # 256 - darwin
+ while (@socks < $sock_limit) {
+ socket my $work, PF_INET, SOCK_STREAM, $tcp
+ or last;
+ push @socks, $work;
+ }
+ @socks == $sock_limit
+ and skip "Didn't run out of open handles", 1;
+ is(0+$!, Errno::EMFILE(), "check correct errno for too many files");
+}
+
done_testing();
my @child_tests;
--
2.5.5

View File

@ -0,0 +1,44 @@
From bce4a2abeb8652d19e97d3bf07dd2580a3cc2e6c Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Sat, 25 Feb 2017 10:42:17 +0000
Subject: [PATCH] fix VMS test fail
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
d7186add added a runperl() test that breaks command line length limits for
VMS. Switch to fresh_perl() instead, so the prog is put in a file for us.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/comp/parser_run.t | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/t/comp/parser_run.t b/t/comp/parser_run.t
index 2543f49..e74644d 100644
--- a/t/comp/parser_run.t
+++ b/t/comp/parser_run.t
@@ -14,14 +14,14 @@ plan(1);
# [perl #130814] can reallocate lineptr while looking ahead for
# "Missing $ on loop variable" diagnostic.
-my $result = runperl(
- prog => " foreach m0\n\$" . ("0" x 0x2000),
- stderr => 1,
+my $result = fresh_perl(
+ " foreach m0\n\$" . ("0" x 0x2000),
+ { stderr => 1 },
);
-is($result, <<EXPECT);
-syntax error at -e line 3, near "foreach m0
+is($result . "\n", <<EXPECT);
+syntax error at - line 3, near "foreach m0
"
-Identifier too long at -e line 3.
+Identifier too long at - line 3.
EXPECT
__END__
--
2.7.4

View File

@ -0,0 +1,55 @@
From d7186addd1b477f6bdcef5e9d24f2125691a9082 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Sun, 19 Feb 2017 11:15:38 +0000
Subject: [PATCH] [perl #130814] Add testcase, and new testfile
t/comp/parser_run.t
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Sometimes it's useful to have test.pl around, but it seems inappropriate
to pollute the existing t/comp/parser.t with that.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/comp/parser_run.t | 28 ++++++++++++++++++++++++++++
1 file changed, 28 insertions(+)
create mode 100644 t/comp/parser_run.t
diff --git a/t/comp/parser_run.t b/t/comp/parser_run.t
new file mode 100644
index 0000000..2543f49
--- /dev/null
+++ b/t/comp/parser_run.t
@@ -0,0 +1,28 @@
+#!./perl
+
+# Parser tests that want test.pl, eg to use runperl() for tests to show
+# reads through invalid pointers.
+# Note that this should still be runnable under miniperl.
+
+BEGIN {
+ @INC = qw(. ../lib );
+ chdir 't' if -d 't';
+}
+
+require './test.pl';
+plan(1);
+
+# [perl #130814] can reallocate lineptr while looking ahead for
+# "Missing $ on loop variable" diagnostic.
+my $result = runperl(
+ prog => " foreach m0\n\$" . ("0" x 0x2000),
+ stderr => 1,
+);
+is($result, <<EXPECT);
+syntax error at -e line 3, near "foreach m0
+"
+Identifier too long at -e line 3.
+EXPECT
+
+__END__
+# ex: set ts=8 sts=4 sw=4 et:
--
2.7.4

View File

@ -0,0 +1,54 @@
From bd1a29f218b291165e47d9035aaeec14abd9732e Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 8 May 2017 21:06:38 +0100
Subject: [PATCH] avoid a memory wrap in sv_vcatpvfn_flags()
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
RT #131260
When calculating the new size of PL_efloatbuf, avoid wrapping 'need'.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
sv.c | 14 +++++++++++---
1 file changed, 11 insertions(+), 3 deletions(-)
diff --git a/sv.c b/sv.c
index e90ea84..9f3e28e 100644
--- a/sv.c
+++ b/sv.c
@@ -12448,7 +12448,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
need = BIT_DIGITS(i);
} /* if i < 0, the number of digits is hard to predict. */
}
- need += has_precis ? precis : 6; /* known default */
+
+ {
+ STRLEN pr = has_precis ? precis : 6; /* known default */
+ if (need >= ((STRLEN)~0) - pr)
+ croak_memory_wrap();
+ need += pr;
+ }
if (need < width)
need = width;
@@ -12519,10 +12525,12 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
#endif /* HAS_LDBL_SPRINTF_BUG */
- need += 20; /* fudge factor */
+ if (need >= ((STRLEN)~0) - 40)
+ croak_memory_wrap();
+ need += 40; /* fudge factor */
if (PL_efloatsize < need) {
Safefree(PL_efloatbuf);
- PL_efloatsize = need + 20; /* more fudge */
+ PL_efloatsize = need;
Newx(PL_efloatbuf, PL_efloatsize, char);
PL_efloatbuf[0] = '\0';
}
--
2.9.4

View File

@ -0,0 +1,74 @@
From f6203e997f3012b8aab4cd35fe49f58e4d71fb8c Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Sun, 10 Jul 2016 22:06:12 -0600
Subject: [PATCH] t/test.pl: Add fresh_perl() function
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This will be useful for cases where the results don't readily fall into
fresh_perl_is and fresh_perl_like, such as when a bunch of massaging of
the results is needed before it is convenient to test them.
fresh_perl_like() could be used, but in the case of failure there could
be lines and lines of noise output.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/test.pl | 25 +++++++++++++++++++++----
1 file changed, 21 insertions(+), 4 deletions(-)
diff --git a/t/test.pl b/t/test.pl
index 41b77f4..20d08e9 100644
--- a/t/test.pl
+++ b/t/test.pl
@@ -953,11 +953,16 @@ sub register_tempfile {
return $count;
}
-# This is the temporary file for _fresh_perl
+# This is the temporary file for fresh_perl
my $tmpfile = tempfile();
-sub _fresh_perl {
- my($prog, $action, $expect, $runperl_args, $name) = @_;
+sub fresh_perl {
+ my($prog, $runperl_args) = @_;
+
+ # Run 'runperl' with the complete perl program contained in '$prog', and
+ # arguments in the hash referred to by '$runperl_args'. The results are
+ # returned, with $? set to the exit code. Unless overridden, stderr is
+ # redirected to stdout.
# Given the choice of the mis-parsable {}
# (we want an anon hash, but a borked lexer might think that it's a block)
@@ -975,7 +980,8 @@ sub _fresh_perl {
close TEST or die "Cannot close $tmpfile: $!";
my $results = runperl(%$runperl_args);
- my $status = $?;
+ my $status = $?; # Not necessary to save this, but it makes it clear to
+ # future maintainers.
# Clean up the results into something a bit more predictable.
$results =~ s/\n+$//;
@@ -994,6 +1000,17 @@ sub _fresh_perl {
$results =~ s/\n\n/\n/g;
}
+ $? = $status;
+ return $results;
+}
+
+
+sub _fresh_perl {
+ my($prog, $action, $expect, $runperl_args, $name) = @_;
+
+ my $results = fresh_perl($prog, $runperl_args);
+ my $status = $?;
+
# Use the first line of the program as a name if none was given
unless( $name ) {
($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
--
2.7.4

View File

@ -0,0 +1,32 @@
From d5ea0ef8623c7d7ba5f42d239787aa71393e2054 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 13 Sep 2016 23:06:58 +0200
Subject: [PATCH 2/5] clean up gv_fetchmethod_pvn_flags: move origname init to
function start
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
so it is more obvious that it is a constant copy of the
original name.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
gv.c | 1 -
1 file changed, 1 deletion(-)
diff --git a/gv.c b/gv.c
index b0221e0..fe38d44 100644
--- a/gv.c
+++ b/gv.c
@@ -1014,7 +1014,6 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
const char *nsplit = NULL;
GV* gv;
HV* ostash = stash;
- const char * const origname = name;
SV *const error_report = MUTABLE_SV(stash);
const U32 autoload = flags & GV_AUTOLOAD;
const U32 do_croak = flags & GV_CROAK;
--
2.7.4

View File

@ -0,0 +1,92 @@
From e2cace1e9e89525afbca257742ddb36630b7fbc3 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 13 Sep 2016 23:10:48 +0200
Subject: [PATCH 3/5] clean up gv_fetchmethod_pvn_flags: rename nsplit to
last_separator
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
nsplit if set points at the first char of the last separator
in name, so rename it so it is more comprehensible what it means.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
gv.c | 24 ++++++++++++------------
1 file changed, 12 insertions(+), 12 deletions(-)
diff --git a/gv.c b/gv.c
index fe38d44..07709a0 100644
--- a/gv.c
+++ b/gv.c
@@ -1011,7 +1011,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
const char * const origname = name;
const char * const name_end = name + len;
const char *nend;
- const char *nsplit = NULL;
+ const char *last_separator = NULL;
GV* gv;
HV* ostash = stash;
SV *const error_report = MUTABLE_SV(stash);
@@ -1024,38 +1024,38 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
if (SvTYPE(stash) < SVt_PVHV)
stash = NULL;
else {
- /* The only way stash can become NULL later on is if nsplit is set,
+ /* The only way stash can become NULL later on is if last_separator is set,
which in turn means that there is no need for a SVt_PVHV case
the error reporting code. */
}
for (nend = name; *nend || nend != name_end; nend++) {
if (*nend == '\'') {
- nsplit = nend;
+ last_separator = nend;
name = nend + 1;
}
else if (*nend == ':' && *(nend + 1) == ':') {
- nsplit = nend++;
+ last_separator = nend++;
name = nend + 1;
}
}
- if (nsplit) {
- if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
+ if (last_separator) {
+ if ((last_separator - origname) == 5 && memEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
stash = CopSTASH(PL_curcop);
flags |= GV_SUPER;
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvENAME_get(stash), name) );
}
- else if ((nsplit - origname) >= 7 &&
- strnEQ(nsplit - 7, "::SUPER", 7)) {
+ else if ((last_separator - origname) >= 7 &&
+ strnEQ(last_separator - 7, "::SUPER", 7)) {
/* don't autovifify if ->NoSuchStash::SUPER::method */
- stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
+ stash = gv_stashpvn(origname, last_separator - origname - 7, is_utf8);
if (stash) flags |= GV_SUPER;
}
else {
/* don't autovifify if ->NoSuchStash::method */
- stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
+ stash = gv_stashpvn(origname, last_separator - origname, is_utf8);
}
ostash = stash;
}
@@ -1098,8 +1098,8 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
else {
SV* packnamesv;
- if (nsplit) {
- packnamesv = newSVpvn_flags(origname, nsplit - origname,
+ if (last_separator) {
+ packnamesv = newSVpvn_flags(origname, last_separator - origname,
SVs_TEMP | is_utf8);
} else {
packnamesv = error_report;
--
2.7.4

View File

@ -0,0 +1,81 @@
From cfb736762c1becf344ce6beaa701ff2e1abd5f9c Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 13 Sep 2016 23:14:49 +0200
Subject: [PATCH 4/5] fix #129267: rework gv_fetchmethod_pvn_flags separator
parsing
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
With previous code we could overrun the end of the name when
the last char in the string was a colon. This reworks the code
so it is more clear what is going on, and so it more similar
to other code that also parses out package separaters in gv.c.
This is a rework of the reverted patches:
243ca72 rename "nend" name_cursor in Perl_gv_fetchmethod_pvn_flags
b053c93 fix: [perl #129267] Possible string overrun with invalid len in gv.c
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
gv.c | 36 ++++++++++++++++++++++++++----------
1 file changed, 26 insertions(+), 10 deletions(-)
diff --git a/gv.c b/gv.c
index 07709a0..3237c53 100644
--- a/gv.c
+++ b/gv.c
@@ -1010,7 +1010,6 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
{
const char * const origname = name;
const char * const name_end = name + len;
- const char *nend;
const char *last_separator = NULL;
GV* gv;
HV* ostash = stash;
@@ -1029,16 +1028,33 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
the error reporting code. */
}
- for (nend = name; *nend || nend != name_end; nend++) {
- if (*nend == '\'') {
- last_separator = nend;
- name = nend + 1;
- }
- else if (*nend == ':' && *(nend + 1) == ':') {
- last_separator = nend++;
- name = nend + 1;
- }
+ {
+ /* check if the method name is fully qualified or
+ * not, and separate the package name from the actual
+ * method name.
+ *
+ * leaves last_separator pointing to the beginning of the
+ * last package separator (either ' or ::) or 0
+ * if none was found.
+ *
+ * leaves name pointing at the beginning of the
+ * method name.
+ */
+ const char *name_cursor = name;
+ const char * const name_em1 = name_end - 1; /* name_end minus 1 */
+ for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
+ if (*name_cursor == '\'') {
+ last_separator = name_cursor;
+ name = name_cursor + 1;
+ }
+ else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
+ last_separator = name_cursor++;
+ name = name_cursor + 1;
+ }
+ }
}
+
+ /* did we find a separator? */
if (last_separator) {
if ((last_separator - origname) == 5 && memEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
--
2.7.4

View File

@ -0,0 +1,37 @@
From 9bde56224e82f20e7a65b3469b1ffb6b9f6d4df8 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 4 Sep 2016 20:24:19 -0700
Subject: [PATCH] =?UTF-8?q?[perl=20#129196]=20Crash/bad=20read=20with=20?=
=?UTF-8?q?=E2=80=98evalbytes=20S=E2=80=99?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
5dc13276 added some code to toke.c that did not take into account
that the opnum (f) argument to UNI* could be a negated op number.
PL_last_lop_op must never be negative, since it is used as an offset
into a struct.
Tests for the crash will come in the next commit.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
toke.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/toke.c b/toke.c
index 2fe8b69..2350703 100644
--- a/toke.c
+++ b/toke.c
@@ -241,7 +241,7 @@ static const char* const lex_state_names[] = {
if (have_x) PL_expect = x; \
PL_bufptr = s; \
PL_last_uni = PL_oldbufptr; \
- PL_last_lop_op = f; \
+ PL_last_lop_op = f < 0 ? -f : f; \
if (*s == '(') \
return REPORT( (int)FUNC1 ); \
s = skipspace(s); \
--
2.7.4

View File

@ -0,0 +1,44 @@
From 1665b718d8fbd58705dbe6376fa51f8c1a02d887 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Tue, 13 Sep 2016 22:38:59 -0700
Subject: [PATCH 5/5] [perl #129267] Test for gv_fetchmethod buffer overrun
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/XS-APItest/APItest.xs | 3 +++
ext/XS-APItest/t/gv_fetchmethod_flags.t | 5 +++++
2 files changed, 8 insertions(+)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 992b6a5..4602cee 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -2571,6 +2571,9 @@ gv_fetchmethod_flags_type(stash, methname, type, flags)
gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
break;
}
+ case 4:
+ gv = gv_fetchmethod_pvn_flags(stash, SvPV_nolen(methname),
+ flags, SvUTF8(methname));
}
XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
diff --git a/ext/XS-APItest/t/gv_fetchmethod_flags.t b/ext/XS-APItest/t/gv_fetchmethod_flags.t
index 15d1c41..2da3b70 100644
--- a/ext/XS-APItest/t/gv_fetchmethod_flags.t
+++ b/ext/XS-APItest/t/gv_fetchmethod_flags.t
@@ -49,3 +49,8 @@ is XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 2, 0), "*m
}
}
}
+
+# [perl #129267] Buffer overrun when argument name ends with colon and
+# there is a colon past the end. This used to segv.
+XS::APItest::gv_fetchmethod_flags_type(\%::, "method:::::", 4, 7);
+ # With type 4, 7 is the length
--
2.7.4

View File

@ -0,0 +1,46 @@
From 0af40c757f083cc12988effb46da5313cd042f00 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 5 Sep 2016 15:49:28 +0100
Subject: [PATCH] toke.c: fix mswin32 builds
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
9bde56224 added this as part of macro:
- PL_last_lop_op = f; \
+ PL_last_lop_op = f < 0 ? -f : f; \
which broke win32 builds due to this
UNIBRACK(-OP_ENTEREVAL)
expanding to
PL_last_lop_op = -345 < 0 ? --345 : -345
and the -- being seen as a pre-dec op.
Diagnosed by Dagfinn Ilmari Mannsåker.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
toke.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/toke.c b/toke.c
index 2350703..a1cdda8 100644
--- a/toke.c
+++ b/toke.c
@@ -241,7 +241,7 @@ static const char* const lex_state_names[] = {
if (have_x) PL_expect = x; \
PL_bufptr = s; \
PL_last_uni = PL_oldbufptr; \
- PL_last_lop_op = f < 0 ? -f : f; \
+ PL_last_lop_op = (f) < 0 ? -(f) : (f); \
if (*s == '(') \
return REPORT( (int)FUNC1 ); \
s = skipspace(s); \
--
2.7.4

View File

@ -0,0 +1,32 @@
From 9ce5bf4c39e28441410672f39b5ee1c4569967f8 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Fri, 28 Oct 2016 13:27:23 +0100
Subject: [PATCH] [perl #130001] h2xs: avoid infinite loop for enums
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
'typedef enum x { ... } x' causes h2xs to enter a substitution loop while
trying to write the typemap file.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
utils/h2xs.PL | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/utils/h2xs.PL b/utils/h2xs.PL
index 8fda87b..f9063cb 100644
--- a/utils/h2xs.PL
+++ b/utils/h2xs.PL
@@ -1034,7 +1034,7 @@ if( ! $opt_X ){ # use XS, unless it was disabled
}
}
{ local $" = '|';
- $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
+ $typedef_rex = qr(\b(?<!struct )(?<!enum )(?:@good_td)\b) if @good_td;
}
%known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
if ($fmask) {
--
2.7.4

View File

@ -0,0 +1,61 @@
From fecd3be8dbdb747b9cbf4cbb9299ce40faabc8e6 Mon Sep 17 00:00:00 2001
From: John Lightsey <lightsey@debian.org>
Date: Mon, 14 Nov 2016 11:56:15 +0100
Subject: [PATCH] Fix Storable segfaults.
Fix a null pointed dereference segfault in storable when the
retrieve_code logic was unable to read the string that contained
the code.
Also fix several locations where retrieve_other was called with a
null context pointer. This also resulted in a null pointer
dereference.
---
dist/Storable/Storable.xs | 10 +++++++---
1 file changed, 7 insertions(+), 3 deletions(-)
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 053951c..caa489c 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -5647,6 +5647,10 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
CROAK(("Unexpected type %d in retrieve_code\n", type));
}
+ if (!text) {
+ CROAK(("Unable to retrieve code\n"));
+ }
+
/*
* prepend "sub " to the source
*/
@@ -5767,7 +5771,7 @@ static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname)
continue; /* av_extend() already filled us with undef */
}
if (c != SX_ITEM)
- (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
TRACEME(("(#%d) item", i));
sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
if (!sv)
@@ -5844,7 +5848,7 @@ static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
if (!sv)
return (SV *) 0;
} else
- (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
/*
* Get key.
@@ -5855,7 +5859,7 @@ static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
GETMARK(c);
if (c != SX_KEY)
- (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
RLEN(size); /* Get key size */
KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
if (size)
--
2.10.2

View File

@ -0,0 +1,58 @@
From bf4a926a29374161655548b149d1cb37300bcc05 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 7 Sep 2016 16:51:39 +1000
Subject: [PATCH] (perl #129149) avoid a heap buffer overflow with pack "W"...
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_pack.c | 2 +-
t/op/pack.t | 13 ++++++++++++-
2 files changed, 13 insertions(+), 2 deletions(-)
diff --git a/pp_pack.c b/pp_pack.c
index ee4c69e..737e019 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2587,7 +2587,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
if (in_bytes) auv = auv % 0x100;
if (utf8) {
W_utf8:
- if (cur > end) {
+ if (cur >= end) {
*cur = '\0';
SvCUR_set(cat, cur - start);
diff --git a/t/op/pack.t b/t/op/pack.t
index 3fc12e4..47d1216 100644
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -12,7 +12,7 @@ my $no_endianness = $] > 5.009 ? '' :
my $no_signedness = $] > 5.009 ? '' :
"Signed/unsigned pack modifiers not available on this perl";
-plan tests => 14712;
+plan tests => 14713;
use strict;
use warnings qw(FATAL all);
@@ -2047,3 +2047,14 @@ ok(1, "argument underflow did not crash");
is(pack("H40", $up_nul), $twenty_nuls,
"check pack H zero fills (utf8 source)");
}
+
+{
+ # [perl #129149] the code below would write one past the end of the output
+ # buffer, only detected by ASAN, not by valgrind
+ $Config{ivsize} >= 8
+ or skip "[perl #129149] need 64-bit for this test", 1;
+ fresh_perl_is(<<'EOS', "ok\n", { stderr => 1 }, "pack W overflow");
+print pack("ucW", "0000", 0, 140737488355327) eq "\$,#`P,```\n\0\x{7fffffffffff}"
+ ? "ok\n" : "not ok\n";
+EOS
+}
--
2.7.4

View File

@ -0,0 +1,30 @@
From 30be69c851a7fa7e29d85c9b6e070273df82f3e7 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 17 Jan 2017 15:36:31 +1100
Subject: [PATCH] (perl #129149) fix the test so skip has a SKIP: to work with
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Thanks to bulk88 for pointing this out.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/op/pack.t | 1 +
1 file changed, 1 insertion(+)
diff --git a/t/op/pack.t b/t/op/pack.t
index 47d1216..919e4c5 100644
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -2048,6 +2048,7 @@ ok(1, "argument underflow did not crash");
"check pack H zero fills (utf8 source)");
}
+SKIP:
{
# [perl #129149] the code below would write one past the end of the output
# buffer, only detected by ASAN, not by valgrind
--
2.7.4

View File

@ -0,0 +1,69 @@
From 42e9b60980bb8e29e76629e14c6aa945194c0647 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Wed, 5 Oct 2016 02:20:26 +0100
Subject: [PATCH] [perl #129061] CURLYX nodes can be studied more than once
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
study_chunk() for CURLYX is used to set flags on the linked WHILEM
node to say it is the whilem_c'th of whilem_seen. However it assumes
each CURLYX can be studied only once, which is not the case - there
are various cases such as GOSUB which call study_chunk() recursively
on already-visited parts of the program.
Storing the wrong index can cause the super-linear cache handling in
regmatch() to read/write the byte after the end of poscache.
Also reported in [perl #129281].
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 12 +++++++++---
t/re/pat.t | 1 -
2 files changed, 9 insertions(+), 4 deletions(-)
diff --git a/regcomp.c b/regcomp.c
index 850a6c1..48c8d8d 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -5218,15 +5218,21 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
However, this time it's not a subexpression
we care about, but the expression itself. */
&& (maxcount == REG_INFTY)
- && data && ++data->whilem_c < 16) {
+ && data) {
/* This stays as CURLYX, we can put the count/of pair. */
/* Find WHILEM (as in regexec.c) */
regnode *nxt = oscan + NEXT_OFF(oscan);
if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
nxt += ARG(nxt);
- PREVOPER(nxt)->flags = (U8)(data->whilem_c
- | (RExC_whilem_seen << 4)); /* On WHILEM */
+ nxt = PREVOPER(nxt);
+ if (nxt->flags & 0xf) {
+ /* we've already set whilem count on this node */
+ } else if (++data->whilem_c < 16) {
+ assert(data->whilem_c <= RExC_whilem_seen);
+ nxt->flags = (U8)(data->whilem_c
+ | (RExC_whilem_seen << 4)); /* On WHILEM */
+ }
}
if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
pars++;
diff --git a/t/re/pat.t b/t/re/pat.t
index ecd3af1..16bfc8e 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -1909,7 +1909,6 @@ EOP
}
{
# [perl #129281] buffer write overflow, detected by ASAN, valgrind
- local $::TODO = "whilem_c bumped too much";
fresh_perl_is('/0(?0)|^*0(?0)|^*(^*())0|/', '', {}, "don't bump whilem_c too much");
}
} # End of sub run_tests
--
2.7.4

View File

@ -0,0 +1,34 @@
From 923e23bad0514e1bd29112650fb78aa4ea69e1b7 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Sat, 28 Jan 2017 15:13:17 +0100
Subject: [PATCH] silence warnings from tests about impossible quantifiers
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
thanks to Dave M for noticing....
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/re/pat_rt_report.t | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
index 21aff58..dd740e7 100644
--- a/t/re/pat_rt_report.t
+++ b/t/re/pat_rt_report.t
@@ -1134,9 +1134,10 @@ EOP
{
# rt
fresh_perl_is(
- '"foo"=~/((?1)){8,0}/; print "ok"',
+ 'no warnings "regexp"; "foo"=~/((?1)){8,0}/; print "ok"',
"ok", {}, 'RT #130561 - allowing impossible quantifier should not cause SEGVs');
my $s= "foo";
+ no warnings 'regexp';
ok($s=~/(foo){1,0}|(?1)/,
"RT #130561 - allowing impossible quantifier should not break recursion");
}
--
2.7.4

View File

@ -0,0 +1,33 @@
From 2c2da8e7f0f6325fab643997a536072633fa0cf8 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Thu, 1 Jun 2017 14:51:44 +0200
Subject: [PATCH] Fix #131190 - UTF8 code improperly casting negative integer
to U8 in comparison
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This reverts commit b4972372a75776de3c9e6bd234a398d103677316,
effectively restoring commit ca7eb79a236b41b7722c6800527f95cd76843eed,
and commit 85fde2b7c3f5631fd982f5db735b84dc9224bec0.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regexec.c | 1 +
1 file changed, 1 insertion(+)
diff --git a/regexec.c b/regexec.c
index 82128a7..35b88d7 100644
--- a/regexec.c
+++ b/regexec.c
@@ -5593,6 +5593,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
if (scan->flags == EXACTL || scan->flags == EXACTFLU8) {
_CHECK_AND_WARN_PROBLEMATIC_LOCALE;
if (utf8_target
+ && nextchr >= 0 /* guard against negative EOS value in nextchr */
&& UTF8_IS_ABOVE_LATIN1(nextchr)
&& scan->flags == EXACTL)
{
--
2.9.4

View File

@ -0,0 +1,32 @@
From e80af1fd276d83858d27742ea887415e3263960b Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 12 Oct 2016 10:42:47 +1100
Subject: [PATCH] (perl 129183) don't treat \ as an escape in PATH for -S
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
util.c | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/util.c b/util.c
index 5bb0dfc..6bc2fe5 100644
--- a/util.c
+++ b/util.c
@@ -3352,9 +3352,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
# else
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
- ':',
- &len);
+ s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
+ ':', &len);
# endif
if (s < bufend)
s++;
--
2.9.4

View File

@ -0,0 +1,71 @@
From 7b3443d31f11c15859593e5b710c301795a6de01 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 8 Jun 2017 11:06:39 +1000
Subject: [PATCH] [perl #131221] sv_dup/sv_dup_inc are only available under
threads
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/PerlIO-via/via.xs | 42 +++++++++++++++++++++++-------------------
1 file changed, 23 insertions(+), 19 deletions(-)
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
index 61953c8..d91c685 100644
--- a/ext/PerlIO-via/via.xs
+++ b/ext/PerlIO-via/via.xs
@@ -619,26 +619,30 @@ static PerlIO *
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
int flags)
{
- if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)) && param) {
- /* For a non-interpreter dup stash and obj have been set up
- by the implied push.
-
- But if this is a clone for a new interpreter we need to
- translate the objects to their dups.
- */
-
- PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
- PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
-
- fs->obj = sv_dup_inc(os->obj, param);
- fs->stash = (HV*)sv_dup((SV*)os->stash, param);
- fs->var = sv_dup_inc(os->var, param);
- fs->cnt = os->cnt;
-
- /* fh, io, cached CVs left as NULL, PerlIOVia_method()
- will reinitialize them if needed */
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
+#ifdef USE_ITHREADS
+ if (param) {
+ /* For a non-interpreter dup stash and obj have been set up
+ by the implied push.
+
+ But if this is a clone for a new interpreter we need to
+ translate the objects to their dups.
+ */
+
+ PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
+ PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
+
+ fs->obj = sv_dup_inc(os->obj, param);
+ fs->stash = (HV*)sv_dup((SV*)os->stash, param);
+ fs->var = sv_dup_inc(os->var, param);
+ fs->cnt = os->cnt;
+
+ /* fh, io, cached CVs left as NULL, PerlIOVia_method()
+ will reinitialize them if needed */
+ }
+#endif
+ /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
}
- /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
return f;
}
--
2.9.4

View File

@ -0,0 +1,37 @@
From 9604fbf0722bd97ca6031a263c50ad52b6633db7 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 14 Jun 2017 09:42:31 +1000
Subject: [PATCH] (perl #131526) don't go beyond the end of the NUL in my_atof2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Perl_my_atof2() calls GROK_NUMERIC_RADIX() to detect and skip past
a decimal point and then can increment the parse pointer (s) before
checking what it points at, so skipping the terminating NUL if the
decimal point is immediately before the NUL.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
numeric.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/numeric.c b/numeric.c
index 6ea6968..5771907 100644
--- a/numeric.c
+++ b/numeric.c
@@ -1485,9 +1485,9 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
seen_dp = 1;
if (sig_digits > MAX_SIG_DIGITS) {
- do {
+ while (isDIGIT(*s)) {
++s;
- } while (isDIGIT(*s));
+ }
break;
}
}
--
2.9.4

410
perl.spec
View File

@ -1,4 +1,4 @@
%global perl_version 5.22.1
%global perl_version 5.22.4
%global perl_epoch 4
%global perl_arch_stem -thread-multi
%global perl_archname %{_arch}-%{_os}%{perl_arch_stem}
@ -29,7 +29,7 @@
Name: perl
Version: %{perl_version}
# release number must be even higher, because dual-lived modules will be broken otherwise
Release: 358%{?dist}
Release: 372%{?dist}
Epoch: %{perl_epoch}
Summary: Practical Extraction and Report Language
Group: Development/Languages
@ -84,17 +84,184 @@ Patch22: perl-5.18.1-Document-Math-BigInt-CalcEmu-requires-Math-BigInt.pa
# Make *DBM_File desctructors thread-safe, bug #1107543, RT#61912
Patch26: perl-5.18.2-Destroy-GDBM-NDBM-ODBM-SDBM-_File-objects-only-from-.patch
# Make PadlistNAMES() lvalue again, bug #1231165, CPAN RT#101063,
# in upstream after 5.22.0
Patch27: perl-5.22.0-make-PadlistNAMES-lvalue-again.patch
# Workaround for Coro, bug #1231165, CPAN RT#101063. To remove in the future.
Patch28: perl-5.22.0-Revert-const-the-core-magic-vtables.patch
# Fix CVE-2016-2381 (ambiguous environment variables handling), bug #1313702,
# in upstream after 5.23.8
Patch29: perl-5.23.8-remove-duplicate-environment-variables-from-environ.patch
# Fix duplicating PerlIO::encoding when spawning threads, bug #1345788,
# RT#31923, in upstream after 5.23.3
Patch29: perl-5.23.3-Properly-duplicate-PerlIO-encoding-objects.patch
# Fix a crash in lexical scope warnings, RT#128597, in upstream after 5.25.2
Patch32: perl-5.22.2-perl-128597-Crash-from-gp_free-ckWARN_d.patch
# Do not mangle errno from failed socket calls, RT#128316,
# in upstream after 5.25.1
Patch33: perl-5.25.1-perl-128316-preserve-errno-from-failed-system-calls.patch
# Fix crash in "evalbytes S", RT#129196, in upstream after 5.25.4
Patch34: perl-5.25.4-perl-129196-Crash-bad-read-with-evalbytes-S.patch
Patch35: perl-5.24.0-Regression-test-for-RT-129196.patch
Patch36: perl-5.25.4-toke.c-fix-mswin32-builds.patch
# Fix crash in splice, RT#129164, RT#129166, RT#129167, in upstream after 5.25.4
Patch37: perl-5.22.2-perl-129164-Crash-with-splice.patch
# Fix string overrun in Perl_gv_fetchmethod_pvn_flags, RT#129267,
# in upstream after 5.25.4
Patch38: perl-5.24.0-clean-up-gv_fetchmethod_pvn_flags-introduce-name_end.patch
Patch39: perl-5.25.4-clean-up-gv_fetchmethod_pvn_flags-move-origname-init.patch
Patch40: perl-5.25.4-clean-up-gv_fetchmethod_pvn_flags-rename-nsplit-to-l.patch
Patch41: perl-5.25.4-fix-129267-rework-gv_fetchmethod_pvn_flags-separator.patch
Patch42: perl-5.25.4-perl-129267-Test-for-gv_fetchmethod-buffer-overrun.patch
# Fix crash when matching UTF-8 string with non-UTF-8 substrings, RT#129350,
# in upstream after 5.25.5
Patch43: perl-5.22.2-perl-129350-anchored-floating-substrings-must-be-utf.patch
# Fix parsing perl options in shell bang line, RT#129336,
# in upstream after 5.25.5
Patch44: perl-5.24.0-rt-129336-perl-i-u-erroneously-interpreted-as-u.patch
# Fix firstchar bitmap under UTF-8 with prefix optimization, RT#129950,
# in upstream after 5.25.6
Patch45: perl-5.22.2-regcomp.c-fix-perl-129950-fix-firstchar-bitmap-under.patch
# Avoid infinite loop in h2xs tool if enum and type have the same name,
# RT#130001, in upstream after 5.25.6
Patch46: perl-5.25.6-perl-130001-h2xs-avoid-infinite-loop-for-enums.patch
# Fix stack handling when calling chdir without an argument, RT#129130,
# in upstream after 5.25.6
Patch47: perl-5.22.2-perl-129130-make-chdir-allocate-the-stack-it-needs.patch
# Fix crash in Storable when deserializing malformed code reference, RT#68348,
# RT130098
Patch48: perl-5.25.7-Fix-Storable-segfaults.patch
# Fix assigning split() return values to an array, in upstream after 5.25.7
Patch49: perl-5.24.0-split-was-leaving-PL_sv_undef-in-unused-ary-slots.patch
# Fix const correctness in hv_func.h, bug #1242980, RT#130169,
# in upstream after 5.25.7
Patch50: perl-5.22.2-Fix-const-correctness-in-hv_func.h.patch
# Fix a crash in optimized evaluation of "or ((0) x 0))", RT#130247,
# in upsream after 5.25.7
Patch51: perl-5.22.2-assertion-failure-in-.-or-0-x-0.patch
# Fix a memory leak in IO::Poll, RT#129788, in upstream after 5.25.7
Patch52: perl-5.22.2-perl-129788-IO-Poll-fix-memory-leak.patch
# Fix regular expression matching, RT#130307, in upstream after 5.25.7
Patch53: perl-5.22.2-perl-130307-Correctly-unwind-on-cache-hit.patch
# Fix a buffer overflow in split in scalar context, RT#130262,
# in upstream after 5.25.8
Patch54: perl-5.24.1-perl-130262-split-scalar-context-stack-overflow-fix.patch
# Fix a heap overflow with pack "W", RT129149, in upstream after 5.25.8
Patch55: perl-5.25.8-perl-129149-avoid-a-heap-buffer-overflow-with-pack-W.patch
Patch56: perl-5.25.8-perl-129149-fix-the-test-so-skip-has-a-SKIP-to-work-.patch
# Fix a use-after-free when processing scalar variables in forms, RT#129125,
# in upstream after 5.25.8
Patch57: perl-5.24.1-perl-129125-copy-form-data-if-it-might-be-freed.patch
# Fix a heap overflow if invalid octal or hexadecimal number is used in
# transliteration expression, RT#129342, in upstream after 5.25.8
Patch58: perl-5.24.1-perl-129342-ensure-range-start-is-set-after-error-in.patch
# Fix out-of-bound read in case of unmatched regexp backreference, RT#129377,
# in upstream after 5.25.8
Patch59: perl-5.22.3-perl-129377-don-t-read-past-start-of-string-for-unma.patch
# Fix UTF-8 string handling in & operator, RT#129287, in upstream after 5.25.4
Patch60: perl-5.22.3-perl-129287-Make-UTF8-append-null.patch
# Fix recreation of *::, RT#129869, in upstream after 5.25.9
Patch61: perl-5.22.3-fix-special-case-recreation-of.patch
# Fix parsing goto statements in multicalled subroutine, RT#113938,
# in upstream after 5.25.9
Patch62: perl-5.22.3-permit-goto-at-top-level-of-multicalled-sub.patch
# Fix a heap overlow in parsing $#, RT#129274, in upstream after 5.25.9
Patch63: perl-5.22.3-perl-129274-avoid-treating-the-in-as-a-comment-intro.patch
# Fix a crash when compiling a regexp with impossible quantifiers, RT#130561,
# in upstream after 5.25.9
Patch64: perl-5.22.3-fix-RT-130561-recursion-and-optimising-away-impossib.patch
Patch65: perl-5.22.3-only-mess-with-NEXT_OFF-when-we-are-in-PASS2.patch
Patch66: perl-5.25.9-silence-warnings-from-tests-about-impossible-quantif.patch
# Fix a buffer overrun with format and "use bytes", RT#130703,
# in upstream after 5.25.9
Patch67: perl-5.24.1-buffer-overrun-with-format-and-use-bytes.patch
# Fix a buffer overflow when studying some regexps repeatedly,
# RT#129281, RT#129061, un upstream after 5.25.9
Patch68: perl-5.22.3-perl-129281-test-for-buffer-overflow-issue.patch
Patch69: perl-5.25.9-perl-129061-CURLYX-nodes-can-be-studied-more-than-on.patch
# Fix a null-pointer dereference on malformed code, RT#130815,
# in upstream after 5.25.9
Patch70: perl-5.24.1-perl-130815-fix-ck_return-null-pointer-deref-on-malf.patch
# Fix an use-after-free in substr() that modifies a magic variable, RT#129340,
# in upstream after 5.25.9
Patch71: perl-5.22.3-perl-129340-copy-the-source-when-inside-the-dest-in-.patch
# Fix a memory leak leak in Perl_reg_named_buff_fetch(), RT#130822,
# in upstream after 5.25.10
Patch72: perl-5.22.3-perl-130822-fix-an-AV-leak-in-Perl_reg_named_buff_fe.patch
# Fix an invalid memory read when parsing a loop variable, RT#130814,
# in upstream after 5.25.10
Patch73: perl-5.25.10-perl-130814-Add-testcase-and-new-testfile-t-comp-par.patch
# in upstream after 5.25.10
Patch74: perl-5.22.3-perl-130814-update-pointer-into-PL_linestr-after-loo.patch
# in upstream after 5.25.2
Patch75: perl-5.25.2-t-test.pl-Add-fresh_perl-function.patch
# in upstream after 5.25.10
Patch76: perl-5.25.10-fix-VMS-test-fail.patch
# Fix a heap-use-after-free in four-arguments substr call, RT#130624,
# in upstream after 5.25.10
Patch77: perl-5.24.1-RT-130624-heap-use-after-free-in-4-arg-substr.patch
# Make File::Glob more resistant against degenerative matching, RT#131211,
# in upstream after 5.27.0
Patch78: perl-5.24.1-perl-131211-fixup-File-Glob-degenerate-matching.patch
# Fix a memory wrap in sv_vcatpvfn_flags(), RT#131260, in upstream after 5.25.12
Patch79: perl-5.25.12-avoid-a-memory-wrap-in-sv_vcatpvfn_flags.patch
# Tests for avoid-a-memory-wrap-in-sv_vcatpvfn_flags.patch, RT#131260,
# in upstream after 5.27.0
Patch80: perl-5.24.1-sprintf-add-memory-wrap-tests.patch
# Fix a crash when calling a subroutine from a stash, RT#131085,
# in upstream after 5.27.0
Patch81: perl-5.24.1-perl-131085-Crash-with-sub-in-stash.patch
# Fix an improper cast of a negative integer to an unsigned 8-bit type,
# RT#131190, in upstream after 5.27.0
Patch82: perl-5.27.0-Fix-131190-UTF8-code-improperly-casting-negative-int.patch
# Fix cloning :via handles on thread creation, RT#131221,
# in upstream after 5.27.0
Patch83: perl-5.22.3-perl-131221-improve-duplication-of-via-handles.patch
Patch84: perl-5.27.0-perl-131221-sv_dup-sv_dup_inc-are-only-available-und.patch
# Fix glob UTF-8 flag on a glob reassignment, RT#131263,
# in upstream after 5.27.0
Patch85: perl-5.24.1-perl-131263-clear-the-UTF8-flag-on-a-glob-if-it-isn-.patch
# Fix a buffer overflow in my_atof2(), RT#131526, in upstream after 5.27.0
Patch86: perl-5.27.0-perl-131526-don-t-go-beyond-the-end-of-the-NUL-in-my.patch
# Fix handling backslashes in PATH environment variable when executing
# "perl -S", RT#129183, in upstream after 5.27.0
Patch88: perl-5.27.0-perl-129183-don-t-treat-as-an-escape-in-PATH-for-S.patch
# Link XS modules to libperl.so with EU::CBuilder on Linux, bug #960048
Patch200: perl-5.16.3-Link-XS-modules-to-libperl.so-with-EU-CBuilder-on-Li.patch
@ -120,7 +287,12 @@ BuildRequires: procps, rsyslog
# compat macro needed for rebuild
%global perl_compat perl(:MODULE_COMPAT_5.22.1)
%global perl_compat perl(:MODULE_COMPAT_5.22.4)
# perl-interpreter denotes a package with the perl executable.
# Full EVR is for compatibility with systems that swapped perl and perl-core
# <https://fedoraproject.org/wiki/Changes/perl_Package_to_Install_Core_Modules>.
Provides: perl-interpreter = %{perl_epoch}:%{perl_version}-%{release}
# File provides
Provides: perl(bytes_heavy.pl)
@ -130,7 +302,7 @@ Provides: perl(perl5db.pl)
# suidperl isn't created by upstream since 5.12.0
Obsoletes: perl-suidperl <= 4:5.12.2
Requires: perl-libs = %{perl_epoch}:%{perl_version}-%{release}
Requires: perl-libs%{?_isa} = %{perl_epoch}:%{perl_version}-%{release}
# Require this till perl sub-package requires any modules
Requires: %perl_compat
@ -173,6 +345,9 @@ Group: Development/Languages
License: GPL+ or Artistic
# Compat provides
Provides: %perl_compat
Provides: perl(:MODULE_COMPAT_5.22.3)
Provides: perl(:MODULE_COMPAT_5.22.2)
Provides: perl(:MODULE_COMPAT_5.22.1)
Provides: perl(:MODULE_COMPAT_5.22.0)
# Interpreter version to fulfil required genersted from "require 5.006;"
Provides: perl(:VERSION) = %{perl_version}
@ -218,7 +393,7 @@ Requires: systemtap-sdt-devel
Requires: perl(ExtUtils::ParseXS)
Requires: %perl_compat
# Match library and header files when downgrading releases
Requires: perl-libs = %{perl_epoch}:%{perl_version}-%{release}
Requires: perl-libs%{?_isa} = %{perl_epoch}:%{perl_version}-%{release}
%description devel
This package contains header files and development modules.
@ -282,8 +457,8 @@ License: GPL+ or Artistic
Epoch: 0
Version: %{perl_version}
Requires: %perl_compat
Requires: perl-libs = %{perl_epoch}:%{perl_version}-%{release}
Requires: perl-devel = %{perl_epoch}:%{perl_version}-%{release}
Requires: perl-libs%{?_isa} = %{perl_epoch}:%{perl_version}-%{release}
Requires: perl-devel%{?_isa} = %{perl_epoch}:%{perl_version}-%{release}
Requires: perl-macros
Requires: perl-utils
@ -812,7 +987,7 @@ module can handle all types of input, including partial-byte data.
%package Encode
Summary: Character encodings in Perl
Group: Development/Libraries
License: (GPL+ or Artistic) and UCD
License: (GPL+ or Artistic) and Artistic 2.0 and UCD
Epoch: 3
Version: 2.72
Requires: %perl_compat
@ -892,6 +1067,9 @@ License: GPL+ or Artistic
Epoch: 0
Version: 1.23
Requires: %perl_compat
# Errno.pm bakes in kernel version at build time and compares it against
# $Config{osvers} at run time. Match exact interpreter build. Bug #1393421.
Requires: perl-libs%{?_isa} = %{perl_epoch}:%{perl_version}-%{release}
Requires: perl(Carp)
Conflicts: perl < 4:5.22.0-351
@ -1556,7 +1734,7 @@ Summary: What modules are shipped with versions of perl
Group: Development/Libraries
License: GPL+ or Artistic
Epoch: 1
Version: 5.20151213
Version: 5.20160429
Requires: %perl_compat
Requires: perl(List::Util)
Requires: perl(version) >= 0.88
@ -1572,7 +1750,7 @@ Summary: Tool for listing modules shipped with perl
Group: Development/Tools
License: GPL+ or Artistic
Epoch: 1
Version: 5.20151213
Version: 5.20160429
Requires: %perl_compat
Requires: perl(feature)
Requires: perl(version) >= 0.88
@ -2302,7 +2480,7 @@ hashes and hash refs.
%package Unicode-Collate
Summary: Unicode Collation Algorithm
Group: Development/Libraries
License: (GPL+ or Artistic) and UCD
License: (GPL+ or Artistic) and Unicode
Epoch: 0
Version: 1.12
Requires: %perl_compat
@ -2362,9 +2540,64 @@ Perl extension for Version Objects
%patch16 -p1
%patch22 -p1
%patch26 -p1
%patch27 -p1
%patch28 -p1
%patch29 -p1
%patch32 -p1
%patch33 -p1
%patch34 -p1
%patch35 -p1
%patch36 -p1
%patch37 -p1
%patch38 -p1
%patch39 -p1
%patch40 -p1
%patch41 -p1
%patch42 -p1
%patch43 -p1
%patch44 -p1
%patch45 -p1
%patch46 -p1
%patch47 -p1
%patch48 -p1
%patch49 -p1
%patch50 -p1
%patch51 -p1
%patch52 -p1
%patch53 -p1
%patch54 -p1
%patch55 -p1
%patch56 -p1
%patch57 -p1
%patch58 -p1
%patch59 -p1
%patch60 -p1
%patch61 -p1
%patch62 -p1
%patch63 -p1
%patch64 -p1
%patch65 -p1
%patch66 -p1
%patch67 -p1
%patch68 -p1
%patch69 -p1
%patch70 -p1
%patch71 -p1
%patch72 -p1
%patch73 -p1
%patch74 -p1
%patch75 -p1
%patch76 -p1
%patch77 -p1
%patch78 -p1
%patch79 -p1
%patch80 -p1
%patch81 -p1
%patch82 -p1
%patch83 -p1
%patch84 -p1
%patch85 -p1
%patch86 -p1
%patch88 -p1
%patch200 -p1
%patch201 -p1
@ -2383,9 +2616,55 @@ perl -x patchlevel.h \
'Fedora Patch16: Install libperl.so to -Dshrpdir value' \
'Fedora Patch22: Document Math::BigInt::CalcEmu requires Math::BigInt (CPAN RT#85015)' \
'Fedora Patch26: Make *DBM_File desctructors thread-safe (RT#61912)' \
'Fedora Patch27: Make PadlistNAMES() lvalue again (CPAN RT#101063)' \
'Fedora Patch28: Make magic vtable writable as a work-around for Coro (CPAN RT#101063)' \
'Fedora Patch29: Fix CVE-2016-2381 (ambiguous environment variables handling)' \
'Fedora Patch29: Fix duplicating PerlIO::encoding when spawning threads (RT#31923)' \
'Fedora Patch32: Fix a crash in lexical scope warnings (RT#128597)' \
'Fedora Patch33: Do not mangle errno from failed socket calls (RT#128316)' \
'Fedora Patch34: Fix crash in "evalbytes S" (RT#129196)' \
'Fedora Patch35: Fix crash in "evalbytes S" (RT#129196)' \
'Fedora Patch36: Fix crash in "evalbytes S" (RT#129196)' \
'Fedora Patch37: Fix crash in splice (RT#129164, RT#129166, RT#129167)' \
'Fedora Patch38: Fix string overrun in Perl_gv_fetchmethod_pvn_flags (RT#129267)' \
'Fedora Patch39: Fix string overrun in Perl_gv_fetchmethod_pvn_flags (RT#129267)' \
'Fedora Patch40: Fix string overrun in Perl_gv_fetchmethod_pvn_flags (RT#129267)' \
'Fedora Patch41: Fix string overrun in Perl_gv_fetchmethod_pvn_flags (RT#129267)' \
'Fedora Patch42: Fix string overrun in Perl_gv_fetchmethod_pvn_flags (RT#129267)' \
'Fedora Patch43: Fix crash when matching UTF-8 string with non-UTF-8 substrings (RT#129350)' \
'Fedora Patch44: Fix parsing perl options in shell bang line (RT#129336)' \
'Fedora Patch45: Fix firstchar bitmap under UTF-8 with prefix optimization (RT#129950)' \
'Fedora Patch46: Avoid infinite loop in h2xs tool if enum and type have the same name (RT130001)' \
'Fedora Patch47: Fix stack handling when calling chdir without an argument (RT#129130)' \
'Fedora Patch48: Fix crash in Storable when deserializing malformed code reference (RT#68348, RT#130098)' \
'Fedora Patch49: Fix assigning split() return values to an array' \
'Fedora Patch50: Fix const correctness in hv_func.h (RT#130169)' \
'Fedora Patch51: Fix a crash in optimized evaluation of "or ((0) x 0))" (RT#130247)' \
'Fedora Patch52: Fix a memory leak in IO::Poll (RT#129788)' \
'Fedora Patch53: Fix regular expression matching (RT#130307)' \
'Fedora Patch54: Fix a buffer overflow in split in scalar context (RT#130262)' \
'Fedora Patch55: Fix a heap overflow with pack "W" (RT129149)' \
'Fedora Patch57: Fix a use-after-free when processing scalar variables in forms (RT#129125)' \
'Fedora Patch58: Fix a heap overflow if invalid octal or hexadecimal number is used in transliteration expression (RT#129342)' \
'Fedora Patch59: Fix out-of-bound read in case of unmatched regexp backreference (RT#129377)' \
'Fedora Patch60: Fix UTF-8 string handling in & operator (RT#129287)' \
'Fedora Patch61: Fix recreation of *:: (RT#129869)' \
'Fedora Patch62: Fix parsing goto statements in multicalled subroutine (RT#113938)' \
'Fedora Patch63: Fix a heap overlow in parsing $# (RT#129274)' \
'Fedora Patch64: Fix a crash when compiling a regexp with impossible quantifiers (RT#130561)' \
'Fedora Patch67: Fix a buffer overrun with format and "use bytes" (RT#130703)' \
'Fedora Patch68: Fix a buffer overflow when studying some regexps repeatedly (RT#129281, RT#129061)' \
'Fedora Patch70: Fix a null-pointer dereference on malformed code (RT#130815)' \
'Fedora Patch71: Fix an use-after-free in substr() that modifies a magic variable (RT#129340)' \
'Fedora Patch72: Fix a memory leak leak in Perl_reg_named_buff_fetch() (RT#130822)' \
'Fedora Patch73: Fix an invalid memory read when parsing a loop variable (RT#130814)' \
'Fedora Patch77: Fix a heap-use-after-free in four-arguments substr call (RT#130624)' \
'Fedora Patch78: Make File::Glob more resistant against degenerative matching (RT#131211)' \
'Fedora Patch79: Fix a memory wrap in sv_vcatpvfn_flags() (RT#131260)' \
'Fedora Patch81: Fix a crash when calling a subroutine from a stash (RT#131085)' \
'Fedora Patch82: Fix an improper cast of a negative integer to an unsigned 8-bit type (RT#131190)' \
'Fedora Patch83: Fix cloning :via handles on thread creation (RT#131221)' \
'Fedora Patch85: Fix glob UTF-8 flag on a glob reassignment (RT#131263)' \
'Fedora Patch86: Fix a buffer overflow in my_atof2() (RT#131526)' \
'Fedora Patch88: Fix handling backslashes in PATH environment variable when executing "perl -S" (RT#129183)' \
'Fedora Patch200: Link XS modules to libperl.so with EU::CBuilder on Linux' \
'Fedora Patch201: Link XS modules to libperl.so with EU::MM on Linux' \
%{nil}
@ -4638,6 +4917,95 @@ popd
# Old changelog entries are preserved in CVS.
%changelog
* Mon Jul 17 2017 Jitka Plesnikova <jplesnik@redhat.com> - 4:5.22.4-372
- 5.22.4 bump (see <http://search.cpan.org/dist/perl-5.22.4/pod/perldelta.pod>
for release notes)
* Mon Jun 26 2017 Petr Pisar <ppisar@redhat.com> - 4:5.22.3-371
- Make File::Glob more resistant against degenerative matching (RT#131211)
- Fix a memory wrap in sv_vcatpvfn_flags() (RT#131260)
- Fix a crash when calling a subroutine from a stash (RT#131085)
- Fix an improper cast of a negative integer to an unsigned 8-bit type (RT#131190)
- Fix cloning :via handles on thread creation (RT#131221)
- Fix glob UTF-8 flag on a glob reassignment (RT#131263)
- Fix a buffer overflow in my_atof2() (RT#131526)
- Fix checks for tainted directory in $ENV{PATH} if a backslash escape presents
- Fix handling backslashes in PATH environment variable when executing
"perl -S" (RT#129183)
- Provide perl-interpreter RPM dependency symbol
<https://fedoraproject.org/wiki/Changes/perl_Package_to_Install_Core_Modules>
* Wed Mar 08 2017 Petr Pisar <ppisar@redhat.com> - 4:5.22.3-370
- Fix a null-pointer dereference on malformed code (RT#130815)
- Fix an use-after-free in substr() that modifies a magic variable (RT#129340)
- Fix a memory leak leak in Perl_reg_named_buff_fetch() (RT#130822)
- Fix an invalid memory read when parsing a loop variable (RT#130814)
- Fix a heap-use-after-free in four-arguments substr call (RT#130624)
* Fri Feb 17 2017 Petr Pisar <ppisar@redhat.com> - 4:5.22.3-369
- Fix a crash when compiling a regexp with impossible quantifiers (RT#130561)
- Fix a buffer overrun with format and "use bytes" (RT#130703)
- Fix a buffer overflow when studying some regexps repeatedly
(RT#129281, RT#129061)
* Thu Jan 26 2017 Petr Pisar <ppisar@redhat.com> - 4:5.22.3-368
- Fix UTF-8 string handling in & operator (RT#129287)
- Fix recreation of *:: (RT#129869)
- Fix parsing goto statements in multicalled subroutine (RT#113938)
- Fix a heap overlow in parsing $# (RT#129274)
* Fri Jan 20 2017 Petr Pisar <ppisar@redhat.com> - 4:5.22.3-367
- Fix a buffer overflow in split in scalar context (RT#130262)
- Fix a heap overflow with pack "W" (RT129149)
- Fix a use-after-free when processing scalar variables in forms (RT#129125)
- Fix a heap overflow if invalid octal or hexadecimal number is used in
transliteration expression (RT#129342)
- Fix out-of-bound read in case of unmatched regexp backreference (RT#129377)
* Mon Jan 16 2017 Jitka Plesnikova <jplesnik@redhat.com> - 4:5.22.3-366
- 5.22.3 bump (see <http://search.cpan.org/dist/perl-5.22.3/pod/perldelta.pod>
for release notes)
* Mon Dec 19 2016 Petr Pisar <ppisar@redhat.com> - 4:5.22.2-365
- Fix crash in Storable when deserializing malformed code reference
(RT#68348, RT#130098)
- Tighten dependencies between architecture specific sub-packages to ISA
- Fix assigning split() return values to an array
- Fix const correctness in hv_func.h (bug #1242980)
- Fix a crash in optimized evaluation of "or ((0) x 0))" (RT#130247)
- Fix a memory leak in IO::Poll (RT#129788)
- Fix regular expression matching (RT#130307)
* Wed Nov 09 2016 Petr Pisar <ppisar@redhat.com> - 4:5.22.2-364
- Tie perl-Errno release to interpreter build because of kernel version check
(bug #1393421)
* Fri Nov 04 2016 Petr Pisar <ppisar@redhat.com> - 4:5.22.2-363
- Fix a crash in lexical scope warnings (RT#128597)
- Do not mangle errno from failed socket calls (RT#128316)
- Fix crash in "evalbytes S" (RT#129196)
- Fix crash in splice (RT#129164, RT#129166, RT#129167)
- Fix string overrun in Perl_gv_fetchmethod_pvn_flags (RT#129267)
- Fix crash when matching UTF-8 string with non-UTF-8 substrings (RT#129350)
- Fix parsing perl options in shell bang line (RT#129336)
- Fix firstchar bitmap under UTF-8 with prefix optimization (RT#129950)
- Avoid infinite loop in h2xs tool if enum and type have the same name
(RT130001)
- Fix stack handling when calling chdir without an argument (RT#129130)
* Wed Aug 03 2016 Jitka Plesnikova <jplesnik@redhat.com> - 4:5.22.2-362
- Avoid loading optional modules from default . (CVE-2016-1238)
* Thu Jul 07 2016 Jitka Plesnikova <jplesnik@redhat.com> - 4:5.22.2-361
- Do not let XSLoader load relative paths (CVE-2016-6185)
* Mon Jun 13 2016 Petr Pisar <ppisar@redhat.com> - 4:5.22.2-360
- Fix duplicating PerlIO::encoding when spawning threads (bug #1345788)
* Mon May 02 2016 Jitka Plesnikova <jplesnik@redhat.com> - 4:5.22.2-359
- 5.22.2 bump (see <http://search.cpan.org/dist/perl-5.22.2/pod/perldelta.pod>
for release notes)
* Fri Mar 04 2016 Petr Pisar <ppisar@redhat.com> - 4:5.22.1-358
- Remove bundled perl-IPC-SysV (bug #1308527)

View File

@ -1 +1 @@
67242b9bd642b458bec884ed2a040910 perl-5.22.1.tar.bz2
SHA512 (perl-5.22.4.tar.bz2) = d91e86449e86e42657e62f7592675cee73eeef1766fdde6df923702f3b5f30ae82c0e4c847615f3de61acf6ff4e294f763fc0381a9cc044f25debb369415d96b