Compare commits
No commits in common. "stream-perl-5.24-rhel-8.9.0" and "c8" have entirely different histories.
stream-per
...
c8
|
@ -1 +1 @@
|
||||||
SOURCES/perl-5.24.4.tar.bz2
|
SOURCES/perl-5.26.3.tar.bz2
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
4c61872bab631427cbb5b519ef8809d3a4c7f921 SOURCES/perl-5.26.3.tar.bz2
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -27,14 +27,14 @@ index a8b172f..a3fbce2 100644
|
||||||
$Is{Solaris} = $^O eq 'solaris';
|
$Is{Solaris} = $^O eq 'solaris';
|
||||||
$Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
|
$Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
|
||||||
@@ -932,7 +933,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
|
@@ -932,7 +933,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
|
||||||
|
push(@m," \$(RM_F) \$\@\n");
|
||||||
|
|
||||||
my $libs = '$(LDLOADLIBS)';
|
my $libs = '$(LDLOADLIBS)';
|
||||||
|
|
||||||
- if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
|
- if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
|
||||||
+ if (($Is{Linux} || $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
|
# Use nothing on static perl platforms, and to the flags needed
|
||||||
# to link against the shared libperl library on shared perl
|
# to link against the shared libperl library on shared perl
|
||||||
# platforms. We peek at lddlflags to see if we need -Wl,-R
|
# platforms. We peek at lddlflags to see if we need -Wl,-R
|
||||||
@@ -941,6 +942,11 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
|
@@ -941,6 +942,11 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
|
||||||
# The Android linker will not recognize symbols from
|
# The Android linker will not recognize symbols from
|
||||||
# libperl unless the module explicitly depends on it.
|
# libperl unless the module explicitly depends on it.
|
|
@ -24,7 +24,7 @@ index 6af238c..d4f0c56 100644
|
||||||
--- a/MANIFEST
|
--- a/MANIFEST
|
||||||
+++ b/MANIFEST
|
+++ b/MANIFEST
|
||||||
@@ -1045,6 +1045,7 @@ cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
|
@@ -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_QNX.pm MakeMaker methods for QNX
|
||||||
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm MakeMaker methods for Unix
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm MakeMaker methods for Unix
|
||||||
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm Independed MM methods
|
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm Independed MM methods
|
|
@ -0,0 +1,73 @@
|
||||||
|
From 8985b12868f07d9ef501580d600e49fe8f230eb4 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Tue, 22 Aug 2017 09:49:42 +0200
|
||||||
|
Subject: [PATCH] Time-HiRes: Fix unreliable t/usleep.t and t/utime.t
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported from Time-HiRes-1.9746.
|
||||||
|
|
||||||
|
The tests randomly failed on loaded machines because a CPU scheduler
|
||||||
|
could add unpredictable delays.
|
||||||
|
|
||||||
|
CPAN RT#122819
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Time-HiRes/t/usleep.t | 4 ++--
|
||||||
|
dist/Time-HiRes/t/utime.t | 9 +++++----
|
||||||
|
2 files changed, 7 insertions(+), 6 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Time-HiRes/t/usleep.t b/dist/Time-HiRes/t/usleep.t
|
||||||
|
index 9322458..bb66cbe 100644
|
||||||
|
--- a/dist/Time-HiRes/t/usleep.t
|
||||||
|
+++ b/dist/Time-HiRes/t/usleep.t
|
||||||
|
@@ -32,7 +32,7 @@ SKIP: {
|
||||||
|
Time::HiRes::usleep(500_000);
|
||||||
|
my $f2 = Time::HiRes::time();
|
||||||
|
my $d = $f2 - $f;
|
||||||
|
- ok $d > 0.4 && $d < 0.9 or print("# slept $d secs $f to $f2\n");
|
||||||
|
+ ok $d > 0.49 or print("# slept $d secs $f to $f2\n");
|
||||||
|
}
|
||||||
|
|
||||||
|
SKIP: {
|
||||||
|
@@ -40,7 +40,7 @@ SKIP: {
|
||||||
|
my $r = [ Time::HiRes::gettimeofday() ];
|
||||||
|
Time::HiRes::sleep( 0.5 );
|
||||||
|
my $f = Time::HiRes::tv_interval $r;
|
||||||
|
- ok $f > 0.4 && $f < 0.9 or print("# slept $f instead of 0.5 secs.\n");
|
||||||
|
+ ok $f > 0.49 or print("# slept $f instead of 0.5 secs.\n");
|
||||||
|
}
|
||||||
|
|
||||||
|
SKIP: {
|
||||||
|
diff --git a/dist/Time-HiRes/t/utime.t b/dist/Time-HiRes/t/utime.t
|
||||||
|
index 22fd48e..c5c7e55 100644
|
||||||
|
--- a/dist/Time-HiRes/t/utime.t
|
||||||
|
+++ b/dist/Time-HiRes/t/utime.t
|
||||||
|
@@ -106,17 +106,18 @@ print "# utime undef sets time to now\n";
|
||||||
|
my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
|
||||||
|
|
||||||
|
my $now = Time::HiRes::time;
|
||||||
|
+ sleep(1);
|
||||||
|
is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed";
|
||||||
|
|
||||||
|
{
|
||||||
|
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
|
||||||
|
- cmp_ok abs( $got_atime - $now), '<', 0.1, "File 1 atime set correctly";
|
||||||
|
- cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 1 mtime set correctly";
|
||||||
|
+ cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly";
|
||||||
|
+ cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly";
|
||||||
|
}
|
||||||
|
{
|
||||||
|
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
|
||||||
|
- cmp_ok abs( $got_atime - $now), '<', 0.1, "File 2 atime set correctly";
|
||||||
|
- cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 2 mtime set correctly";
|
||||||
|
+ cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly";
|
||||||
|
+ cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly";
|
||||||
|
}
|
||||||
|
};
|
||||||
|
|
||||||
|
--
|
||||||
|
2.9.5
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
From 064604f904546ae4ddada5a2aa30256faccee39c Mon Sep 17 00:00:00 2001
|
From 7b3e03bd309fcc48a135123a60678ae2596b1c38 Mon Sep 17 00:00:00 2001
|
||||||
From: Tony Cook <tony@develop-help.com>
|
From: Tony Cook <tony@develop-help.com>
|
||||||
Date: Wed, 7 Jun 2017 15:00:26 +1000
|
Date: Wed, 7 Jun 2017 15:00:26 +1000
|
||||||
Subject: [PATCH] clear the UTF8 flag on a glob if it isn't UTF8
|
Subject: [PATCH] clear the UTF8 flag on a glob if it isn't UTF8
|
||||||
|
@ -6,7 +6,7 @@ MIME-Version: 1.0
|
||||||
Content-Type: text/plain; charset=UTF-8
|
Content-Type: text/plain; charset=UTF-8
|
||||||
Content-Transfer-Encoding: 8bit
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
Ported to 5.24.1:
|
Ported to 5.26.0:
|
||||||
|
|
||||||
commit 1097da16b21fe0a2257dba9937e55c0cca18f7e1
|
commit 1097da16b21fe0a2257dba9937e55c0cca18f7e1
|
||||||
Author: Tony Cook <tony@develop-help.com>
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
@ -27,10 +27,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
2 files changed, 11 insertions(+), 1 deletion(-)
|
2 files changed, 11 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
diff --git a/sv.c b/sv.c
|
diff --git a/sv.c b/sv.c
|
||||||
index 12cbb5f..05584a2 100644
|
index 9f3e28e..ae3dc95 100644
|
||||||
--- a/sv.c
|
--- a/sv.c
|
||||||
+++ b/sv.c
|
+++ b/sv.c
|
||||||
@@ -3162,6 +3162,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
|
@@ -3179,6 +3179,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
|
||||||
assert(SvPOK(buffer));
|
assert(SvPOK(buffer));
|
||||||
if (SvUTF8(buffer))
|
if (SvUTF8(buffer))
|
||||||
SvUTF8_on(sv);
|
SvUTF8_on(sv);
|
||||||
|
@ -40,21 +40,21 @@ index 12cbb5f..05584a2 100644
|
||||||
*lp = SvCUR(buffer);
|
*lp = SvCUR(buffer);
|
||||||
return SvPVX(buffer);
|
return SvPVX(buffer);
|
||||||
diff --git a/t/op/gv.t b/t/op/gv.t
|
diff --git a/t/op/gv.t b/t/op/gv.t
|
||||||
index cdaaef5..ea79e51 100644
|
index 4fe6b00..670ccf6 100644
|
||||||
--- a/t/op/gv.t
|
--- a/t/op/gv.t
|
||||||
+++ b/t/op/gv.t
|
+++ b/t/op/gv.t
|
||||||
@@ -12,7 +12,7 @@ BEGIN {
|
@@ -12,7 +12,7 @@ BEGIN {
|
||||||
|
|
||||||
use warnings;
|
use warnings;
|
||||||
|
|
||||||
-plan(tests => 277 );
|
-plan(tests => 280);
|
||||||
+plan(tests => 279 );
|
+plan(tests => 282);
|
||||||
|
|
||||||
# type coercion on assignment
|
# type coercion on assignment
|
||||||
$foo = 'foo';
|
$foo = 'foo';
|
||||||
@@ -1173,6 +1173,14 @@ SKIP: {
|
@@ -1170,6 +1170,14 @@ SKIP: {
|
||||||
# [perl #131085] This used to crash; no ok() necessary.
|
is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
|
||||||
$::{"A131085"} = sub {}; \&{"A131085"};
|
}
|
||||||
|
|
||||||
+{
|
+{
|
||||||
+ # [perl #131263]
|
+ # [perl #131263]
|
||||||
|
@ -64,9 +64,9 @@ index cdaaef5..ea79e51 100644
|
||||||
+ ok(*sym eq "*main::\xC3\x80", "utf8 flag properly cleared");
|
+ ok(*sym eq "*main::\xC3\x80", "utf8 flag properly cleared");
|
||||||
+}
|
+}
|
||||||
+
|
+
|
||||||
|
# test gv_try_downgrade()
|
||||||
__END__
|
# If a GV can be stored in a stash in a compact, non-GV form, then
|
||||||
Perl
|
# whenever ops are freed which reference the GV, an attempt is made to
|
||||||
--
|
--
|
||||||
2.9.4
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,61 @@
|
||||||
|
From cb2fda94b02c5b7e8d16582410034f5a3dae526f Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Tue, 25 Jul 2017 16:21:22 +1000
|
||||||
|
Subject: [PATCH] (perl #131588) be a little more careful in arybase::_tie_it()
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Original patch by John Leitch <john@autosectools.com>
|
||||||
|
Petr Pisar: Ported to 5.26.0.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/arybase/arybase.xs | 10 ++++++----
|
||||||
|
ext/arybase/t/arybase.t | 4 +++-
|
||||||
|
2 files changed, 9 insertions(+), 5 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/arybase/arybase.xs b/ext/arybase/arybase.xs
|
||||||
|
index 880bbe3..216442a 100644
|
||||||
|
--- a/ext/arybase/arybase.xs
|
||||||
|
+++ b/ext/arybase/arybase.xs
|
||||||
|
@@ -438,10 +438,12 @@ _tie_it(SV *sv)
|
||||||
|
INIT:
|
||||||
|
GV * const gv = (GV *)sv;
|
||||||
|
CODE:
|
||||||
|
- if (GvSV(gv))
|
||||||
|
- /* This is *our* scalar now! */
|
||||||
|
- sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
|
||||||
|
- tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
|
||||||
|
+ if (isGV(gv)) {
|
||||||
|
+ if (GvSV(gv))
|
||||||
|
+ /* This is *our* scalar now! */
|
||||||
|
+ sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
|
||||||
|
+ tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
|
||||||
|
+ }
|
||||||
|
|
||||||
|
void
|
||||||
|
FETCH(...)
|
||||||
|
diff --git a/ext/arybase/t/arybase.t b/ext/arybase/t/arybase.t
|
||||||
|
index f3d3287..41e90df 100644
|
||||||
|
--- a/ext/arybase/t/arybase.t
|
||||||
|
+++ b/ext/arybase/t/arybase.t
|
||||||
|
@@ -4,7 +4,7 @@
|
||||||
|
# plus miscellaneous bug fix tests
|
||||||
|
|
||||||
|
no warnings 'deprecated';
|
||||||
|
-use Test::More tests => 7;
|
||||||
|
+use Test::More tests => 8;
|
||||||
|
|
||||||
|
sub outside_base_scope { return "${'['}" }
|
||||||
|
|
||||||
|
@@ -34,4 +34,6 @@ is $@, "That use of \$[ is unsupported at $f line $l.\n",
|
||||||
|
|
||||||
|
sub foo { my $x; $x = wait } # compilation of this routine used to crash
|
||||||
|
|
||||||
|
+ok eval { arybase::_tie_it(1); 1 }, "don't crash on bad call to _tie_it()";
|
||||||
|
+
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,37 @@
|
||||||
|
From 37268580c0cfbf190ff9aa7859a604713cb366ee Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 27 Jun 2017 16:36:57 +0200
|
||||||
|
Subject: [PATCH] t/op/hash.t: fixup intermittently failing test
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Port to 5.26.0:
|
||||||
|
|
||||||
|
commit b2ac59d1d0fda74d6612701d8316fe8dfb6a1b90
|
||||||
|
Author: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue Jun 27 16:36:57 2017 +0200
|
||||||
|
|
||||||
|
t/op/hash.t: fixup intermittently failing test
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/op/hash.t | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/op/hash.t b/t/op/hash.t
|
||||||
|
index a0e79c7..b941c57 100644
|
||||||
|
--- a/t/op/hash.t
|
||||||
|
+++ b/t/op/hash.t
|
||||||
|
@@ -206,7 +206,7 @@ sub torture_hash {
|
||||||
|
my $keys = pop @groups;
|
||||||
|
++$h->{$_} foreach @$keys;
|
||||||
|
my (undef, $total) = validate_hash("$desc " . keys %$h, $h);
|
||||||
|
- is($total, $total0, "bucket count is constant when rebuilding");
|
||||||
|
+ ok($total == $total0 || $total == ($total0*2), "bucket count is expected size when rebuilding");
|
||||||
|
is(scalar %$h, pop @groups, "scalar keys is identical when rebuilding");
|
||||||
|
++$h1->{$_} foreach @$keys;
|
||||||
|
validate_hash("$desc copy " . keys %$h1, $h1);
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
From 2657358b67ba3eadd1be99bd7e732a8d68f1f95d Mon Sep 17 00:00:00 2001
|
From abd17348111a99642da217c45d836f2df5713594 Mon Sep 17 00:00:00 2001
|
||||||
From: John Lightsey <lightsey@debian.org>
|
From: John Lightsey <lightsey@debian.org>
|
||||||
Date: Tue, 31 Oct 2017 18:12:26 -0500
|
Date: Tue, 31 Oct 2017 18:12:26 -0500
|
||||||
Subject: [PATCH] Fix deparsing of transliterations with unprintable
|
Subject: [PATCH] Fix deparsing of transliterations with unprintable
|
||||||
|
@ -10,7 +10,7 @@ Content-Transfer-Encoding: 8bit
|
||||||
RT #132405
|
RT #132405
|
||||||
|
|
||||||
Signed-off-by: Nicolas R <atoomic@cpan.org>
|
Signed-off-by: Nicolas R <atoomic@cpan.org>
|
||||||
Petr Písař: Port to 5.24.3.
|
Petr Písař: Port to 5.26.1.
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
---
|
---
|
||||||
lib/B/Deparse.pm | 2 +-
|
lib/B/Deparse.pm | 2 +-
|
||||||
|
@ -18,10 +18,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
2 files changed, 6 insertions(+), 1 deletion(-)
|
2 files changed, 6 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
|
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
|
||||||
index 9879d67..f5f7d82 100644
|
index 3166415..cc74552 100644
|
||||||
--- a/lib/B/Deparse.pm
|
--- a/lib/B/Deparse.pm
|
||||||
+++ b/lib/B/Deparse.pm
|
+++ b/lib/B/Deparse.pm
|
||||||
@@ -5047,7 +5047,7 @@ sub pchr { # ASCII
|
@@ -5200,7 +5200,7 @@ sub pchr { # ASCII
|
||||||
} elsif ($n == ord "\r") {
|
} elsif ($n == ord "\r") {
|
||||||
return '\\r';
|
return '\\r';
|
||||||
} elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
|
} elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
|
||||||
|
@ -31,13 +31,13 @@ index 9879d67..f5f7d82 100644
|
||||||
# return '\x' . sprintf("%02x", $n);
|
# return '\x' . sprintf("%02x", $n);
|
||||||
return '\\' . sprintf("%03o", $n);
|
return '\\' . sprintf("%03o", $n);
|
||||||
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
|
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
|
||||||
index 19db404..45b1ff3 100644
|
index 7eeb4f8..eae9c49 100644
|
||||||
--- a/lib/B/Deparse.t
|
--- a/lib/B/Deparse.t
|
||||||
+++ b/lib/B/Deparse.t
|
+++ b/lib/B/Deparse.t
|
||||||
@@ -2488,3 +2488,8 @@ $_ ^= $_;
|
@@ -2610,3 +2610,8 @@ sub ($a, $=) {
|
||||||
$_ |.= $_;
|
$a;
|
||||||
$_ &.= $_;
|
}
|
||||||
$_ ^.= $_;
|
;
|
||||||
+####
|
+####
|
||||||
+# tr with unprintable characters
|
+# tr with unprintable characters
|
||||||
+my $str;
|
+my $str;
|
File diff suppressed because it is too large
Load Diff
|
@ -1,4 +1,4 @@
|
||||||
From 9a4826e0881f8c5498a0fd5f24ed2a0fefb771b7 Mon Sep 17 00:00:00 2001
|
From 4ac7295514f35016a79dbcc07500f6c9ca4729b7 Mon Sep 17 00:00:00 2001
|
||||||
From: Tony Cook <tony@develop-help.com>
|
From: Tony Cook <tony@develop-help.com>
|
||||||
Date: Thu, 2 Nov 2017 20:18:56 +0000
|
Date: Thu, 2 Nov 2017 20:18:56 +0000
|
||||||
Subject: [PATCH] (perl #131895) fail stat on names with \0 embedded
|
Subject: [PATCH] (perl #131895) fail stat on names with \0 embedded
|
||||||
|
@ -8,7 +8,7 @@ Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
Also lstat() and the file test ops.
|
Also lstat() and the file test ops.
|
||||||
|
|
||||||
Petr Písař: Port to 5.24.3.
|
Petr Písař: Port to 5.26.1.
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
---
|
---
|
||||||
|
@ -20,10 +20,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
5 files changed, 73 insertions(+), 13 deletions(-)
|
5 files changed, 73 insertions(+), 13 deletions(-)
|
||||||
|
|
||||||
diff --git a/doio.c b/doio.c
|
diff --git a/doio.c b/doio.c
|
||||||
index 6704862..2792c66 100644
|
index becb19b..70d7747 100644
|
||||||
--- a/doio.c
|
--- a/doio.c
|
||||||
+++ b/doio.c
|
+++ b/doio.c
|
||||||
@@ -1458,7 +1458,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
@@ -1466,7 +1466,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
return PL_laststatval;
|
return PL_laststatval;
|
||||||
else {
|
else {
|
||||||
SV* const sv = TOPs;
|
SV* const sv = TOPs;
|
||||||
|
@ -32,7 +32,7 @@ index 6704862..2792c66 100644
|
||||||
STRLEN len;
|
STRLEN len;
|
||||||
if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
|
if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
|
||||||
goto do_fstat;
|
goto do_fstat;
|
||||||
@@ -1472,9 +1472,14 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
@@ -1480,9 +1480,14 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
s = SvPV_flags_const(sv, len, flags);
|
s = SvPV_flags_const(sv, len, flags);
|
||||||
PL_statgv = NULL;
|
PL_statgv = NULL;
|
||||||
sv_setpvn(PL_statname, s, len);
|
sv_setpvn(PL_statname, s, len);
|
||||||
|
@ -49,7 +49,7 @@ index 6704862..2792c66 100644
|
||||||
if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
|
if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
|
||||||
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
|
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
|
||||||
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
|
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
|
||||||
@@ -1491,6 +1496,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
@@ -1499,6 +1504,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||||
static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
|
static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
|
||||||
dSP;
|
dSP;
|
||||||
const char *file;
|
const char *file;
|
||||||
|
@ -57,7 +57,7 @@ index 6704862..2792c66 100644
|
||||||
SV* const sv = TOPs;
|
SV* const sv = TOPs;
|
||||||
bool isio = FALSE;
|
bool isio = FALSE;
|
||||||
if (PL_op->op_flags & OPf_REF) {
|
if (PL_op->op_flags & OPf_REF) {
|
||||||
@@ -1534,9 +1540,14 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
@@ -1542,9 +1548,14 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||||
HEKfARG(GvENAME_HEK((const GV *)
|
HEKfARG(GvENAME_HEK((const GV *)
|
||||||
(SvROK(sv) ? SvRV(sv) : sv))));
|
(SvROK(sv) ? SvRV(sv) : sv))));
|
||||||
}
|
}
|
||||||
|
@ -75,10 +75,10 @@ index 6704862..2792c66 100644
|
||||||
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
|
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
|
||||||
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
|
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
|
||||||
diff --git a/pp_sys.c b/pp_sys.c
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
index bd55043..1a72e60 100644
|
index 0b60584..1b81fda 100644
|
||||||
--- a/pp_sys.c
|
--- a/pp_sys.c
|
||||||
+++ b/pp_sys.c
|
+++ b/pp_sys.c
|
||||||
@@ -2927,19 +2927,24 @@ PP(pp_stat)
|
@@ -2963,19 +2963,24 @@ PP(pp_stat)
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
const char *file;
|
const char *file;
|
||||||
|
@ -106,7 +106,7 @@ index bd55043..1a72e60 100644
|
||||||
PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
|
PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
|
||||||
else
|
else
|
||||||
PL_laststatval = PerlLIO_stat(file, &PL_statcache);
|
PL_laststatval = PerlLIO_stat(file, &PL_statcache);
|
||||||
@@ -3175,8 +3180,12 @@ PP(pp_ftrread)
|
@@ -3211,8 +3216,12 @@ PP(pp_ftrread)
|
||||||
|
|
||||||
if (use_access) {
|
if (use_access) {
|
||||||
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
|
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
|
||||||
|
@ -121,7 +121,7 @@ index bd55043..1a72e60 100644
|
||||||
# ifdef PERL_EFF_ACCESS
|
# ifdef PERL_EFF_ACCESS
|
||||||
result = PERL_EFF_ACCESS(name, access_mode);
|
result = PERL_EFF_ACCESS(name, access_mode);
|
||||||
# else
|
# else
|
||||||
@@ -3501,10 +3510,18 @@ PP(pp_fttext)
|
@@ -3537,10 +3546,18 @@ PP(pp_fttext)
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
const char *file;
|
const char *file;
|
||||||
|
@ -142,13 +142,13 @@ index bd55043..1a72e60 100644
|
||||||
file = SvPVX_const(PL_statname);
|
file = SvPVX_const(PL_statname);
|
||||||
PL_statgv = NULL;
|
PL_statgv = NULL;
|
||||||
diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
|
diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
|
||||||
index 6338964..ded5d7d 100644
|
index 9c544e0..c599aa3 100644
|
||||||
--- a/t/lib/warnings/pp_sys
|
--- a/t/lib/warnings/pp_sys
|
||||||
+++ b/t/lib/warnings/pp_sys
|
+++ b/t/lib/warnings/pp_sys
|
||||||
@@ -962,3 +962,17 @@ close $fh;
|
@@ -972,3 +972,17 @@ close $fh;
|
||||||
unlink $file;
|
unlink $file;
|
||||||
EXPECT
|
EXPECT
|
||||||
syswrite() is deprecated on :utf8 handles at - line 6.
|
syswrite() is deprecated on :utf8 handles. This will be a fatal error in Perl 5.30 at - line 5.
|
||||||
+########
|
+########
|
||||||
+# NAME stat on name with \0
|
+# NAME stat on name with \0
|
||||||
+use warnings;
|
+use warnings;
|
||||||
|
@ -189,7 +189,7 @@ index 8883381..bd1d08c 100644
|
||||||
+ ok(!-r "TEST\0-", '-r on name with \0');
|
+ ok(!-r "TEST\0-", '-r on name with \0');
|
||||||
+}
|
+}
|
||||||
diff --git a/t/op/stat.t b/t/op/stat.t
|
diff --git a/t/op/stat.t b/t/op/stat.t
|
||||||
index 637a902..71193ad 100644
|
index 323c498..dbbe6ec 100644
|
||||||
--- a/t/op/stat.t
|
--- a/t/op/stat.t
|
||||||
+++ b/t/op/stat.t
|
+++ b/t/op/stat.t
|
||||||
@@ -25,7 +25,7 @@ if ($^O eq 'MSWin32') {
|
@@ -25,7 +25,7 @@ if ($^O eq 'MSWin32') {
|
||||||
|
@ -201,7 +201,7 @@ index 637a902..71193ad 100644
|
||||||
|
|
||||||
my $Perl = which_perl();
|
my $Perl = which_perl();
|
||||||
|
|
||||||
@@ -651,6 +651,16 @@ SKIP:
|
@@ -653,6 +653,16 @@ SKIP:
|
||||||
'stat on an array of valid paths should return ENOENT';
|
'stat on an array of valid paths should return ENOENT';
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
From 86a48d83a7caf38c553000a250ed1359c235f55e Mon Sep 17 00:00:00 2001
|
From dc5c68130b7c8b727e9e792506183c255fc2bc70 Mon Sep 17 00:00:00 2001
|
||||||
From: Tony Cook <tony@develop-help.com>
|
From: Tony Cook <tony@develop-help.com>
|
||||||
Date: Thu, 19 Oct 2017 10:46:04 +1100
|
Date: Thu, 19 Oct 2017 10:46:04 +1100
|
||||||
Subject: [PATCH] (perl #132245) don't try to process a char range with no
|
Subject: [PATCH] (perl #132245) don't try to process a char range with no
|
||||||
|
@ -11,38 +11,40 @@ A range like \N{}-0 eventually results in compilation failing, but
|
||||||
before that, get_and_check_backslash_N_name() attempts to treat
|
before that, get_and_check_backslash_N_name() attempts to treat
|
||||||
the memory before the empty output of \N{} as a character.
|
the memory before the empty output of \N{} as a character.
|
||||||
|
|
||||||
Petr Písař: Ported to 5.24.3.
|
Petr Písař: Ported to 5.26.1.
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
---
|
---
|
||||||
t/lib/warnings/toke | 5 +++++
|
t/lib/warnings/toke | 5 +++++
|
||||||
toke.c | 4 ++--
|
toke.c | 6 +++---
|
||||||
2 files changed, 7 insertions(+), 2 deletions(-)
|
2 files changed, 8 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
|
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
|
||||||
index 493c8a2..4a521e0 100644
|
index fc51d9f..398ee22 100644
|
||||||
--- a/t/lib/warnings/toke
|
--- a/t/lib/warnings/toke
|
||||||
+++ b/t/lib/warnings/toke
|
+++ b/t/lib/warnings/toke
|
||||||
@@ -1509,3 +1509,8 @@ my $v = 𝛃 - 5;
|
@@ -1651,3 +1651,8 @@ Execution of - aborted due to compilation errors.
|
||||||
|
use utf8;
|
||||||
|
qw∘foo ∞ ♥ bar∘
|
||||||
EXPECT
|
EXPECT
|
||||||
OPTION regex
|
|
||||||
(Wide character.*\n)?Warning: Use of "𝛃" without parentheses is ambiguous
|
|
||||||
+########
|
+########
|
||||||
+# NAME tr/// range with empty \N{} at the start
|
+# NAME tr/// range with empty \N{} at the start
|
||||||
+tr//\N{}-0/;
|
+tr//\N{}-0/;
|
||||||
+EXPECT
|
+EXPECT
|
||||||
+Unknown charname '' is deprecated at - line 1.
|
+Unknown charname '' is deprecated. Its use will be fatal in Perl 5.28 at - line 1.
|
||||||
diff --git a/toke.c b/toke.c
|
diff --git a/toke.c b/toke.c
|
||||||
index f2310cc..3d93fac 100644
|
index 6f84d2d..6ee7a68 100644
|
||||||
--- a/toke.c
|
--- a/toke.c
|
||||||
+++ b/toke.c
|
+++ b/toke.c
|
||||||
@@ -2906,8 +2906,8 @@ S_scan_const(pTHX_ char *start)
|
@@ -2958,9 +2958,9 @@ S_scan_const(pTHX_ char *start)
|
||||||
* at least one character, then see if this next one is a '-',
|
|
||||||
* indicating the previous one was the start of a range. But
|
/* Here, we don't think we're in a range. If the new character
|
||||||
* don't bother if we're too close to the end for the minus to
|
* is not a hyphen; or if it is a hyphen, but it's too close to
|
||||||
- * mean that. */
|
- * either edge to indicate a range, then it's a regular
|
||||||
|
- * character. */
|
||||||
- if (*s != '-' || s >= send - 1 || s == start) {
|
- if (*s != '-' || s >= send - 1 || s == start) {
|
||||||
+ * mean that, or if we haven't output any characters yet. */
|
+ * either edge to indicate a range, or if we haven't output any
|
||||||
|
+ * characters yet then it's a regular character. */
|
||||||
+ if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
|
+ if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
|
||||||
|
|
||||||
/* A regular character. Process like any other, but first
|
/* A regular character. Process like any other, but first
|
|
@ -1,4 +1,4 @@
|
||||||
From 0a41ca5a68626a0f44e0d552e460e86567e47140 Mon Sep 17 00:00:00 2001
|
From 8c7182b26a43f14cd8afbfbe4448cbbd691c3609 Mon Sep 17 00:00:00 2001
|
||||||
From: Zefram <zefram@fysh.org>
|
From: Zefram <zefram@fysh.org>
|
||||||
Date: Wed, 15 Nov 2017 08:11:37 +0000
|
Date: Wed, 15 Nov 2017 08:11:37 +0000
|
||||||
Subject: [PATCH] set $! when statting a closed filehandle
|
Subject: [PATCH] set $! when statting a closed filehandle
|
||||||
|
@ -11,7 +11,7 @@ filehandle, $! was often not being set, depending on the operation
|
||||||
and the nature of the invalidity. Consistently set it to EBADF.
|
and the nature of the invalidity. Consistently set it to EBADF.
|
||||||
Fixes [perl #108288].
|
Fixes [perl #108288].
|
||||||
|
|
||||||
Petr Písař: Ported to 5.24.3.
|
Petr Písař: Ported to 5.26.1.
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
---
|
---
|
||||||
|
@ -23,22 +23,22 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
create mode 100644 t/op/stat_errors.t
|
create mode 100644 t/op/stat_errors.t
|
||||||
|
|
||||||
diff --git a/MANIFEST b/MANIFEST
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
index fcf7eae..3077142 100644
|
index fcbf5cc..996759e 100644
|
||||||
--- a/MANIFEST
|
--- a/MANIFEST
|
||||||
+++ b/MANIFEST
|
+++ b/MANIFEST
|
||||||
@@ -5394,6 +5394,7 @@ t/op/sselect.t See if 4 argument select works
|
@@ -5670,6 +5670,7 @@ t/op/srand.t See if srand works
|
||||||
|
t/op/sselect.t See if 4 argument select works
|
||||||
t/op/stash.t See if %:: stashes work
|
t/op/stash.t See if %:: stashes work
|
||||||
t/op/state.t See if state variables work
|
|
||||||
t/op/stat.t See if stat works
|
t/op/stat.t See if stat works
|
||||||
+t/op/stat_errors.t See if stat and file tests handle threshold errors
|
+t/op/stat_errors.t See if stat and file tests handle threshold errors
|
||||||
|
t/op/state.t See if state variables work
|
||||||
t/op/study.t See if study works
|
t/op/study.t See if study works
|
||||||
t/op/studytied.t See if study works with tied scalars
|
t/op/studytied.t See if study works with tied scalars
|
||||||
t/op/sub_lval.t See if lvalue subroutines work
|
|
||||||
diff --git a/doio.c b/doio.c
|
diff --git a/doio.c b/doio.c
|
||||||
index 2792c66..f2934c5 100644
|
index 70d7747..71dc6e4 100644
|
||||||
--- a/doio.c
|
--- a/doio.c
|
||||||
+++ b/doio.c
|
+++ b/doio.c
|
||||||
@@ -1429,8 +1429,11 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
@@ -1437,8 +1437,11 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
if (PL_op->op_flags & OPf_REF) {
|
if (PL_op->op_flags & OPf_REF) {
|
||||||
gv = cGVOP_gv;
|
gv = cGVOP_gv;
|
||||||
do_fstat:
|
do_fstat:
|
||||||
|
@ -51,7 +51,7 @@ index 2792c66..f2934c5 100644
|
||||||
io = GvIO(gv);
|
io = GvIO(gv);
|
||||||
do_fstat_have_io:
|
do_fstat_have_io:
|
||||||
PL_laststype = OP_STAT;
|
PL_laststype = OP_STAT;
|
||||||
@@ -1441,6 +1444,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
@@ -1449,6 +1452,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
int fd = PerlIO_fileno(IoIFP(io));
|
int fd = PerlIO_fileno(IoIFP(io));
|
||||||
if (fd < 0) {
|
if (fd < 0) {
|
||||||
/* E.g. PerlIO::scalar has no real fd. */
|
/* E.g. PerlIO::scalar has no real fd. */
|
||||||
|
@ -59,7 +59,7 @@ index 2792c66..f2934c5 100644
|
||||||
return (PL_laststatval = -1);
|
return (PL_laststatval = -1);
|
||||||
} else {
|
} else {
|
||||||
return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
|
return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
|
||||||
@@ -1451,6 +1455,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
@@ -1459,6 +1463,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
}
|
}
|
||||||
PL_laststatval = -1;
|
PL_laststatval = -1;
|
||||||
report_evil_fh(gv);
|
report_evil_fh(gv);
|
||||||
|
@ -67,7 +67,7 @@ index 2792c66..f2934c5 100644
|
||||||
return -1;
|
return -1;
|
||||||
}
|
}
|
||||||
else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
|
else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
|
||||||
@@ -1503,6 +1508,8 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
@@ -1511,6 +1516,8 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||||
if (cGVOP_gv == PL_defgv) {
|
if (cGVOP_gv == PL_defgv) {
|
||||||
if (PL_laststype != OP_LSTAT)
|
if (PL_laststype != OP_LSTAT)
|
||||||
Perl_croak(aTHX_ "%s", no_prev_lstat);
|
Perl_croak(aTHX_ "%s", no_prev_lstat);
|
||||||
|
@ -76,8 +76,8 @@ index 2792c66..f2934c5 100644
|
||||||
return PL_laststatval;
|
return PL_laststatval;
|
||||||
}
|
}
|
||||||
PL_laststatval = -1;
|
PL_laststatval = -1;
|
||||||
@@ -1512,6 +1519,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
@@ -1520,6 +1527,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||||
"Use of -l on filehandle %"HEKf,
|
"Use of -l on filehandle %" HEKf,
|
||||||
HEKfARG(GvENAME_HEK(cGVOP_gv)));
|
HEKfARG(GvENAME_HEK(cGVOP_gv)));
|
||||||
}
|
}
|
||||||
+ SETERRNO(EBADF,RMS_IFI);
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
@ -85,10 +85,10 @@ index 2792c66..f2934c5 100644
|
||||||
}
|
}
|
||||||
if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
|
if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
|
||||||
diff --git a/pp_sys.c b/pp_sys.c
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
index 5e0993d..2fcc219 100644
|
index fefbea3..87961f1 100644
|
||||||
--- a/pp_sys.c
|
--- a/pp_sys.c
|
||||||
+++ b/pp_sys.c
|
+++ b/pp_sys.c
|
||||||
@@ -2889,10 +2889,11 @@ PP(pp_stat)
|
@@ -2925,10 +2925,11 @@ PP(pp_stat)
|
||||||
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
|
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -102,8 +102,8 @@ index 5e0993d..2fcc219 100644
|
||||||
- havefp = FALSE;
|
- havefp = FALSE;
|
||||||
PL_laststype = OP_STAT;
|
PL_laststype = OP_STAT;
|
||||||
PL_statgv = gv ? gv : (GV *)io;
|
PL_statgv = gv ? gv : (GV *)io;
|
||||||
sv_setpvs(PL_statname, "");
|
SvPVCLEAR(PL_statname);
|
||||||
@@ -2903,22 +2904,25 @@ PP(pp_stat)
|
@@ -2939,22 +2940,25 @@ PP(pp_stat)
|
||||||
if (IoIFP(io)) {
|
if (IoIFP(io)) {
|
||||||
int fd = PerlIO_fileno(IoIFP(io));
|
int fd = PerlIO_fileno(IoIFP(io));
|
||||||
if (fd < 0) {
|
if (fd < 0) {
|
||||||
|
@ -134,7 +134,7 @@ index 5e0993d..2fcc219 100644
|
||||||
}
|
}
|
||||||
|
|
||||||
if (PL_laststatval < 0) {
|
if (PL_laststatval < 0) {
|
||||||
@@ -3415,7 +3419,7 @@ PP(pp_fttty)
|
@@ -3451,7 +3455,7 @@ PP(pp_fttty)
|
||||||
else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
|
else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
|
||||||
fd = (int)uv;
|
fd = (int)uv;
|
||||||
else
|
else
|
|
@ -0,0 +1,105 @@
|
||||||
|
From dc1f8f6b581a8e4efbb782398ab3e7c3a52b062f Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Tue, 8 May 2018 12:13:18 -0600
|
||||||
|
Subject: [PATCH] PATCH: [perl #133185] Infinite loop in qr//
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This loop was inadvertently introduced as part of patches to fix
|
||||||
|
(perl #132227 CVE-2018-6797] heap-buffer-overflow". The commit in 5.27
|
||||||
|
responsible was f8fb8615ddc5a80e3bbd4386a8914497f921b62d.
|
||||||
|
|
||||||
|
To be vulnerable, the pattern must start out as /d (hence no use 5.012
|
||||||
|
or higher), and then there must be something that implicitly forces /u
|
||||||
|
(which the \pp does in the test case added by this patch), and then
|
||||||
|
(?aa), and then the code point \xDF. (German Sharp S). The /i must be
|
||||||
|
in effect by the time the DF is encountered, but it needn't come in the
|
||||||
|
(?aa) which the test does.
|
||||||
|
|
||||||
|
The problem is that the conditional that is testing that we switched
|
||||||
|
away from /d rules is assuming that this happened during the
|
||||||
|
construction of the current EXACTFish node. The comments I wrote
|
||||||
|
indicate this assumption. But this example shows that the switch can
|
||||||
|
come before this node started getting constructed, and so it loops.
|
||||||
|
|
||||||
|
The patch explicitly saves the state at the beginning of this node's
|
||||||
|
construction, and only retries if it changed during that construction.
|
||||||
|
Therefore the next time through, it will see that it hasn't changed
|
||||||
|
since the previous time, and won't loop.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.2 from:
|
||||||
|
|
||||||
|
commit 0b9cb33b146b3eb55634853f883a880771dd1413
|
||||||
|
Author: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Tue May 8 12:13:18 2018 -0600
|
||||||
|
|
||||||
|
PATCH: [perl #133185] Infinite loop in qr//
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 10 +++++++++-
|
||||||
|
t/re/speed.t | 5 ++++-
|
||||||
|
2 files changed, 13 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 845e660..18fa465 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -13100,6 +13100,10 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
bool maybe_exactfu = PASS2
|
||||||
|
&& (node_type == EXACTF || node_type == EXACTFL);
|
||||||
|
|
||||||
|
+ /* To see if RExC_uni_semantics changes during parsing of the node.
|
||||||
|
+ * */
|
||||||
|
+ bool uni_semantics_at_node_start;
|
||||||
|
+
|
||||||
|
/* If a folding node contains only code points that don't
|
||||||
|
* participate in folds, it can be changed into an EXACT node,
|
||||||
|
* which allows the optimizer more things to look for */
|
||||||
|
@@ -13147,6 +13151,8 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
|| UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
|
||||||
|
|| UTF8_IS_START(UCHARAT(RExC_parse)));
|
||||||
|
|
||||||
|
+ uni_semantics_at_node_start = RExC_uni_semantics;
|
||||||
|
+
|
||||||
|
/* Here, we have a literal character. Find the maximal string of
|
||||||
|
* them in the input that we can fit into a single EXACTish node.
|
||||||
|
* We quit at the first non-literal or when the node gets full */
|
||||||
|
@@ -13550,7 +13556,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
* didn't think it needed to reparse. But this
|
||||||
|
* sharp s now does indicate the need for
|
||||||
|
* reparsing. */
|
||||||
|
- if (RExC_uni_semantics) {
|
||||||
|
+ if ( uni_semantics_at_node_start
|
||||||
|
+ != RExC_uni_semantics)
|
||||||
|
+ {
|
||||||
|
p = oldp;
|
||||||
|
goto loopdone;
|
||||||
|
}
|
||||||
|
diff --git a/t/re/speed.t b/t/re/speed.t
|
||||||
|
index 4a4830f..9a57de1 100644
|
||||||
|
--- a/t/re/speed.t
|
||||||
|
+++ b/t/re/speed.t
|
||||||
|
@@ -24,7 +24,7 @@ BEGIN {
|
||||||
|
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
|
||||||
|
skip_all_without_unicode_tables();
|
||||||
|
|
||||||
|
-plan tests => 58; #** update watchdog timeouts proportionally when adding tests
|
||||||
|
+plan tests => 59; #** update watchdog timeouts proportionally when adding tests
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
@@ -156,6 +156,9 @@ PROG
|
||||||
|
ok( $elapsed <= 1, "should not COW on long string with substr and m//g");
|
||||||
|
}
|
||||||
|
|
||||||
|
+ # [perl #133185] Infinite loop
|
||||||
|
+ like("!\xdf", eval 'qr/\pp(?aai)\xdf/',
|
||||||
|
+ 'Compiling qr/\pp(?aai)\xdf/ doesn\'t loop');
|
||||||
|
|
||||||
|
} # End of sub run_tests
|
||||||
|
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
|
@ -10,7 +10,7 @@ diff --git a/Makefile.SH b/Makefile.SH
|
||||||
index 5fc6d1c..e89ad70 100755
|
index 5fc6d1c..e89ad70 100755
|
||||||
--- a/Makefile.SH
|
--- a/Makefile.SH
|
||||||
+++ b/Makefile.SH
|
+++ b/Makefile.SH
|
||||||
@@ -462,6 +462,8 @@ CCCMD = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@
|
@@ -457,6 +457,8 @@ CCCMD = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@
|
||||||
|
|
||||||
CCCMDSRC = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $<
|
CCCMDSRC = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $<
|
||||||
|
|
||||||
|
@ -19,7 +19,7 @@ index 5fc6d1c..e89ad70 100755
|
||||||
CONFIGPM_FROM_CONFIG_SH = lib/Config.pm lib/Config_heavy.pl
|
CONFIGPM_FROM_CONFIG_SH = lib/Config.pm lib/Config_heavy.pl
|
||||||
CONFIGPM = $(CONFIGPM_FROM_CONFIG_SH) lib/Config_git.pl
|
CONFIGPM = $(CONFIGPM_FROM_CONFIG_SH) lib/Config_git.pl
|
||||||
|
|
||||||
@@ -895,19 +897,19 @@ $(DTRACE_MINI_O): perldtrace.d $(miniperl_objs_nodt)
|
@@ -890,19 +892,19 @@ $(DTRACE_MINI_O): perldtrace.d $(miniperl_objs_nodt)
|
||||||
-rm -rf mpdtrace
|
-rm -rf mpdtrace
|
||||||
mkdir mpdtrace
|
mkdir mpdtrace
|
||||||
cp $(miniperl_objs_nodt) mpdtrace/
|
cp $(miniperl_objs_nodt) mpdtrace/
|
||||||
|
@ -46,10 +46,10 @@ diff --git a/cflags.SH b/cflags.SH
|
||||||
index 3af1e97..b845127 100755
|
index 3af1e97..b845127 100755
|
||||||
--- a/cflags.SH
|
--- a/cflags.SH
|
||||||
+++ b/cflags.SH
|
+++ b/cflags.SH
|
||||||
@@ -519,7 +519,10 @@ for file do
|
@@ -516,7 +516,10 @@ for file do
|
||||||
toke) optimize=-O0 ;;
|
|
||||||
esac
|
esac
|
||||||
|
|
||||||
|
# Can we perhaps use $ansi2knr here
|
||||||
- echo "$cc -c -DPERL_CORE $ccflags $stdflags $optimize $warn $extra"
|
- echo "$cc -c -DPERL_CORE $ccflags $stdflags $optimize $warn $extra"
|
||||||
+ case "$file" in
|
+ case "$file" in
|
||||||
+ dtrace_*) echo "$ccflags $stdflags $optimize $warn $extra";;
|
+ dtrace_*) echo "$ccflags $stdflags $optimize $warn $extra";;
|
|
@ -0,0 +1,143 @@
|
||||||
|
From 07ebe9c4fb1028d17e61caabe8c15abd0cd48983 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Thu, 29 Jun 2017 11:31:14 +0200
|
||||||
|
Subject: [PATCH] Parse caret vars with subscripts the same as normal vars
|
||||||
|
inside of ${..} escaping
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This behavior is discussed in perl #131664, which complains that
|
||||||
|
"${^CAPTURE}[0]" does not work as expected. Abigail explains the
|
||||||
|
behavior is by design and Eirik Berg Hanssen expands on that explanation
|
||||||
|
pointing out that what /should/ work, "${^CAPTURE[0]}" does not,
|
||||||
|
which Sawyer then ruled was a bug.
|
||||||
|
|
||||||
|
So this patch makes "${^CAPTURE[0]}" (and "${^CAPTURE [0]}" [hi
|
||||||
|
abigial]) work the same as they would if the var was called @foo.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.2-RC1.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/base/lex.t | 28 +++++++++++++++++++++++++++-
|
||||||
|
toke.c | 46 +++++++++++++++++++++++++---------------------
|
||||||
|
2 files changed, 52 insertions(+), 22 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/base/lex.t b/t/base/lex.t
|
||||||
|
index 99fd3bb..ae17bbd 100644
|
||||||
|
--- a/t/base/lex.t
|
||||||
|
+++ b/t/base/lex.t
|
||||||
|
@@ -1,6 +1,6 @@
|
||||||
|
#!./perl
|
||||||
|
|
||||||
|
-print "1..112\n";
|
||||||
|
+print "1..119\n";
|
||||||
|
|
||||||
|
$x = 'x';
|
||||||
|
|
||||||
|
@@ -154,6 +154,32 @@ my $test = 31;
|
||||||
|
print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1;
|
||||||
|
print "ok $test\n"; $test++;
|
||||||
|
# print "($@)\n" if $@;
|
||||||
|
+#
|
||||||
|
+ ${^TEST}= "splat";
|
||||||
|
+ @{^TEST}= ("foo", "bar");
|
||||||
|
+ %{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST}" ne "splat";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST}[0]" ne "splat[0]";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST[0]}" ne "foo";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${ ^TEST [1] }" ne "bar";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST}{foo}" ne "splat{foo}";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST{foo}}" ne "FOO";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${ ^TEST {bar} }" ne "BAR";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
|
||||||
|
# Now let's make sure that caret variables are all forced into the main package.
|
||||||
|
package Someother;
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index ee9c464..aff785b 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -9416,19 +9416,36 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
|
||||||
|
bool skip;
|
||||||
|
char *s2;
|
||||||
|
/* If we were processing {...} notation then... */
|
||||||
|
- if (isIDFIRST_lazy_if_safe(d, e, is_utf8)) {
|
||||||
|
- /* if it starts as a valid identifier, assume that it is one.
|
||||||
|
- (the later check for } being at the expected point will trap
|
||||||
|
- cases where this doesn't pan out.) */
|
||||||
|
- d += is_utf8 ? UTF8SKIP(d) : 1;
|
||||||
|
- parse_ident(&s, &d, e, 1, is_utf8, TRUE);
|
||||||
|
- *d = '\0';
|
||||||
|
+ if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
|
||||||
|
+ || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
|
||||||
|
+ && isWORDCHAR(*s))
|
||||||
|
+ ) {
|
||||||
|
+ /* note we have to check for a normal identifier first,
|
||||||
|
+ * as it handles utf8 symbols, and only after that has
|
||||||
|
+ * been ruled out can we look at the caret words */
|
||||||
|
+ if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
|
||||||
|
+ /* if it starts as a valid identifier, assume that it is one.
|
||||||
|
+ (the later check for } being at the expected point will trap
|
||||||
|
+ cases where this doesn't pan out.) */
|
||||||
|
+ d += is_utf8 ? UTF8SKIP(d) : 1;
|
||||||
|
+ parse_ident(&s, &d, e, 1, is_utf8, TRUE);
|
||||||
|
+ *d = '\0';
|
||||||
|
+ }
|
||||||
|
+ else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
|
||||||
|
+ d++;
|
||||||
|
+ while (isWORDCHAR(*s) && d < e) {
|
||||||
|
+ *d++ = *s++;
|
||||||
|
+ }
|
||||||
|
+ if (d >= e)
|
||||||
|
+ Perl_croak(aTHX_ "%s", ident_too_long);
|
||||||
|
+ *d = '\0';
|
||||||
|
+ }
|
||||||
|
tmp_copline = CopLINE(PL_curcop);
|
||||||
|
if (s < PL_bufend && isSPACE(*s)) {
|
||||||
|
s = skipspace(s);
|
||||||
|
}
|
||||||
|
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
|
||||||
|
- /* ${foo[0]} and ${foo{bar}} notation. */
|
||||||
|
+ /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
|
||||||
|
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
|
||||||
|
const char * const brack =
|
||||||
|
(const char *)
|
||||||
|
@@ -9447,19 +9464,6 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
|
||||||
|
return s;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
- /* Handle extended ${^Foo} variables
|
||||||
|
- * 1999-02-27 mjd-perl-patch@plover.com */
|
||||||
|
- else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
|
||||||
|
- && isWORDCHAR(*s))
|
||||||
|
- {
|
||||||
|
- d++;
|
||||||
|
- while (isWORDCHAR(*s) && d < e) {
|
||||||
|
- *d++ = *s++;
|
||||||
|
- }
|
||||||
|
- if (d >= e)
|
||||||
|
- Perl_croak(aTHX_ "%s", ident_too_long);
|
||||||
|
- *d = '\0';
|
||||||
|
- }
|
||||||
|
|
||||||
|
if ( !tmp_copline )
|
||||||
|
tmp_copline = CopLINE(PL_curcop);
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
|
@ -0,0 +1,45 @@
|
||||||
|
From edea384e57453b0a62de58445eed1fded18c1cca Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Thu, 29 Jun 2017 13:20:49 +0200
|
||||||
|
Subject: [PATCH] add an additional test for whitespace tolerance in caret
|
||||||
|
word-vars
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.2-RC1.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/base/lex.t | 7 +++++--
|
||||||
|
1 file changed, 5 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/base/lex.t b/t/base/lex.t
|
||||||
|
index ae17bbd..414aa1f 100644
|
||||||
|
--- a/t/base/lex.t
|
||||||
|
+++ b/t/base/lex.t
|
||||||
|
@@ -1,6 +1,6 @@
|
||||||
|
#!./perl
|
||||||
|
|
||||||
|
-print "1..119\n";
|
||||||
|
+print "1..120\n";
|
||||||
|
|
||||||
|
$x = 'x';
|
||||||
|
|
||||||
|
@@ -158,9 +158,12 @@ my $test = 31;
|
||||||
|
${^TEST}= "splat";
|
||||||
|
@{^TEST}= ("foo", "bar");
|
||||||
|
%{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
|
||||||
|
-
|
||||||
|
+
|
||||||
|
print "not " if "${^TEST}" ne "splat";
|
||||||
|
print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${ ^TEST }" ne "splat";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
|
||||||
|
print "not " if "${^TEST}[0]" ne "splat[0]";
|
||||||
|
print "ok $test\n"; $test++;
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
From bee36f5b5aad82c566311cf8785aa67ba3696155 Mon Sep 17 00:00:00 2001
|
From 3e6e57e89f298f450cbe14c61609f08fc01bf233 Mon Sep 17 00:00:00 2001
|
||||||
From: Zefram <zefram@fysh.org>
|
From: Zefram <zefram@fysh.org>
|
||||||
Date: Sat, 16 Dec 2017 05:33:20 +0000
|
Date: Sat, 16 Dec 2017 05:33:20 +0000
|
||||||
Subject: [PATCH] perform system() arg processing before fork
|
Subject: [PATCH] perform system() arg processing before fork
|
||||||
|
@ -14,7 +14,7 @@ $$, and in that case it should also happen in the parent process.
|
||||||
Therefore reduce the argument scalars to strings first thing in pp_system.
|
Therefore reduce the argument scalars to strings first thing in pp_system.
|
||||||
Fixes [perl #121105].
|
Fixes [perl #121105].
|
||||||
|
|
||||||
Petr Písař: Ported to 5.24.4 from
|
Petr Písař: Ported to 5.26.2-RC1 from
|
||||||
64def2aeaeb63f92dadc6dfa33486c1d7b311963.
|
64def2aeaeb63f92dadc6dfa33486c1d7b311963.
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
@ -24,10 +24,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
2 files changed, 24 insertions(+), 7 deletions(-)
|
2 files changed, 24 insertions(+), 7 deletions(-)
|
||||||
|
|
||||||
diff --git a/pp_sys.c b/pp_sys.c
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
index 2fcc219..4ce8540 100644
|
index 87961f1..07e552a 100644
|
||||||
--- a/pp_sys.c
|
--- a/pp_sys.c
|
||||||
+++ b/pp_sys.c
|
+++ b/pp_sys.c
|
||||||
@@ -4343,14 +4343,18 @@ PP(pp_system)
|
@@ -4375,14 +4375,18 @@ PP(pp_system)
|
||||||
int result;
|
int result;
|
||||||
# endif
|
# endif
|
||||||
|
|
||||||
|
@ -53,19 +53,19 @@ index 2fcc219..4ce8540 100644
|
||||||
}
|
}
|
||||||
PERL_FLUSHALL_FOR_CHILD;
|
PERL_FLUSHALL_FOR_CHILD;
|
||||||
diff --git a/t/op/exec.t b/t/op/exec.t
|
diff --git a/t/op/exec.t b/t/op/exec.t
|
||||||
index 726f548..e43dd6e 100644
|
index 237388b..e29de82 100644
|
||||||
--- a/t/op/exec.t
|
--- a/t/op/exec.t
|
||||||
+++ b/t/op/exec.t
|
+++ b/t/op/exec.t
|
||||||
@@ -36,7 +36,7 @@ $ENV{LANGUAGE} = 'C'; # Ditto in GNU.
|
@@ -36,7 +36,7 @@ $ENV{LANGUAGE} = 'C'; # Ditto in GNU.
|
||||||
my $Is_VMS = $^O eq 'VMS';
|
my $Is_VMS = $^O eq 'VMS';
|
||||||
my $Is_Win32 = $^O eq 'MSWin32';
|
my $Is_Win32 = $^O eq 'MSWin32';
|
||||||
|
|
||||||
-plan(tests => 33);
|
-plan(tests => 34);
|
||||||
+plan(tests => 36);
|
+plan(tests => 37);
|
||||||
|
|
||||||
my $Perl = which_perl();
|
my $Perl = which_perl();
|
||||||
|
|
||||||
@@ -173,6 +173,19 @@ TODO: {
|
@@ -177,6 +177,19 @@ TODO: {
|
||||||
"exec failure doesn't terminate process");
|
"exec failure doesn't terminate process");
|
||||||
}
|
}
|
||||||
|
|
|
@ -0,0 +1,35 @@
|
||||||
|
From 7714b11d11da2bfd0dc11638e9dd6836b6a32e90 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Mon, 11 Jun 2018 13:26:24 -0600
|
||||||
|
Subject: [PATCH] perl.h: Add parens around macro arguments
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Arguments used within macros need to be parenthesized in case they are
|
||||||
|
called with an expression. This commit changes
|
||||||
|
_CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG() to do that.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.2 from upstream ff58ca57f844 commit.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
perl.h | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/perl.h b/perl.h
|
||||||
|
index 1c613bc..d278c2a 100644
|
||||||
|
--- a/perl.h
|
||||||
|
+++ b/perl.h
|
||||||
|
@@ -5980,7 +5980,7 @@ typedef struct am_table_short AMTS;
|
||||||
|
# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \
|
||||||
|
STMT_START { /* Check if to warn before doing the conversion work */\
|
||||||
|
if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \
|
||||||
|
- UV cp = utf8_to_uvchr_buf((U8 *) s, (U8 *) send, NULL); \
|
||||||
|
+ UV cp = utf8_to_uvchr_buf((U8 *) (s), (U8 *) (send), NULL); \
|
||||||
|
Perl_warner(aTHX_ packWARN(WARN_LOCALE), \
|
||||||
|
"Wide character (U+%" UVXf ") in %s", \
|
||||||
|
(cp == 0) \
|
||||||
|
--
|
||||||
|
2.14.4
|
||||||
|
|
|
@ -0,0 +1,34 @@
|
||||||
|
From 208dea486fa24081cbc0cf05fa5a15c802e2bc68 Mon Sep 17 00:00:00 2001
|
||||||
|
From: John Lightsey <jd@cpanel.net>
|
||||||
|
Date: Wed, 20 Nov 2019 20:02:45 -0600
|
||||||
|
Subject: [PATCH v528 1/3] regcomp.c: Prevent integer overflow from nested
|
||||||
|
regex quantifiers.
|
||||||
|
|
||||||
|
(CVE-2020-10543) On 32bit systems the size calculations for nested regular
|
||||||
|
expression quantifiers could overflow causing heap memory corruption.
|
||||||
|
|
||||||
|
Fixes: Perl/perl5-security#125
|
||||||
|
---
|
||||||
|
regcomp.c | 6 ++++++
|
||||||
|
1 file changed, 6 insertions(+)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index e1da15a77c..dd18add1db 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -5102,6 +5139,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
(void)ReREFCNT_inc(RExC_rx_sv);
|
||||||
|
}
|
||||||
|
|
||||||
|
+ if ( ( minnext > 0 && mincount >= SSize_t_MAX / minnext )
|
||||||
|
+ || min >= SSize_t_MAX - minnext * mincount )
|
||||||
|
+ {
|
||||||
|
+ FAIL("Regexp out of space");
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
min += minnext * mincount;
|
||||||
|
is_inf_internal |= deltanext == SSize_t_MAX
|
||||||
|
|| (maxcount == REG_INFTY && minnext + deltanext > 0);
|
||||||
|
--
|
||||||
|
2.20.1
|
||||||
|
|
|
@ -0,0 +1,148 @@
|
||||||
|
From a3a7598c8ec6efb0eb9c0b786d80c4d2a3751b70 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Tue, 18 Feb 2020 13:51:16 +0000
|
||||||
|
Subject: [PATCH v528 2/3] study_chunk: extract rck_elide_nothing
|
||||||
|
|
||||||
|
(CVE-2020-10878)
|
||||||
|
---
|
||||||
|
embed.fnc | 1 +
|
||||||
|
embed.h | 1 +
|
||||||
|
proto.h | 3 +++
|
||||||
|
regcomp.c | 70 ++++++++++++++++++++++++++++++++++---------------------
|
||||||
|
4 files changed, 48 insertions(+), 27 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/embed.fnc b/embed.fnc
|
||||||
|
index e762fe1eec..cf89277163 100644
|
||||||
|
--- a/embed.fnc
|
||||||
|
+++ b/embed.fnc
|
||||||
|
@@ -2398,6 +2398,7 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|
||||||
|
|I32 stopparen|U32 recursed_depth \
|
||||||
|
|NULLOK regnode_ssc *and_withp \
|
||||||
|
|U32 flags|U32 depth|bool was_mutate_ok
|
||||||
|
+Es |void |rck_elide_nothing|NN regnode *node
|
||||||
|
EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
|
||||||
|
|NN const char* const s|const U32 n
|
||||||
|
rs |void |re_croak2 |bool utf8|NN const char* pat1|NN const char* pat2|...
|
||||||
|
diff --git a/embed.h b/embed.h
|
||||||
|
index a5416a1148..886551ce5c 100644
|
||||||
|
--- a/embed.h
|
||||||
|
+++ b/embed.h
|
||||||
|
@@ -1046,6 +1046,7 @@
|
||||||
|
#define output_or_return_posix_warnings(a,b,c) S_output_or_return_posix_warnings(aTHX_ a,b,c)
|
||||||
|
#define parse_lparen_question_flags(a) S_parse_lparen_question_flags(aTHX_ a)
|
||||||
|
#define populate_ANYOF_from_invlist(a,b) S_populate_ANYOF_from_invlist(aTHX_ a,b)
|
||||||
|
+#define rck_elide_nothing(a) S_rck_elide_nothing(aTHX_ a)
|
||||||
|
#define reg(a,b,c,d) S_reg(aTHX_ a,b,c,d)
|
||||||
|
#define reg2Lanode(a,b,c,d) S_reg2Lanode(aTHX_ a,b,c,d)
|
||||||
|
#define reg_node(a,b) S_reg_node(aTHX_ a,b)
|
||||||
|
diff --git a/proto.h b/proto.h
|
||||||
|
index 66bb29b132..d3f8802c1d 100644
|
||||||
|
--- a/proto.h
|
||||||
|
+++ b/proto.h
|
||||||
|
@@ -5150,6 +5150,9 @@ STATIC void S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state);
|
||||||
|
STATIC void S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr);
|
||||||
|
#define PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST \
|
||||||
|
assert(node); assert(invlist_ptr)
|
||||||
|
+STATIC void S_rck_elide_nothing(pTHX_ regnode *node);
|
||||||
|
+#define PERL_ARGS_ASSERT_RCK_ELIDE_NOTHING \
|
||||||
|
+ assert(node)
|
||||||
|
PERL_STATIC_NO_RET void S_re_croak2(pTHX_ bool utf8, const char* pat1, const char* pat2, ...)
|
||||||
|
__attribute__noreturn__;
|
||||||
|
#define PERL_ARGS_ASSERT_RE_CROAK2 \
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index dd18add1db..0a9c6a8085 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -4094,6 +4094,43 @@ S_unwind_scan_frames(pTHX_ const void *p)
|
||||||
|
} while (f);
|
||||||
|
}
|
||||||
|
|
||||||
|
+/* Follow the next-chain of the current node and optimize away
|
||||||
|
+ all the NOTHINGs from it.
|
||||||
|
+ */
|
||||||
|
+STATIC void
|
||||||
|
+S_rck_elide_nothing(pTHX_ regnode *node)
|
||||||
|
+{
|
||||||
|
+ dVAR;
|
||||||
|
+
|
||||||
|
+ PERL_ARGS_ASSERT_RCK_ELIDE_NOTHING;
|
||||||
|
+
|
||||||
|
+ if (OP(node) != CURLYX) {
|
||||||
|
+ const int max = (reg_off_by_arg[OP(node)]
|
||||||
|
+ ? I32_MAX
|
||||||
|
+ /* I32 may be smaller than U16 on CRAYs! */
|
||||||
|
+ : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
|
||||||
|
+ int off = (reg_off_by_arg[OP(node)] ? ARG(node) : NEXT_OFF(node));
|
||||||
|
+ int noff;
|
||||||
|
+ regnode *n = node;
|
||||||
|
+
|
||||||
|
+ /* Skip NOTHING and LONGJMP. */
|
||||||
|
+ while (
|
||||||
|
+ (n = regnext(n))
|
||||||
|
+ && (
|
||||||
|
+ (PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
|
||||||
|
+ || ((OP(n) == LONGJMP) && (noff = ARG(n)))
|
||||||
|
+ )
|
||||||
|
+ && off + noff < max
|
||||||
|
+ ) {
|
||||||
|
+ off += noff;
|
||||||
|
+ }
|
||||||
|
+ if (reg_off_by_arg[OP(node)])
|
||||||
|
+ ARG(node) = off;
|
||||||
|
+ else
|
||||||
|
+ NEXT_OFF(node) = off;
|
||||||
|
+ }
|
||||||
|
+ return;
|
||||||
|
+}
|
||||||
|
|
||||||
|
STATIC SSize_t
|
||||||
|
S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
@@ -4197,28 +4234,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
if (mutate_ok)
|
||||||
|
JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
|
||||||
|
|
||||||
|
- /* Follow the next-chain of the current node and optimize
|
||||||
|
- away all the NOTHINGs from it. */
|
||||||
|
- if (OP(scan) != CURLYX) {
|
||||||
|
- const int max = (reg_off_by_arg[OP(scan)]
|
||||||
|
- ? I32_MAX
|
||||||
|
- /* I32 may be smaller than U16 on CRAYs! */
|
||||||
|
- : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
|
||||||
|
- int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
|
||||||
|
- int noff;
|
||||||
|
- regnode *n = scan;
|
||||||
|
-
|
||||||
|
- /* Skip NOTHING and LONGJMP. */
|
||||||
|
- while ((n = regnext(n))
|
||||||
|
- && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
|
||||||
|
- || ((OP(n) == LONGJMP) && (noff = ARG(n))))
|
||||||
|
- && off + noff < max)
|
||||||
|
- off += noff;
|
||||||
|
- if (reg_off_by_arg[OP(scan)])
|
||||||
|
- ARG(scan) = off;
|
||||||
|
- else
|
||||||
|
- NEXT_OFF(scan) = off;
|
||||||
|
- }
|
||||||
|
+ /* Follow the next-chain of the current node and optimize
|
||||||
|
+ away all the NOTHINGs from it.
|
||||||
|
+ */
|
||||||
|
+ rck_elide_nothing(scan);
|
||||||
|
|
||||||
|
/* The principal pseudo-switch. Cannot be a switch, since we
|
||||||
|
look into several different things. */
|
||||||
|
@@ -5348,11 +5367,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||||
|
if (data && (fl & SF_HAS_EVAL))
|
||||||
|
data->flags |= SF_HAS_EVAL;
|
||||||
|
optimize_curly_tail:
|
||||||
|
- if (OP(oscan) != CURLYX) {
|
||||||
|
- while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
|
||||||
|
- && NEXT_OFF(next))
|
||||||
|
- NEXT_OFF(oscan) += NEXT_OFF(next);
|
||||||
|
- }
|
||||||
|
+ rck_elide_nothing(oscan);
|
||||||
|
continue;
|
||||||
|
|
||||||
|
default:
|
||||||
|
--
|
||||||
|
2.20.1
|
||||||
|
|
|
@ -0,0 +1,279 @@
|
||||||
|
From c031e3ec7c713077659f5f7dc6638d926c69d7b2 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Sat, 11 Apr 2020 14:10:24 +0100
|
||||||
|
Subject: [PATCH v528 3/3] study_chunk: avoid mutating regexp program within
|
||||||
|
GOSUB
|
||||||
|
|
||||||
|
gh16947 and gh17743: studying GOSUB may restudy in an inner call
|
||||||
|
(via a mix of recursion and enframing) something that an outer call
|
||||||
|
is in the middle of looking at. Let the outer frame deal with it.
|
||||||
|
|
||||||
|
(CVE-2020-12723)
|
||||||
|
---
|
||||||
|
embed.fnc | 2 +-
|
||||||
|
embed.h | 2 +-
|
||||||
|
proto.h | 2 +-
|
||||||
|
regcomp.c | 48 ++++++++++++++++++++++++++++++++----------------
|
||||||
|
t/re/pat.t | 26 +++++++++++++++++++++++++-
|
||||||
|
5 files changed, 60 insertions(+), 20 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/embed.fnc b/embed.fnc
|
||||||
|
index cf89277163..4b1ba28277 100644
|
||||||
|
--- a/embed.fnc
|
||||||
|
+++ b/embed.fnc
|
||||||
|
@@ -2397,7 +2397,7 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|
||||||
|
|NULLOK struct scan_data_t *data \
|
||||||
|
|I32 stopparen|U32 recursed_depth \
|
||||||
|
|NULLOK regnode_ssc *and_withp \
|
||||||
|
- |U32 flags|U32 depth
|
||||||
|
+ |U32 flags|U32 depth|bool was_mutate_ok
|
||||||
|
EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
|
||||||
|
|NN const char* const s|const U32 n
|
||||||
|
rs |void |re_croak2 |bool utf8|NN const char* pat1|NN const char* pat2|...
|
||||||
|
diff --git a/embed.h b/embed.h
|
||||||
|
index 886551ce5c..50fcabc140 100644
|
||||||
|
--- a/embed.h
|
||||||
|
+++ b/embed.h
|
||||||
|
@@ -1075,7 +1075,7 @@
|
||||||
|
#define ssc_is_cp_posixl_init S_ssc_is_cp_posixl_init
|
||||||
|
#define ssc_or(a,b,c) S_ssc_or(aTHX_ a,b,c)
|
||||||
|
#define ssc_union(a,b,c) S_ssc_union(aTHX_ a,b,c)
|
||||||
|
-#define study_chunk(a,b,c,d,e,f,g,h,i,j,k) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k)
|
||||||
|
+#define study_chunk(a,b,c,d,e,f,g,h,i,j,k,l) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k,l)
|
||||||
|
# endif
|
||||||
|
# if defined(PERL_IN_REGCOMP_C) || defined (PERL_IN_DUMP_C)
|
||||||
|
#define _invlist_dump(a,b,c,d) Perl__invlist_dump(aTHX_ a,b,c,d)
|
||||||
|
diff --git a/proto.h b/proto.h
|
||||||
|
index d3f8802c1d..e276f69bd1 100644
|
||||||
|
--- a/proto.h
|
||||||
|
+++ b/proto.h
|
||||||
|
@@ -5258,7 +5258,7 @@ PERL_STATIC_INLINE void S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, c
|
||||||
|
#define PERL_ARGS_ASSERT_SSC_UNION \
|
||||||
|
assert(ssc); assert(invlist)
|
||||||
|
#endif
|
||||||
|
-STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U32 recursed_depth, regnode_ssc *and_withp, U32 flags, U32 depth);
|
||||||
|
+STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U32 recursed_depth, regnode_ssc *and_withp, U32 flags, U32 depth, bool was_mutate_ok);
|
||||||
|
#define PERL_ARGS_ASSERT_STUDY_CHUNK \
|
||||||
|
assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last)
|
||||||
|
#endif
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 0a9c6a8085..e66032a16a 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -110,6 +110,7 @@ typedef struct scan_frame {
|
||||||
|
regnode *next_regnode; /* next node to process when last is reached */
|
||||||
|
U32 prev_recursed_depth;
|
||||||
|
I32 stopparen; /* what stopparen do we use */
|
||||||
|
+ bool in_gosub; /* this or an outer frame is for GOSUB */
|
||||||
|
U32 is_top_frame; /* what flags do we use? */
|
||||||
|
|
||||||
|
struct scan_frame *this_prev_frame; /* this previous frame */
|
||||||
|
@@ -4102,7 +4103,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
I32 stopparen,
|
||||||
|
U32 recursed_depth,
|
||||||
|
regnode_ssc *and_withp,
|
||||||
|
- U32 flags, U32 depth)
|
||||||
|
+ U32 flags, U32 depth, bool was_mutate_ok)
|
||||||
|
/* scanp: Start here (read-write). */
|
||||||
|
/* deltap: Write maxlen-minlen here. */
|
||||||
|
/* last: Stop before this one. */
|
||||||
|
@@ -4179,6 +4180,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
node length to get a real minimum (because
|
||||||
|
the folded version may be shorter) */
|
||||||
|
bool unfolded_multi_char = FALSE;
|
||||||
|
+ /* avoid mutating ops if we are anywhere within the recursed or
|
||||||
|
+ * enframed handling for a GOSUB: the outermost level will handle it.
|
||||||
|
+ */
|
||||||
|
+ bool mutate_ok = was_mutate_ok && !(frame && frame->in_gosub);
|
||||||
|
/* Peephole optimizer: */
|
||||||
|
DEBUG_STUDYDATA("Peep:", data, depth);
|
||||||
|
DEBUG_PEEP("Peep", scan, depth);
|
||||||
|
@@ -4189,7 +4194,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
* parsing code, as each (?:..) is handled by a different invocation of
|
||||||
|
* reg() -- Yves
|
||||||
|
*/
|
||||||
|
- JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
|
||||||
|
+ if (mutate_ok)
|
||||||
|
+ JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
|
||||||
|
|
||||||
|
/* Follow the next-chain of the current node and optimize
|
||||||
|
away all the NOTHINGs from it. */
|
||||||
|
@@ -4238,7 +4244,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
* NOTE we dont use the return here! */
|
||||||
|
(void)study_chunk(pRExC_state, &scan, &minlen,
|
||||||
|
&deltanext, next, &data_fake, stopparen,
|
||||||
|
- recursed_depth, NULL, f, depth+1);
|
||||||
|
+ recursed_depth, NULL, f, depth+1, mutate_ok);
|
||||||
|
|
||||||
|
scan = next;
|
||||||
|
} else
|
||||||
|
@@ -4305,7 +4311,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
/* we suppose the run is continuous, last=next...*/
|
||||||
|
minnext = study_chunk(pRExC_state, &scan, minlenp,
|
||||||
|
&deltanext, next, &data_fake, stopparen,
|
||||||
|
- recursed_depth, NULL, f,depth+1);
|
||||||
|
+ recursed_depth, NULL, f, depth+1,
|
||||||
|
+ mutate_ok);
|
||||||
|
|
||||||
|
if (min1 > minnext)
|
||||||
|
min1 = minnext;
|
||||||
|
@@ -4372,9 +4379,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
- if (PERL_ENABLE_TRIE_OPTIMISATION &&
|
||||||
|
- OP( startbranch ) == BRANCH )
|
||||||
|
- {
|
||||||
|
+ if (PERL_ENABLE_TRIE_OPTIMISATION
|
||||||
|
+ && OP(startbranch) == BRANCH
|
||||||
|
+ && mutate_ok
|
||||||
|
+ ) {
|
||||||
|
/* demq.
|
||||||
|
|
||||||
|
Assuming this was/is a branch we are dealing with: 'scan'
|
||||||
|
@@ -4825,6 +4833,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
newframe->stopparen = stopparen;
|
||||||
|
newframe->prev_recursed_depth = recursed_depth;
|
||||||
|
newframe->this_prev_frame= frame;
|
||||||
|
+ newframe->in_gosub = (
|
||||||
|
+ (frame && frame->in_gosub) || OP(scan) == GOSUB
|
||||||
|
+ );
|
||||||
|
|
||||||
|
DEBUG_STUDYDATA("frame-new:",data,depth);
|
||||||
|
DEBUG_PEEP("fnew", scan, depth);
|
||||||
|
@@ -5043,7 +5054,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
(mincount == 0
|
||||||
|
? (f & ~SCF_DO_SUBSTR)
|
||||||
|
: f)
|
||||||
|
- ,depth+1);
|
||||||
|
+ , depth+1, mutate_ok);
|
||||||
|
|
||||||
|
if (flags & SCF_DO_STCLASS)
|
||||||
|
data->start_class = oclass;
|
||||||
|
@@ -5105,7 +5116,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
if ( OP(oscan) == CURLYX && data
|
||||||
|
&& data->flags & SF_IN_PAR
|
||||||
|
&& !(data->flags & SF_HAS_EVAL)
|
||||||
|
- && !deltanext && minnext == 1 ) {
|
||||||
|
+ && !deltanext && minnext == 1
|
||||||
|
+ && mutate_ok
|
||||||
|
+ ) {
|
||||||
|
/* Try to optimize to CURLYN. */
|
||||||
|
regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
|
||||||
|
regnode * const nxt1 = nxt;
|
||||||
|
@@ -5151,10 +5164,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
&& !(data->flags & SF_HAS_EVAL)
|
||||||
|
&& !deltanext /* atom is fixed width */
|
||||||
|
&& minnext != 0 /* CURLYM can't handle zero width */
|
||||||
|
-
|
||||||
|
/* Nor characters whose fold at run-time may be
|
||||||
|
* multi-character */
|
||||||
|
&& ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
|
||||||
|
+ && mutate_ok
|
||||||
|
) {
|
||||||
|
/* XXXX How to optimize if data == 0? */
|
||||||
|
/* Optimize to a simpler form. */
|
||||||
|
@@ -5201,7 +5214,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
#endif
|
||||||
|
/* Optimize again: */
|
||||||
|
study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
|
||||||
|
- NULL, stopparen, recursed_depth, NULL, 0,depth+1);
|
||||||
|
+ NULL, stopparen, recursed_depth, NULL, 0,
|
||||||
|
+ depth+1, mutate_ok);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
oscan->flags = 0;
|
||||||
|
@@ -5592,7 +5606,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||||
|
nscan = NEXTOPER(NEXTOPER(scan));
|
||||||
|
minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
|
||||||
|
last, &data_fake, stopparen,
|
||||||
|
- recursed_depth, NULL, f, depth+1);
|
||||||
|
+ recursed_depth, NULL, f, depth+1,
|
||||||
|
+ mutate_ok);
|
||||||
|
if (scan->flags) {
|
||||||
|
if (deltanext) {
|
||||||
|
FAIL("Variable length lookbehind not implemented");
|
||||||
|
@@ -5681,7 +5696,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||||
|
*minnextp = study_chunk(pRExC_state, &nscan, minnextp,
|
||||||
|
&deltanext, last, &data_fake,
|
||||||
|
stopparen, recursed_depth, NULL,
|
||||||
|
- f,depth+1);
|
||||||
|
+ f, depth+1, mutate_ok);
|
||||||
|
if (scan->flags) {
|
||||||
|
if (deltanext) {
|
||||||
|
FAIL("Variable length lookbehind not implemented");
|
||||||
|
@@ -5841,7 +5856,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||||
|
branches even though they arent otherwise used. */
|
||||||
|
minnext = study_chunk(pRExC_state, &scan, minlenp,
|
||||||
|
&deltanext, (regnode *)nextbranch, &data_fake,
|
||||||
|
- stopparen, recursed_depth, NULL, f,depth+1);
|
||||||
|
+ stopparen, recursed_depth, NULL, f, depth+1,
|
||||||
|
+ mutate_ok);
|
||||||
|
}
|
||||||
|
if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
|
||||||
|
nextbranch= regnext((regnode*)nextbranch);
|
||||||
|
@@ -7524,7 +7540,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
|
||||||
|
&data, -1, 0, NULL,
|
||||||
|
SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
|
||||||
|
| (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
|
||||||
|
- 0);
|
||||||
|
+ 0, TRUE);
|
||||||
|
|
||||||
|
|
||||||
|
CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
|
||||||
|
@@ -7670,7 +7686,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
|
||||||
|
SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
|
||||||
|
? SCF_TRIE_DOING_RESTUDY
|
||||||
|
: 0),
|
||||||
|
- 0);
|
||||||
|
+ 0, TRUE);
|
||||||
|
|
||||||
|
CHECK_RESTUDY_GOTO_butfirst(NOOP);
|
||||||
|
|
||||||
|
diff --git a/t/re/pat.t b/t/re/pat.t
|
||||||
|
index 1d98fe77d7..1488259b02 100644
|
||||||
|
--- a/t/re/pat.t
|
||||||
|
+++ b/t/re/pat.t
|
||||||
|
@@ -23,7 +23,7 @@ BEGIN {
|
||||||
|
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
|
||||||
|
skip_all_without_unicode_tables();
|
||||||
|
|
||||||
|
-plan tests => 840; # Update this when adding/deleting tests.
|
||||||
|
+plan tests => 844; # Update this when adding/deleting tests.
|
||||||
|
|
||||||
|
run_tests() unless caller;
|
||||||
|
|
||||||
|
@@ -1929,6 +1929,30 @@ EOP
|
||||||
|
fresh_perl_is('"AA" =~ m/AA{1,0}/','',{},"handle OPFAIL insert properly");
|
||||||
|
}
|
||||||
|
|
||||||
|
+ # gh16947: test regexp corruption (GOSUB)
|
||||||
|
+ {
|
||||||
|
+ fresh_perl_is(q{
|
||||||
|
+ 'xy' =~ /x(?0)|x(?|y|y)/ && print 'ok'
|
||||||
|
+ }, 'ok', {}, 'gh16947: test regexp corruption (GOSUB)');
|
||||||
|
+ }
|
||||||
|
+ # gh16947: test fix doesn't break SUSPEND
|
||||||
|
+ {
|
||||||
|
+ fresh_perl_is(q{ 'sx' =~ m{ss++}i; print 'ok' },
|
||||||
|
+ 'ok', {}, "gh16947: test fix doesn't break SUSPEND");
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+ # gh17743: more regexp corruption via GOSUB
|
||||||
|
+ {
|
||||||
|
+ fresh_perl_is(q{
|
||||||
|
+ "0" =~ /((0(?0)|000(?|0000|0000)(?0))|)/; print "ok"
|
||||||
|
+ }, 'ok', {}, 'gh17743: test regexp corruption (1)');
|
||||||
|
+
|
||||||
|
+ fresh_perl_is(q{
|
||||||
|
+ "000000000000" =~ /(0(())(0((?0)())|000(?|\x{ef}\x{bf}\x{bd}|\x{ef}\x{bf}\x{bd}))|)/;
|
||||||
|
+ print "ok"
|
||||||
|
+ }, 'ok', {}, 'gh17743: test regexp corruption (2)');
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
} # End of sub run_tests
|
||||||
|
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
2.20.1
|
||||||
|
|
|
@ -0,0 +1,62 @@
|
||||||
|
From 47d2c70bde8c0bdc67e85578133338fc63c33f13 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Jitka Plesnikova <jplesnik@redhat.com>
|
||||||
|
Date: Thu, 17 Jun 2021 11:41:48 +0200
|
||||||
|
Subject: [PATCH 2/2] Fix _resolv return value
|
||||||
|
|
||||||
|
in case of the new warnings.
|
||||||
|
Thanks to @nlv02636
|
||||||
|
|
||||||
|
Backported fromn Net-Ping 2.68
|
||||||
|
---
|
||||||
|
dist/Net-Ping/lib/Net/Ping.pm | 8 +++++++-
|
||||||
|
1 file changed, 7 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm
|
||||||
|
index 9e2497c..87087fc 100644
|
||||||
|
--- a/dist/Net-Ping/lib/Net/Ping.pm
|
||||||
|
+++ b/dist/Net-Ping/lib/Net/Ping.pm
|
||||||
|
@@ -1794,6 +1794,7 @@ sub _resolv {
|
||||||
|
# Clean up port
|
||||||
|
if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) {
|
||||||
|
croak("Invalid port `$h{port}' in `$name'");
|
||||||
|
+ return undef;
|
||||||
|
}
|
||||||
|
# END - host:port
|
||||||
|
|
||||||
|
@@ -1850,18 +1851,21 @@ sub _resolv {
|
||||||
|
} else {
|
||||||
|
(undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
|
||||||
|
}
|
||||||
|
- return \%h
|
||||||
|
+ return \%h;
|
||||||
|
} else {
|
||||||
|
carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
|
||||||
|
+ return undef;
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
|
||||||
|
$family == AF_INET ? "AF_INET" : "AF_INET6"));
|
||||||
|
+ return undef;
|
||||||
|
}
|
||||||
|
# old way
|
||||||
|
} else {
|
||||||
|
if ($family == $AF_INET6) {
|
||||||
|
croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION");
|
||||||
|
+ return undef;
|
||||||
|
}
|
||||||
|
|
||||||
|
my @gethost = gethostbyname($h{host});
|
||||||
|
@@ -1872,8 +1876,10 @@ sub _resolv {
|
||||||
|
return \%h
|
||||||
|
} else {
|
||||||
|
carp("gethostbyname($h{host}) failed - $^E");
|
||||||
|
+ return undef;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
+ return undef;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _pack_sockaddr_in($$) {
|
||||||
|
--
|
||||||
|
2.31.1
|
||||||
|
|
|
@ -0,0 +1,99 @@
|
||||||
|
From 5a3f94a3f0e21d8e685ede4e851a318578a2151f Mon Sep 17 00:00:00 2001
|
||||||
|
From: Jitka Plesnikova <jplesnik@redhat.com>
|
||||||
|
Date: Thu, 17 Jun 2021 11:12:30 +0200
|
||||||
|
Subject: [PATCH 1/2] carp, not croak on most name lookup failures
|
||||||
|
|
||||||
|
See RT #124830, a regression.
|
||||||
|
Return undef instead.
|
||||||
|
|
||||||
|
Backported from Net-Ping 2.67
|
||||||
|
---
|
||||||
|
dist/Net-Ping/lib/Net/Ping.pm | 24 ++++++++++++------------
|
||||||
|
1 file changed, 12 insertions(+), 12 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm
|
||||||
|
index 13cbe81..9e2497c 100644
|
||||||
|
--- a/dist/Net-Ping/lib/Net/Ping.pm
|
||||||
|
+++ b/dist/Net-Ping/lib/Net/Ping.pm
|
||||||
|
@@ -144,7 +144,7 @@ sub new
|
||||||
|
if ($self->{'host'}) {
|
||||||
|
my $host = $self->{'host'};
|
||||||
|
my $ip = _resolv($host)
|
||||||
|
- or croak("could not resolve host $host");
|
||||||
|
+ or carp("could not resolve host $host");
|
||||||
|
$self->{host} = $ip;
|
||||||
|
$self->{family} = $ip->{family};
|
||||||
|
}
|
||||||
|
@@ -152,7 +152,7 @@ sub new
|
||||||
|
if ($self->{bind}) {
|
||||||
|
my $addr = $self->{bind};
|
||||||
|
my $ip = _resolv($addr)
|
||||||
|
- or croak("could not resolve local addr $addr");
|
||||||
|
+ or carp("could not resolve local addr $addr");
|
||||||
|
$self->{local_addr} = $ip;
|
||||||
|
} else {
|
||||||
|
$self->{local_addr} = undef; # Don't bind by default
|
||||||
|
@@ -323,7 +323,7 @@ sub bind
|
||||||
|
($self->{proto} eq "udp" || $self->{proto} eq "icmp");
|
||||||
|
|
||||||
|
$ip = $self->_resolv($local_addr);
|
||||||
|
- croak("nonexistent local address $local_addr") unless defined($ip);
|
||||||
|
+ carp("nonexistent local address $local_addr") unless defined($ip);
|
||||||
|
$self->{local_addr} = $ip;
|
||||||
|
|
||||||
|
if (($self->{proto} ne "udp") &&
|
||||||
|
@@ -1129,13 +1129,14 @@ sub open
|
||||||
|
$self->{family_local} = $self->{family};
|
||||||
|
}
|
||||||
|
|
||||||
|
- $ip = $self->_resolv($host);
|
||||||
|
$timeout = $self->{timeout} unless $timeout;
|
||||||
|
+ $ip = $self->_resolv($host);
|
||||||
|
|
||||||
|
- if($self->{proto} eq "stream") {
|
||||||
|
- if(defined($self->{fh}->fileno())) {
|
||||||
|
+ if ($self->{proto} eq "stream") {
|
||||||
|
+ if (defined($self->{fh}->fileno())) {
|
||||||
|
croak("socket is already open");
|
||||||
|
} else {
|
||||||
|
+ return () unless $ip;
|
||||||
|
$self->tcp_connect($ip, $timeout);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
@@ -1851,12 +1852,11 @@ sub _resolv {
|
||||||
|
}
|
||||||
|
return \%h
|
||||||
|
} else {
|
||||||
|
- croak("getnameinfo($getaddr[0]->{addr}) failed - $err");
|
||||||
|
+ carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
- my $error = sprintf "getaddrinfo($h{host},,%s) failed - $err",
|
||||||
|
- ($family == AF_INET) ? "AF_INET" : "AF_INET6";
|
||||||
|
- croak("$error");
|
||||||
|
+ warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
|
||||||
|
+ $family == AF_INET ? "AF_INET" : "AF_INET6"));
|
||||||
|
}
|
||||||
|
# old way
|
||||||
|
} else {
|
||||||
|
@@ -1871,7 +1871,7 @@ sub _resolv {
|
||||||
|
$h{family} = AF_INET;
|
||||||
|
return \%h
|
||||||
|
} else {
|
||||||
|
- croak("gethostbyname($h{host}) failed - $^E");
|
||||||
|
+ carp("gethostbyname($h{host}) failed - $^E");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
@@ -1913,7 +1913,7 @@ sub _inet_ntoa {
|
||||||
|
if (defined($address)) {
|
||||||
|
$ret = $address;
|
||||||
|
} else {
|
||||||
|
- croak("getnameinfo($addr) failed - $err");
|
||||||
|
+ carp("getnameinfo($addr) failed - $err");
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
$ret = inet_ntoa($addr)
|
||||||
|
--
|
||||||
|
2.31.1
|
||||||
|
|
|
@ -1,30 +1,22 @@
|
||||||
From 30cba075ecbb662b392b2c6e896dec287ea49aa8 Mon Sep 17 00:00:00 2001
|
From 0db967b2e6a4093a6a5f649190159767e5d005e0 Mon Sep 17 00:00:00 2001
|
||||||
From: Yves Orton <demerphq@gmail.com>
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
Date: Tue, 25 Apr 2017 15:17:06 +0200
|
Date: Tue, 25 Apr 2017 15:17:06 +0200
|
||||||
Subject: [PATCH] fixup File::Glob degenerate matching
|
Subject: [PATCH] [perl #131211] fixup File::Glob degenerate matching
|
||||||
MIME-Version: 1.0
|
MIME-Version: 1.0
|
||||||
Content-Type: text/plain; charset=UTF-8
|
Content-Type: text/plain; charset=UTF-8
|
||||||
Content-Transfer-Encoding: 8bit
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
Ported to 5.24.1:
|
The old code would go quadratic with recursion and backtracking
|
||||||
|
when doing patterns like "a*a*a*a*a*a*a*x" on a file like
|
||||||
|
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa".
|
||||||
|
|
||||||
commit 0db967b2e6a4093a6a5f649190159767e5d005e0
|
This patch changes the code to not recurse, and to not backtrack,
|
||||||
Author: Yves Orton <demerphq@gmail.com>
|
as per this article from Russ Cox: https://research.swtch.com/glob
|
||||||
Date: Tue Apr 25 15:17:06 2017 +0200
|
|
||||||
|
|
||||||
[perl #131211] fixup File::Glob degenerate matching
|
It also adds a micro-optimisation for M_ONE and M_SET under the new code.
|
||||||
|
|
||||||
The old code would go quadratic with recursion and backtracking
|
Thanks to Avar and Russ Cox for helping with this patch, along with
|
||||||
when doing patterns like "a*a*a*a*a*a*a*x" on a file like
|
Jilles Tjoelker and the rest of the FreeBSD community.
|
||||||
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa".
|
|
||||||
|
|
||||||
This patch changes the code to not recurse, and to not backtrack,
|
|
||||||
as per this article from Russ Cox: https://research.swtch.com/glob
|
|
||||||
|
|
||||||
It also adds a micro-optimisation for M_ONE and M_SET under the new code.
|
|
||||||
|
|
||||||
Thanks to Avar and Russ Cox for helping with this patch, along with
|
|
||||||
Jilles Tjoelker and the rest of the FreeBSD community.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
---
|
---
|
||||||
|
@ -35,17 +27,17 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
create mode 100644 ext/File-Glob/t/rt131211.t
|
create mode 100644 ext/File-Glob/t/rt131211.t
|
||||||
|
|
||||||
diff --git a/MANIFEST b/MANIFEST
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
index fe045a7..be2a44f 100644
|
index b7b6e74..af0da6c 100644
|
||||||
--- a/MANIFEST
|
--- a/MANIFEST
|
||||||
+++ b/MANIFEST
|
+++ b/MANIFEST
|
||||||
@@ -3678,6 +3678,7 @@ ext/File-Glob/t/case.t See if File::Glob works
|
@@ -3948,6 +3948,7 @@ ext/File-Glob/t/basic.t See if File::Glob works
|
||||||
|
ext/File-Glob/t/case.t See if File::Glob works
|
||||||
ext/File-Glob/t/global.t See if File::Glob works
|
ext/File-Glob/t/global.t See if File::Glob works
|
||||||
ext/File-Glob/TODO File::Glob extension todo list
|
|
||||||
ext/File-Glob/t/rt114984.t See if File::Glob works
|
ext/File-Glob/t/rt114984.t See if File::Glob works
|
||||||
+ext/File-Glob/t/rt131211.t See if File::Glob works
|
+ext/File-Glob/t/rt131211.t See if File::Glob works
|
||||||
ext/File-Glob/t/taint.t See if File::Glob works
|
ext/File-Glob/t/taint.t See if File::Glob works
|
||||||
ext/File-Glob/t/threads.t See if File::Glob + threads works
|
ext/File-Glob/t/threads.t See if File::Glob + threads works
|
||||||
ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
|
ext/File-Glob/TODO File::Glob extension todo list
|
||||||
diff --git a/ext/File-Glob/bsd_glob.c b/ext/File-Glob/bsd_glob.c
|
diff --git a/ext/File-Glob/bsd_glob.c b/ext/File-Glob/bsd_glob.c
|
||||||
index 821ef20..e96fb73 100644
|
index 821ef20..e96fb73 100644
|
||||||
--- a/ext/File-Glob/bsd_glob.c
|
--- a/ext/File-Glob/bsd_glob.c
|
|
@ -0,0 +1,45 @@
|
||||||
|
From b4d257e2d408f0f1c6686dcdc112f3ebfec68f44 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 27 Jun 2017 10:22:23 +0200
|
||||||
|
Subject: [PATCH] File::Glob - tweak rt131211.t to be less sensitive on wonky
|
||||||
|
boxes
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
make the test less senstive and avoid divide by zero errors,
|
||||||
|
also we skip the test if either elapsed_match or elapsed_fail is
|
||||||
|
true, as we can not rely on the timings then. For the operations
|
||||||
|
we are doing we should get a non-zero timing from Time::HiRes.
|
||||||
|
|
||||||
|
This should mean that running this test on boxes with heavy
|
||||||
|
load, etc, will no longer result in false positives.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/File-Glob/t/rt131211.t | 9 +++++++--
|
||||||
|
1 file changed, 7 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/File-Glob/t/rt131211.t b/ext/File-Glob/t/rt131211.t
|
||||||
|
index c1bcbe0..b29cd04 100644
|
||||||
|
--- a/ext/File-Glob/t/rt131211.t
|
||||||
|
+++ b/ext/File-Glob/t/rt131211.t
|
||||||
|
@@ -49,8 +49,13 @@ while (++$count < 10) {
|
||||||
|
is $count,10,
|
||||||
|
"tried all the patterns without bailing out";
|
||||||
|
|
||||||
|
-cmp_ok $elapsed_fail/$elapsed_match,"<",2,
|
||||||
|
- "time to fail less than twice the time to match";
|
||||||
|
+SKIP: {
|
||||||
|
+ skip "unstable timing", 1 unless $elapsed_match && $elapsed_fail;
|
||||||
|
+ ok $elapsed_fail <= 10 * $elapsed_match,
|
||||||
|
+ "time to fail less than 10x the time to match"
|
||||||
|
+ or diag("elapsed_match=$elapsed_match elapsed_fail=$elapsed_fail");
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
is "@got_files", catfile($path, $files[0]),
|
||||||
|
"only got the expected file for xa*..b";
|
||||||
|
is "@no_files", "", "shouldnt have files for xa*..c";
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,226 @@
|
||||||
|
From 5aca16e032861ea3dfcc96ad417ea87e2b1552e5 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Aaron Crane <arc@cpan.org>
|
||||||
|
Date: Sat, 4 Mar 2017 12:50:58 +0000
|
||||||
|
Subject: [PATCH] RT #130907: Fix the Unicode Bug in split " "
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.26.0:
|
||||||
|
|
||||||
|
commit 20ae58f7a9bbf84d043d6e90f5988b6e3ca4ee3d
|
||||||
|
Author: Aaron Crane <arc@cpan.org>
|
||||||
|
Date: Sat Mar 4 12:50:58 2017 +0000
|
||||||
|
|
||||||
|
RT #130907: Fix the Unicode Bug in split " "
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
lib/feature.pm | 5 +++--
|
||||||
|
pod/perldelta.pod | 9 +++++++++
|
||||||
|
pod/perlfunc.pod | 8 ++++++++
|
||||||
|
pod/perlunicode.pod | 11 +++++++++++
|
||||||
|
pod/perluniintro.pod | 5 +++--
|
||||||
|
pp.c | 13 +++++++++++++
|
||||||
|
regen/feature.pl | 5 +++--
|
||||||
|
t/op/split.t | 20 +++++++++++++++++++-
|
||||||
|
8 files changed, 69 insertions(+), 7 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/lib/feature.pm b/lib/feature.pm
|
||||||
|
index ed13273..93e020b 100644
|
||||||
|
--- a/lib/feature.pm
|
||||||
|
+++ b/lib/feature.pm
|
||||||
|
@@ -175,8 +175,9 @@ C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
|
||||||
|
|
||||||
|
This feature is available starting with Perl 5.12; was almost fully
|
||||||
|
implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>;
|
||||||
|
-and extended further in Perl 5.26 to cover L<the range
|
||||||
|
-operator|perlop/Range Operators>.
|
||||||
|
+was extended further in Perl 5.26 to cover L<the range
|
||||||
|
+operator|perlop/Range Operators>; and was extended again in Perl 5.28 to
|
||||||
|
+cover L<special-cased whitespace splitting|perlfunc/split>.
|
||||||
|
|
||||||
|
=head2 The 'unicode_eval' and 'evalbytes' features
|
||||||
|
|
||||||
|
#diff --git a/pod/perldelta.pod b/pod/perldelta.pod
|
||||||
|
#index 06dcd1d..d31335f 100644
|
||||||
|
#--- a/pod/perldelta.pod
|
||||||
|
#+++ b/pod/perldelta.pod
|
||||||
|
#@@ -3206,6 +3206,15 @@ calls.
|
||||||
|
# Parsing bad POSIX charclasses no longer leaks memory.
|
||||||
|
# L<[perl #128313]|https://rt.perl.org/Public/Bug/Display.html?id=128313>
|
||||||
|
#
|
||||||
|
#+=item *
|
||||||
|
#+
|
||||||
|
#+C<split ' '> now correctly handles the argument being split when in the
|
||||||
|
#+scope of the L<< C<unicode_strings>|feature/"The 'unicode_strings' feature"
|
||||||
|
#+>> feature. Previously, when a string using the single-byte internal
|
||||||
|
#+representation contained characters that are whitespace by Unicode rules but
|
||||||
|
#+not by ASCII rules, it treated those characters as part of fields rather
|
||||||
|
#+than as field separators. [perl #130907]
|
||||||
|
#+
|
||||||
|
# =back
|
||||||
|
#
|
||||||
|
# =head1 Known Problems
|
||||||
|
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
|
||||||
|
index b8dca6e..9abadf4 100644
|
||||||
|
--- a/pod/perlfunc.pod
|
||||||
|
+++ b/pod/perlfunc.pod
|
||||||
|
@@ -7616,6 +7616,14 @@ special case was restricted to the use of a plain S<C<" ">> as the
|
||||||
|
pattern argument to split; in Perl 5.18.0 and later this special case is
|
||||||
|
triggered by any expression which evaluates to the simple string S<C<" ">>.
|
||||||
|
|
||||||
|
+As of Perl 5.28, this special-cased whitespace splitting works as expected in
|
||||||
|
+the scope of L<< S<C<"use feature 'unicode_strings">>|feature/The
|
||||||
|
+'unicode_strings' feature >>. In previous versions, and outside the scope of
|
||||||
|
+that feature, it exhibits L<perlunicode/The "Unicode Bug">: characters that are
|
||||||
|
+whitespace according to Unicode rules but not according to ASCII rules can be
|
||||||
|
+treated as part of fields rather than as field separators, depending on the
|
||||||
|
+string's internal encoding.
|
||||||
|
+
|
||||||
|
If omitted, PATTERN defaults to a single space, S<C<" ">>, triggering
|
||||||
|
the previously described I<awk> emulation.
|
||||||
|
|
||||||
|
diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod
|
||||||
|
index 9c13c35..2e84e95 100644
|
||||||
|
--- a/pod/perlunicode.pod
|
||||||
|
+++ b/pod/perlunicode.pod
|
||||||
|
@@ -1835,6 +1835,17 @@ outside its scope, it could produce strings whose length in characters
|
||||||
|
exceeded that of the right-hand side, where the right-hand side took up more
|
||||||
|
bytes than the correct range endpoint.
|
||||||
|
|
||||||
|
+=item *
|
||||||
|
+
|
||||||
|
+In L<< C<split>'s special-case whitespace splitting|perlfunc/split >>.
|
||||||
|
+
|
||||||
|
+Starting in Perl 5.28.0, the C<split> function with a pattern specified as
|
||||||
|
+a string containing a single space handles whitespace characters consistently
|
||||||
|
+within the scope of of C<unicode_strings>. Prior to that, or outside its scope,
|
||||||
|
+characters that are whitespace according to Unicode rules but not according to
|
||||||
|
+ASCII rules were treated as field contents rather than field separators when
|
||||||
|
+they appear in byte-encoded strings.
|
||||||
|
+
|
||||||
|
=back
|
||||||
|
|
||||||
|
You can see from the above that the effect of C<unicode_strings>
|
||||||
|
diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod
|
||||||
|
index d35de34..595ec46 100644
|
||||||
|
--- a/pod/perluniintro.pod
|
||||||
|
+++ b/pod/perluniintro.pod
|
||||||
|
@@ -151,11 +151,12 @@ serious Unicode work. The maintenance release 5.6.1 fixed many of the
|
||||||
|
problems of the initial Unicode implementation, but for example
|
||||||
|
regular expressions still do not work with Unicode in 5.6.1.
|
||||||
|
Perl v5.14.0 is the first release where Unicode support is
|
||||||
|
-(almost) seamlessly integrable without some gotchas. (There are two
|
||||||
|
+(almost) seamlessly integrable without some gotchas. (There are a few
|
||||||
|
exceptions. Firstly, some differences in L<quotemeta|perlfunc/quotemeta>
|
||||||
|
were fixed starting in Perl 5.16.0. Secondly, some differences in
|
||||||
|
L<the range operator|perlop/Range Operators> were fixed starting in
|
||||||
|
-Perl 5.26.0.)
|
||||||
|
+Perl 5.26.0. Thirdly, some differences in L<split|perlfunc/split> were fixed
|
||||||
|
+started in Perl 5.28.0.)
|
||||||
|
|
||||||
|
To enable this
|
||||||
|
seamless support, you should C<use feature 'unicode_strings'> (which is
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index cc4cb59..d9dd005 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -5740,6 +5740,7 @@ PP(pp_split)
|
||||||
|
STRLEN len;
|
||||||
|
const char *s = SvPV_const(sv, len);
|
||||||
|
const bool do_utf8 = DO_UTF8(sv);
|
||||||
|
+ const bool in_uni_8_bit = IN_UNI_8_BIT;
|
||||||
|
const char *strend = s + len;
|
||||||
|
PMOP *pm = cPMOPx(PL_op);
|
||||||
|
REGEXP *rx;
|
||||||
|
@@ -5826,6 +5827,10 @@ PP(pp_split)
|
||||||
|
while (s < strend && isSPACE_LC(*s))
|
||||||
|
s++;
|
||||||
|
}
|
||||||
|
+ else if (in_uni_8_bit) {
|
||||||
|
+ while (s < strend && isSPACE_L1(*s))
|
||||||
|
+ s++;
|
||||||
|
+ }
|
||||||
|
else {
|
||||||
|
while (s < strend && isSPACE(*s))
|
||||||
|
s++;
|
||||||
|
@@ -5857,6 +5862,10 @@ PP(pp_split)
|
||||||
|
{
|
||||||
|
while (m < strend && !isSPACE_LC(*m))
|
||||||
|
++m;
|
||||||
|
+ }
|
||||||
|
+ else if (in_uni_8_bit) {
|
||||||
|
+ while (m < strend && !isSPACE_L1(*m))
|
||||||
|
+ ++m;
|
||||||
|
} else {
|
||||||
|
while (m < strend && !isSPACE(*m))
|
||||||
|
++m;
|
||||||
|
@@ -5891,6 +5900,10 @@ PP(pp_split)
|
||||||
|
{
|
||||||
|
while (s < strend && isSPACE_LC(*s))
|
||||||
|
++s;
|
||||||
|
+ }
|
||||||
|
+ else if (in_uni_8_bit) {
|
||||||
|
+ while (s < strend && isSPACE_L1(*s))
|
||||||
|
+ ++s;
|
||||||
|
} else {
|
||||||
|
while (s < strend && isSPACE(*s))
|
||||||
|
++s;
|
||||||
|
diff --git a/regen/feature.pl b/regen/feature.pl
|
||||||
|
index 579120e..8a4ce63 100755
|
||||||
|
--- a/regen/feature.pl
|
||||||
|
+++ b/regen/feature.pl
|
||||||
|
@@ -485,8 +485,9 @@ C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
|
||||||
|
|
||||||
|
This feature is available starting with Perl 5.12; was almost fully
|
||||||
|
implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>;
|
||||||
|
-and extended further in Perl 5.26 to cover L<the range
|
||||||
|
-operator|perlop/Range Operators>.
|
||||||
|
+was extended further in Perl 5.26 to cover L<the range
|
||||||
|
+operator|perlop/Range Operators>; and was extended again in Perl 5.28 to
|
||||||
|
+cover L<special-cased whitespace splitting|perlfunc/split>.
|
||||||
|
|
||||||
|
=head2 The 'unicode_eval' and 'evalbytes' features
|
||||||
|
|
||||||
|
diff --git a/t/op/split.t b/t/op/split.t
|
||||||
|
index d60bcaf..038c5d7 100644
|
||||||
|
--- a/t/op/split.t
|
||||||
|
+++ b/t/op/split.t
|
||||||
|
@@ -7,7 +7,7 @@ BEGIN {
|
||||||
|
set_up_inc('../lib');
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 163;
|
||||||
|
+plan tests => 172;
|
||||||
|
|
||||||
|
$FS = ':';
|
||||||
|
|
||||||
|
@@ -480,6 +480,24 @@ is($cnt, scalar(@ary));
|
||||||
|
qq{split(\$cond ? qr/ / : " ", "$exp") behaves as expected over repeated similar patterns};
|
||||||
|
}
|
||||||
|
|
||||||
|
+SKIP: {
|
||||||
|
+ # RT #130907: unicode_strings feature doesn't work with split ' '
|
||||||
|
+
|
||||||
|
+ my ($sp) = grep /\s/u, map chr, reverse 128 .. 255 # prefer \xA0 over \x85
|
||||||
|
+ or skip 'no unicode whitespace found in high-8-bit range', 9;
|
||||||
|
+
|
||||||
|
+ for (["$sp$sp. /", "leading unicode whitespace"],
|
||||||
|
+ [".$sp$sp/", "unicode whitespace separator"],
|
||||||
|
+ [". /$sp$sp", "trailing unicode whitespace"]) {
|
||||||
|
+ my ($str, $desc) = @$_;
|
||||||
|
+ use feature "unicode_strings";
|
||||||
|
+ my @got = split " ", $str;
|
||||||
|
+ is @got, 2, "whitespace split: $desc: field count";
|
||||||
|
+ is $got[0], '.', "whitespace split: $desc: field 0";
|
||||||
|
+ is $got[1], '/', "whitespace split: $desc: field 1";
|
||||||
|
+ }
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
{
|
||||||
|
# 'RT #116086: split "\x20" does not work as documented';
|
||||||
|
my @results;
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,51 @@
|
||||||
|
From b9a58d500dd75ba783abac92a56e57d41227f62b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Sun, 2 Jul 2017 11:35:20 -0700
|
||||||
|
Subject: [PATCH] =?UTF-8?q?[perl=20#131679]=20Fix=20=E2=80=98our=20sub=20f?=
|
||||||
|
=?UTF-8?q?oo::bar=E2=80=99=20message?=
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
It should say subroutine, not variable.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/lib/croak/toke | 6 ++++++
|
||||||
|
toke.c | 3 ++-
|
||||||
|
2 files changed, 8 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/lib/croak/toke b/t/lib/croak/toke
|
||||||
|
index 7aa15ef..2603224 100644
|
||||||
|
--- a/t/lib/croak/toke
|
||||||
|
+++ b/t/lib/croak/toke
|
||||||
|
@@ -133,6 +133,12 @@ state sub;
|
||||||
|
EXPECT
|
||||||
|
Missing name in "state sub" at - line 2.
|
||||||
|
########
|
||||||
|
+# NAME our sub pack::foo
|
||||||
|
+our sub foo::bar;
|
||||||
|
+EXPECT
|
||||||
|
+No package name allowed for subroutine &foo::bar in "our" at - line 1, near "our sub foo::bar"
|
||||||
|
+Execution of - aborted due to compilation errors.
|
||||||
|
+########
|
||||||
|
# NAME my sub pack::foo
|
||||||
|
use feature 'lexical_subs', 'state';
|
||||||
|
my sub foo::bar;
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index ace92e3..6aa5f26 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -8848,7 +8848,8 @@ S_pending_ident(pTHX)
|
||||||
|
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
|
||||||
|
if (has_colon)
|
||||||
|
yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
|
||||||
|
- "variable %s in \"our\"",
|
||||||
|
+ "%se %s in \"our\"",
|
||||||
|
+ *PL_tokenbuf=='&' ?"subroutin":"variabl",
|
||||||
|
PL_tokenbuf), UTF ? SVf_UTF8 : 0);
|
||||||
|
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,30 @@
|
||||||
|
From 97e57bec1f0ba4f0c3b1dc18ee146632010e3373 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Sat, 15 Jul 2017 19:36:25 -0600
|
||||||
|
Subject: [PATCH] t/lib/warnings/utf8: Fix test
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
There is some randomness to this test added to fix [perl #131646].
|
||||||
|
Change what passes to be a pattern that matches the correct template
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/lib/warnings/utf8 | 3 ++-
|
||||||
|
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8
|
||||||
|
index 9066308..dfc58c1 100644
|
||||||
|
--- a/t/lib/warnings/utf8
|
||||||
|
+++ b/t/lib/warnings/utf8
|
||||||
|
@@ -781,4 +781,5 @@ no warnings;
|
||||||
|
use warnings 'utf8';
|
||||||
|
for(uc 0..t){0~~pack"UXc",exp}
|
||||||
|
EXPECT
|
||||||
|
-Malformed UTF-8 character: \xc2\x00 (unexpected non-continuation byte 0x00, immediately after start byte 0xc2; need 2 bytes, got 1) in smart match at - line 9.
|
||||||
|
+OPTIONS regex
|
||||||
|
+Malformed UTF-8 character: \\x([[:xdigit:]]{2})\\x([[:xdigit:]]{2}) \(unexpected non-continuation byte 0x\2, immediately after start byte 0x\1; need 2 bytes, got 1\) in smart match at - line 9.
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,43 @@
|
||||||
|
From 05b9033b464ce8dd2c9b33238f9aa14755d7a91a Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Sat, 17 Jun 2017 17:56:10 -0600
|
||||||
|
Subject: [PATCH] utf8n_to_uvchr(): Don't display too many bytes in msg
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
When raising a message about malformed UTF-8, we shouldn't display bytes
|
||||||
|
from the next character, unless those bytes were expected to have been
|
||||||
|
part of the current one. Tests for this will be added in future commits
|
||||||
|
in ext/XS-APItest/t/utf8_warn_base.pl
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
utf8.c | 4 ++--
|
||||||
|
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/utf8.c b/utf8.c
|
||||||
|
index ee5405f..e55a6f1 100644
|
||||||
|
--- a/utf8.c
|
||||||
|
+++ b/utf8.c
|
||||||
|
@@ -1428,7 +1428,7 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
|
||||||
|
if (pack_warn) {
|
||||||
|
message = Perl_form(aTHX_ "%s: %s (overflows)",
|
||||||
|
malformed_text,
|
||||||
|
- _byte_dump_string(s0, send - s0, 0));
|
||||||
|
+ _byte_dump_string(s0, curlen, 0));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
@@ -1554,7 +1554,7 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
|
||||||
|
"%s: %s (overlong; instead use %s to represent"
|
||||||
|
" U+%0*" UVXf ")",
|
||||||
|
malformed_text,
|
||||||
|
- _byte_dump_string(s0, send - s0, 0),
|
||||||
|
+ _byte_dump_string(s0, curlen, 0),
|
||||||
|
_byte_dump_string(tmpbuf, e - tmpbuf, 0),
|
||||||
|
((uv < 256) ? 2 : 4), /* Field width of 2 for
|
||||||
|
small code points */
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,57 @@
|
||||||
|
From 8121278aa8fe72e9e8aca8651c7f1d4fa204ac1d Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Mon, 2 Apr 2018 21:54:59 -0600
|
||||||
|
Subject: [PATCH] PATCH: [perl #132167] Parse error in regex_sets
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
When popping the stack, the code inappropriately also subtracted one
|
||||||
|
from the result. This is probably left over from an earlier change in
|
||||||
|
the implementation. The top of the stack contained the correct value;
|
||||||
|
subtracting was a mistake.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 2 +-
|
||||||
|
t/re/regex_sets.t | 11 +++++++++++
|
||||||
|
2 files changed, 12 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 018d5646fc..39ab260efa 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -15689,7 +15689,7 @@ redo_curchar:
|
||||||
|
* fence. Get rid of it */
|
||||||
|
fence_ptr = av_pop(fence_stack);
|
||||||
|
assert(fence_ptr);
|
||||||
|
- fence = SvIV(fence_ptr) - 1;
|
||||||
|
+ fence = SvIV(fence_ptr);
|
||||||
|
SvREFCNT_dec_NN(fence_ptr);
|
||||||
|
fence_ptr = NULL;
|
||||||
|
|
||||||
|
diff --git a/t/re/regex_sets.t b/t/re/regex_sets.t
|
||||||
|
index e9644bd4e6..e70df81254 100644
|
||||||
|
--- a/t/re/regex_sets.t
|
||||||
|
+++ b/t/re/regex_sets.t
|
||||||
|
@@ -204,6 +204,17 @@ for my $char ("٠", "٥", "٩") {
|
||||||
|
like("a", qr/$pat/, "/$pat/ compiles and matches 'a'");
|
||||||
|
}
|
||||||
|
|
||||||
|
+{ # [perl #132167]
|
||||||
|
+ fresh_perl_is('no warnings "experimental::regex_sets";
|
||||||
|
+ print "c" =~ qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ])/;',
|
||||||
|
+ 1, {},
|
||||||
|
+ 'qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ]) compiles and properly matches');
|
||||||
|
+ fresh_perl_is('no warnings "experimental::regex_sets";
|
||||||
|
+ print "b" =~ qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ])/;',
|
||||||
|
+ "", {},
|
||||||
|
+ 'qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ]) compiles and properly matches');
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
done_testing();
|
||||||
|
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
|
@ -0,0 +1,71 @@
|
||||||
|
From 62e6b70574842d7f2c547d33c85c50228522f685 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Marc-Philip <marc-philip.werner@sap.com>
|
||||||
|
Date: Sun, 8 Apr 2018 12:15:29 -0600
|
||||||
|
Subject: [PATCH] PATCH: [perl #133074] 5.26.1: some coverity fixes
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
we have some coverity code scans here. They have found this
|
||||||
|
uninilialized variable in pp.c and the integer overrun in toke.c.
|
||||||
|
Though it might be possible that these are false positives (no
|
||||||
|
reasonable control path gets there), it's good to mute the scan here to
|
||||||
|
see the real problems easier.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp.c | 1 +
|
||||||
|
toke.c | 8 ++++----
|
||||||
|
2 files changed, 5 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index 5524131658..d777ae4309 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -3727,6 +3727,7 @@ PP(pp_ucfirst)
|
||||||
|
if (! slen) { /* If empty */
|
||||||
|
need = 1; /* still need a trailing NUL */
|
||||||
|
ulen = 0;
|
||||||
|
+ *tmpbuf = '\0';
|
||||||
|
}
|
||||||
|
else if (DO_UTF8(source)) { /* Is the source utf8? */
|
||||||
|
doing_utf8 = TRUE;
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index 3405dc6c89..fc87252bb1 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -9052,7 +9052,7 @@ S_pending_ident(pTHX)
|
||||||
|
HEK * const stashname = HvNAME_HEK(stash);
|
||||||
|
SV * const sym = newSVhek(stashname);
|
||||||
|
sv_catpvs(sym, "::");
|
||||||
|
- sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
|
||||||
|
+ sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
|
||||||
|
pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
|
||||||
|
pl_yylval.opval->op_private = OPpCONST_ENTERED;
|
||||||
|
if (pit != '&')
|
||||||
|
@@ -9080,7 +9080,7 @@ S_pending_ident(pTHX)
|
||||||
|
&& PL_lex_state != LEX_NORMAL
|
||||||
|
&& !PL_lex_brackets)
|
||||||
|
{
|
||||||
|
- GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
|
||||||
|
+ GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||||
|
( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
|
||||||
|
SVt_PVAV);
|
||||||
|
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
|
||||||
|
@@ -9097,11 +9097,11 @@ S_pending_ident(pTHX)
|
||||||
|
/* build ops for a bareword */
|
||||||
|
pl_yylval.opval = newSVOP(OP_CONST, 0,
|
||||||
|
newSVpvn_flags(PL_tokenbuf + 1,
|
||||||
|
- tokenbuf_len - 1,
|
||||||
|
+ tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||||
|
UTF ? SVf_UTF8 : 0 ));
|
||||||
|
pl_yylval.opval->op_private = OPpCONST_ENTERED;
|
||||||
|
if (pit != '&')
|
||||||
|
- gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
|
||||||
|
+ gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||||
|
(PL_in_eval ? GV_ADDMULTI : GV_ADD)
|
||||||
|
| ( UTF ? SVf_UTF8 : 0 ),
|
||||||
|
((PL_tokenbuf[0] == '$') ? SVt_PV
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
|
@ -0,0 +1,45 @@
|
||||||
|
From 357c35e6f18e65f372e7a1b22ee39a3c7c9e5810 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Robin Barker <RMBarker@cpan.org>
|
||||||
|
Date: Mon, 17 Dec 2012 18:20:14 +0100
|
||||||
|
Subject: [PATCH] Avoid compiler warnings due to mismatched types in *printf
|
||||||
|
format strings.
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
gcc (and probably others) was warning about a mismatch for between `int`
|
||||||
|
(implied by the format %d) and the actual type passed, `line_t`. Avoid this
|
||||||
|
by explicitly casting to UV, and using UVuf.
|
||||||
|
|
||||||
|
CPAN #63832
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm | 7 ++++---
|
||||||
|
1 file changed, 4 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||||
|
index 545d322..c7e6d05 100644
|
||||||
|
--- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||||
|
+++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||||
|
@@ -629,13 +629,14 @@ EOA
|
||||||
|
if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
|
||||||
|
? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
|
||||||
|
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
|
||||||
|
- ", used at %" COP_FILE_F " line %d\\n", sv,
|
||||||
|
- COP_FILE(cop), CopLINE(cop));
|
||||||
|
+ ", used at %" COP_FILE_F " line %" UVuf "\\n",
|
||||||
|
+ sv, COP_FILE(cop), (UV)CopLINE(cop));
|
||||||
|
} else
|
||||||
|
#endif
|
||||||
|
{
|
||||||
|
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro at %"
|
||||||
|
- COP_FILE_F " line %d\\n", sv, COP_FILE(cop), CopLINE(cop));
|
||||||
|
+ COP_FILE_F " line %" UVuf "\\n",
|
||||||
|
+ sv, COP_FILE(cop), (UV)CopLINE(cop));
|
||||||
|
}
|
||||||
|
croak_sv(sv_2mortal(sv));
|
||||||
|
EOC
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,69 @@
|
||||||
|
From 389f3ef2fdfbba2c2816e7334a69a5f540c0a33d Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Mon, 15 Dec 2014 16:14:13 +0000
|
||||||
|
Subject: [PATCH] EU::Constant: avoid 'uninit' warning
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
The code generated by ExtUtils::Constant can look something like:
|
||||||
|
|
||||||
|
static int
|
||||||
|
constant (..., IV *iv_return) {
|
||||||
|
switch (...) {
|
||||||
|
case ...:
|
||||||
|
*iv_return = ...;
|
||||||
|
return PERL_constant_ISIV;
|
||||||
|
...
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
{
|
||||||
|
int type;
|
||||||
|
IV iv;
|
||||||
|
type = constant(..., &iv);
|
||||||
|
switch (type) {
|
||||||
|
case PERL_constant_ISIV:
|
||||||
|
PUSHi(iv);
|
||||||
|
...
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
and the compiler isn't clever enough to realise that the value of iv
|
||||||
|
is only used in the code path where its been set.
|
||||||
|
|
||||||
|
So initialise it to zero to shut gcc up. Ditto nv and pv.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm | 6 +++---
|
||||||
|
1 file changed, 3 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||||
|
index 0dc9258..cf0e1ca 100644
|
||||||
|
--- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||||
|
+++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||||
|
@@ -198,17 +198,17 @@ $XS_subname(sv)
|
||||||
|
EOT
|
||||||
|
|
||||||
|
if ($params->{IV}) {
|
||||||
|
- $xs .= " IV iv;\n";
|
||||||
|
+ $xs .= " IV iv = 0; /* avoid uninit var warning */\n";
|
||||||
|
} else {
|
||||||
|
$xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
|
||||||
|
}
|
||||||
|
if ($params->{NV}) {
|
||||||
|
- $xs .= " NV nv;\n";
|
||||||
|
+ $xs .= " NV nv = 0.0; /* avoid uninit var warning */\n";
|
||||||
|
} else {
|
||||||
|
$xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
|
||||||
|
}
|
||||||
|
if ($params->{PV}) {
|
||||||
|
- $xs .= " const char *pv;\n";
|
||||||
|
+ $xs .= " const char *pv = NULL; /* avoid uninit var warning */\n";
|
||||||
|
} else {
|
||||||
|
$xs .=
|
||||||
|
" /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
|
@ -0,0 +1,30 @@
|
||||||
|
From 4369267db9ca4982c1a9bd1ef680bc4350decc3a Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 18 Sep 2017 15:07:21 +1000
|
||||||
|
Subject: [PATCH] (perl #132008) try to prevent the similar mistakes in the
|
||||||
|
future
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Term-ReadLine/lib/Term/ReadLine.pm | 2 ++
|
||||||
|
1 file changed, 2 insertions(+)
|
||||||
|
|
||||||
|
diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||||
|
index e00fb376cd..78c1ebf5b6 100644
|
||||||
|
--- a/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||||
|
+++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||||
|
@@ -75,6 +75,8 @@ history. Returns the old value.
|
||||||
|
returns an array with two strings that give most appropriate names for
|
||||||
|
files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
|
||||||
|
|
||||||
|
+The strings returned may not be useful for 3-argument open().
|
||||||
|
+
|
||||||
|
=item Attribs
|
||||||
|
|
||||||
|
returns a reference to a hash which describes internal configuration
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
From ab3bb20383d6dbf9baa811d06414ee474bb8f91e Mon Sep 17 00:00:00 2001
|
From b3937e202aaf10c2f8996e2993c880bb38a7a268 Mon Sep 17 00:00:00 2001
|
||||||
From: Father Chrysostomos <sprout@cpan.org>
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
Date: Wed, 1 Nov 2017 13:11:27 -0700
|
Date: Wed, 1 Nov 2017 13:11:27 -0700
|
||||||
Subject: [PATCH] =?UTF-8?q?Carp:=20Don=E2=80=99t=20choke=20on=20ISA=20cons?=
|
Subject: [PATCH] =?UTF-8?q?Carp:=20Don=E2=80=99t=20choke=20on=20ISA=20cons?=
|
||||||
|
@ -17,8 +17,6 @@ and still persisted in bleadperl (Carp 1.43) until this commit.
|
||||||
The code that goes poking through the symbol table needs to take into
|
The code that goes poking through the symbol table needs to take into
|
||||||
account that not all stash elements are globs.
|
account that not all stash elements are globs.
|
||||||
|
|
||||||
Petr Písař: Ported to 5.24.3.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
---
|
---
|
||||||
dist/Carp/lib/Carp.pm | 3 ++-
|
dist/Carp/lib/Carp.pm | 3 ++-
|
||||||
|
@ -26,10 +24,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
2 files changed, 14 insertions(+), 2 deletions(-)
|
2 files changed, 14 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
|
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
|
||||||
index 92f8866..f94b9d4 100644
|
index 6127b26f54..ef11a0c046 100644
|
||||||
--- a/dist/Carp/lib/Carp.pm
|
--- a/dist/Carp/lib/Carp.pm
|
||||||
+++ b/dist/Carp/lib/Carp.pm
|
+++ b/dist/Carp/lib/Carp.pm
|
||||||
@@ -594,7 +594,8 @@ sub trusts_directly {
|
@@ -593,7 +593,8 @@ sub trusts_directly {
|
||||||
for my $var (qw/ CARP_NOT ISA /) {
|
for my $var (qw/ CARP_NOT ISA /) {
|
||||||
# Don't try using the variable until we know it exists,
|
# Don't try using the variable until we know it exists,
|
||||||
# to avoid polluting the caller's namespace.
|
# to avoid polluting the caller's namespace.
|
||||||
|
@ -40,19 +38,19 @@ index 92f8866..f94b9d4 100644
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
diff --git a/dist/Carp/t/Carp.t b/dist/Carp/t/Carp.t
|
diff --git a/dist/Carp/t/Carp.t b/dist/Carp/t/Carp.t
|
||||||
index 9ecdf88..f981005 100644
|
index 65daed7c6c..b1e399d143 100644
|
||||||
--- a/dist/Carp/t/Carp.t
|
--- a/dist/Carp/t/Carp.t
|
||||||
+++ b/dist/Carp/t/Carp.t
|
+++ b/dist/Carp/t/Carp.t
|
||||||
@@ -3,7 +3,7 @@ no warnings "once";
|
@@ -3,7 +3,7 @@ no warnings "once";
|
||||||
use Config;
|
use Config;
|
||||||
|
|
||||||
use IPC::Open3 1.0103 qw(open3);
|
use IPC::Open3 1.0103 qw(open3);
|
||||||
-use Test::More tests => 66;
|
-use Test::More tests => 67;
|
||||||
+use Test::More tests => 67;
|
+use Test::More tests => 68;
|
||||||
|
|
||||||
sub runperl {
|
sub runperl {
|
||||||
my(%args) = @_;
|
my(%args) = @_;
|
||||||
@@ -478,6 +478,17 @@ SKIP:
|
@@ -488,6 +488,17 @@ SKIP:
|
||||||
);
|
);
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
From a56b6643ac9d2bae70dc93d49a08ba1eafa62c30 Mon Sep 17 00:00:00 2001
|
From 3f8a98327dfdb171bd6e447fec23721b0e74c7a6 Mon Sep 17 00:00:00 2001
|
||||||
From: Zefram <zefram@fysh.org>
|
From: Zefram <zefram@fysh.org>
|
||||||
Date: Sun, 19 Nov 2017 09:15:53 +0000
|
Date: Sun, 19 Nov 2017 09:15:53 +0000
|
||||||
Subject: [PATCH] fix tainting of s/// with overloaded replacement
|
Subject: [PATCH] fix tainting of s/// with overloaded replacement
|
||||||
|
@ -18,20 +18,20 @@ there's no visible behaviour that distinguishes taint specifically from
|
||||||
the replacement. Also remove a related taint check that seems to be
|
the replacement. Also remove a related taint check that seems to be
|
||||||
not needed at all. Fixes [perl #115266].
|
not needed at all. Fixes [perl #115266].
|
||||||
|
|
||||||
Petr Písař: Ported to 5.24.3.
|
Petr Písař: Ported to 5.26.1.
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
---
|
---
|
||||||
pp_ctl.c | 4 +-
|
pp_ctl.c | 4 +-
|
||||||
pp_hot.c | 4 +-
|
pp_hot.c | 4 +-
|
||||||
t/op/taint.t | 429 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
|
t/op/taint.t | 428 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
|
||||||
3 files changed, 423 insertions(+), 14 deletions(-)
|
3 files changed, 422 insertions(+), 14 deletions(-)
|
||||||
|
|
||||||
diff --git a/pp_ctl.c b/pp_ctl.c
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
index 9150142..97a4607 100644
|
index f136f91..15c193b 100644
|
||||||
--- a/pp_ctl.c
|
--- a/pp_ctl.c
|
||||||
+++ b/pp_ctl.c
|
+++ b/pp_ctl.c
|
||||||
@@ -218,9 +218,9 @@ PP(pp_substcont)
|
@@ -219,9 +219,9 @@ PP(pp_substcont)
|
||||||
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
|
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
|
||||||
|
|
||||||
/* See "how taint works" above pp_subst() */
|
/* See "how taint works" above pp_subst() */
|
||||||
|
@ -44,10 +44,10 @@ index 9150142..97a4607 100644
|
||||||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
|
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
|
||||||
(s == m), cx->sb_targ, NULL,
|
(s == m), cx->sb_targ, NULL,
|
||||||
diff --git a/pp_hot.c b/pp_hot.c
|
diff --git a/pp_hot.c b/pp_hot.c
|
||||||
index 243f43a..e80d991 100644
|
index f445fd9..5899413 100644
|
||||||
--- a/pp_hot.c
|
--- a/pp_hot.c
|
||||||
+++ b/pp_hot.c
|
+++ b/pp_hot.c
|
||||||
@@ -3004,7 +3004,7 @@ PP(pp_subst)
|
@@ -3250,7 +3250,7 @@ PP(pp_subst)
|
||||||
doutf8 = DO_UTF8(dstr);
|
doutf8 = DO_UTF8(dstr);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -56,25 +56,25 @@ index 243f43a..e80d991 100644
|
||||||
rxtainted |= SUBST_TAINT_REPL;
|
rxtainted |= SUBST_TAINT_REPL;
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
@@ -3181,8 +3181,6 @@ PP(pp_subst)
|
@@ -3421,8 +3421,6 @@ PP(pp_subst)
|
||||||
sv_catsv(dstr, nsv);
|
}
|
||||||
}
|
else {
|
||||||
else sv_catsv(dstr, repl);
|
sv_catsv(dstr, repl);
|
||||||
- if (UNLIKELY(SvTAINTED(repl)))
|
- if (UNLIKELY(SvTAINTED(repl)))
|
||||||
- rxtainted |= SUBST_TAINT_REPL;
|
- rxtainted |= SUBST_TAINT_REPL;
|
||||||
}
|
}
|
||||||
if (once)
|
if (once)
|
||||||
break;
|
break;
|
||||||
diff --git a/t/op/taint.t b/t/op/taint.t
|
diff --git a/t/op/taint.t b/t/op/taint.t
|
||||||
index 846ac23..dbcc418 100644
|
index c13eaf6..be5eaa8 100644
|
||||||
--- a/t/op/taint.t
|
--- a/t/op/taint.t
|
||||||
+++ b/t/op/taint.t
|
+++ b/t/op/taint.t
|
||||||
@@ -17,7 +17,7 @@ BEGIN {
|
@@ -17,7 +17,7 @@ BEGIN {
|
||||||
use strict;
|
use strict;
|
||||||
use Config;
|
use Config;
|
||||||
|
|
||||||
-plan tests => 812;
|
-plan tests => 828;
|
||||||
+plan tests => 1024;
|
+plan tests => 1040;
|
||||||
|
|
||||||
$| = 1;
|
$| = 1;
|
||||||
|
|
||||||
|
@ -303,10 +303,10 @@ index 846ac23..dbcc418 100644
|
||||||
# [perl #121854] match taintedness became sticky
|
# [perl #121854] match taintedness became sticky
|
||||||
# when one match has a taintess result, subseqent matches
|
# when one match has a taintess result, subseqent matches
|
||||||
# using the same pattern shouldn't necessarily be tainted
|
# using the same pattern shouldn't necessarily be tainted
|
||||||
@@ -2408,6 +2540,285 @@ is eval { eval $::x.1 }, 1, 'reset does not taint undef';
|
@@ -2448,6 +2580,284 @@ is eval { eval $::x.1 }, 1, 'reset does not taint undef';
|
||||||
|
isnt_tainted $b, "list assign post tainted expression b";
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
+# taint passing through overloading
|
+# taint passing through overloading
|
||||||
+package OvTaint {
|
+package OvTaint {
|
||||||
+ sub new { bless({ t => $_[1] }, $_[0]) }
|
+ sub new { bless({ t => $_[1] }, $_[0]) }
|
||||||
|
@ -585,10 +585,9 @@ index 846ac23..dbcc418 100644
|
||||||
+ is($res, 4, "$desc: res value");
|
+ is($res, 4, "$desc: res value");
|
||||||
+ is($one, 'd', "$desc: \$1 value");
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
+}
|
+}
|
||||||
+
|
|
||||||
# This may bomb out with the alarm signal so keep it last
|
# This may bomb out with the alarm signal so keep it last
|
||||||
SKIP: {
|
SKIP: {
|
||||||
skip "No alarm()" unless $Config{d_alarm};
|
|
||||||
--
|
--
|
||||||
2.13.6
|
2.13.6
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
From 264472b6e83dd1a9d0e0e58d75f7162471a5b29b Mon Sep 17 00:00:00 2001
|
From 695d6585affc8f13711f013329fb4810ab89d833 Mon Sep 17 00:00:00 2001
|
||||||
From: Father Chrysostomos <sprout@cpan.org>
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
Date: Tue, 14 Nov 2017 18:55:55 -0800
|
Date: Tue, 14 Nov 2017 18:55:55 -0800
|
||||||
Subject: [PATCH] Fix stack with do {my sub l; 1}
|
Subject: [PATCH] [perl #132442] Fix stack with do {my sub l; 1}
|
||||||
MIME-Version: 1.0
|
MIME-Version: 1.0
|
||||||
Content-Type: text/plain; charset=UTF-8
|
Content-Type: text/plain; charset=UTF-8
|
||||||
Content-Transfer-Encoding: 8bit
|
Content-Transfer-Encoding: 8bit
|
||||||
|
@ -61,8 +61,6 @@ setting the HINT_BLOCK_SCOPE flag when a lexical sub is declared.
|
||||||
Thus, we end up with an enter/leave pair, which creates a
|
Thus, we end up with an enter/leave pair, which creates a
|
||||||
proper scope.
|
proper scope.
|
||||||
|
|
||||||
Petr Písař: Ported to 5.24.3.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
---
|
---
|
||||||
op.c | 2 ++
|
op.c | 2 ++
|
||||||
|
@ -70,10 +68,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
2 files changed, 6 insertions(+), 1 deletion(-)
|
2 files changed, 6 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
diff --git a/op.c b/op.c
|
diff --git a/op.c b/op.c
|
||||||
index 8a5fc3f..695bfa4 100644
|
index 8fa5aad876..c617ad2a00 100644
|
||||||
--- a/op.c
|
--- a/op.c
|
||||||
+++ b/op.c
|
+++ b/op.c
|
||||||
@@ -7936,6 +7936,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
|
@@ -9243,6 +9243,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
|
||||||
|
|
||||||
PERL_ARGS_ASSERT_NEWMYSUB;
|
PERL_ARGS_ASSERT_NEWMYSUB;
|
||||||
|
|
||||||
|
@ -83,19 +81,19 @@ index 8a5fc3f..695bfa4 100644
|
||||||
We cannot use PL_comppad, as it is the pad owned by the new sub. We
|
We cannot use PL_comppad, as it is the pad owned by the new sub. We
|
||||||
need to look in CvOUTSIDE and find the pad belonging to the enclos-
|
need to look in CvOUTSIDE and find the pad belonging to the enclos-
|
||||||
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
|
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
|
||||||
index adccf4c..cf90a76 100644
|
index 3fa17acdda..f085cd97e8 100644
|
||||||
--- a/t/op/lexsub.t
|
--- a/t/op/lexsub.t
|
||||||
+++ b/t/op/lexsub.t
|
+++ b/t/op/lexsub.t
|
||||||
@@ -7,7 +7,7 @@ BEGIN {
|
@@ -7,7 +7,7 @@ BEGIN {
|
||||||
*bar::is = *is;
|
*bar::is = *is;
|
||||||
*bar::like = *like;
|
*bar::like = *like;
|
||||||
}
|
}
|
||||||
-plan 151;
|
-plan 149;
|
||||||
+plan 152;
|
+plan 150;
|
||||||
|
|
||||||
# -------------------- Errors with feature disabled -------------------- #
|
# -------------------- our -------------------- #
|
||||||
|
|
||||||
@@ -967,3 +967,6 @@ like runperl(
|
@@ -957,3 +957,6 @@ like runperl(
|
||||||
{
|
{
|
||||||
my sub h; sub{my $x; sub{h}}
|
my sub h; sub{my $x; sub{h}}
|
||||||
}
|
}
|
|
@ -0,0 +1,127 @@
|
||||||
|
From fed9fe5b48ccdffef9065a03c12c237cc7418de6 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Zefram <zefram@fysh.org>
|
||||||
|
Date: Fri, 16 Feb 2018 17:20:34 +0000
|
||||||
|
Subject: [PATCH] don't clobber file bytes in :encoding layer
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
The PerlIO::encoding layer, when used on input, was creating an SvLEN==0
|
||||||
|
scalar pointing into the byte buffer, to pass to the ->decode method
|
||||||
|
of the encoding object. Since the method mutates this scalar, for some
|
||||||
|
encodings this led to mutating the byte buffer, and depending on where
|
||||||
|
it came from that might be something visible elsewhere that should not
|
||||||
|
be mutated. Remove the code for the SvLEN==0 scalar, instead always
|
||||||
|
using the alternate code that would copy the bytes into a separate buffer
|
||||||
|
owned by the scalar. Fixes [perl #132833].
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/PerlIO-encoding/encoding.pm | 2 +-
|
||||||
|
ext/PerlIO-encoding/encoding.xs | 43 ++++++++++------------------------------
|
||||||
|
ext/PerlIO-encoding/t/encoding.t | 12 ++++++++++-
|
||||||
|
3 files changed, 22 insertions(+), 35 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/PerlIO-encoding/encoding.pm b/ext/PerlIO-encoding/encoding.pm
|
||||||
|
index 08d2df4713..3d740b181a 100644
|
||||||
|
--- a/ext/PerlIO-encoding/encoding.pm
|
||||||
|
+++ b/ext/PerlIO-encoding/encoding.pm
|
||||||
|
@@ -1,7 +1,7 @@
|
||||||
|
package PerlIO::encoding;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
-our $VERSION = '0.25';
|
||||||
|
+our $VERSION = '0.26';
|
||||||
|
our $DEBUG = 0;
|
||||||
|
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
|
||||||
|
|
||||||
|
diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs
|
||||||
|
index bb4754f3d9..941d786266 100644
|
||||||
|
--- a/ext/PerlIO-encoding/encoding.xs
|
||||||
|
+++ b/ext/PerlIO-encoding/encoding.xs
|
||||||
|
@@ -307,42 +307,19 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
|
||||||
|
goto end_of_file;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
- if (SvCUR(e->dataSV)) {
|
||||||
|
- /* something left over from last time - create a normal
|
||||||
|
- SV with new data appended
|
||||||
|
- */
|
||||||
|
- if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
|
||||||
|
- if (e->flags & NEEDS_LINES) {
|
||||||
|
- /* Have to grow buffer */
|
||||||
|
- e->base.bufsiz = use + SvCUR(e->dataSV);
|
||||||
|
- PerlIOEncode_get_base(aTHX_ f);
|
||||||
|
- }
|
||||||
|
- else {
|
||||||
|
- use = e->base.bufsiz - SvCUR(e->dataSV);
|
||||||
|
- }
|
||||||
|
- }
|
||||||
|
- sv_catpvn(e->dataSV,(char*)ptr,use);
|
||||||
|
- }
|
||||||
|
- else {
|
||||||
|
- /* Create a "dummy" SV to represent the available data from layer below */
|
||||||
|
- if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
|
||||||
|
- Safefree(SvPVX_mutable(e->dataSV));
|
||||||
|
- }
|
||||||
|
- if (use > (SSize_t)e->base.bufsiz) {
|
||||||
|
- if (e->flags & NEEDS_LINES) {
|
||||||
|
- /* Have to grow buffer */
|
||||||
|
- e->base.bufsiz = use;
|
||||||
|
- PerlIOEncode_get_base(aTHX_ f);
|
||||||
|
- }
|
||||||
|
- else {
|
||||||
|
- use = e->base.bufsiz;
|
||||||
|
+ if (!SvCUR(e->dataSV))
|
||||||
|
+ SvPVCLEAR(e->dataSV);
|
||||||
|
+ if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
|
||||||
|
+ if (e->flags & NEEDS_LINES) {
|
||||||
|
+ /* Have to grow buffer */
|
||||||
|
+ e->base.bufsiz = use + SvCUR(e->dataSV);
|
||||||
|
+ PerlIOEncode_get_base(aTHX_ f);
|
||||||
|
}
|
||||||
|
+ else {
|
||||||
|
+ use = e->base.bufsiz - SvCUR(e->dataSV);
|
||||||
|
}
|
||||||
|
- SvPV_set(e->dataSV, (char *) ptr);
|
||||||
|
- SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
|
||||||
|
- SvCUR_set(e->dataSV,use);
|
||||||
|
- SvPOK_only(e->dataSV);
|
||||||
|
}
|
||||||
|
+ sv_catpvn(e->dataSV,(char*)ptr,use);
|
||||||
|
SvUTF8_off(e->dataSV);
|
||||||
|
PUSHMARK(sp);
|
||||||
|
XPUSHs(e->enc);
|
||||||
|
diff --git a/ext/PerlIO-encoding/t/encoding.t b/ext/PerlIO-encoding/t/encoding.t
|
||||||
|
index 088f89ee20..41cefcb137 100644
|
||||||
|
--- a/ext/PerlIO-encoding/t/encoding.t
|
||||||
|
+++ b/ext/PerlIO-encoding/t/encoding.t
|
||||||
|
@@ -16,7 +16,7 @@ BEGIN {
|
||||||
|
require "../../t/charset_tools.pl";
|
||||||
|
}
|
||||||
|
|
||||||
|
-use Test::More tests => 24;
|
||||||
|
+use Test::More tests => 27;
|
||||||
|
|
||||||
|
my $grk = "grk$$";
|
||||||
|
my $utf = "utf$$";
|
||||||
|
@@ -231,6 +231,16 @@ is $x, "To hymn him who heard her herd herd\n",
|
||||||
|
|
||||||
|
} # SKIP
|
||||||
|
|
||||||
|
+# decoding shouldn't mutate the original bytes [perl #132833]
|
||||||
|
+{
|
||||||
|
+ my $b = "a\0b\0\n\0";
|
||||||
|
+ open my $fh, "<:encoding(UTF16-LE)", \$b or die;
|
||||||
|
+ is scalar(<$fh>), "ab\n";
|
||||||
|
+ is $b, "a\0b\0\n\0";
|
||||||
|
+ close $fh or die;
|
||||||
|
+ is $b, "a\0b\0\n\0";
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
END {
|
||||||
|
1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
|
@ -0,0 +1,68 @@
|
||||||
|
From 823ba440369100de3f2693420a3887a645a57d28 Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Wed, 7 Mar 2018 09:27:26 +0000
|
||||||
|
Subject: [PATCH] fix line numbers in multi-line s///
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
my commit v5.25.6-230-g6432a58, "Eliminate SVrepl_EVAL and SvEVALED()",
|
||||||
|
introduced a regression: __LINE__ no longer took account of multiple
|
||||||
|
lines in the s///.
|
||||||
|
|
||||||
|
Now fixed.
|
||||||
|
|
||||||
|
Spotted by Abigail.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/re/subst.t | 12 +++++++++++-
|
||||||
|
toke.c | 2 +-
|
||||||
|
2 files changed, 12 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/re/subst.t b/t/re/subst.t
|
||||||
|
index b9b9939b11..dd62e95ee6 100644
|
||||||
|
--- a/t/re/subst.t
|
||||||
|
+++ b/t/re/subst.t
|
||||||
|
@@ -11,7 +11,7 @@ BEGIN {
|
||||||
|
require './loc_tools.pl';
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan(tests => 275);
|
||||||
|
+plan(tests => 276);
|
||||||
|
|
||||||
|
$_ = 'david';
|
||||||
|
$a = s/david/rules/r;
|
||||||
|
@@ -1163,6 +1163,16 @@ __EOF__
|
||||||
|
pass("RT #130188");
|
||||||
|
}
|
||||||
|
|
||||||
|
+# RT #131930
|
||||||
|
+# a multi-line s/// wasn't resetting the cop_line correctly
|
||||||
|
+{
|
||||||
|
+ my $l0 = __LINE__;
|
||||||
|
+ my $s = "a";
|
||||||
|
+ $s =~ s[a]
|
||||||
|
+ [b];
|
||||||
|
+ my $lines = __LINE__ - $l0;
|
||||||
|
+ is $lines, 4, "RT #131930";
|
||||||
|
+}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index 9dbad98408..0ef33415c0 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -9884,7 +9884,7 @@ S_scan_subst(pTHX_ char *start)
|
||||||
|
* the NVX field indicates how many src code lines the replacement
|
||||||
|
* spreads over */
|
||||||
|
sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
|
||||||
|
- ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
|
||||||
|
+ ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
|
||||||
|
((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
|
||||||
|
cBOOL(es);
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
|
@ -0,0 +1,113 @@
|
||||||
|
From 381d51822fccaa333cbd0ab9fca8b69f650c05f9 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Fri, 14 Feb 2020 14:10:10 +0100
|
||||||
|
Subject: [PATCH] Only pass 2-digit years to tests when testing 2-digit year
|
||||||
|
handling
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This will start breaking in 2020 if done without working around the whole
|
||||||
|
breakpoint thing. See https://rt.cpan.org/Ticket/Display.html?id=124787.
|
||||||
|
|
||||||
|
Ported from Time-Local 63265fd81c7f6177bf28dfe0d1ada9cb897de566 commit
|
||||||
|
by Dave Rolsky <autarch@urth.org> to perl 5.28.2.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
cpan/Time-Local/t/Local.t | 40 +++++++++++++++++++++++++++++----------
|
||||||
|
1 file changed, 30 insertions(+), 10 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/cpan/Time-Local/t/Local.t b/cpan/Time-Local/t/Local.t
|
||||||
|
index 6341396..701d22d 100644
|
||||||
|
--- a/cpan/Time-Local/t/Local.t
|
||||||
|
+++ b/cpan/Time-Local/t/Local.t
|
||||||
|
@@ -85,19 +85,17 @@ my $epoch_is_64
|
||||||
|
|
||||||
|
for ( @time, @neg_time ) {
|
||||||
|
my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
|
||||||
|
- $year -= 1900;
|
||||||
|
$mon--;
|
||||||
|
|
||||||
|
SKIP: {
|
||||||
|
skip '1970 test on VOS fails.', 12
|
||||||
|
- if $^O eq 'vos' && $year == 70;
|
||||||
|
+ if $^O eq 'vos' && $year == 1970;
|
||||||
|
skip 'this platform does not support negative epochs.', 12
|
||||||
|
- if $year < 70 && !$neg_epoch_ok;
|
||||||
|
+ if $year < 1970 && !$neg_epoch_ok;
|
||||||
|
|
||||||
|
# Test timelocal()
|
||||||
|
{
|
||||||
|
- my $year_in = $year < 70 ? $year + 1900 : $year;
|
||||||
|
- my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year_in );
|
||||||
|
+ my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year );
|
||||||
|
|
||||||
|
my ( $s, $m, $h, $D, $M, $Y ) = localtime($time);
|
||||||
|
|
||||||
|
@@ -106,13 +104,12 @@ SKIP: {
|
||||||
|
is( $h, $hour, "timelocal hour for @$_" );
|
||||||
|
is( $D, $mday, "timelocal day for @$_" );
|
||||||
|
is( $M, $mon, "timelocal month for @$_" );
|
||||||
|
- is( $Y, $year, "timelocal year for @$_" );
|
||||||
|
+ is( $Y, $year - 1900, "timelocal year for @$_" );
|
||||||
|
}
|
||||||
|
|
||||||
|
# Test timegm()
|
||||||
|
{
|
||||||
|
- my $year_in = $year < 70 ? $year + 1900 : $year;
|
||||||
|
- my $time = timegm( $sec, $min, $hour, $mday, $mon, $year_in );
|
||||||
|
+ my $time = timegm( $sec, $min, $hour, $mday, $mon, $year );
|
||||||
|
|
||||||
|
my ( $s, $m, $h, $D, $M, $Y ) = gmtime($time);
|
||||||
|
|
||||||
|
@@ -121,14 +118,13 @@ SKIP: {
|
||||||
|
is( $h, $hour, "timegm hour for @$_" );
|
||||||
|
is( $D, $mday, "timegm day for @$_" );
|
||||||
|
is( $M, $mon, "timegm month for @$_" );
|
||||||
|
- is( $Y, $year, "timegm year for @$_" );
|
||||||
|
+ is( $Y, $year - 1900, "timegm year for @$_" );
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
for (@bad_time) {
|
||||||
|
my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
|
||||||
|
- $year -= 1900;
|
||||||
|
$mon--;
|
||||||
|
|
||||||
|
eval { timegm( $sec, $min, $hour, $mday, $mon, $year ) };
|
||||||
|
@@ -229,6 +225,30 @@ SKIP:
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
+# 2-digit years
|
||||||
|
+{
|
||||||
|
+ my $current_year = ( localtime() )[5];
|
||||||
|
+ my $pre_break = ( $current_year + 49 ) - 100;
|
||||||
|
+ my $break = ( $current_year + 50 ) - 100;
|
||||||
|
+ my $post_break = ( $current_year + 51 ) - 100;
|
||||||
|
+
|
||||||
|
+ is(
|
||||||
|
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $pre_break ) ) )[5] ),
|
||||||
|
+ $pre_break + 100,
|
||||||
|
+ "year $pre_break is treated as next century",
|
||||||
|
+ );
|
||||||
|
+ is(
|
||||||
|
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $break ) ) )[5] ),
|
||||||
|
+ $break + 100,
|
||||||
|
+ "year $break is treated as next century",
|
||||||
|
+ );
|
||||||
|
+ is(
|
||||||
|
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $post_break ) ) )[5] ),
|
||||||
|
+ $post_break,
|
||||||
|
+ "year $post_break is treated as current century",
|
||||||
|
+ );
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
SKIP:
|
||||||
|
{
|
||||||
|
skip 'These tests only run for the package maintainer.', 8
|
||||||
|
--
|
||||||
|
2.21.1
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
From 0711044bfd02bbd7d2967ba96c6fdcae5b7132d6 Mon Sep 17 00:00:00 2001
|
From 892e8b006aa99ac2c880cdc2a81fd16f06c1a0f3 Mon Sep 17 00:00:00 2001
|
||||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
Date: Mon, 9 Jul 2018 16:18:36 +0200
|
Date: Mon, 9 Jul 2018 16:18:36 +0200
|
||||||
Subject: [PATCH] Remove ext/GDBM_File/t/fatal.t
|
Subject: [PATCH] Remove ext/GDBM_File/t/fatal.t
|
||||||
|
@ -23,10 +23,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
delete mode 100644 ext/GDBM_File/t/fatal.t
|
delete mode 100644 ext/GDBM_File/t/fatal.t
|
||||||
|
|
||||||
diff --git a/MANIFEST b/MANIFEST
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
index a1a5320..ed5d05f 100644
|
index 95fa539095..b07fed1f54 100644
|
||||||
--- a/MANIFEST
|
--- a/MANIFEST
|
||||||
+++ b/MANIFEST
|
+++ b/MANIFEST
|
||||||
@@ -3719,7 +3719,6 @@ ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
|
@@ -4100,7 +4100,6 @@ ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
|
||||||
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
|
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
|
||||||
ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
|
ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
|
||||||
ext/GDBM_File/Makefile.PL GDBM extension makefile writer
|
ext/GDBM_File/Makefile.PL GDBM extension makefile writer
|
||||||
|
@ -36,7 +36,7 @@ index a1a5320..ed5d05f 100644
|
||||||
ext/Hash-Util/Changes Change history of Hash::Util
|
ext/Hash-Util/Changes Change history of Hash::Util
|
||||||
diff --git a/ext/GDBM_File/t/fatal.t b/ext/GDBM_File/t/fatal.t
|
diff --git a/ext/GDBM_File/t/fatal.t b/ext/GDBM_File/t/fatal.t
|
||||||
deleted file mode 100644
|
deleted file mode 100644
|
||||||
index b7045ba..0000000
|
index 0e426d4dbc..0000000000
|
||||||
--- a/ext/GDBM_File/t/fatal.t
|
--- a/ext/GDBM_File/t/fatal.t
|
||||||
+++ /dev/null
|
+++ /dev/null
|
||||||
@@ -1,49 +0,0 @@
|
@@ -1,49 +0,0 @@
|
||||||
|
@ -60,7 +60,7 @@ index b7045ba..0000000
|
||||||
-
|
-
|
||||||
-unlink <Op_dbmx*>;
|
-unlink <Op_dbmx*>;
|
||||||
-
|
-
|
||||||
-open my $fh, $^X or die "Can't open $^X: $!";
|
-open my $fh, '<', $^X or die "Can't open $^X: $!";
|
||||||
-my $fileno = fileno $fh;
|
-my $fileno = fileno $fh;
|
||||||
-isnt($fileno, undef, "Can find next available file descriptor");
|
-isnt($fileno, undef, "Can find next available file descriptor");
|
||||||
-close $fh or die $!;
|
-close $fh or die $!;
|
|
@ -0,0 +1,32 @@
|
||||||
|
From e1a2878a55b1a7f11f19b384c4ea5235c29866b2 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Mon, 11 Jun 2018 13:28:53 -0600
|
||||||
|
Subject: [PATCH] regexec.c: Call macro with correct args.
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
The second argument to this macro is a pointer to the end, as opposed to
|
||||||
|
a length.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regexec.c | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/regexec.c b/regexec.c
|
||||||
|
index 7ed8f4fabc..ba52ae97c7 100644
|
||||||
|
--- a/regexec.c
|
||||||
|
+++ b/regexec.c
|
||||||
|
@@ -1808,7 +1808,7 @@ STMT_START {
|
||||||
|
case trie_flu8: \
|
||||||
|
_CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
|
||||||
|
if (UTF8_IS_ABOVE_LATIN1(*uc)) { \
|
||||||
|
- _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end - uc); \
|
||||||
|
+ _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end); \
|
||||||
|
} \
|
||||||
|
goto do_trie_utf8_fold; \
|
||||||
|
case trie_utf8_exactfa_fold: \
|
||||||
|
--
|
||||||
|
2.14.4
|
||||||
|
|
|
@ -0,0 +1,22 @@
|
||||||
|
From 70f089724b15d1b2ed9264f277454aa559d50232 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Fri, 15 Nov 2019 15:01:15 -0700
|
||||||
|
Subject: [PATCH] PATCH: gh#17218 memory leak
|
||||||
|
|
||||||
|
Indeed, a variable's ref count was not getting decremented.
|
||||||
|
---
|
||||||
|
regcomp.c | 1 +
|
||||||
|
1 file changed, 1 insertion(+)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index ddac290d2bf0..de4f6f24dac8 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -17602,6 +17602,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
|
||||||
|
|
||||||
|
/* Likewise for 'posixes' */
|
||||||
|
_invlist_union(posixes, cp_list, &cp_list);
|
||||||
|
+ SvREFCNT_dec(posixes);
|
||||||
|
|
||||||
|
/* Likewise for anything else in the range that matched only
|
||||||
|
* under UTF-8 */
|
|
@ -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
|
PERM_DIR PERM_RW PERM_RWX MAGICXS
|
||||||
PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
|
PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
|
||||||
PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
|
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 VERSION VERSION_FROM XS
|
||||||
+ SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST USE_MM_LD_RUN_PATH VERSION VERSION_FROM XS XSOPT XSPROTOARG
|
+ SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST USE_MM_LD_RUN_PATH VERSION VERSION_FROM XS
|
||||||
XS_VERSION clean depend dist dynamic_lib linkext macro realclean
|
XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION
|
||||||
tool_autosplit
|
clean depend dist dynamic_lib linkext macro realclean tool_autosplit
|
||||||
|
|
||||||
@@ -422,7 +422,27 @@ sub new {
|
@@ -422,7 +422,27 @@ sub new {
|
||||||
# PRINT_PREREQ is RedHatism.
|
# 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 = "";
|
my $ld_run_path_shell = "";
|
||||||
- if ($self->{LD_RUN_PATH} ne "") {
|
- if ($self->{LD_RUN_PATH} ne "") {
|
||||||
+ if (($self->{LD_RUN_PATH} ne "") && ($self->{USE_MM_LD_RUN_PATH})) {
|
+ 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)" ';
|
||||||
}
|
}
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
29
STAGE2-perl
29
STAGE2-perl
|
@ -1,29 +0,0 @@
|
||||||
#requires gdbm
|
|
||||||
|
|
||||||
mcd $BUILDDIR/perl
|
|
||||||
|
|
||||||
GV=$(cd $SRC; echo perl-*)
|
|
||||||
SONAME_VER=`echo $GV | cut -f2- -d'-' | sed 's/^\\([^.]*\\.[^.]*\\).*/\\1/'`
|
|
||||||
PERL_VER=`echo $GV | cut -f2- -d'-'`
|
|
||||||
|
|
||||||
cd $SRC/$GV
|
|
||||||
|
|
||||||
sh $SRC/$GV/Configure -des -Dprefix=/usr -Dlibpth="/usr/local/lib$SUFFIX /lib$SUFFIX /usr/lib$SUFFIX" -Darchlib="/usr/lib$SUFFIX/perl5" -Dsitelib="/usr/local/share/perl5" -DDEBUGGING=-g -Dcc=gcc -Dmyhostname=localhost -Dperladmin=root@localhost -Duseshrplib -Dusethreads -Duseithreads -Uusedtrace -Duselargefiles -Dd_semctl_semun -Di_db -Ui_ndbm -Di_gdbm -Di_shadow -Di_syslog -Dman3ext=3pm -Duseperlio -Dinstallusrbinperl=n -Ubincompat5005 -Uversiononly -Dd_gethostent_r_proto -Ud_endhostent_r_proto -Ud_sethostent_r_proto -Ud_endprotoent_r_proto -Ud_setprotoent_r_proto -Ud_endservent_r_proto -Ud_setservent_r_proto
|
|
||||||
|
|
||||||
BUILD_BZIP2=0
|
|
||||||
BZIP2_LIB=%{_libdir}
|
|
||||||
export BUILD_BZIP2 BZIP2_LIB
|
|
||||||
|
|
||||||
ln -sf libperl.so libperl.so.${SONAME_VER}
|
|
||||||
|
|
||||||
make
|
|
||||||
|
|
||||||
rm -f /usr/lib${SUFFIX}/perl5/CORE/libperl.so
|
|
||||||
|
|
||||||
make install
|
|
||||||
|
|
||||||
rm -f /usr/lib${SUFFIX}/libperl.so.${PERL_VER}
|
|
||||||
mv /usr/lib${SUFFIX}/perl5/CORE/libperl.so /usr/lib${SUFFIX}/libperl.so.${PERL_VER}
|
|
||||||
ln -sf libperl.so.${PERL_VER} /usr/lib${SUFFIX}/libperl.so.${SONAME_VER}
|
|
||||||
ln -sf libperl.so.${PERL_VER} /usr/lib${SUFFIX}/libperl.so
|
|
||||||
ln -sf libperl.so.${PERL_VER} /usr/lib${SUFFIX}/perl5/CORE/libperl.so
|
|
|
@ -1,11 +0,0 @@
|
||||||
#!/bin/bash
|
|
||||||
for P in "$@"; do
|
|
||||||
echo "Empty directories in RPM package $P:"
|
|
||||||
|
|
||||||
for D in $(rpm -qlvp "$P" | \
|
|
||||||
perl -ne \
|
|
||||||
'if (/\Adrwx/) {$n=${[split /\s+/]}[8]; print qq{$n\n}}' | \
|
|
||||||
sort -f); do
|
|
||||||
test $(rpm -qlp "$P" | grep -c -F "$D/") == 0 && echo "$D";
|
|
||||||
done
|
|
||||||
done
|
|
|
@ -1,93 +0,0 @@
|
||||||
#!/usr/bin/perl
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
|
|
||||||
use RPM2;
|
|
||||||
|
|
||||||
for my $rpm_file (@ARGV) {
|
|
||||||
my $package = RPM2->open_package($rpm_file)
|
|
||||||
or die q{Could not open `} . $rpm_file . q{'.};
|
|
||||||
|
|
||||||
my $package_name = $package->tag('NAME');
|
|
||||||
my $package_version = $package->tag('VERSION');
|
|
||||||
|
|
||||||
my $module_name = $package_name;
|
|
||||||
$module_name =~ s/^([^-]+)-(.*)/$1($2)/;
|
|
||||||
$module_name =~ s/-/::/g;
|
|
||||||
|
|
||||||
my @names = $package->tag('PROVIDENAME');
|
|
||||||
my @flags = $package->tag('PROVIDEFLAGS');
|
|
||||||
my @versions = $package->tag('PROVIDEVERSION');
|
|
||||||
if (!($#names == $#flags) && ($#names == $#versions)) {
|
|
||||||
die (q{Inconsistent number of provides names, flags, and versions in `}
|
|
||||||
. $rpm_file . q{'.});
|
|
||||||
}
|
|
||||||
|
|
||||||
my $found = 0;
|
|
||||||
for my $name (@names) {
|
|
||||||
my $flag = shift @flags;
|
|
||||||
my $version = shift @versions;
|
|
||||||
if ($name eq $module_name) {
|
|
||||||
$found = 1;
|
|
||||||
|
|
||||||
if (($flag & 0x8) && (($flag & (0x2+0x4)) == 0)) {
|
|
||||||
if (!($package_version eq $version)) {
|
|
||||||
print $rpm_file . q{: Package version `} .
|
|
||||||
$package_version . q{' differs from `} .
|
|
||||||
$module_name . q{' module version `} .
|
|
||||||
$version . q{'.} . "\n";
|
|
||||||
}
|
|
||||||
last;
|
|
||||||
} else {
|
|
||||||
print $rpm_file . q{: `} . $module_name .
|
|
||||||
q{' in list of provides is not qualified (};
|
|
||||||
printf '0x%x', $flag;
|
|
||||||
print q{) as equaled.} . "\n";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($found == 0) {
|
|
||||||
print $rpm_file . q{: missing `} . $module_name .
|
|
||||||
q{' in list of provides.} . "\n";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
__END__
|
|
||||||
=encoding utf8
|
|
||||||
|
|
||||||
=head1 NAME
|
|
||||||
|
|
||||||
checkpackageversion - Check a RPM package version matches main Perl module
|
|
||||||
version
|
|
||||||
|
|
||||||
=head1 SYNOPSIS
|
|
||||||
|
|
||||||
checkpackageversion RPM_PACKAGE...
|
|
||||||
|
|
||||||
It opens each RPM_PACKAGE, guesses a main Perl module from package name, finds
|
|
||||||
it in list of provides (e.g. perl-Foo-Bar → perl(Foo::Bar) and compares
|
|
||||||
versions. It reports any irregularities to standard output.
|
|
||||||
|
|
||||||
Petr Písař <ppisar@redhat.com>
|
|
||||||
|
|
||||||
=head1 COPYING
|
|
||||||
|
|
||||||
Copyright (C) 2011 Petr Písař <ppisar@redhat.com>
|
|
||||||
|
|
||||||
This program is free software: you can redistribute it and/or modify
|
|
||||||
it under the terms of the GNU General Public License as published by
|
|
||||||
the Free Software Foundation, either version 3 of the License, or
|
|
||||||
(at your option) any later version.
|
|
||||||
|
|
||||||
This program is distributed in the hope that it will be useful,
|
|
||||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
GNU General Public License for more details.
|
|
||||||
|
|
||||||
You should have received a copy of the GNU General Public License
|
|
||||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
=cut
|
|
||||||
|
|
|
@ -1,39 +0,0 @@
|
||||||
#!/usr/bin/perl -w
|
|
||||||
use strict;
|
|
||||||
|
|
||||||
my ($arch, $patfile, $infile, $outfile, $libdir, $thread_arch) = @ARGV;
|
|
||||||
|
|
||||||
if (not $arch or not $patfile or not $infile or not $outfile or not $libdir) {
|
|
||||||
die "Usage: $0 arch thread_arch pattern-file in-file out-file libdir [ threadarch ]";
|
|
||||||
}
|
|
||||||
|
|
||||||
$thread_arch ||= '';
|
|
||||||
|
|
||||||
open IN, "<$infile"
|
|
||||||
or die "Can't open $infile: $!";
|
|
||||||
open OUT, ">$outfile"
|
|
||||||
or die "Can't open $outfile: $!";
|
|
||||||
open PATTERN, "<$patfile"
|
|
||||||
or die "Can't open $patfile: $!";
|
|
||||||
|
|
||||||
my @patterns = <PATTERN>;
|
|
||||||
chomp @patterns;
|
|
||||||
for my $p (@patterns) {
|
|
||||||
$p =~ s/%{_libdir}/$libdir/g;
|
|
||||||
$p =~ s/%{_arch}/$arch/g;
|
|
||||||
$p =~ s/%{thread_arch}/$thread_arch/g;
|
|
||||||
}
|
|
||||||
|
|
||||||
my %exclude = map { $_ => 1 } @patterns;
|
|
||||||
|
|
||||||
close PATTERN;
|
|
||||||
|
|
||||||
while(<IN>) {
|
|
||||||
chomp;
|
|
||||||
|
|
||||||
print OUT "$_\n"
|
|
||||||
unless exists $exclude{$_}
|
|
||||||
}
|
|
||||||
|
|
||||||
close IN;
|
|
||||||
close OUT;
|
|
33
diffrpms
33
diffrpms
|
@ -1,33 +0,0 @@
|
||||||
#!/bin/bash
|
|
||||||
|
|
||||||
if [ "$#" != 2 ]; then
|
|
||||||
cat<<EOM
|
|
||||||
Usage: $(basename $0) OLD_RELEASE NEW_RELEASE
|
|
||||||
|
|
||||||
Compares corresponding RPM packages produced in OLD_RELASE and NEW_RELEASE.
|
|
||||||
The same version strings are assumed.
|
|
||||||
EOM
|
|
||||||
exit 1;
|
|
||||||
fi
|
|
||||||
|
|
||||||
OLD_RELEASE="$1"
|
|
||||||
NEW_RELEASE="$2"
|
|
||||||
|
|
||||||
function process_dir() {
|
|
||||||
for F in $(ls $1/* | sed -r 's/-[0-9].*//' | sort | uniq ); do
|
|
||||||
OLD_RPM=$(echo ${F}-[0-9]*-${OLD_RELEASE}.*)
|
|
||||||
NEW_RPM=$(echo ${F}-[0-9]*-${NEW_RELEASE}.*)
|
|
||||||
|
|
||||||
test \( ! -e "$OLD_RPM" \) -a \( ! -e "$NEW_RPM" \) && continue
|
|
||||||
if [ ! -e "$OLD_RPM" ]; then echo "+ Package ${F}"; continue; fi
|
|
||||||
if [ ! -e "$NEW_RPM" ]; then echo "- Package ${F}"; continue; fi
|
|
||||||
|
|
||||||
DIFF=$(rpmdiff -i S -i 5 -i T "$OLD_RPM" "$NEW_RPM" | \
|
|
||||||
grep -vE 'REQUIRES perl = | REQUIRES rpmlib\(' )
|
|
||||||
|
|
||||||
test -n "$DIFF" && printf '* %s:\n%s\n' "$F" "$DIFF"
|
|
||||||
done
|
|
||||||
}
|
|
||||||
|
|
||||||
process_dir 'x86_64'
|
|
||||||
process_dir 'noarch'
|
|
10
gating.yaml
10
gating.yaml
|
@ -1,10 +0,0 @@
|
||||||
--- !Policy
|
|
||||||
product_versions:
|
|
||||||
- rhel-9
|
|
||||||
decision_context: osci_compose_gate
|
|
||||||
rules:
|
|
||||||
- !PassingTestCaseRule {test_case_name: baseos-ci.brew-build.acceptance-tier.functional}
|
|
||||||
- !PassingTestCaseRule {test_case_name: baseos-ci.brew-build.tier1.functional}
|
|
||||||
- !PassingTestCaseRule {test_case_name: baseos-ci.brew-build.tier2.functional}
|
|
||||||
- !PassingTestCaseRule {test_case_name: baseos-ci.brew-build.tier3.functional}
|
|
||||||
- !PassingTestCaseRule {test_case_name: baseos-ci.brew-build.tiers-no-perlcore.functional}
|
|
|
@ -1,163 +0,0 @@
|
||||||
#!/usr/bin/perl
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
|
|
||||||
# Split "A B >= 1" dependencies string into ("A", "B >= 1") list.
|
|
||||||
sub appendsymbols {
|
|
||||||
my ($array, $line) = @_;
|
|
||||||
my $qualified;
|
|
||||||
my $dependency;
|
|
||||||
for my $token (split(/\s/, $line)) {
|
|
||||||
if ($token =~ /\A[<>]?=\z/) {
|
|
||||||
$qualified = 1;
|
|
||||||
$dependency .= ' ' . $token;
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
if (!$qualified) {
|
|
||||||
if (defined $dependency) {
|
|
||||||
push @$array, $dependency;
|
|
||||||
}
|
|
||||||
$dependency = $token;
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
if ($qualified) {
|
|
||||||
$qualified = 0;
|
|
||||||
$dependency .= ' ' . $token;
|
|
||||||
push @$array, $dependency;
|
|
||||||
$dependency = undef;
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (defined $dependency) {
|
|
||||||
push @$array, $dependency;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
# Return true if the argument is a Perl dependency. Otherwise return false.
|
|
||||||
sub is_perl_dependency {
|
|
||||||
my $dependency = shift;
|
|
||||||
return ($dependency =~ /\Aperl\(/);
|
|
||||||
}
|
|
||||||
|
|
||||||
my $file = shift @ARGV;
|
|
||||||
if (!defined $file) {
|
|
||||||
die "Missing an argument with an RPM build log!\n"
|
|
||||||
}
|
|
||||||
|
|
||||||
# Parse build log
|
|
||||||
open(my $log, '<', $file) or die "Could not open `$file': $!\n";
|
|
||||||
my ($package, %packages);
|
|
||||||
while (!eof($log)) {
|
|
||||||
defined($_ = <$log>) or die "Error while reading from `$file': $!\n";
|
|
||||||
chomp;
|
|
||||||
|
|
||||||
if (/\AProcessing files: ([\S]+)-[^-]+-[^-]+$/) {
|
|
||||||
$package = $1;
|
|
||||||
$packages{$package}{requires} = [];
|
|
||||||
$packages{$package}{provides} = [];
|
|
||||||
} elsif ($package && /\AProvides: (.*)\z/) {
|
|
||||||
appendsymbols($packages{$package}{provides}, $1);
|
|
||||||
} elsif ($package && /\ARequires: (.*)\z/) {
|
|
||||||
appendsymbols($packages{$package}{requires}, $1);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
close($log);
|
|
||||||
|
|
||||||
# Save dependencies into file
|
|
||||||
my $filename = 'gendep.macros';
|
|
||||||
open (my $gendep, '>', $filename) or
|
|
||||||
die "Could not open `$filename' for writing: $!\n";
|
|
||||||
for my $package (sort keys %packages) {
|
|
||||||
# Macro name
|
|
||||||
my $macro = 'gendep_' . $package;
|
|
||||||
$macro =~ s/[+-]/_/g;
|
|
||||||
$gendep->print("%global $macro \\\n");
|
|
||||||
# Macro value
|
|
||||||
for my $dependency (@{$packages{$package}{requires}}) {
|
|
||||||
if (is_perl_dependency($dependency)) {
|
|
||||||
$gendep->print("Requires: $dependency \\\n");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
for my $dependency (@{$packages{$package}{provides}}) {
|
|
||||||
if (is_perl_dependency($dependency)) {
|
|
||||||
$gendep->print("Provides: $dependency \\\n");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
# Macro trailer
|
|
||||||
$gendep->print("%{nil}\n");
|
|
||||||
}
|
|
||||||
close($gendep) or die "Could not close `$filename': $!\n";
|
|
||||||
|
|
||||||
|
|
||||||
__END__
|
|
||||||
=encoding utf8
|
|
||||||
|
|
||||||
=head1 NAME
|
|
||||||
|
|
||||||
generatedependencies - Distil generated Perl dependencies from a build log
|
|
||||||
|
|
||||||
=head1 SYNOPSIS
|
|
||||||
|
|
||||||
B<generatedependencies> I<BUILD_LOG>
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
It opens specified RPM build log I<BUILD_LOG>. It locates a protocol about
|
|
||||||
autogenerated dependencies. It stores the reported dependencies into F<./gendep.macros> file.
|
|
||||||
|
|
||||||
The output file will define macros C<gendep_I<BINARY_PACKAGE_NAME>>. A macro
|
|
||||||
for each binary package. The macro name will use underscores instead of
|
|
||||||
hyphens or other SPEC language special characters.
|
|
||||||
|
|
||||||
It will ignore non-Perl dependencies (not C<perl(*)>) as they do not come from
|
|
||||||
Perl dependency generator.
|
|
||||||
|
|
||||||
=head1 EXIT CODE
|
|
||||||
|
|
||||||
Returns zero, if no error occurred. Otherwise non-zero code is returned.
|
|
||||||
|
|
||||||
=head1 EXAMPLE
|
|
||||||
|
|
||||||
The invocation is:
|
|
||||||
|
|
||||||
$ generatedependencies .build-5.24.0-364.fc25.log
|
|
||||||
|
|
||||||
The output is:
|
|
||||||
|
|
||||||
$ grep -A5 perl_Devel_Peek gendep.macros
|
|
||||||
%global gendep_perl_Devel_Peek \
|
|
||||||
Requires: perl(Exporter) \
|
|
||||||
Requires: perl(XSLoader) \
|
|
||||||
Provides: perl(Devel::Peek) = 1.23 \
|
|
||||||
%nil{}
|
|
||||||
%global gendep_perl_Devel_SelfStubber \
|
|
||||||
|
|
||||||
|
|
||||||
The output can be used in a spec file like:
|
|
||||||
|
|
||||||
Name: perl
|
|
||||||
Source0: gendep.macros
|
|
||||||
%include %{SOURCE0}
|
|
||||||
%package Devel-Peek
|
|
||||||
%gendep_Devel_Peek
|
|
||||||
%package Devel-SelfStubber
|
|
||||||
%gendep_Devel_SelfStubber
|
|
||||||
|
|
||||||
=head1 COPYING
|
|
||||||
|
|
||||||
Copyright (C) 2016 Petr Písař <ppisar@redhat.com>
|
|
||||||
|
|
||||||
This program is free software: you can redistribute it and/or modify
|
|
||||||
it under the terms of the GNU General Public License as published by
|
|
||||||
the Free Software Foundation, either version 3 of the License, or
|
|
||||||
(at your option) any later version.
|
|
||||||
|
|
||||||
This program is distributed in the hope that it will be useful,
|
|
||||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
GNU General Public License for more details.
|
|
||||||
|
|
||||||
You should have received a copy of the GNU General Public License
|
|
||||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
=cut
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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 => 271 );
|
|
||||||
+plan( tests => 272 );
|
|
||||||
|
|
||||||
$_ = 'david';
|
|
||||||
$a = s/david/rules/r;
|
|
||||||
@@ -1119,3 +1119,15 @@ SKIP: {
|
|
||||||
{stderr => 1 },
|
|
||||||
'[perl #129038 ] s/\xff//l no longer crashes');
|
|
||||||
}
|
|
||||||
+
|
|
||||||
+# [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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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 => 26);
|
|
||||||
+plan(tests => 27);
|
|
||||||
|
|
||||||
{
|
|
||||||
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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -1,116 +0,0 @@
|
||||||
From b0254cedee2517d2705070839549189cf9f72db4 Mon Sep 17 00:00:00 2001
|
|
||||||
From: David Mitchell <davem@iabyn.com>
|
|
||||||
Date: Fri, 16 Jun 2017 15:46:19 +0100
|
|
||||||
Subject: [PATCH] don't call Perl_fbm_instr() with negative length
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Ported to 5.24.1:
|
|
||||||
|
|
||||||
commit bb152a4b442f7718fd37d32cc558be675e8ae1ae
|
|
||||||
Author: David Mitchell <davem@iabyn.com>
|
|
||||||
Date: Fri Jun 16 15:46:19 2017 +0100
|
|
||||||
|
|
||||||
don't call Perl_fbm_instr() with negative length
|
|
||||||
|
|
||||||
RT #131575
|
|
||||||
|
|
||||||
re_intuit_start() could calculate a maximum end position less than the
|
|
||||||
current start position. This used to get rejected by fbm_intr(), until
|
|
||||||
v5.23.3-110-g147f21b, which made fbm_intr() faster and removed unnecessary
|
|
||||||
checks.
|
|
||||||
|
|
||||||
This commits fixes re_intuit_start(), and adds an assert to fbm_intr().
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
regexec.c | 17 +++++++++++------
|
|
||||||
t/re/pat.t | 13 ++++++++++++-
|
|
||||||
util.c | 2 ++
|
|
||||||
3 files changed, 25 insertions(+), 7 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/regexec.c b/regexec.c
|
|
||||||
index f1a52ab..3080880 100644
|
|
||||||
--- a/regexec.c
|
|
||||||
+++ b/regexec.c
|
|
||||||
@@ -127,13 +127,16 @@ static const char* const non_utf8_target_but_utf8_required
|
|
||||||
(U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \
|
|
||||||
: (U8*)(pos + off))
|
|
||||||
|
|
||||||
-#define HOPBACKc(pos, off) \
|
|
||||||
- (char*)(reginfo->is_utf8_target \
|
|
||||||
- ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(reginfo->strbeg)) \
|
|
||||||
- : (pos - off >= reginfo->strbeg) \
|
|
||||||
- ? (U8*)pos - off \
|
|
||||||
+/* like HOPMAYBE3 but backwards. lim must be +ve. Returns NULL on overshoot */
|
|
||||||
+#define HOPBACK3(pos, off, lim) \
|
|
||||||
+ (reginfo->is_utf8_target \
|
|
||||||
+ ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(lim)) \
|
|
||||||
+ : (pos - off >= lim) \
|
|
||||||
+ ? (U8*)pos - off \
|
|
||||||
: NULL)
|
|
||||||
|
|
||||||
+#define HOPBACKc(pos, off) ((char*)HOPBACK3(pos, off, reginfo->strbeg))
|
|
||||||
+
|
|
||||||
#define HOP3(pos,off,lim) (reginfo->is_utf8_target ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
|
|
||||||
#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
|
|
||||||
|
|
||||||
@@ -871,7 +874,9 @@ Perl_re_intuit_start(pTHX_
|
|
||||||
(IV)prog->check_end_shift);
|
|
||||||
});
|
|
||||||
|
|
||||||
- end_point = HOP3(strend, -end_shift, strbeg);
|
|
||||||
+ end_point = HOPBACK3(strend, end_shift, rx_origin);
|
|
||||||
+ if (!end_point)
|
|
||||||
+ goto fail_finish;
|
|
||||||
start_point = HOPMAYBE3(rx_origin, start_shift, end_point);
|
|
||||||
if (!start_point)
|
|
||||||
goto fail_finish;
|
|
||||||
diff --git a/t/re/pat.t b/t/re/pat.t
|
|
||||||
index 50529b8..007f11d 100644
|
|
||||||
--- a/t/re/pat.t
|
|
||||||
+++ b/t/re/pat.t
|
|
||||||
@@ -23,7 +23,7 @@ BEGIN {
|
|
||||||
skip_all_without_unicode_tables();
|
|
||||||
}
|
|
||||||
|
|
||||||
-plan tests => 793; # Update this when adding/deleting tests.
|
|
||||||
+plan tests => 794; # Update this when adding/deleting tests.
|
|
||||||
|
|
||||||
run_tests() unless caller;
|
|
||||||
|
|
||||||
@@ -1783,6 +1783,17 @@ EOP
|
|
||||||
# [perl #129281] buffer write overflow, detected by ASAN, valgrind
|
|
||||||
fresh_perl_is('/0(?0)|^*0(?0)|^*(^*())0|/', '', {}, "don't bump whilem_c too much");
|
|
||||||
}
|
|
||||||
+
|
|
||||||
+ {
|
|
||||||
+ # RT #131575 intuit skipping back from the end to find the highest
|
|
||||||
+ # possible start point, was potentially hopping back beyond pos()
|
|
||||||
+ # and crashing by calling fbm_instr with a negative length
|
|
||||||
+
|
|
||||||
+ my $text = "=t=\x{5000}";
|
|
||||||
+ pos($text) = 3;
|
|
||||||
+ ok(scalar($text !~ m{(~*=[a-z]=)}g), "RT #131575");
|
|
||||||
+ }
|
|
||||||
+
|
|
||||||
} # End of sub run_tests
|
|
||||||
|
|
||||||
1;
|
|
||||||
diff --git a/util.c b/util.c
|
|
||||||
index df75db0..bc265f5 100644
|
|
||||||
--- a/util.c
|
|
||||||
+++ b/util.c
|
|
||||||
@@ -806,6 +806,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U
|
|
||||||
|
|
||||||
PERL_ARGS_ASSERT_FBM_INSTR;
|
|
||||||
|
|
||||||
+ assert(bigend >= big);
|
|
||||||
+
|
|
||||||
if ((STRLEN)(bigend - big) < littlelen) {
|
|
||||||
if ( SvTAIL(littlestr)
|
|
||||||
&& ((STRLEN)(bigend - big) == littlelen - 1)
|
|
||||||
--
|
|
||||||
2.9.4
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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 => 27);
|
|
||||||
+plan(tests => 28);
|
|
||||||
|
|
||||||
{
|
|
||||||
no warnings 'deprecated';
|
|
||||||
@@ -223,3 +223,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
|
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue