rpms/perl
7
0
Fork 0
Code Issues Pull Requests Releases Activity

5.26.0 bump; Update sub-packages; Update or remove patches

Browse Source
This commit is contained in:
Jitka Plesnikova 2017-06-02 08:17:46 +02:00
parent b14a87313b
commit 59397e34d7
70 changed files with 613 additions and 5941 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -23,3 +23,4 @@ perl-5.12.1.tar.gz
/perl-5.22.2.tar.bz2
/perl-5.24.0.tar.bz2
/perl-5.24.1.tar.bz2
/perl-5.26.0.tar.bz2

367
Compress-Raw-Zlib-2.071-Adapt-to-zlib-1.2.11.patch
View File

@ -1,367 +0,0 @@
From 0c7af9e6cb05b436505e7f46ef49dcb6f791f30a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Fri, 17 Feb 2017 11:00:21 +0100
Subject: [PATCH] Adapt to zlib-1.2.11
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This is a fix ported from Compress-Raw-Zlib-2.072 that restores
compatibility with zlib-1.2.11.
CPAN RT#119762
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
Zlib.xs | 220 +++++++++++++++++++++++++++++++++++++++++++++++--------------
t/02zlib.t | 11 +++-
2 files changed, 178 insertions(+), 53 deletions(-)
diff --git a/Zlib.xs b/Zlib.xs
index d379f78..83d1423 100644
--- a/Zlib.xs
+++ b/Zlib.xs
@@ -74,6 +74,10 @@
# define AT_LEAST_ZLIB_1_2_8
#endif
+#if defined(ZLIB_VERNUM) && ZLIB_VERNUM >= 0x1290
+# define AT_LEAST_ZLIB_1_2_9
+#endif
+
#ifdef USE_PPPORT_H
# define NEED_sv_2pvbyte
# define NEED_sv_2pv_nolen
@@ -134,12 +138,13 @@ typedef struct di_stream {
uLong dict_adler ;
int last_error ;
bool zip_mode ;
-#define SETP_BYTE
+/* #define SETP_BYTE */
#ifdef SETP_BYTE
+ /* SETP_BYTE only works with zlib up to 1.2.8 */
bool deflateParams_out_valid ;
Bytef deflateParams_out_byte;
#else
-#define deflateParams_BUFFER_SIZE 0x4000
+#define deflateParams_BUFFER_SIZE 0x40000
uLong deflateParams_out_length;
Bytef* deflateParams_out_buffer;
#endif
@@ -636,6 +641,103 @@ char * string ;
return sv ;
}
+#if 0
+int
+flushToBuffer(di_stream* s, int flush)
+{
+ dTHX;
+ int ret ;
+ z_stream * strm = &s->stream;
+
+ Bytef* output = s->deflateParams_out_buffer ;
+
+ strm->next_in = NULL;
+ strm->avail_in = 0;
+
+ uLong total_output = 0;
+ uLong have = 0;
+
+ do
+ {
+ if (output)
+ output = (unsigned char *)saferealloc(output, total_output + s->bufsize);
+ else
+ output = (unsigned char *)safemalloc(s->bufsize);
+
+ strm->next_out = output + total_output;
+ strm->avail_out = s->bufsize;
+
+ ret = deflate(strm, flush); /* no bad return value */
+ //assert(ret != Z_STREAM_ERROR); /* state not clobbered */
+ if(ret == Z_STREAM_ERROR)
+ {
+ safefree(output);
+ return ret;
+ }
+ have = s->bufsize - strm->avail_out;
+ total_output += have;
+
+ //fprintf(stderr, "FLUSH %s %d, return %d\n", flush_flags[flush], have, ret);
+
+ } while (strm->avail_out == 0);
+
+ s->deflateParams_out_buffer = output;
+ s->deflateParams_out_length = total_output;
+
+ return Z_OK;
+}
+#endif
+
+#ifndef SETP_BYTE
+int
+flushParams(di_stream* s)
+{
+ dTHX;
+ int ret ;
+ z_stream * strm = &s->stream;
+
+ strm->next_in = NULL;
+ strm->avail_in = 0;
+
+ Bytef* output = s->deflateParams_out_buffer ;
+ uLong total_output = s->deflateParams_out_length;
+
+ uLong have = 0;
+
+ do
+ {
+ if (output)
+ output = (unsigned char *)saferealloc(output, total_output + s->bufsize);
+ else
+ output = (unsigned char *)safemalloc(s->bufsize);
+
+ strm->next_out = output + total_output;
+ strm->avail_out = s->bufsize;
+
+ ret = deflateParams(&(s->stream), s->Level, s->Strategy);
+ /* fprintf(stderr, "deflateParams %d %s %lu\n", ret,
+ GetErrorString(ret), s->bufsize - strm->avail_out); */
+
+ if (ret == Z_STREAM_ERROR)
+ break;
+
+ have = s->bufsize - strm->avail_out;
+ total_output += have;
+
+
+ } while (ret == Z_BUF_ERROR) ;
+
+ if(ret == Z_STREAM_ERROR)
+ safefree(output);
+ else
+ {
+ s->deflateParams_out_buffer = output;
+ s->deflateParams_out_length = total_output;
+ }
+
+ return ret;
+}
+#endif /* ! SETP_BYTE */
#include "constants.h"
@@ -991,20 +1093,24 @@ deflate (s, buf, output)
/* Check for saved output from deflateParams */
if (s->deflateParams_out_length) {
uLong plen = s->deflateParams_out_length ;
- /* printf("Copy %d bytes saved data\n", plen);*/
+ /* printf("Copy %lu bytes saved data\n", plen); */
if (s->stream.avail_out < plen) {
- /*printf("GROW from %d to %d\n", s->stream.avail_out,
- SvLEN(output) + plen - s->stream.avail_out); */
- Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ;
+ /* printf("GROW from %d to %lu\n", s->stream.avail_out,
+ SvLEN(output) + plen - s->stream.avail_out); */
+ s->stream.next_out = (Bytef*) Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ;
+ s->stream.next_out += cur_length;
}
- Copy(s->stream.next_out, s->deflateParams_out_buffer, plen, Bytef) ;
- cur_length = cur_length + plen;
+ Copy(s->deflateParams_out_buffer, s->stream.next_out, plen, Bytef) ;
+ cur_length += plen;
SvCUR_set(output, cur_length);
- s->stream.next_out += plen ;
- s->stream.avail_out = SvLEN(output) - cur_length ;
- increment = s->stream.avail_out;
- s->deflateParams_out_length = 0;
+ s->stream.next_out += plen ;
+ s->stream.avail_out = SvLEN(output) - cur_length ;
+ increment = s->stream.avail_out;
+
+ s->deflateParams_out_length = 0;
+ Safefree(s->deflateParams_out_buffer);
+ s->deflateParams_out_buffer = NULL;
}
#endif
RETVAL = Z_OK ;
@@ -1027,6 +1133,12 @@ deflate (s, buf, output)
}
RETVAL = deflate(&(s->stream), Z_NO_FLUSH);
+ if (RETVAL != Z_STREAM_ERROR) {
+ int done = increment - s->stream.avail_out ;
+ /* printf("std DEFLATEr returned %d '%s' avail in %d, out %d wrote %d\n", RETVAL,
+ GetErrorString(RETVAL), s->stream.avail_in,
+s->stream.avail_out, done); */
+ }
if (trace) {
printf("DEFLATE returned %d %s, avail in %d, out %d\n", RETVAL,
@@ -1080,7 +1192,6 @@ flush(s, output, f=Z_FINISH)
CODE:
bufinc = s->bufsize;
- s->stream.avail_in = 0; /* should be zero already anyway */
/* retrieve the output buffer */
output = deRef_l(output, "flush") ;
@@ -1108,20 +1219,24 @@ flush(s, output, f=Z_FINISH)
/* Check for saved output from deflateParams */
if (s->deflateParams_out_length) {
uLong plen = s->deflateParams_out_length ;
- /* printf("Copy %d bytes saved data\n", plen); */
+ /* printf("Copy %lu bytes saved data\n", plen); */
if (s->stream.avail_out < plen) {
- /* printf("GROW from %d to %d\n", s->stream.avail_out,
+ /* printf("GROW from %d to %lu\n", s->stream.avail_out,
SvLEN(output) + plen - s->stream.avail_out); */
- Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ;
+ s->stream.next_out = (Bytef*) Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ;
+ s->stream.next_out += cur_length;
}
- Copy(s->stream.next_out, s->deflateParams_out_buffer, plen, Bytef) ;
- cur_length = cur_length + plen;
+ Copy(s->deflateParams_out_buffer, s->stream.next_out, plen, Bytef) ;
+ cur_length += plen;
SvCUR_set(output, cur_length);
- s->stream.next_out += plen ;
- s->stream.avail_out = SvLEN(output) - cur_length ;
- increment = s->stream.avail_out;
- s->deflateParams_out_length = 0;
+ s->stream.next_out += plen ;
+ s->stream.avail_out = SvLEN(output) - cur_length ;
+ increment = s->stream.avail_out;
+
+ s->deflateParams_out_length = 0;
+ Safefree(s->deflateParams_out_buffer);
+ s->deflateParams_out_buffer = NULL;
}
#endif
@@ -1145,9 +1260,15 @@ flush(s, output, f=Z_FINISH)
}
RETVAL = deflate(&(s->stream), f);
+ if (RETVAL != Z_STREAM_ERROR) {
+ int done = availableout - s->stream.avail_out ;
+ /* printf("flush DEFLATEr returned %d '%s' avail in %d, out %d wrote %d\n", RETVAL,
+ GetErrorString(RETVAL), s->stream.avail_in,
+s->stream.avail_out, done); */
+ }
if (trace) {
- printf("flush DEFLATE returned %d %s, avail in %d, out %d\n", RETVAL,
+ printf("flush DEFLATE returned %d '%s', avail in %d, out %d\n", RETVAL,
GetErrorString(RETVAL), s->stream.avail_in, s->stream.avail_out);
DispStream(s, "AFTER");
}
@@ -1184,41 +1305,38 @@ _deflateParams(s, flags, level, strategy, bufsize)
int level
int strategy
uLong bufsize
+ bool changed = FALSE;
CODE:
- /* printf("_deflateParams(Flags %d Level %d Strategy %d Bufsize %d)\n", flags, level, strategy, bufsize);
- printf("Before -- Level %d, Strategy %d, Bufsize %d\n", s->Level, s->Strategy, s->bufsize); */
- if (flags & 1)
- s->Level = level ;
- if (flags & 2)
- s->Strategy = strategy ;
- if (flags & 4) {
+ /* printf("_deflateParams(Flags %d Level %d Strategy %d Bufsize %d)\n", flags, level, strategy, bufsize);
+ printf("Before -- Level %d, Strategy %d, Bufsize %d\n", s->Level, s->Strategy, s->bufsize); */
+ if (flags & 1 && level != s->Level) {
+ s->Level = level ;
+ changed = TRUE;
+ }
+ if (flags & 2 && strategy != s->Strategy) {
+ s->Strategy = strategy ;
+ changed = TRUE;
+ }
+ if (flags & 4)
s->bufsize = bufsize;
- }
- /* printf("After -- Level %d, Strategy %d, Bufsize %d\n", s->Level, s->Strategy, s->bufsize);*/
+ if (changed) {
#ifdef SETP_BYTE
- s->stream.avail_in = 0;
- s->stream.next_out = &(s->deflateParams_out_byte) ;
- s->stream.avail_out = 1;
- RETVAL = deflateParams(&(s->stream), s->Level, s->Strategy);
- s->deflateParams_out_valid =
- (RETVAL == Z_OK && s->stream.avail_out == 0) ;
- /* printf("RETVAL %d, avail out %d, byte %c\n", RETVAL, s->stream.avail_out, s->deflateParams_out_byte); */
+ s->stream.avail_in = 0;
+ s->stream.next_out = &(s->deflateParams_out_byte) ;
+ s->stream.avail_out = 1;
+ RETVAL = deflateParams(&(s->stream), s->Level, s->Strategy);
+ s->deflateParams_out_valid =
+ (RETVAL == Z_OK && s->stream.avail_out == 0) ;
#else
- /* printf("Level %d Strategy %d, Prev Len %d\n",
+ /* printf("Level %d Strategy %d, Prev Len %d\n",
s->Level, s->Strategy, s->deflateParams_out_length); */
- s->stream.avail_in = 0;
- if (s->deflateParams_out_buffer == NULL)
- s->deflateParams_out_buffer = safemalloc(deflateParams_BUFFER_SIZE);
- s->stream.next_out = s->deflateParams_out_buffer ;
- s->stream.avail_out = deflateParams_BUFFER_SIZE;
-
- RETVAL = deflateParams(&(s->stream), s->Level, s->Strategy);
- s->deflateParams_out_length = deflateParams_BUFFER_SIZE - s->stream.avail_out;
- /* printf("RETVAL %d, length out %d, avail %d\n",
- RETVAL, s->deflateParams_out_length, s->stream.avail_out ); */
+ RETVAL = flushParams(s);
#endif
+ }
+ else
+ RETVAL = Z_OK;
OUTPUT:
- RETVAL
+ RETVAL
int
diff --git a/t/02zlib.t b/t/02zlib.t
index 2c9aad6..5d024a9 100644
--- a/t/02zlib.t
+++ b/t/02zlib.t
@@ -27,7 +27,7 @@ BEGIN
$count = 232 ;
}
elsif ($] >= 5.006) {
- $count = 317 ;
+ $count = 320 ;
}
else {
$count = 275 ;
@@ -559,6 +559,13 @@ SKIP:
is $x->get_Level(), Z_BEST_SPEED;
is $x->get_Strategy(), Z_HUFFMAN_ONLY;
+ # change both Level & Strategy again without any calls to deflate
+ $status = $x->deflateParams(-Level => Z_DEFAULT_COMPRESSION, -Strategy => Z_DEFAULT_STRATEGY, -Bufsize => 1234) ;
+ cmp_ok $status, '==', Z_OK ;
+
+ is $x->get_Level(), Z_DEFAULT_COMPRESSION;
+ is $x->get_Strategy(), Z_DEFAULT_STRATEGY;
+
$status = $x->deflate($goodbye, $Answer) ;
cmp_ok $status, '==', Z_OK ;
$input .= $goodbye;
@@ -568,7 +575,7 @@ SKIP:
cmp_ok $status, '==', Z_OK ;
is $x->get_Level(), Z_NO_COMPRESSION;
- is $x->get_Strategy(), Z_HUFFMAN_ONLY;
+ is $x->get_Strategy(), Z_DEFAULT_STRATEGY;
$status = $x->deflate($goodbye, $Answer) ;
cmp_ok $status, '==', Z_OK ;
--
2.7.4

82
Compress-Raw-Zlib-2.071-Conform-to-C90.patch
View File

@ -1,82 +0,0 @@
From 1f3ac68dac93b7b85f09427d188386aaff0d3f80 Mon Sep 17 00:00:00 2001
From: Reini Urban <reini.urban@gmail.com>
Date: Fri, 17 Feb 2017 12:06:27 +0100
Subject: [PATCH] Conform to C90
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
The code failed to compile when building perl because perl adds -Werror=declaration-after-statement:
gcc -c -I/usr/include -D_REENTRANT -D_GNU_SOURCE -O2 -g -pipe -Wall -Werror=format-security -Wp,-D_FORTIFY_SOURCE=2 -fexceptions -fstack-protector-strong --param=ssp-buffer-size=4 -grecord-gcc-switches -m64 -mtune=generic -fwrapv -fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -Werror=declaration-after-statement -Wextra -Wc++-compat -Wwrite-strings -g -DVERSION=\"2.069\" -DXS_VERSION=\"2.069\" -fPIC "-I../.." -DNO_VIZ -DZ_SOLO -DGZIP_OS_CODE=3 Zlib.c
Zlib.xs: In function 'flushParams':
Zlib.xs:702:5: error: ISO C90 forbids mixed declarations and code [-Werror=declaration-after-statement]
Bytef* output = s->deflateParams_out_buffer ;
^~~~~
CPAN RT#120272
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
Zlib.xs | 22 +++++++++++-----------
1 file changed, 11 insertions(+), 11 deletions(-)
diff --git a/Zlib.xs b/Zlib.xs
index 83d1423..7f4396a 100644
--- a/Zlib.xs
+++ b/Zlib.xs
@@ -696,14 +696,14 @@ flushParams(di_stream* s)
int ret ;
z_stream * strm = &s->stream;
- strm->next_in = NULL;
- strm->avail_in = 0;
-
Bytef* output = s->deflateParams_out_buffer ;
uLong total_output = s->deflateParams_out_length;
uLong have = 0;
+ strm->next_in = NULL;
+ strm->avail_in = 0;
+
do
{
if (output)
@@ -1133,12 +1133,12 @@ deflate (s, buf, output)
}
RETVAL = deflate(&(s->stream), Z_NO_FLUSH);
- if (RETVAL != Z_STREAM_ERROR) {
+ /* if (RETVAL != Z_STREAM_ERROR) {
int done = increment - s->stream.avail_out ;
- /* printf("std DEFLATEr returned %d '%s' avail in %d, out %d wrote %d\n", RETVAL,
+ printf("std DEFLATEr returned %d '%s' avail in %d, out %d wrote %d\n", RETVAL,
GetErrorString(RETVAL), s->stream.avail_in,
-s->stream.avail_out, done); */
- }
+s->stream.avail_out, done);
+ } */
if (trace) {
printf("DEFLATE returned %d %s, avail in %d, out %d\n", RETVAL,
@@ -1260,12 +1260,12 @@ flush(s, output, f=Z_FINISH)
}
RETVAL = deflate(&(s->stream), f);
- if (RETVAL != Z_STREAM_ERROR) {
+ /* if (RETVAL != Z_STREAM_ERROR) {
int done = availableout - s->stream.avail_out ;
- /* printf("flush DEFLATEr returned %d '%s' avail in %d, out %d wrote %d\n", RETVAL,
+ printf("flush DEFLATEr returned %d '%s' avail in %d, out %d wrote %d\n", RETVAL,
GetErrorString(RETVAL), s->stream.avail_in,
-s->stream.avail_out, done); */
- }
+s->stream.avail_out, done);
+ } */
if (trace) {
printf("flush DEFLATE returned %d '%s', avail in %d, out %d\n", RETVAL,
--
2.7.4

878
gendep.macros
View File

File diff suppressed because it is too large Load Diff

8
perl-5.16.3-Link-XS-modules-to-libperl.so-with-EU-MM-on-Linux.patch
View File

@ -27,14 +27,14 @@ index a8b172f..a3fbce2 100644
$Is{Solaris} = $^O eq 'solaris';
$Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
@@ -932,7 +933,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
push(@m," \$(RM_F) \$\@\n");
my $libs = '$(LDLOADLIBS)';
- if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
+ if (($Is{Linux} || $Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
# Use nothing on static perl platforms, and to the flags needed
# to link against the shared libperl library on shared perl
# platforms. We peek at lddlflags to see if we need -Wl,-R
# Use nothing on static perl platforms, and to the flags needed
# to link against the shared libperl library on shared perl
# platforms. We peek at lddlflags to see if we need -Wl,-R
@@ -941,6 +942,11 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
# The Android linker will not recognize symbols from
# libperl unless the module explicitly depends on it.

44
perl-5.22.0-Revert-const-the-core-magic-vtables.patch
View File

@ -1,44 +0,0 @@
From 4ccd57ed119eae3847df1ec241daa509f3b86ef3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Thu, 18 Jun 2015 13:19:49 +0200
Subject: [PATCH] Revert "const the core magic vtables"
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This reverts commit c910fead7893fe9700031ee59de6b904260b5d69.
It's necessary for Coro-6.43. This patch will be removed once Coro
will be fixed or in a reasonable time if Coro become unamaintained.
<http://www.nntp.perl.org/group/perl.perl5.porters/2015/06/msg228530.html>
<https://bugzilla.redhat.com/show_bug.cgi?id=1231165>
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
perl.h | 9 ++++++++-
1 file changed, 8 insertions(+), 1 deletion(-)
diff --git a/perl.h b/perl.h
index dcb184b..9bce052 100644
--- a/perl.h
+++ b/perl.h
@@ -5583,7 +5583,14 @@ EXTCONST runops_proc_t PL_runops_std
EXTCONST runops_proc_t PL_runops_dbg
INIT(Perl_runops_debug);
-#define EXT_MGVTBL EXTCONST MGVTBL
+/* PERL_GLOBAL_STRUCT_PRIVATE wants to keep global data like the
+ * magic vtables const, but this is incompatible with SWIG which
+ * does want to modify the vtables. */
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+# define EXT_MGVTBL EXTCONST MGVTBL
+#else
+# define EXT_MGVTBL EXT MGVTBL
+#endif
#define PERL_MAGIC_READONLY_ACCEPTABLE 0x40
#define PERL_MAGIC_VALUE_MAGIC 0x80
--
2.1.0

2
perl-5.22.1-Provide-ExtUtils-MM-methods-as-standalone-ExtUtils-M.patch
View File

@ -24,7 +24,7 @@ index 6af238c..d4f0c56 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1045,6 +1045,7 @@ cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm MakeMaker adaptor class
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm MakeMaker methods for QNX
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm MakeMaker methods for Unix
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm Independed MM methods

150
perl-5.24.0-Fix-a-memory-leak-in-strict-regex-posix-classes.patch
View File

@ -1,150 +0,0 @@
From 4039933788b0393590f48aef41e9de5462fcc1e9 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Wed, 8 Jun 2016 18:42:30 +0200
Subject: [PATCH] Fix a memory leak in strict regex posix classes
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This is a perl-5.24.0 port of these four upstream patches fixing RT#128313:
commit ee072c898947f5fee316f1381b29ad692addcf05
Author: Yves Orton <demerphq@gmail.com>
Date: Wed Jun 8 18:42:30 2016 +0200
[perl #128313] Fix leak in perl 5.24 with strict and regex posix char classes
This patch is a refinement of one written by Dan Collins.
Any thanks for this patch should go to him.
commit 7eec73eb790f7c4982edfc28c17c011e8a072490
Author: Yves Orton <demerphq@gmail.com>
Date: Fri Jun 10 12:20:20 2016 +0200
move warning text to RExC_state (via RExC_warn_text)
This way we reuse the same AV each time, and avoid various refcount bookkeeping issues, all at a relatively modest cost (IMO)
commit 0bf54b1ecaec8f6d80845d6cb77d62f8c9f4c415
Author: Yves Orton <demerphq@gmail.com>
Date: Fri Jun 10 13:34:37 2016 +0200
fixup, guard av_top_index() for null RExC_warn_text
commit 222c4b0094b4145d06cb164bedd2a66a3141203b
Author: Dan Collins <dcollinsn@gmail.com>
Date: Wed Jun 8 16:26:07 2016 -0400
[perl #128313] test for memory leak in POSIX classes
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 21 ++++++++++-----------
t/op/svleak.t | 12 +++++++++++-
2 files changed, 21 insertions(+), 12 deletions(-)
diff --git a/regcomp.c b/regcomp.c
index be6cb96..f29892c 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -199,6 +199,7 @@ struct RExC_state_t {
scan_frame *frame_head;
scan_frame *frame_last;
U32 frame_count;
+ AV *warn_text;
#ifdef ADD_TO_REGEXEC
char *starttry; /* -Dr: where regtry was called. */
#define RExC_starttry (pRExC_state->starttry)
@@ -288,6 +289,7 @@ struct RExC_state_t {
#define RExC_frame_last (pRExC_state->frame_last)
#define RExC_frame_count (pRExC_state->frame_count)
#define RExC_strict (pRExC_state->strict)
+#define RExC_warn_text (pRExC_state->warn_text)
/* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
* a flag to disable back-off on the fixed/floating substrings - if it's
@@ -6767,6 +6769,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
#endif
}
+ pRExC_state->warn_text = NULL;
pRExC_state->code_blocks = NULL;
pRExC_state->num_code_blocks = 0;
@@ -13704,8 +13707,8 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
* routine. q.v. */
#define ADD_POSIX_WARNING(p, text) STMT_START { \
if (posix_warnings) { \
- if (! warn_text) warn_text = newAV(); \
- av_push(warn_text, Perl_newSVpvf(aTHX_ \
+ if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
+ av_push(RExC_warn_text, Perl_newSVpvf(aTHX_ \
WARNING_PREFIX \
text \
REPORT_LOCATION, \
@@ -13836,7 +13839,6 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
bool has_opening_colon = FALSE;
int class_number = OOB_NAMEDCLASS; /* Out-of-bounds until find
valid class */
- AV* warn_text = NULL; /* any warning messages */
const char * possible_end = NULL; /* used for a 2nd parse pass */
const char* name_start; /* ptr to class name first char */
@@ -13852,6 +13854,9 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
+ if (posix_warnings && RExC_warn_text)
+ av_clear(RExC_warn_text);
+
if (p >= e) {
return NOT_MEANT_TO_BE_A_POSIX_CLASS;
}
@@ -14469,14 +14474,8 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
ADD_POSIX_WARNING(p, "there is no terminating ']'");
}
- if (warn_text) {
- if (posix_warnings) {
- /* mortalize to avoid a leak with FATAL warnings */
- *posix_warnings = (AV *) sv_2mortal((SV *) warn_text);
- }
- else {
- SvREFCNT_dec_NN(warn_text);
- }
+ if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
+ *posix_warnings = RExC_warn_text;
}
}
else if (class_number != OOB_NAMEDCLASS) {
diff --git a/t/op/svleak.t b/t/op/svleak.t
index 595bf3e..c18f498 100644
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
use Config;
-plan tests => 131;
+plan tests => 132;
# 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
@@ -537,3 +537,13 @@ EOF
::leak(5, 0, \&f, q{goto shouldn't leak @_});
}
+
+# [perl #128313] POSIX warnings shouldn't leak
+{
+ no warnings 'experimental';
+ use re 'strict';
+ my $a = 'aaa';
+ my $b = 'aa';
+ sub f { $a =~ /[^.]+$b/; }
+ ::leak(2, 0, \&f, q{use re 'strict' shouldn't leak warning strings});
+}
--
2.5.5

62
perl-5.24.0-PATCH-perl-128734-tr-N-.-failing-for-128-255.patch
View File

@ -1,62 +0,0 @@
From 9b3f53bd7af9574dcc38432cb191b90e9f957362 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Wed, 27 Jul 2016 12:44:42 -0600
Subject: [PATCH] PATCH: [perl #128734] tr/\N{...}/ failing for 128-255
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
The upper latin1 characters when expressed as \N{U+...} were failing.
This was due to trying to convert them to UTF-8 when the result isn't
UTF-8. I added a test for \N{name} as well, though these were not
affected by this regression.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/op/tr.t | 11 ++++++++++-
toke.c | 2 +-
2 files changed, 11 insertions(+), 2 deletions(-)
diff --git a/t/op/tr.t b/t/op/tr.t
index 6783dad..d40187f 100644
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -9,7 +9,7 @@ BEGIN {
set_up_inc('../lib');
}
-plan tests => 164;
+plan tests => 166;
# Test this first before we extend the stack with other operations.
# This caused an asan failure due to a bad write past the end of the stack.
@@ -643,4 +643,13 @@ for ("", nullrocow) {
ok(1, "tr///d on glob does not assert");
}
+{ # [perl #128734
+ my $string = "\x{00e0}";
+ $string =~ tr/\N{U+00e0}/A/;
+ is($string, "A", 'tr// of \N{U+...} works for upper-Latin1');
+ $string = "\x{00e1}";
+ $string =~ tr/\N{LATIN SMALL LETTER A WITH ACUTE}/A/;
+ is($string, "A", 'tr// of \N{name} works for upper-Latin1');
+}
+
1;
diff --git a/toke.c b/toke.c
index 59a0749..52e658f 100644
--- a/toke.c
+++ b/toke.c
@@ -3540,7 +3540,7 @@ S_scan_const(pTHX_ char *start)
}
/* Add the (Unicode) code point to the output. */
- if (OFFUNI_IS_INVARIANT(uv)) {
+ if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
*d++ = (char) LATIN1_TO_NATIVE(uv);
}
else {
--
2.5.5

45
perl-5.24.0-Regression-test-for-RT-129196.patch
View File

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

73
perl-5.24.0-assertion-failure-in-.-or-0-x-0.patch
View File

@ -1,73 +0,0 @@
From 702cf95bcb627f2b3b44fad409df7f0fd517af60 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.24.0:
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 d7b900e..018d90c 100644
--- a/op.c
+++ b/op.c
@@ -13573,10 +13573,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 bee7dac..c933475 100644
--- a/t/op/repeat.t
+++ b/t/op/repeat.t
@@ -6,7 +6,7 @@ BEGIN {
}
require './test.pl';
-plan(tests => 48);
+plan(tests => 49);
# compile time
@@ -183,3 +183,12 @@ fresh_perl_like(
{ },
'(1) x ~1',
);
+
+# [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

94
perl-5.24.0-clean-up-gv_fetchmethod_pvn_flags-introduce-name_end.patch
View File

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

94
perl-5.24.0-crash-on-explicit-return-from-s-e.patch
View File

@ -1,94 +0,0 @@
From 2c639acf40b4abc2783352f8e20dbfb68389e633 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 28 Nov 2016 08:03:49 +0000
Subject: [PATCH] crash on explicit return from s///e
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Pisar: Ported to 5.24.0:
commit 7332835e5da7b7a793ef814a84e53003be1d0138
Author: David Mitchell <davem@iabyn.com>
Date: Mon Nov 28 08:03:49 2016 +0000
crash on explicit return from s///e
RT #130188
In
sub f {
my $x = 'a';
$x =~ s/./return;/e;
}
the 'return' triggers popping any contexts above the subroutine context:
in this case, a CXt_SUBST context. In this case, Perl_dounwind() calls
cx_popblock() for the bottom-most popped context, to restore any saved
vars. However, CXt_SUBST is the one context type which *doesn't* use
'struct block' as part of its context struct union, so you can't
cx_popblock() a CXt_SUBST context.
This commit makes it skip the cx_popblock() in this case.
Bug was introduced by me with v5.23.7-235-gfc6e609.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_ctl.c | 6 ++++++
t/re/subst.t | 17 ++++++++++++++++-
2 files changed, 22 insertions(+), 1 deletion(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index 99ff59a..b94c09a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1529,6 +1529,12 @@ Perl_dounwind(pTHX_ I32 cxix)
switch (CxTYPE(cx)) {
case CXt_SUBST:
CX_POPSUBST(cx);
+ /* CXt_SUBST is not a block context type, so skip the
+ * cx_popblock(cx) below */
+ if (cxstack_ix == cxix + 1) {
+ cxstack_ix--;
+ return;
+ }
break;
case CXt_SUB:
cx_popsub(cx);
diff --git a/t/re/subst.t b/t/re/subst.t
index 26a78c7..c039cc4 100644
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -11,7 +11,7 @@ BEGIN {
require './loc_tools.pl';
}
-plan( tests => 270 );
+plan( tests => 271 );
$_ = 'david';
$a = s/david/rules/r;
@@ -1102,3 +1102,18 @@ SKIP: {
$s =~ s/..\G//g;
is($s, "\x{123}", "#RT 126260 gofs");
}
+
+# [perl #130188] crash on return from substitution in subroutine
+# make sure returning from s///e doesn't SEGV
+{
+ my $f = sub {
+ my $x = 'a';
+ $x =~ s/./return;/e;
+ };
+ my $x = $f->();
+ pass("RT #130188");
+}
+
+
+
+
--
2.7.4

123
perl-5.24.0-fix-128109-do-not-move-RExC_open_parens-0-in-reginse.patch
View File

@ -1,123 +0,0 @@
From c6e7032a63f2162405644582af6600dcb5ba66d1 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 10 May 2016 09:44:31 +0200
Subject: [PATCH] fix #128109 - do not move RExC_open_parens[0] in reginsert
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Pisar: Two commits ported to 5.24.0:
commit da7cf1cc7cedc01f35ceb6724e8260c3b0ee0d12
Author: Yves Orton <demerphq@gmail.com>
Date: Tue May 10 09:44:31 2016 +0200
fix #128109 - do not move RExC_open_parens[0] in reginsert
In d5a00e4af6b155495be31a35728b8fef8e671ebe I merged GOSUB and GOSTART,
part of which involved making RExC_open_parens[0] refer to the start of
the pattern, and RExC_close_parens[0] referring to the end of the pattern.
This tripped up in reginsert in a subtle way, the start of the pattern
cannot and should not move in reginsert(). Unlike a paren that might
be at the start of the pattern which should move when something is inserted
in front of it, the start is a fixed point and should never move.
This patches fixes this up, and adds an assert to check that reginsert()
is not called once study_chunk() starts, as reginsert() does not adjust
RExC_recurse.
This was noticed by hv while debugging [perl #128085], thanks hugo!
commit ec5bd2262bb4e28f0dc6a0a3edb9b1f1b5befa2f
Author: Dan Collins <dcollinsn@gmail.com>
Date: Fri Jun 17 19:40:57 2016 -0400
Add tests for regex recursion
d5a00e4af introduced a bug in reginsert that was fixed by da7cf1cc7,
originally documented in [perl #128109]. This patch adds two
regression tests for the testcase reported by Jan Goyvaerts in
[perl #128420].
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 13 +++++++++++--
t/re/re_tests | 2 ++
2 files changed, 13 insertions(+), 2 deletions(-)
diff --git a/regcomp.c b/regcomp.c
index f29892c..7462885 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -223,6 +223,7 @@ struct RExC_state_t {
#endif
bool seen_unfolded_sharp_s;
bool strict;
+ bool study_started;
};
#define RExC_flags (pRExC_state->flags)
@@ -289,6 +290,7 @@ struct RExC_state_t {
#define RExC_frame_last (pRExC_state->frame_last)
#define RExC_frame_count (pRExC_state->frame_count)
#define RExC_strict (pRExC_state->strict)
+#define RExC_study_started (pRExC_state->study_started)
#define RExC_warn_text (pRExC_state->warn_text)
/* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
@@ -4104,6 +4106,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_STUDY_CHUNK;
+ RExC_study_started= 1;
if ( depth == 0 ) {
@@ -6886,6 +6889,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
RExC_contains_locale = 0;
RExC_contains_i = 0;
RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
+ RExC_study_started = 0;
pRExC_state->runtime_code_qr = NULL;
RExC_frame_head= NULL;
RExC_frame_last= NULL;
@@ -18240,7 +18244,9 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
RExC_size += size;
return;
}
-
+ assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
+ studying. If this is wrong then we need to adjust RExC_recurse
+ below like we do with RExC_open_parens/RExC_close_parens. */
src = RExC_emit;
RExC_emit += size;
dst = RExC_emit;
@@ -18251,7 +18257,10 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
* iow it is 1 more than the number of parens seen in
* the pattern so far. */
for ( paren=0 ; paren < RExC_npar ; paren++ ) {
- if ( RExC_open_parens[paren] >= opnd ) {
+ /* note, RExC_open_parens[0] is the start of the
+ * regex, it can't move. RExC_close_parens[0] is the end
+ * of the regex, it *can* move. */
+ if ( paren && RExC_open_parens[paren] >= opnd ) {
/*DEBUG_PARSE_FMT("open"," - %d",size);*/
RExC_open_parens[paren] += size;
} else {
diff --git a/t/re/re_tests b/t/re/re_tests
index 34ac94a..7e8522d 100644
--- a/t/re/re_tests
+++ b/t/re/re_tests
@@ -1966,6 +1966,8 @@ ab(?#Comment){2}c abbc y $& abbc
.{1}?? - c - Nested quantifiers
.{1}?+ - c - Nested quantifiers
(?:.||)(?|)000000000@ 000000000@ y $& 000000000@ # [perl #126405]
+aa$|a(?R)a|a aaa y $& aaa # [perl 128420] recursive matches
+(?:\1|a)([bcd])\1(?:(?R)|e)\1 abbaccaddedcb y $& abbaccaddedcb # [perl 128420] recursive match with backreferences
# Keep these lines at the end of the file
# vim: softtabstop=0 noexpandtab
--
2.5.5

66
perl-5.24.0-perl-129130-make-chdir-allocate-the-stack-it-needs.patch
View File

@ -1,66 +0,0 @@
From d47812b974b515e952dc093e692bf15f0a9afbc4 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.24.0:
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 3bf2673..d2cf872 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3639,6 +3639,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 a5ea76a..685e556 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 => 47);
+ plan(tests => 48);
}
use Config;
@@ -161,6 +161,12 @@ sub check_env {
}
}
+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

79
perl-5.24.0-perl-129164-Crash-with-splice.patch
View File

@ -1,79 +0,0 @@
From 54550573a613ad20f00521880f345644a1db85cc 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.24.0:
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 4a2cde0..4153482 100644
--- a/pp.c
+++ b/pp.c
@@ -5488,6 +5488,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;
@@ -5584,6 +5586,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 4f0a772..fb4e8c6 100644
--- a/t/op/array.t
+++ b/t/op/array.t
@@ -555,4 +555,21 @@ is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)';
is "@a", 'a b c', 'assigning to itself';
}
+# [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

56
perl-5.24.0-perl-129350-anchored-floating-substrings-must-be-utf.patch
View File

@ -1,56 +0,0 @@
From 62130748594f803da49b6abf3e352e51148a3886 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.24.0:
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 cdaa95c..38ff44a 100644
--- a/regexec.c
+++ b/regexec.c
@@ -703,7 +703,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 7e8522d..2f4d00c 100644
--- a/t/re/re_tests
+++ b/t/re/re_tests
@@ -1968,6 +1968,7 @@ ab(?#Comment){2}c abbc y $& abbc
(?:.||)(?|)000000000@ 000000000@ y $& 000000000@ # [perl #126405]
aa$|a(?R)a|a aaa y $& aaa # [perl 128420] recursive matches
(?:\1|a)([bcd])\1(?:(?R)|e)\1 abbaccaddedcb y $& abbaccaddedcb # [perl 128420] recursive match with backreferences
+\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

134
perl-5.24.0-perl-129788-IO-Poll-fix-memory-leak.patch
View File

@ -1,134 +0,0 @@
From 478d23ef9e7700e20a75907648dd4c53b1b4f544 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.24.0:
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 2cdf616..3b5f8fb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3228,6 +3228,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 4cb21a9..2809b58 100644
--- a/META.json
+++ b/META.json
@@ -84,6 +84,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 13a2bb3..7494d2a 100644
--- a/META.yml
+++ b/META.yml
@@ -81,6 +81,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 fe749a6..15ef9b2 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)));
/* We should pass _some_ valid pointer even if nfd is zero, but it
* doesn't matter what it is, since we're telling it to not check any fds.
*/
@@ -337,7 +337,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

97
perl-5.24.0-regcomp.c-fix-perl-129950-fix-firstchar-bitmap-under.patch
View File

@ -1,97 +0,0 @@
From 1b90dad20879f0e7a3eced5da0e0aacda93708ed 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.24.0:
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 7462885..bcb8db5 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -3272,6 +3272,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(
Perl_re_printf( aTHX_ "%s", (char*)ch)
);
@@ -3280,6 +3287,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(Perl_re_printf( aTHX_ "%s", ch));
}
idx = ofs;
diff --git a/t/re/pat.t b/t/re/pat.t
index 295a9f7..4aa77cf 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -23,7 +23,7 @@ BEGIN {
skip_all_without_unicode_tables();
}
-plan tests => 789; # Update this when adding/deleting tests.
+plan tests => 791; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1758,6 +1758,13 @@ EOP
fresh_perl_is($code, $expect, {}, "$bug - $test_name" );
}
}
+
+ {
+ 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

92
perl-5.24.0-rt-129336-perl-i-u-erroneously-interpreted-as-u.patch
View File

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

94
perl-5.24.0-split-was-leaving-PL_sv_undef-in-unused-ary-slots.patch
View File

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

65
perl-5.24.1-Fix-memory-leak-in-B-RHE-HASH-method.patch
View File

@ -1,65 +0,0 @@
From 3c38abae50c05c6f3c9f7eca561ec08c62fba1ba Mon Sep 17 00:00:00 2001
From: Sergey Aleynikov <sergey.aleynikov@gmail.com>
Date: Thu, 5 Jan 2017 01:33:32 +0300
Subject: [PATCH] Fix memory leak in B::RHE->HASH method.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Písař: Ported to 5.24.1:
commit 4b6e9aa6aa2256da1ec7ed08f819cbf5d1463741
Author: Sergey Aleynikov <sergey.aleynikov@gmail.com>
Date: Thu Jan 5 01:33:32 2017 +0300
Fix memory leak in B::RHE->HASH method.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/B/B.xs | 2 +-
t/op/svleak.t | 12 +++++++++++-
2 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/ext/B/B.xs b/ext/B/B.xs
index b4b6a40..e859d7d 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -2179,7 +2179,7 @@ SV*
HASH(h)
B::RHE h
CODE:
- RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
+ RETVAL = newRV_noinc( (SV*)cophh_2hv(h, 0) );
OUTPUT:
RETVAL
diff --git a/t/op/svleak.t b/t/op/svleak.t
index c18f498..b0692ff 100644
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
use Config;
-plan tests => 132;
+plan tests => 133;
# 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
@@ -547,3 +547,13 @@ EOF
sub f { $a =~ /[^.]+$b/; }
::leak(2, 0, \&f, q{use re 'strict' shouldn't leak warning strings});
}
+
+# check that B::RHE->HASH does not leak
+{
+ package BHINT;
+ sub foo {}
+ require B;
+ my $op = B::svref_2object(\&foo)->ROOT->first;
+ sub lk { { my $d = $op->hints_hash->HASH } }
+ ::leak(3, 0, \&lk, q!B::RHE->HASH shoudln't leak!);
+}
--
2.7.4

70
perl-5.24.1-RT-130624-heap-use-after-free-in-4-arg-substr.patch
View File

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

93
perl-5.24.1-buffer-overrun-with-format-and-use-bytes.patch
View File

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

93
perl-5.24.1-fix-RT-130561-recursion-and-optimising-away-impossib.patch
View File

@ -1,93 +0,0 @@
From fbb9dc823a06b4815ee8fd8632fc475b8034e379 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.24.1:
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 bcb8db5..9f343d3 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -11497,19 +11497,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 amount 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 = reganode(pRExC_state, OPFAIL, 0);
+ 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 == '?')
diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
index cb02ad2..2c1dbc4 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 => 2500; # Update this when adding/deleting tests.
+plan tests => 2502; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1113,6 +1113,15 @@ EOP
my $s = "\x{1ff}" . "f" x 32;
ok($s =~ /\x{1ff}[[:alpha:]]+/gca, "POSIXA 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

198
perl-5.24.1-fix-pad-scope-issue-in-re_evals.patch
View File

@ -1,198 +0,0 @@
From f3704e62341b10824f503aa0c8029670d101a434 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Sat, 11 Feb 2017 11:53:41 +0000
Subject: [PATCH] fix pad/scope issue in re_evals
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.1:
commit 4b9c7caeaecf4e9df0be3a2e296644f763f775d6
Author: David Mitchell <davem@iabyn.com>
Date: Sat Feb 11 11:53:41 2017 +0000
fix pad/scope issue in re_evals
RT #129881 heap-buffer-overflow Perl_pad_sv
In some circumstances involving a pattern which has embedded code blocks
from more than one source, e.g.
my $r = qr{(?{1;}){2}X};
"" =~ /$r|(?{1;})/;
the wrong PL_comppad could be active while doing a LEAVE_SCOPE() or on
exit from the pattern.
This was mainly due to the big context stack changes in 5.24.0 - in
particular, since POP_MULTICALL() now does CX_LEAVE_SCOPE(cx) *before*
restoring PL_comppad, the (correct) unwinding of any SAVECOMPPAD's was
being followed by C<PL_comppad = cx->blk_sub.prevcomppad>, which wasn't
necessarily a sensible value.
To fix this, record the value of PL_savestack_ix at entry to S_regmatch(),
and set the cx->blk_oldsaveix of the MULTICALL to this value when pushed.
On exit from S_regmatch, we either POP_MULTICALL which will do a
LEAVE_SCOPE(cx->blk_oldsaveix), or in the absense of any EVAL, do the
explicit but equivalent LEAVE_SCOPE(orig_savestack_ix).
Note that this is a change in behaviour to S_regmatch() - formerly it
wouldn't necessarily clear the savestack completely back the point of
entry - that would get left to do by its caller, S_regtry(), or indirectly
by Perl_regexec_flags(). This shouldn't make any practical difference, but
is tidier and less likely to introduce bugs later.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regexec.c | 69 +++++++++++++++++++++++++++++++++++++++++++-----------
t/re/pat_re_eval.t | 20 +++++++++++++++-
2 files changed, 74 insertions(+), 15 deletions(-)
diff --git a/regexec.c b/regexec.c
index a7bc0c3..5656cdd 100644
--- a/regexec.c
+++ b/regexec.c
@@ -5233,6 +5233,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
_char_class_number classnum;
bool is_utf8_pat = reginfo->is_utf8_pat;
bool match = FALSE;
+ I32 orig_savestack_ix = PL_savestack_ix;
/* Solaris Studio 12.3 messes up fetching PL_charclass['\n'] */
#if (defined(__SUNPRO_C) && (__SUNPRO_C == 0x5120) && defined(__x86_64) && defined(USE_64_BIT_ALL))
@@ -6646,30 +6647,67 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
nop = (OP*)rexi->data->data[n];
}
- /* normally if we're about to execute code from the same
- * CV that we used previously, we just use the existing
- * CX stack entry. However, its possible that in the
- * meantime we may have backtracked, popped from the save
- * stack, and undone the SAVECOMPPAD(s) associated with
- * PUSH_MULTICALL; in which case PL_comppad no longer
- * points to newcv's pad. */
+ /* Some notes about MULTICALL and the context and save stacks.
+ *
+ * In something like
+ * /...(?{ my $x)}...(?{ my $z)}...(?{ my $z)}.../
+ * since codeblocks don't introduce a new scope (so that
+ * local() etc accumulate), at the end of a successful
+ * match there will be a SAVEt_CLEARSV on the savestack
+ * for each of $x, $y, $z. If the three code blocks above
+ * happen to have come from different CVs (e.g. via
+ * embedded qr//s), then we must ensure that during any
+ * savestack unwinding, PL_comppad always points to the
+ * right pad at each moment. We achieve this by
+ * interleaving SAVEt_COMPPAD's on the savestack whenever
+ * there is a change of pad.
+ * In theory whenever we call a code block, we should
+ * push a CXt_SUB context, then pop it on return from
+ * that code block. This causes a bit of an issue in that
+ * normally popping a context also clears the savestack
+ * back to cx->blk_oldsaveix, but here we specifically
+ * don't want to clear the save stack on exit from the
+ * code block.
+ * Also for efficiency we don't want to keep pushing and
+ * popping the single SUB context as we backtrack etc.
+ * So instead, we push a single context the first time
+ * we need, it, then hang onto it until the end of this
+ * function. Whenever we encounter a new code block, we
+ * update the CV etc if that's changed. During the times
+ * in this function where we're not executing a code
+ * block, having the SUB context still there is a bit
+ * naughty - but we hope that no-one notices.
+ * When the SUB context is initially pushed, we fake up
+ * cx->blk_oldsaveix to be as if we'd pushed this context
+ * on first entry to S_regmatch rather than at some random
+ * point during the regexe execution. That way if we
+ * croak, popping the context stack will ensure that
+ * *everything* SAVEd by this function is undone and then
+ * the context popped, rather than e.g., popping the
+ * context (and restoring the original PL_comppad) then
+ * popping more of the savestack and restoiring a bad
+ * PL_comppad.
+ */
+
+ /* If this is the first EVAL, push a MULTICALL. On
+ * subsequent calls, if we're executing a different CV, or
+ * if PL_comppad has got messed up from backtracking
+ * through SAVECOMPPADs, then refresh the context.
+ */
if (newcv != last_pushed_cv || PL_comppad != last_pad)
{
U8 flags = (CXp_SUB_RE |
((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0));
+ SAVECOMPPAD();
if (last_pushed_cv) {
- /* PUSH/POP_MULTICALL save and restore the
- * caller's PL_comppad; if we call multiple subs
- * using the same CX block, we have to save and
- * unwind the varying PL_comppad's ourselves,
- * especially restoring the right PL_comppad on
- * backtrack - so save it on the save stack */
- SAVECOMPPAD();
CHANGE_MULTICALL_FLAGS(newcv, flags);
}
else {
PUSH_MULTICALL_FLAGS(newcv, flags);
}
+ /* see notes above */
+ CX_CUR()->blk_oldsaveix = orig_savestack_ix;
+
last_pushed_cv = newcv;
}
else {
@@ -8456,9 +8494,12 @@ NULL
if (last_pushed_cv) {
dSP;
+ /* see "Some notes about MULTICALL" above */
POP_MULTICALL;
PERL_UNUSED_VAR(SP);
}
+ else
+ LEAVE_SCOPE(orig_savestack_ix);
assert(!result || locinput - reginfo->strbeg >= 0);
return result ? locinput - reginfo->strbeg : -1;
diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t
index e59b059..1a0b228 100644
--- a/t/re/pat_re_eval.t
+++ b/t/re/pat_re_eval.t
@@ -22,7 +22,7 @@ BEGIN {
}
-plan tests => 527; # Update this when adding/deleting tests.
+plan tests => 530; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1232,6 +1232,24 @@ sub run_tests {
'padtmp swiping does not affect "$a$b" =~ /(??{})/'
}
+ # RT #129881
+ # on exit from a pattern with multiple code blocks from different
+ # CVs, PL_comppad wasn't being restored correctly
+
+ sub {
+ # give first few pad slots known values
+ my ($x1, $x2, $x3, $x4, $x5) = 101..105;
+ # these vars are in a separate pad
+ my $r = qr/((?{my ($y1, $y2) = 201..202; 1;})A){2}X/;
+ # the first alt fails, causing a switch to this anon
+ # sub's pad
+ "AAA" =~ /$r|(?{my ($z1, $z2) = 301..302; 1;})A/;
+ is $x1, 101, "RT #129881: x1";
+ is $x2, 102, "RT #129881: x2";
+ is $x3, 103, "RT #129881: x3";
+ }->();
+
+
} # End of sub run_tests
1;
--
2.7.4

79
perl-5.24.1-fix-special-case-recreation-of.patch
View File

@ -1,79 +0,0 @@
From 59ef97c7af81ab6faba749d88b558a55da41c249 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.24.1:
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 c89a3e7..3fda9b9 100644
--- a/gv.c
+++ b/gv.c
@@ -1642,8 +1642,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 7ac379b..d6fded4 100644
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
BEGIN { require "./test.pl"; }
-plan( tests => 54 );
+plan( tests => 55 );
# Used to segfault (bug #15479)
fresh_perl_like(
@@ -355,3 +355,10 @@ is runperl(
),
"ok\n",
"[perl #128238] non-stashes in stashes";
+
+is runperl(
+ prog => '%:: = (); print *{q|::|}, qq|\n|',
+ stderr => 1,
+ ),
+ "*main::main::\n",
+ "[perl #129869] lookup %:: by name after clearing %::";
--
2.7.4

107
perl-5.24.1-perl-129125-copy-form-data-if-it-might-be-freed.patch
View File

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

70
perl-5.24.1-perl-129274-avoid-treating-the-in-as-a-comment-intro.patch
View File

@ -1,70 +0,0 @@
From 2f221fc2333bd87615c03354b591b390e8b06715 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.24.1:
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 9ada592..d679d7c 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 576ce72..630fc59 100644
--- a/toke.c
+++ b/toke.c
@@ -4090,7 +4090,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

49
perl-5.24.1-perl-129281-test-for-buffer-overflow-issue.patch
View File

@ -1,49 +0,0 @@
From 92f8cd4e7b0ff3d09162139e3c99b1d9310bca81 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.24.1:
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 749edd0..7b8e6f7 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -23,7 +23,7 @@ BEGIN {
skip_all_without_unicode_tables();
}
-plan tests => 792; # Update this when adding/deleting tests.
+plan tests => 793; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1779,6 +1779,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

104
perl-5.24.1-perl-129340-copy-the-source-when-inside-the-dest-in-.patch
View File

@ -1,104 +0,0 @@
From 4fe0e2d067ac5639d94f35f8c7e8ac4e0e3ab336 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.24.1:
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 a64ffba..2395efb 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1437,7 +1437,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 fb4ee29..2b2004a 100644
--- a/proto.h
+++ b/proto.h
@@ -3015,7 +3015,7 @@ PERL_CALLCONV void Perl_sv_inc_nomg(pTHX_ SV *const sv);
/* PERL_CALLCONV void Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen); */
#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);
#define PERL_ARGS_ASSERT_SV_INSERT_FLAGS \
assert(bigstr); assert(little)
PERL_CALLCONV int Perl_sv_isa(pTHX_ SV* sv, const char *const name);
diff --git a/sv.c b/sv.c
index d1e84f0..697db41 100644
--- a/sv.c
+++ b/sv.c
@@ -6223,7 +6223,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;
@@ -6236,6 +6236,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 eae2403..01c36a9 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;
@@ -869,3 +869,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

73
perl-5.24.1-perl-129342-ensure-range-start-is-set-after-error-in.patch
View File

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

107
perl-5.24.1-perl-129377-don-t-read-past-start-of-string-for-unma.patch
View File

@ -1,107 +0,0 @@
From a08fa6fd157fd0d61da7f20f07b939fbc302c2c6 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] [perl #129377] 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.24.1:
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 a5d5db4..a7bc0c3 100644
--- a/regexec.c
+++ b/regexec.c
@@ -5179,6 +5179,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), or -1 at EOS */
@@ -6489,10 +6490,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;
@@ -6506,7 +6508,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;
@@ -6521,7 +6523,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 4aa77cf..749edd0 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -23,7 +23,7 @@ BEGIN {
skip_all_without_unicode_tables();
}
-plan tests => 791; # Update this when adding/deleting tests.
+plan tests => 792; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1765,6 +1765,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

62
perl-5.24.1-perl-130262-split-scalar-context-stack-overflow-fix.patch
View File

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

50
perl-5.24.1-perl-130814-update-pointer-into-PL_linestr-after-loo.patch
View File

@ -1,50 +0,0 @@
From 9df34f9c4701104a366e768237ca694411136d2a 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.24.1:
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 630fc59..029d2ea 100644
--- a/toke.c
+++ b/toke.c
@@ -7565,6 +7565,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)))
@@ -7582,6 +7583,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

72
perl-5.24.1-perl-130815-fix-ck_return-null-pointer-deref-on-malf.patch
View File

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

81
perl-5.24.1-perl-130822-fix-an-AV-leak-in-Perl_reg_named_buff_fe.patch
View File

@ -1,81 +0,0 @@
From 0cefeca1fd2405ad1b5544a3919e0000377fde5e 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.24.1:
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 6329f6c..989c528 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -7849,21 +7849,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 b0692ff..eeea7c1 100644
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
use Config;
-plan tests => 133;
+plan tests => 134;
# 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
@@ -557,3 +557,13 @@ EOF
sub lk { { my $d = $op->hints_hash->HASH } }
::leak(3, 0, \&lk, q!B::RHE->HASH shoudln't leak!);
}
+
+{
+ # 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

94
perl-5.24.1-permit-goto-at-top-level-of-multicalled-sub.patch
View File

@ -1,94 +0,0 @@
From 0a1ddbeaeeea3c690c2408bd4c3a61c05cb9695f 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.24.1:
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 e859e01..a1fc2f4 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2921,6 +2921,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 */
@@ -2959,11 +2960,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");
@@ -2992,6 +2991,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 aa2f24f..07bd6fb 100644
--- a/t/op/goto.t
+++ b/t/op/goto.t
@@ -10,7 +10,7 @@ BEGIN {
use warnings;
use strict;
-plan tests => 98;
+plan tests => 99;
our $TODO;
my $deprecated = 0;
@@ -774,3 +774,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

82
perl-5.25.0-Fix-precedence-in-hv_ename_delete.patch
View File

@ -1,82 +0,0 @@
From 60a26c797bbff039ea7f861903732e7cceae415a Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Sun, 15 May 2016 13:48:58 -0700
Subject: [PATCH 1/2] [perl #128086] Fix precedence in hv_ename_delete
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
A stash’s array of names may have null for the first entry, in which
case it is not one of the effective names, and the name count will
be negative.
The ‘count > 0’ is meant to prevent hv_ename_delete from trying to
read that entry, but a precedence problem introduced in 4643eb699
stopped it from doing that.
[This commit message was written by the committer.]
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
hv.c | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/hv.c b/hv.c
index 7b5ad95..5523475 100644
--- a/hv.c
+++ b/hv.c
@@ -2476,9 +2476,10 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
return;
}
if (
- count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
+ count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8))
? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
: (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
+ )
) {
aux->xhv_name_count = -count;
}
--
2.5.5
From 7f1bd063e5aa5aeb26ed9c39db6864cc0ecd7a73 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 15 May 2016 13:49:33 -0700
Subject: [PATCH 2/2] [perl #128086] Test the prev commit
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/op/stash.t | 9 ++++++++-
1 file changed, 8 insertions(+), 1 deletion(-)
diff --git a/t/op/stash.t b/t/op/stash.t
index 151b729..b8e0f34 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 => '%h; *::::::=*h; delete $::{q|::|}; print qq|ok\n|',
+ stderr => 1,
+ ),
+ "ok\n",
+ '[perl #128086] no crash from assigning hash to *:::::: & deleting it';
--
2.5.5

73
perl-5.25.1-perl-128316-preserve-errno-from-failed-system-calls.patch
View File

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

44
perl-5.25.10-fix-VMS-test-fail.patch
View File

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

55
perl-5.25.10-perl-130814-Add-testcase-and-new-testfile-t-comp-par.patch
View File

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

76
perl-5.25.2-SEGV-in-Subroutine-redefined-warning.patch
View File

@ -1,76 +0,0 @@
From fc0fe26a7d286480c1bb25f57e469ece575bb68d Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Thu, 7 Jul 2016 17:03:29 +0100
Subject: [PATCH] SEGV in "Subroutine redefined" warning
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
RT #128257
The following SEGVed:
sub P::f{}
undef *P::;
*P::f =sub{};
due to the code which generates the "Subroutine STASH::NAME redefined"
warning assuming that the GV always has a stash. Make it so that if it
hasn't, the message changes to "Subroutine NAME redefined" rather than
just crashing.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
sv.c | 18 +++++++++++-------
t/lib/warnings/sv | 8 ++++++++
2 files changed, 19 insertions(+), 7 deletions(-)
diff --git a/sv.c b/sv.c
index 1b7a283..0cbe371 100644
--- a/sv.c
+++ b/sv.c
@@ -4074,14 +4074,18 @@ Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
CvCONST((const CV *)sref)
? cv_const_sv((const CV *)sref)
: NULL;
+ HV * const stash = GvSTASH((const GV *)dstr);
report_redefined_cv(
- sv_2mortal(Perl_newSVpvf(aTHX_
- "%"HEKf"::%"HEKf,
- HEKfARG(
- HvNAME_HEK(GvSTASH((const GV *)dstr))
- ),
- HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
- )),
+ sv_2mortal(
+ stash
+ ? Perl_newSVpvf(aTHX_
+ "%"HEKf"::%"HEKf,
+ HEKfARG(HvNAME_HEK(stash)),
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
+ : Perl_newSVpvf(aTHX_
+ "%"HEKf,
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
+ ),
cv,
CvCONST((const CV *)sref) ? &new_const_sv : NULL
);
diff --git a/t/lib/warnings/sv b/t/lib/warnings/sv
index 5ddd4fe..c8e0e62 100644
--- a/t/lib/warnings/sv
+++ b/t/lib/warnings/sv
@@ -413,3 +413,11 @@ Argument "a_c" isn't numeric in preincrement (++) at - line 5.
Argument "(?^:abc)" isn't numeric in preincrement (++) at - line 6.
Argument "123x" isn't numeric in preincrement (++) at - line 7.
Argument "123e" isn't numeric in preincrement (++) at - line 8.
+########
+# RT #128257 This used to SEGV
+use warnings;
+sub Foo::f {}
+undef *Foo::;
+*Foo::f =sub {};
+EXPECT
+Subroutine f redefined at - line 5.
--
2.5.5

64
perl-5.25.2-only-treat-stash-entries-with-.-as-sub-stashes.patch
View File

@ -1,64 +0,0 @@
From e7acdfe976f01ee0d1ba31b3b1db61454a72d6c9 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Tue, 21 Jun 2016 17:06:52 +0100
Subject: [PATCH] only treat stash entries with .*:: as sub-stashes
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
RT #128238
%: = 0 would cause an assertion failure in Perl_gv_check(), since when
it searched a stash for substashes, it assumed anything ending in ':' was
a substash, whereas substashes end in '::'. So check for a double colon
before recursing.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
gv.c | 5 ++++-
t/op/stash.t | 9 ++++++++-
2 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/gv.c b/gv.c
index 4df3bce..2b3bdfa 100644
--- a/gv.c
+++ b/gv.c
@@ -2423,7 +2423,10 @@ Perl_gv_check(pTHX_ HV *stash)
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
GV *gv;
HV *hv;
- if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
+ STRLEN keylen = HeKLEN(entry);
+ const char * const key = HeKEY(entry);
+
+ if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' &&
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
{
if (hv != PL_defstash && hv != stash
diff --git a/t/op/stash.t b/t/op/stash.t
index b8e0f34..ec795a9 100644
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
BEGIN { require "./test.pl"; }
-plan( tests => 52 );
+plan( tests => 53 );
# Used to segfault (bug #15479)
fresh_perl_like(
@@ -341,3 +341,10 @@ is runperl(
),
"ok\n",
'[perl #128086] no crash from assigning hash to *:::::: & deleting it';
+
+is runperl(
+ prog => 'BEGIN { %: = 0; $^W=1}; print qq|ok\n|',
+ stderr => 1,
+ ),
+ "ok\n",
+ "[perl #128238] don't treat %: as a stash (needs 2 colons)"
--
2.5.5

66
perl-5.25.2-perl-128238-Crash-with-non-stash-in-stash.patch
View File

@ -1,66 +0,0 @@
From 9e5cda6b852ca831004628051cf32c1576146452 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Thu, 23 Jun 2016 21:57:09 -0700
Subject: [PATCH] [perl #128238] Crash with non-stash in stash
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This is a follow-up to e7acdfe976f. Even if the name of the stash
entry ends with ::, it may not itself contain a real stash (though
this only happens with code that assigns directly to stash entries,
which has undefined behaviour according to perlmod), so skip hashes
that are not stashes.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
gv.c | 4 ++--
t/op/stash.t | 11 +++++++++--
2 files changed, 11 insertions(+), 4 deletions(-)
diff --git a/gv.c b/gv.c
index 2b3bdfa..dff611e 100644
--- a/gv.c
+++ b/gv.c
@@ -2411,10 +2411,10 @@ Perl_gv_check(pTHX_ HV *stash)
PERL_ARGS_ASSERT_GV_CHECK;
- if (!HvARRAY(stash))
+ if (!SvOOK(stash))
return;
- assert(SvOOK(stash));
+ assert(HvARRAY(stash));
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
diff --git a/t/op/stash.t b/t/op/stash.t
index 1591dbf..fe42700 100644
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
BEGIN { require "./test.pl"; }
-plan( tests => 53 );
+plan( tests => 54 );
# Used to segfault (bug #15479)
fresh_perl_like(
@@ -342,4 +342,11 @@ is runperl(
stderr => 1,
),
"ok\n",
- "[perl #128238] don't treat %: as a stash (needs 2 colons)"
+ "[perl #128238] don't treat %: as a stash (needs 2 colons)";
+
+is runperl(
+ prog => 'BEGIN { $::{q|foo::|}=*ENV; $^W=1}; print qq|ok\n|',
+ stderr => 1,
+ ),
+ "ok\n",
+ "[perl #128238] non-stashes in stashes";
--
2.5.5

96
perl-5.25.2-perl-128508-Fix-line-numbers-with-perl-x.patch
View File

@ -1,96 +0,0 @@
From b3dd0aba3d2bf0b22280303ef6f068e976e31888 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sat, 2 Jul 2016 00:08:48 -0700
Subject: [PATCH] [perl #128508] Fix line numbers with perl -x
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
When lex_start is invoked with an SV and a handle pointer, it expects
the SV to contain the beginning of the code to be parsed. The handle
will be read from for subsequent code.
The -x command line option happens to invoke lex_start with two non-
null pointers like this (a line and a handle), since, to find the
#!perl line, it has to read that first line out of the file handle.
There is a line of code in lex_start that adds "\n;" to the buffer
goes back to 8990e30710 (perl 5.0 alpha 6) and string eval fails
catastrophically without it.
As of v5.19.1-485-g2179133 multiple lines are supported in the current
parsing buffer (PL_linestr) when there is a file handle, and as of
v5.19.3-63-gbf1b738 the line number is correctly incremented when the
parser goes past a newline.
So, for -x, "#!perl\n" turns into "#!perl\n\n" (the final ; is skipped
as of v5.19.3-63-gbf1b738 if there is a handle). That throws line
numbers off by one.
In the case where we have a string to parse and a file handle, the
extra "\n;" added to the end of the buffer turns out to be completely
unnecessary. So this commit makes it conditional on rsfp.
The existing tests for -x are quite exotic. I have made no effort to
make them less so.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/run/switchx.aux | 7 ++++---
t/run/switchx.t | 4 ++--
toke.c | 3 ++-
3 files changed, 8 insertions(+), 6 deletions(-)
diff --git a/t/run/switchx.aux b/t/run/switchx.aux
index b59df4a..106b2f7 100644
--- a/t/run/switchx.aux
+++ b/t/run/switchx.aux
@@ -17,11 +17,12 @@ still not perl
#!/some/path/that/leads/to/perl -l
-print "1..7";
+print "1..8";
+print "ok 1 - Correct line number" if __LINE__ == 4;
if (-f 'run/switchx.aux') {
- print "ok 1 - Test file exists";
+ print "ok 2 - Test file exists";
}
-print "ok 2 - Test file utilized";
+print "ok 3 - Test file utilized";
# other tests are in switchx2.aux
__END__
diff --git a/t/run/switchx.t b/t/run/switchx.t
index bcea3d0..4e57d04 100644
--- a/t/run/switchx.t
+++ b/t/run/switchx.t
@@ -15,9 +15,9 @@ print runperl( switches => ['-x'],
# Test '-xdir'
print runperl( switches => ['-x./run'],
progfile => 'run/switchx2.aux',
- args => [ 3 ] );
+ args => [ 4 ] );
-curr_test(5);
+curr_test(6);
# Test the error message for not found
like(runperl(switches => ['-x'], progfile => 'run/switchx3.aux', stderr => 1),
diff --git a/toke.c b/toke.c
index aebeebb..7e77fae 100644
--- a/toke.c
+++ b/toke.c
@@ -723,7 +723,8 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
parser->linestr = flags & LEX_START_COPIED
? SvREFCNT_inc_simple_NN(line)
: newSVpvn_flags(s, len, SvUTF8(line));
- sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
+ if (!rsfp)
+ sv_catpvs(parser->linestr, "\n;");
} else {
parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
}
--
2.5.5

60
perl-5.25.2-perl-128532-Crash-vivifying-stub-in-deleted-pkg.patch
View File

@ -1,60 +0,0 @@
From 63aab7ecaa6e826f845c405894bd8c4b6f601b39 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 3 Jul 2016 22:23:34 -0700
Subject: [PATCH] [perl #128532] Crash vivifying stub in deleted pkg
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
v5.17.0-515-g186a5ba, which added newSTUB, did not take into account
that a GV may have a null GvSTASH pointer, if its stash has been
freed, so this crashes:
delete $My::{"Foo::"}; \&My::Foo::foo
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
op.c | 2 +-
t/op/ref.t | 6 +++++-
2 files changed, 6 insertions(+), 2 deletions(-)
diff --git a/op.c b/op.c
index 46e76ac..4735d1b 100644
--- a/op.c
+++ b/op.c
@@ -9081,7 +9081,7 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake)
assert(!GvCVu(gv));
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
- if (!fake && HvENAME_HEK(GvSTASH(gv)))
+ if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
gv_method_changed(gv);
if (SvFAKE(gv)) {
cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
diff --git a/t/op/ref.t b/t/op/ref.t
index 19a44bb..84d9217 100644
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -8,7 +8,7 @@ BEGIN {
use strict qw(refs subs);
-plan(235);
+plan(236);
# Test this first before we extend the stack with other operations.
# This caused an asan failure due to a bad write past the end of the stack.
@@ -124,6 +124,10 @@ is (join(':',@{$spring2{"foo"}}), "1:2:3:4");
is ($called, 1);
}
is ref eval {\&{""}}, "CODE", 'reference to &{""} [perl #94476]';
+delete $My::{"Foo::"};
+is ref \&My::Foo::foo, "CODE",
+ 'creating stub with \&deleted_stash::foo [perl #128532]';
+
# Test references to return values of operators (TARGs/PADTMPs)
{
--
2.5.5

93
perl-5.25.2-perl-128597-Crash-from-gp_free-ckWARN_d.patch
View File

@ -1,93 +0,0 @@
From a2637ca0a3fec01b80d7ea5ba62802354fd5e6f3 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Mon, 11 Jul 2016 14:49:17 -0700
Subject: [PATCH] [perl #128597] Crash from gp_free/ckWARN_d
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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 815c735..94cd7a4 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -358,8 +358,10 @@ EOM
print $warn <<'EOM';
-#define isLEXWARN_on cBOOL(PL_curcop->cop_warnings != pWARN_STD)
-#define isLEXWARN_off cBOOL(PL_curcop->cop_warnings == pWARN_STD)
+#define isLEXWARN_on \
+ cBOOL(PL_curcop && PL_curcop->cop_warnings != pWARN_STD)
+#define isLEXWARN_off \
+ cBOOL(!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 d71fd0a..03ae46e 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';
@@ -1153,6 +1153,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 337bef3..4d13732 100644
--- a/warnings.h
+++ b/warnings.h
@@ -115,8 +115,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 cBOOL(PL_curcop->cop_warnings != pWARN_STD)
-#define isLEXWARN_off cBOOL(PL_curcop->cop_warnings == pWARN_STD)
+#define isLEXWARN_on \
+ cBOOL(PL_curcop && PL_curcop->cop_warnings != pWARN_STD)
+#define isLEXWARN_off \
+ cBOOL(!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.5.5

74
perl-5.25.2-t-test.pl-Add-fresh_perl-function.patch
View File

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

74
perl-5.25.2-uninit-warning-from-h-const-coredumped.patch
View File

@ -1,74 +0,0 @@
From 55b6481ff87f84626ba01275708297a42a6537b1 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Tue, 21 Jun 2016 15:23:20 +0100
Subject: [PATCH] uninit warning from $h{\const} coredumped
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
The code that printed the the name and subscript of a hash element
in an "uninitialized variable" warning assumed that a constant
hash subscript would be SvPOK. Something like \1 is a constant,
but is ROK, not POK. SEGVs ensured.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
sv.c | 5 ++++-
t/op/hashwarn.t | 19 ++++++++++++++++++-
2 files changed, 22 insertions(+), 2 deletions(-)
diff --git a/sv.c b/sv.c
index 535ee8d..b0fdd15 100644
--- a/sv.c
+++ b/sv.c
@@ -15683,9 +15683,12 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
if (subscript_type == FUV_SUBSCRIPT_HASH) {
SV * const sv = newSV(0);
+ STRLEN len;
+ const char * const pv = SvPV_nomg_const((SV*)keyname, len);
+
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "{%s}",
- pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
+ pv_pretty(sv, pv, len, 32, NULL, NULL,
PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
SvREFCNT_dec_NN(sv);
}
diff --git a/t/op/hashwarn.t b/t/op/hashwarn.t
index a6a1de9..6d72244 100644
--- a/t/op/hashwarn.t
+++ b/t/op/hashwarn.t
@@ -6,7 +6,7 @@ BEGIN {
}
require './test.pl';
-plan( tests => 16 );
+plan( tests => 18 );
use strict;
use warnings;
@@ -71,3 +71,20 @@ my $fail_not_hr = 'Not a HASH reference at ';
cmp_ok(scalar(@warnings),'==',0,'pseudo-hash 2 count');
cmp_ok(substr($@,0,length($fail_not_hr)),'eq',$fail_not_hr,'pseudo-hash 2 msg');
}
+
+# RT #128189
+# this used to coredump
+
+{
+ @warnings = ();
+ my %h;
+
+ no warnings;
+ use warnings qw(uninitialized);
+
+ my $x = "$h{\1}";
+ is(scalar @warnings, 1, "RT #128189 - 1 warning");
+ like("@warnings",
+ qr/Use of uninitialized value \$h\{"SCALAR\(0x[\da-f]+\)"\}/,
+ "RT #128189 correct warning");
+}
--
2.5.5

32
perl-5.25.4-clean-up-gv_fetchmethod_pvn_flags-move-origname-init.patch
View File

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

92
perl-5.25.4-clean-up-gv_fetchmethod_pvn_flags-rename-nsplit-to-l.patch
View File

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

81
perl-5.25.4-fix-129267-rework-gv_fetchmethod_pvn_flags-separator.patch
View File

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

37
perl-5.25.4-perl-129196-Crash-bad-read-with-evalbytes-S.patch
View File

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

44
perl-5.25.4-perl-129267-Test-for-gv_fetchmethod-buffer-overrun.patch
View File

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

64
perl-5.25.4-perl-129287-Make-UTF8-append-null.patch
View File

@ -1,64 +0,0 @@
From b43665fffa48dd179eba1b5616d4ca35b4def876 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 18 Sep 2016 20:17:08 -0700
Subject: [PATCH] [perl #129287] Make UTF8 & append null
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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 ad9172a..234a425 100644
--- a/doop.c
+++ b/doop.c
@@ -1093,6 +1093,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 2afb8d7..1f96e9b 100644
--- a/t/op/bop.t
+++ b/t/op/bop.t
@@ -19,7 +19,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 => 192 + (10*13*2) + 5 + 29;
+plan tests => 192 + (10*13*2) + 5 + 30;
# numerics
ok ((0xdead & 0xbeef) == 0x9ead);
@@ -664,3 +664,15 @@ is $^A, "123", '~v0 clears vstring magic on retval';
is(-1 >> $w + 1, -1, "IV -1 right shift $w + 1 == -1");
}
}
+
+# [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

46
perl-5.25.4-toke.c-fix-mswin32-builds.patch
View File

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

32
perl-5.25.6-perl-130001-h2xs-avoid-infinite-loop-for-enums.patch
View File

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

61
perl-5.25.7-Fix-Storable-segfaults.patch
View File

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

124
perl-5.25.7-Fix-const-correctness-in-hv_func.h.patch
View File

@ -1,124 +0,0 @@
From 463ddf34c08f2c97199b1bb242da1f17494d4d1a 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];
^
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 8866db9..57b1ed1 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
U64 v3 = UINT64_C(0x7465646279746573);
U64 b;
- U64 k0 = ((U64*)seed)[0];
- U64 k1 = ((U64*)seed)[1];
+ U64 k0 = ((const U64*)seed)[0];
+ U64 k1 = ((const U64*)seed)[1];
U64 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 U64 m = UINT64_C(0xc6a4a7935bd1e995);
const int r = 47;
- U64 h = *((U64*)seed) ^ len;
+ U64 h = *((const U64*)seed) ^ len;
const U64 * data = (const U64 *)str;
const U64 * end = data + (len/8);
const unsigned char * data2;
--
2.7.4

53
perl-5.25.7-perl-130307-Correctly-unwind-on-cache-hit.patch
View File

@ -1,53 +0,0 @@
From 95ec90ac7c7c5fb158401eb65721bbeaae1949ab 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.24.0:
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 38ff44a..a5d5db4 100644
--- a/regexec.c
+++ b/regexec.c
@@ -7322,6 +7322,7 @@ NULL
DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: (cache) already tried at this position...\n",
depth)
);
+ 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 2f4d00c..c81f67f 100644
--- a/t/re/re_tests
+++ b/t/re/re_tests
@@ -1969,6 +1969,7 @@ ab(?#Comment){2}c abbc y $& abbc
aa$|a(?R)a|a aaa y $& aaa # [perl 128420] recursive matches
(?:\1|a)([bcd])\1(?:(?R)|e)\1 abbaccaddedcb y $& abbaccaddedcb # [perl 128420] recursive match with backreferences
\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

58
perl-5.25.8-perl-129149-avoid-a-heap-buffer-overflow-with-pack-W.patch
View File

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

30
perl-5.25.8-perl-129149-fix-the-test-so-skip-has-a-SKIP-to-work-.patch
View File

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

83
perl-5.25.9-avoid-a-leak-in-list-assign-from-to-magic-values.patch
View File

@ -1,83 +0,0 @@
From 1050723fecc0e27677c39fadbb97cb892dfd27d2 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Wed, 15 Feb 2017 15:58:24 +0000
Subject: [PATCH] avoid a leak in list assign from/to magic values
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
RT #130766
A leak in list assignment was introduced by v5.23.6-89-gbeb08a1 and
extended with v5.23.6-90-g5c1db56.
Basically the code in S_aassign_copy_common() which does a mark-and-sweep
looking for common vars by temporarily setting SVf_BREAK on LHS SVs then
seeing if that flag was present on RHS vars, very temporarily removed that
flag from the RHS SV while mortal copying it, then set it again. After
those two commits, the "resetting" code could set SVf_BREAK on the RHS SV
even when it hadn't been been present earlier.
This meant that on exit from S_aassign_copy_common(), some SVs could be
left with SVf_BREAK on. When that SV was freed, the SVf_BREAK flag meant
that the SV head wasn't planted back in the arena (but PL_sv_count was
still decremented). This could lead to slow growth of the SV HEAD arenas.
The two circumstances that could trigger the leak were:
1) An SMG var on the LHS and a temporary on the RHS, e.g.
use Tie::Scalar;
my ($s, $t);
tie $s, 'Tie::StdScalar'; # $s has set magic
while (1) {
($s, $t) = ($t, map 1, 1, 2); # the map returns temporaries
}
2) A temporary on the RHS which has GMG, e.g.
my $s = "abc";
pos($s) = 1;
local our ($x, $y);
while (1) {
my $pr = \pos($s); # creates a ref to a TEMP with get magic
($x, $y) = (1, $$pr);
}
Strictly speaking a TEMP isn't required for either case; just a situation
where there's always a fresh SV on the RHS for each iteration that will
soon get freed and thus leaked.
This commit doesn't include any tests since I can't think of a way of
testing it. svleak.t relies on PL_sv_count, which in this case doesn't
show the leak.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_hot.c | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/pp_hot.c b/pp_hot.c
index a3ee2a7..7d6db0f 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1182,6 +1182,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
assert(svr);
if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
+ U32 brk = (SvFLAGS(svr) & SVf_BREAK);
#ifdef DEBUGGING
if (fake) {
@@ -1217,7 +1218,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
/* ... but restore afterwards in case it's needed again,
* e.g. ($a,$b,$c) = (1,$a,$a)
*/
- SvFLAGS(svr) |= SVf_BREAK;
+ SvFLAGS(svr) |= brk;
}
if (!lcount)
--
2.7.4

38
perl-5.25.9-only-mess-with-NEXT_OFF-when-we-are-in-PASS2.patch
View File

@ -1,38 +0,0 @@
From bb78386f13c18a1a7dae932b9b36e977056b13c7 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
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 322d230..d5ce63f 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -11709,11 +11709,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 == '?')
--
2.7.4

69
perl-5.25.9-perl-129061-CURLYX-nodes-can-be-studied-more-than-on.patch
View File

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

34
perl-5.25.9-silence-warnings-from-tests-about-impossible-quantif.patch
View File

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

10
perl-USE_MM_LD_RUN_PATH.patch
View File

@ -20,10 +20,10 @@ diff -up perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm.usem perl
PERM_DIR PERM_RW PERM_RWX MAGICXS
PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
- SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS XSOPT XSPROTOARG
+ SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST USE_MM_LD_RUN_PATH VERSION VERSION_FROM XS XSOPT XSPROTOARG
XS_VERSION clean depend dist dynamic_lib linkext macro realclean
tool_autosplit
- SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS
+ SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST USE_MM_LD_RUN_PATH VERSION VERSION_FROM XS
XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION
clean depend dist dynamic_lib linkext macro realclean tool_autosplit
@@ -422,7 +422,27 @@ sub new {
# PRINT_PREREQ is RedHatism.
@ -104,6 +104,6 @@ diff -up perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm.usem perl-5
my $ld_run_path_shell = "";
- if ($self->{LD_RUN_PATH} ne "") {
+ if (($self->{LD_RUN_PATH} ne "") && ($self->{USE_MM_LD_RUN_PATH})) {
$ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
$ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
}

599
perl.spec
View File

File diff suppressed because it is too large Load Diff

2
sources
View File

@ -1 +1 @@
SHA512 (perl-5.24.1.tar.bz2) = 5a6e5f5fcd65e7add7ba2126d530a8e2a912cb076cfe61bbf7e49b28e4e63aa0d474183a6f8a388c67d03ea6a44f367efb3b3a768e971ef52b769e737eeb048b
SHA512 (perl-5.26.0.tar.bz2) = 1e3849c0fbf3a1903f83f86470d44f55f0f22136a1bdeb829af9c47351b6c817d7d8961a2db4c9172285f5abc087ea105ccfd4c93025acbd73569e628669aab3