import perl-5.24.4-398.el8+1694+ef8073e1
This commit is contained in:
commit
80a9263a5a
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
|||||||
|
SOURCES/perl-5.24.4.tar.bz2
|
1
.perl.metadata
Normal file
1
.perl.metadata
Normal file
@ -0,0 +1 @@
|
|||||||
|
0606bb25bfe3e00e3e54fe858bd7247a104c3772 SOURCES/perl-5.24.4.tar.bz2
|
367
SOURCES/Compress-Raw-Zlib-2.071-Adapt-to-zlib-1.2.11.patch
Normal file
367
SOURCES/Compress-Raw-Zlib-2.071-Adapt-to-zlib-1.2.11.patch
Normal file
@ -0,0 +1,367 @@
|
|||||||
|
From 0c7af9e6cb05b436505e7f46ef49dcb6f791f30a Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Fri, 17 Feb 2017 11:00:21 +0100
|
||||||
|
Subject: [PATCH] Adapt to zlib-1.2.11
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This is a fix ported from Compress-Raw-Zlib-2.072 that restores
|
||||||
|
compatibility with zlib-1.2.11.
|
||||||
|
|
||||||
|
CPAN RT#119762
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
Zlib.xs | 220 +++++++++++++++++++++++++++++++++++++++++++++++--------------
|
||||||
|
t/02zlib.t | 11 +++-
|
||||||
|
2 files changed, 178 insertions(+), 53 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/Zlib.xs b/Zlib.xs
|
||||||
|
index d379f78..83d1423 100644
|
||||||
|
--- a/Zlib.xs
|
||||||
|
+++ b/Zlib.xs
|
||||||
|
@@ -74,6 +74,10 @@
|
||||||
|
# define AT_LEAST_ZLIB_1_2_8
|
||||||
|
#endif
|
||||||
|
|
||||||
|
+#if defined(ZLIB_VERNUM) && ZLIB_VERNUM >= 0x1290
|
||||||
|
+# define AT_LEAST_ZLIB_1_2_9
|
||||||
|
+#endif
|
||||||
|
+
|
||||||
|
#ifdef USE_PPPORT_H
|
||||||
|
# define NEED_sv_2pvbyte
|
||||||
|
# define NEED_sv_2pv_nolen
|
||||||
|
@@ -134,12 +138,13 @@ typedef struct di_stream {
|
||||||
|
uLong dict_adler ;
|
||||||
|
int last_error ;
|
||||||
|
bool zip_mode ;
|
||||||
|
-#define SETP_BYTE
|
||||||
|
+/* #define SETP_BYTE */
|
||||||
|
#ifdef SETP_BYTE
|
||||||
|
+ /* SETP_BYTE only works with zlib up to 1.2.8 */
|
||||||
|
bool deflateParams_out_valid ;
|
||||||
|
Bytef deflateParams_out_byte;
|
||||||
|
#else
|
||||||
|
-#define deflateParams_BUFFER_SIZE 0x4000
|
||||||
|
+#define deflateParams_BUFFER_SIZE 0x40000
|
||||||
|
uLong deflateParams_out_length;
|
||||||
|
Bytef* deflateParams_out_buffer;
|
||||||
|
#endif
|
||||||
|
@@ -636,6 +641,103 @@ char * string ;
|
||||||
|
return sv ;
|
||||||
|
}
|
||||||
|
|
||||||
|
+#if 0
|
||||||
|
+int
|
||||||
|
+flushToBuffer(di_stream* s, int flush)
|
||||||
|
+{
|
||||||
|
+ dTHX;
|
||||||
|
+ int ret ;
|
||||||
|
+ z_stream * strm = &s->stream;
|
||||||
|
+
|
||||||
|
+ Bytef* output = s->deflateParams_out_buffer ;
|
||||||
|
+
|
||||||
|
+ strm->next_in = NULL;
|
||||||
|
+ strm->avail_in = 0;
|
||||||
|
+
|
||||||
|
+ uLong total_output = 0;
|
||||||
|
+ uLong have = 0;
|
||||||
|
+
|
||||||
|
+ do
|
||||||
|
+ {
|
||||||
|
+ if (output)
|
||||||
|
+ output = (unsigned char *)saferealloc(output, total_output + s->bufsize);
|
||||||
|
+ else
|
||||||
|
+ output = (unsigned char *)safemalloc(s->bufsize);
|
||||||
|
+
|
||||||
|
+ strm->next_out = output + total_output;
|
||||||
|
+ strm->avail_out = s->bufsize;
|
||||||
|
+
|
||||||
|
+ ret = deflate(strm, flush); /* no bad return value */
|
||||||
|
+ //assert(ret != Z_STREAM_ERROR); /* state not clobbered */
|
||||||
|
+ if(ret == Z_STREAM_ERROR)
|
||||||
|
+ {
|
||||||
|
+ safefree(output);
|
||||||
|
+ return ret;
|
||||||
|
+ }
|
||||||
|
+ have = s->bufsize - strm->avail_out;
|
||||||
|
+ total_output += have;
|
||||||
|
+
|
||||||
|
+ //fprintf(stderr, "FLUSH %s %d, return %d\n", flush_flags[flush], have, ret);
|
||||||
|
+
|
||||||
|
+ } while (strm->avail_out == 0);
|
||||||
|
+
|
||||||
|
+ s->deflateParams_out_buffer = output;
|
||||||
|
+ s->deflateParams_out_length = total_output;
|
||||||
|
+
|
||||||
|
+ return Z_OK;
|
||||||
|
+}
|
||||||
|
+#endif
|
||||||
|
+
|
||||||
|
+#ifndef SETP_BYTE
|
||||||
|
+int
|
||||||
|
+flushParams(di_stream* s)
|
||||||
|
+{
|
||||||
|
+ dTHX;
|
||||||
|
+ int ret ;
|
||||||
|
+ z_stream * strm = &s->stream;
|
||||||
|
+
|
||||||
|
+ strm->next_in = NULL;
|
||||||
|
+ strm->avail_in = 0;
|
||||||
|
+
|
||||||
|
+ Bytef* output = s->deflateParams_out_buffer ;
|
||||||
|
+ uLong total_output = s->deflateParams_out_length;
|
||||||
|
+
|
||||||
|
+ uLong have = 0;
|
||||||
|
+
|
||||||
|
+ do
|
||||||
|
+ {
|
||||||
|
+ if (output)
|
||||||
|
+ output = (unsigned char *)saferealloc(output, total_output + s->bufsize);
|
||||||
|
+ else
|
||||||
|
+ output = (unsigned char *)safemalloc(s->bufsize);
|
||||||
|
+
|
||||||
|
+ strm->next_out = output + total_output;
|
||||||
|
+ strm->avail_out = s->bufsize;
|
||||||
|
+
|
||||||
|
+ ret = deflateParams(&(s->stream), s->Level, s->Strategy);
|
||||||
|
+ /* fprintf(stderr, "deflateParams %d %s %lu\n", ret,
|
||||||
|
+ GetErrorString(ret), s->bufsize - strm->avail_out); */
|
||||||
|
+
|
||||||
|
+ if (ret == Z_STREAM_ERROR)
|
||||||
|
+ break;
|
||||||
|
+
|
||||||
|
+ have = s->bufsize - strm->avail_out;
|
||||||
|
+ total_output += have;
|
||||||
|
+
|
||||||
|
+
|
||||||
|
+ } while (ret == Z_BUF_ERROR) ;
|
||||||
|
+
|
||||||
|
+ if(ret == Z_STREAM_ERROR)
|
||||||
|
+ safefree(output);
|
||||||
|
+ else
|
||||||
|
+ {
|
||||||
|
+ s->deflateParams_out_buffer = output;
|
||||||
|
+ s->deflateParams_out_length = total_output;
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+ return ret;
|
||||||
|
+}
|
||||||
|
+#endif /* ! SETP_BYTE */
|
||||||
|
|
||||||
|
#include "constants.h"
|
||||||
|
|
||||||
|
@@ -991,20 +1093,24 @@ deflate (s, buf, output)
|
||||||
|
/* Check for saved output from deflateParams */
|
||||||
|
if (s->deflateParams_out_length) {
|
||||||
|
uLong plen = s->deflateParams_out_length ;
|
||||||
|
- /* printf("Copy %d bytes saved data\n", plen);*/
|
||||||
|
+ /* printf("Copy %lu bytes saved data\n", plen); */
|
||||||
|
if (s->stream.avail_out < plen) {
|
||||||
|
- /*printf("GROW from %d to %d\n", s->stream.avail_out,
|
||||||
|
- SvLEN(output) + plen - s->stream.avail_out); */
|
||||||
|
- Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ;
|
||||||
|
+ /* printf("GROW from %d to %lu\n", s->stream.avail_out,
|
||||||
|
+ SvLEN(output) + plen - s->stream.avail_out); */
|
||||||
|
+ s->stream.next_out = (Bytef*) Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ;
|
||||||
|
+ s->stream.next_out += cur_length;
|
||||||
|
}
|
||||||
|
|
||||||
|
- Copy(s->stream.next_out, s->deflateParams_out_buffer, plen, Bytef) ;
|
||||||
|
- cur_length = cur_length + plen;
|
||||||
|
+ Copy(s->deflateParams_out_buffer, s->stream.next_out, plen, Bytef) ;
|
||||||
|
+ cur_length += plen;
|
||||||
|
SvCUR_set(output, cur_length);
|
||||||
|
- s->stream.next_out += plen ;
|
||||||
|
- s->stream.avail_out = SvLEN(output) - cur_length ;
|
||||||
|
- increment = s->stream.avail_out;
|
||||||
|
- s->deflateParams_out_length = 0;
|
||||||
|
+ s->stream.next_out += plen ;
|
||||||
|
+ s->stream.avail_out = SvLEN(output) - cur_length ;
|
||||||
|
+ increment = s->stream.avail_out;
|
||||||
|
+
|
||||||
|
+ s->deflateParams_out_length = 0;
|
||||||
|
+ Safefree(s->deflateParams_out_buffer);
|
||||||
|
+ s->deflateParams_out_buffer = NULL;
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
RETVAL = Z_OK ;
|
||||||
|
@@ -1027,6 +1133,12 @@ deflate (s, buf, output)
|
||||||
|
}
|
||||||
|
|
||||||
|
RETVAL = deflate(&(s->stream), Z_NO_FLUSH);
|
||||||
|
+ if (RETVAL != Z_STREAM_ERROR) {
|
||||||
|
+ int done = increment - s->stream.avail_out ;
|
||||||
|
+ /* printf("std DEFLATEr returned %d '%s' avail in %d, out %d wrote %d\n", RETVAL,
|
||||||
|
+ GetErrorString(RETVAL), s->stream.avail_in,
|
||||||
|
+s->stream.avail_out, done); */
|
||||||
|
+ }
|
||||||
|
|
||||||
|
if (trace) {
|
||||||
|
printf("DEFLATE returned %d %s, avail in %d, out %d\n", RETVAL,
|
||||||
|
@@ -1080,7 +1192,6 @@ flush(s, output, f=Z_FINISH)
|
||||||
|
CODE:
|
||||||
|
bufinc = s->bufsize;
|
||||||
|
|
||||||
|
- s->stream.avail_in = 0; /* should be zero already anyway */
|
||||||
|
|
||||||
|
/* retrieve the output buffer */
|
||||||
|
output = deRef_l(output, "flush") ;
|
||||||
|
@@ -1108,20 +1219,24 @@ flush(s, output, f=Z_FINISH)
|
||||||
|
/* Check for saved output from deflateParams */
|
||||||
|
if (s->deflateParams_out_length) {
|
||||||
|
uLong plen = s->deflateParams_out_length ;
|
||||||
|
- /* printf("Copy %d bytes saved data\n", plen); */
|
||||||
|
+ /* printf("Copy %lu bytes saved data\n", plen); */
|
||||||
|
if (s->stream.avail_out < plen) {
|
||||||
|
- /* printf("GROW from %d to %d\n", s->stream.avail_out,
|
||||||
|
+ /* printf("GROW from %d to %lu\n", s->stream.avail_out,
|
||||||
|
SvLEN(output) + plen - s->stream.avail_out); */
|
||||||
|
- Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ;
|
||||||
|
+ s->stream.next_out = (Bytef*) Sv_Grow(output, SvLEN(output) + plen - s->stream.avail_out) ;
|
||||||
|
+ s->stream.next_out += cur_length;
|
||||||
|
}
|
||||||
|
|
||||||
|
- Copy(s->stream.next_out, s->deflateParams_out_buffer, plen, Bytef) ;
|
||||||
|
- cur_length = cur_length + plen;
|
||||||
|
+ Copy(s->deflateParams_out_buffer, s->stream.next_out, plen, Bytef) ;
|
||||||
|
+ cur_length += plen;
|
||||||
|
SvCUR_set(output, cur_length);
|
||||||
|
- s->stream.next_out += plen ;
|
||||||
|
- s->stream.avail_out = SvLEN(output) - cur_length ;
|
||||||
|
- increment = s->stream.avail_out;
|
||||||
|
- s->deflateParams_out_length = 0;
|
||||||
|
+ s->stream.next_out += plen ;
|
||||||
|
+ s->stream.avail_out = SvLEN(output) - cur_length ;
|
||||||
|
+ increment = s->stream.avail_out;
|
||||||
|
+
|
||||||
|
+ s->deflateParams_out_length = 0;
|
||||||
|
+ Safefree(s->deflateParams_out_buffer);
|
||||||
|
+ s->deflateParams_out_buffer = NULL;
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
@@ -1145,9 +1260,15 @@ flush(s, output, f=Z_FINISH)
|
||||||
|
}
|
||||||
|
|
||||||
|
RETVAL = deflate(&(s->stream), f);
|
||||||
|
+ if (RETVAL != Z_STREAM_ERROR) {
|
||||||
|
+ int done = availableout - s->stream.avail_out ;
|
||||||
|
+ /* printf("flush DEFLATEr returned %d '%s' avail in %d, out %d wrote %d\n", RETVAL,
|
||||||
|
+ GetErrorString(RETVAL), s->stream.avail_in,
|
||||||
|
+s->stream.avail_out, done); */
|
||||||
|
+ }
|
||||||
|
|
||||||
|
if (trace) {
|
||||||
|
- printf("flush DEFLATE returned %d %s, avail in %d, out %d\n", RETVAL,
|
||||||
|
+ printf("flush DEFLATE returned %d '%s', avail in %d, out %d\n", RETVAL,
|
||||||
|
GetErrorString(RETVAL), s->stream.avail_in, s->stream.avail_out);
|
||||||
|
DispStream(s, "AFTER");
|
||||||
|
}
|
||||||
|
@@ -1184,41 +1305,38 @@ _deflateParams(s, flags, level, strategy, bufsize)
|
||||||
|
int level
|
||||||
|
int strategy
|
||||||
|
uLong bufsize
|
||||||
|
+ bool changed = FALSE;
|
||||||
|
CODE:
|
||||||
|
- /* printf("_deflateParams(Flags %d Level %d Strategy %d Bufsize %d)\n", flags, level, strategy, bufsize);
|
||||||
|
- printf("Before -- Level %d, Strategy %d, Bufsize %d\n", s->Level, s->Strategy, s->bufsize); */
|
||||||
|
- if (flags & 1)
|
||||||
|
- s->Level = level ;
|
||||||
|
- if (flags & 2)
|
||||||
|
- s->Strategy = strategy ;
|
||||||
|
- if (flags & 4) {
|
||||||
|
+ /* printf("_deflateParams(Flags %d Level %d Strategy %d Bufsize %d)\n", flags, level, strategy, bufsize);
|
||||||
|
+ printf("Before -- Level %d, Strategy %d, Bufsize %d\n", s->Level, s->Strategy, s->bufsize); */
|
||||||
|
+ if (flags & 1 && level != s->Level) {
|
||||||
|
+ s->Level = level ;
|
||||||
|
+ changed = TRUE;
|
||||||
|
+ }
|
||||||
|
+ if (flags & 2 && strategy != s->Strategy) {
|
||||||
|
+ s->Strategy = strategy ;
|
||||||
|
+ changed = TRUE;
|
||||||
|
+ }
|
||||||
|
+ if (flags & 4)
|
||||||
|
s->bufsize = bufsize;
|
||||||
|
- }
|
||||||
|
- /* printf("After -- Level %d, Strategy %d, Bufsize %d\n", s->Level, s->Strategy, s->bufsize);*/
|
||||||
|
+ if (changed) {
|
||||||
|
#ifdef SETP_BYTE
|
||||||
|
- s->stream.avail_in = 0;
|
||||||
|
- s->stream.next_out = &(s->deflateParams_out_byte) ;
|
||||||
|
- s->stream.avail_out = 1;
|
||||||
|
- RETVAL = deflateParams(&(s->stream), s->Level, s->Strategy);
|
||||||
|
- s->deflateParams_out_valid =
|
||||||
|
- (RETVAL == Z_OK && s->stream.avail_out == 0) ;
|
||||||
|
- /* printf("RETVAL %d, avail out %d, byte %c\n", RETVAL, s->stream.avail_out, s->deflateParams_out_byte); */
|
||||||
|
+ s->stream.avail_in = 0;
|
||||||
|
+ s->stream.next_out = &(s->deflateParams_out_byte) ;
|
||||||
|
+ s->stream.avail_out = 1;
|
||||||
|
+ RETVAL = deflateParams(&(s->stream), s->Level, s->Strategy);
|
||||||
|
+ s->deflateParams_out_valid =
|
||||||
|
+ (RETVAL == Z_OK && s->stream.avail_out == 0) ;
|
||||||
|
#else
|
||||||
|
- /* printf("Level %d Strategy %d, Prev Len %d\n",
|
||||||
|
+ /* printf("Level %d Strategy %d, Prev Len %d\n",
|
||||||
|
s->Level, s->Strategy, s->deflateParams_out_length); */
|
||||||
|
- s->stream.avail_in = 0;
|
||||||
|
- if (s->deflateParams_out_buffer == NULL)
|
||||||
|
- s->deflateParams_out_buffer = safemalloc(deflateParams_BUFFER_SIZE);
|
||||||
|
- s->stream.next_out = s->deflateParams_out_buffer ;
|
||||||
|
- s->stream.avail_out = deflateParams_BUFFER_SIZE;
|
||||||
|
-
|
||||||
|
- RETVAL = deflateParams(&(s->stream), s->Level, s->Strategy);
|
||||||
|
- s->deflateParams_out_length = deflateParams_BUFFER_SIZE - s->stream.avail_out;
|
||||||
|
- /* printf("RETVAL %d, length out %d, avail %d\n",
|
||||||
|
- RETVAL, s->deflateParams_out_length, s->stream.avail_out ); */
|
||||||
|
+ RETVAL = flushParams(s);
|
||||||
|
#endif
|
||||||
|
+ }
|
||||||
|
+ else
|
||||||
|
+ RETVAL = Z_OK;
|
||||||
|
OUTPUT:
|
||||||
|
- RETVAL
|
||||||
|
+ RETVAL
|
||||||
|
|
||||||
|
|
||||||
|
int
|
||||||
|
diff --git a/t/02zlib.t b/t/02zlib.t
|
||||||
|
index 2c9aad6..5d024a9 100644
|
||||||
|
--- a/t/02zlib.t
|
||||||
|
+++ b/t/02zlib.t
|
||||||
|
@@ -27,7 +27,7 @@ BEGIN
|
||||||
|
$count = 232 ;
|
||||||
|
}
|
||||||
|
elsif ($] >= 5.006) {
|
||||||
|
- $count = 317 ;
|
||||||
|
+ $count = 320 ;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$count = 275 ;
|
||||||
|
@@ -559,6 +559,13 @@ SKIP:
|
||||||
|
is $x->get_Level(), Z_BEST_SPEED;
|
||||||
|
is $x->get_Strategy(), Z_HUFFMAN_ONLY;
|
||||||
|
|
||||||
|
+ # change both Level & Strategy again without any calls to deflate
|
||||||
|
+ $status = $x->deflateParams(-Level => Z_DEFAULT_COMPRESSION, -Strategy => Z_DEFAULT_STRATEGY, -Bufsize => 1234) ;
|
||||||
|
+ cmp_ok $status, '==', Z_OK ;
|
||||||
|
+
|
||||||
|
+ is $x->get_Level(), Z_DEFAULT_COMPRESSION;
|
||||||
|
+ is $x->get_Strategy(), Z_DEFAULT_STRATEGY;
|
||||||
|
+
|
||||||
|
$status = $x->deflate($goodbye, $Answer) ;
|
||||||
|
cmp_ok $status, '==', Z_OK ;
|
||||||
|
$input .= $goodbye;
|
||||||
|
@@ -568,7 +575,7 @@ SKIP:
|
||||||
|
cmp_ok $status, '==', Z_OK ;
|
||||||
|
|
||||||
|
is $x->get_Level(), Z_NO_COMPRESSION;
|
||||||
|
- is $x->get_Strategy(), Z_HUFFMAN_ONLY;
|
||||||
|
+ is $x->get_Strategy(), Z_DEFAULT_STRATEGY;
|
||||||
|
|
||||||
|
$status = $x->deflate($goodbye, $Answer) ;
|
||||||
|
cmp_ok $status, '==', Z_OK ;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
82
SOURCES/Compress-Raw-Zlib-2.071-Conform-to-C90.patch
Normal file
82
SOURCES/Compress-Raw-Zlib-2.071-Conform-to-C90.patch
Normal file
@ -0,0 +1,82 @@
|
|||||||
|
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
|
||||||
|
|
41
SOURCES/Pod-Html-license-clarification
Normal file
41
SOURCES/Pod-Html-license-clarification
Normal file
@ -0,0 +1,41 @@
|
|||||||
|
Date: Sun, 15 Mar 2015 21:22:10 -0600
|
||||||
|
Subject: Re: Pod::Html license
|
||||||
|
From: Tom Christiansen <tchrist53147@gmail.com>
|
||||||
|
To: Petr Šabata <contyk@redhat.com>
|
||||||
|
Cc: Tom Christiansen <tchrist@perl.com>, marcgreen@cpan.org,
|
||||||
|
jplesnik@redhat.com
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
Content-Type: text/plain; charset=utf-8
|
||||||
|
|
||||||
|
Yes, it was supposed to be licensed just like the rest of Perl.
|
||||||
|
|
||||||
|
Sent from my Sprint phone
|
||||||
|
|
||||||
|
Petr Šabata <contyk@redhat.com> wrote:
|
||||||
|
|
||||||
|
>Marc, Tom,
|
||||||
|
>
|
||||||
|
>I'm reviewing licensing of our perl package in Fedora and
|
||||||
|
>noticed Pod::HTML and its pod2html script are licensed under
|
||||||
|
>the Artistic license (only).
|
||||||
|
>
|
||||||
|
>This is an issue for us as this license isn't considered free by
|
||||||
|
>FSF [0]. Unless the license of this core component changes, we
|
||||||
|
>will have to drop it from the tarball and remove support for it
|
||||||
|
>from all the modules we ship that use it, such as Module::Build
|
||||||
|
>or Module::Install.
|
||||||
|
>
|
||||||
|
>What I've seen in the past is authors originally claiming their
|
||||||
|
>module was released under Artistic while what they actually meant
|
||||||
|
>was the common `the same as perl itself', i.e. `GPL+/Aristic' [1],
|
||||||
|
>an FSF free license. Is it possible this is also the case
|
||||||
|
>of Pod::Html?
|
||||||
|
>
|
||||||
|
>Thanks,
|
||||||
|
>Petr
|
||||||
|
>
|
||||||
|
>(also CC'ing Jitka, the primary package maintainer in Fedora)
|
||||||
|
>
|
||||||
|
>[0] https://www.gnu.org/licenses/license-list.html#ArtisticLicense
|
||||||
|
>[1] https://www.gnu.org/licenses/license-list.html#PerlLicense
|
1988
SOURCES/gendep.macros
Normal file
1988
SOURCES/gendep.macros
Normal file
File diff suppressed because it is too large
Load Diff
151
SOURCES/macros.perl
Normal file
151
SOURCES/macros.perl
Normal file
@ -0,0 +1,151 @@
|
|||||||
|
# Sensible Perl-specific RPM build macros.
|
||||||
|
#
|
||||||
|
# Note that these depend on the generic filtering system being in place in
|
||||||
|
# rpm core; but won't cause a build to fail if they're not present.
|
||||||
|
#
|
||||||
|
# Chris Weyl <cweyl@alumni.drew.edu> 2009
|
||||||
|
# Marcela Mašláňová <mmaslano@redhat.com> 2011
|
||||||
|
|
||||||
|
# This macro unsets several common vars used to control how Makefile.PL (et
|
||||||
|
# al) build and install packages. We also set a couple to help some of the
|
||||||
|
# common systems be less interactive. This was blatantly stolen from
|
||||||
|
# cpanminus, and helps building rpms locally when one makes extensive use of
|
||||||
|
# local::lib, etc.
|
||||||
|
#
|
||||||
|
# Usage, in %build, before "%{__perl} Makefile.PL ..."
|
||||||
|
#
|
||||||
|
# %{?perl_ext_env_unset}
|
||||||
|
|
||||||
|
%perl_ext_env_unset %{expand:
|
||||||
|
unset PERL_MM_OPT MODULEBUILDRC PERL5INC
|
||||||
|
export PERL_AUTOINSTALL="--defaultdeps"
|
||||||
|
export PERL_MM_USE_DEFAULT=1
|
||||||
|
}
|
||||||
|
|
||||||
|
#############################################################################
|
||||||
|
# Filtering macro incantations
|
||||||
|
|
||||||
|
# keep track of what "revision" of the filtering we're at. Each time we
|
||||||
|
# change the filter we should increment this.
|
||||||
|
|
||||||
|
%perl_default_filter_revision 3
|
||||||
|
|
||||||
|
# By default, for perl packages we want to filter all files in _docdir from
|
||||||
|
# req/prov scanning.
|
||||||
|
# Filtering out any provides caused by private libs in vendorarch/archlib
|
||||||
|
# (vendor/core) is done by rpmbuild since Fedora 20
|
||||||
|
# <https://fedorahosted.org/fpc/ticket/353>.
|
||||||
|
#
|
||||||
|
# Note that this must be invoked in the spec file, preferably as
|
||||||
|
# "%{?perl_default_filter}", before any %description block.
|
||||||
|
|
||||||
|
%perl_default_filter %{expand: \
|
||||||
|
%global __provides_exclude_from %{?__provides_exclude_from:%__provides_exclude_from|}^%{_docdir}
|
||||||
|
%global __requires_exclude_from %{?__requires_exclude_from:%__requires_exclude_from|}^%{_docdir}
|
||||||
|
%global __provides_exclude %{?__provides_exclude:%__provides_exclude|}^perl\\\\(VMS|^perl\\\\(Win32|^perl\\\\(DB\\\\)|^perl\\\\(UNIVERSAL\\\\)
|
||||||
|
%global __requires_exclude %{?__requires_exclude:%__requires_exclude|}^perl\\\\(VMS|^perl\\\\(Win32
|
||||||
|
}
|
||||||
|
|
||||||
|
#############################################################################
|
||||||
|
# Macros to assist with generating a "-tests" subpackage in a semi-automatic
|
||||||
|
# manner.
|
||||||
|
#
|
||||||
|
# The following macros are still in a highly experimental stage and users
|
||||||
|
# should be aware that the interface and behaviour may change.
|
||||||
|
#
|
||||||
|
# PLEASE, PLEASE CONDITIONALIZE THESE MACROS IF YOU USE THEM.
|
||||||
|
#
|
||||||
|
# See http://gist.github.com/284409
|
||||||
|
|
||||||
|
# These macros should be invoked as above, right before the first %description
|
||||||
|
# section, and conditionalized. e.g., for the common case where all our tests
|
||||||
|
# are located under t/, the correct usage is:
|
||||||
|
#
|
||||||
|
# %{?perl_default_subpackage_tests}
|
||||||
|
#
|
||||||
|
# If custom files/directories need to be specified, this can be done as such:
|
||||||
|
#
|
||||||
|
# %{?perl_subpackage_tests:%perl_subpackage_tests t/ one/ three.sql}
|
||||||
|
#
|
||||||
|
# etc, etc.
|
||||||
|
|
||||||
|
%perl_version %(eval "`%{__perl} -V:version`"; echo $version)
|
||||||
|
%perl_testdir %{_libexecdir}/perl5-tests
|
||||||
|
%cpan_dist_name %(eval echo %{name} | %{__sed} -e 's/^perl-//')
|
||||||
|
|
||||||
|
# easily mark something as required by -tests and BR to the main package
|
||||||
|
%tests_req() %{expand:\
|
||||||
|
BuildRequires: %*\
|
||||||
|
%%tests_subpackage_requires %*\
|
||||||
|
}
|
||||||
|
|
||||||
|
# fixup (and create if needed) the shbang lines in tests, so they work and
|
||||||
|
# rpmlint doesn't (correctly) have a fit
|
||||||
|
%fix_shbang_line() \
|
||||||
|
TMPHEAD=`mktemp`\
|
||||||
|
TMPBODY=`mktemp`\
|
||||||
|
for file in %* ; do \
|
||||||
|
head -1 $file > $TMPHEAD\
|
||||||
|
tail -n +2 $file > $TMPBODY\
|
||||||
|
%{__perl} -pi -e '$f = /^#!/ ? "" : "#!%{__perl}$/"; $_="$f$_"' $TMPHEAD\
|
||||||
|
cat $TMPHEAD $TMPBODY > $file\
|
||||||
|
done\
|
||||||
|
%{__perl} -MExtUtils::MakeMaker -e "ExtUtils::MM_Unix->fixin(qw{%*})"\
|
||||||
|
%{__rm} $TMPHEAD $TMPBODY\
|
||||||
|
%{nil}
|
||||||
|
|
||||||
|
# additional -tests subpackage requires, if any
|
||||||
|
%tests_subpackage_requires() %{expand: \
|
||||||
|
%global __tests_spkg_req %{?__tests_spkg_req} %* \
|
||||||
|
}
|
||||||
|
|
||||||
|
# additional -tests subpackage provides, if any
|
||||||
|
%tests_subpackage_provides() %{expand: \
|
||||||
|
%global __tests_spkg_prov %{?__tests_spkg_prov} %* \
|
||||||
|
}
|
||||||
|
|
||||||
|
#
|
||||||
|
# Runs after the body of %check completes.
|
||||||
|
#
|
||||||
|
|
||||||
|
%__perl_check_pre %{expand: \
|
||||||
|
%{?__spec_check_pre} \
|
||||||
|
pushd %{buildsubdir} \
|
||||||
|
%define perl_br_testdir %{buildroot}%{perl_testdir}/%{cpan_dist_name} \
|
||||||
|
%{__mkdir_p} %{perl_br_testdir} \
|
||||||
|
%{__tar} -cf - %{__perl_test_dirs} | ( cd %{perl_br_testdir} && %{__tar} -xf - ) \
|
||||||
|
find . -maxdepth 1 -type f -name '*META*' -exec %{__cp} -vp {} %{perl_br_testdir} ';' \
|
||||||
|
find %{perl_br_testdir} -type f -exec %{__chmod} -c -x {} ';' \
|
||||||
|
T_FILES=`find %{perl_br_testdir} -type f -name '*.t'` \
|
||||||
|
%fix_shbang_line $T_FILES \
|
||||||
|
%{__chmod} +x $T_FILES \
|
||||||
|
%{_fixperms} %{perl_br_testdir} \
|
||||||
|
popd \
|
||||||
|
}
|
||||||
|
|
||||||
|
#
|
||||||
|
# The actual invoked macro
|
||||||
|
#
|
||||||
|
|
||||||
|
%perl_subpackage_tests() %{expand: \
|
||||||
|
%global __perl_package 1\
|
||||||
|
%global __perl_test_dirs %* \
|
||||||
|
%global __spec_check_pre %{expand:%{__perl_check_pre}} \
|
||||||
|
%package tests\
|
||||||
|
Summary: Test suite for package %{name}\
|
||||||
|
Group: Development/Debug\
|
||||||
|
Requires: %{name} = %{?epoch:%{epoch}:}%{version}-%{release}\
|
||||||
|
Requires: /usr/bin/prove \
|
||||||
|
%{?__tests_spkg_req:Requires: %__tests_spkg_req}\
|
||||||
|
%{?__tests_spkg_prov:Provides: %__tests_spkg_prov}\
|
||||||
|
AutoReqProv: 0 \
|
||||||
|
%description tests\
|
||||||
|
This package provides the test suite for package %{name}.\
|
||||||
|
%files tests\
|
||||||
|
%defattr(-,root,root,-)\
|
||||||
|
%{perl_testdir}\
|
||||||
|
}
|
||||||
|
|
||||||
|
# shortcut sugar
|
||||||
|
%perl_default_subpackage_tests %perl_subpackage_tests t/
|
||||||
|
|
12
SOURCES/perl-5.10.0-libresolv.patch
Normal file
12
SOURCES/perl-5.10.0-libresolv.patch
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
diff -up perl-5.10.0/Configure.didi perl-5.10.0/Configure
|
||||||
|
--- perl-5.10.0/Configure.didi 2007-12-18 11:47:07.000000000 +0100
|
||||||
|
+++ perl-5.10.0/Configure 2008-07-21 10:51:16.000000000 +0200
|
||||||
|
@@ -1479,7 +1479,7 @@ archname=''
|
||||||
|
usereentrant='undef'
|
||||||
|
: List of libraries we want.
|
||||||
|
: If anyone needs extra -lxxx, put those in a hint file.
|
||||||
|
-libswanted="cl pthread socket bind inet nsl ndbm gdbm dbm db malloc dl ld"
|
||||||
|
+libswanted="cl pthread socket resolv inet nsl ndbm gdbm dbm db malloc dl ld"
|
||||||
|
libswanted="$libswanted sun m crypt sec util c cposix posix ucb bsd BSD"
|
||||||
|
: We probably want to search /usr/shlib before most other libraries.
|
||||||
|
: This is only used by the lib/ExtUtils/MakeMaker.pm routine extliblist.
|
12
SOURCES/perl-5.10.0-x86_64-io-test-failure.patch
Normal file
12
SOURCES/perl-5.10.0-x86_64-io-test-failure.patch
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
diff -up perl-5.10.0/t/io/fs.t.BAD perl-5.10.0/t/io/fs.t
|
||||||
|
--- perl-5.10.0/t/io/fs.t.BAD 2008-01-30 13:36:43.000000000 -0500
|
||||||
|
+++ perl-5.10.0/t/io/fs.t 2008-01-30 13:41:27.000000000 -0500
|
||||||
|
@@ -227,7 +227,7 @@ isnt($atime, 500000000, 'atime');
|
||||||
|
isnt($mtime, 500000000 + $delta, 'mtime');
|
||||||
|
|
||||||
|
SKIP: {
|
||||||
|
- skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define";
|
||||||
|
+ skip "no futimes", 6;
|
||||||
|
open(my $fh, "<", 'b');
|
||||||
|
$foo = (utime 500000000,500000000 + $delta, $fh);
|
||||||
|
is($foo, 1, "futime");
|
17
SOURCES/perl-5.14.1-offtest.patch
Normal file
17
SOURCES/perl-5.14.1-offtest.patch
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
diff -up perl-5.14.1/cpan/File-Temp/t/fork.t.off perl-5.14.1/cpan/File-Temp/t/fork.t
|
||||||
|
--- perl-5.14.1/cpan/File-Temp/t/fork.t.off 2011-04-13 13:36:34.000000000 +0200
|
||||||
|
+++ perl-5.14.1/cpan/File-Temp/t/fork.t 2011-06-20 10:29:31.536282611 +0200
|
||||||
|
@@ -12,12 +12,8 @@ BEGIN {
|
||||||
|
$Config::Config{useithreads} and
|
||||||
|
$Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
|
||||||
|
);
|
||||||
|
- if ( $can_fork ) {
|
||||||
|
- print "1..8\n";
|
||||||
|
- } else {
|
||||||
|
- print "1..0 # Skip No fork available\n";
|
||||||
|
+ print "1..0 # Skip Koji doesn't work with Perl fork tests\n";
|
||||||
|
exit;
|
||||||
|
- }
|
||||||
|
}
|
||||||
|
|
||||||
|
use File::Temp;
|
@ -0,0 +1,65 @@
|
|||||||
|
From b598ba3f2d4b8347c6621cff022b8e2329b79ea5 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Wed, 3 Jul 2013 11:01:02 +0200
|
||||||
|
Subject: [PATCH] Link XS modules to libperl.so with EU::CBuilder on Linux
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
<https://bugzilla.redhat.com/show_bug.cgi?id=960048>
|
||||||
|
<http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=327585#50>
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
MANIFEST | 1 +
|
||||||
|
.../lib/ExtUtils/CBuilder/Platform/linux.pm | 26 ++++++++++++++++++++++
|
||||||
|
2 files changed, 27 insertions(+)
|
||||||
|
create mode 100644 dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm
|
||||||
|
|
||||||
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
|
index 397252a..d7c519b 100644
|
||||||
|
--- a/MANIFEST
|
||||||
|
+++ b/MANIFEST
|
||||||
|
@@ -3093,6 +3093,7 @@ dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm CBuilder methods fo
|
||||||
|
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm CBuilder methods for cygwin
|
||||||
|
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm CBuilder methods for darwin
|
||||||
|
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm CBuilder methods for OSF
|
||||||
|
+dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm CBuilder methods for Linux
|
||||||
|
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm CBuilder methods for OS/2
|
||||||
|
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm CBuilder methods for Unix
|
||||||
|
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm CBuilder methods for VMS
|
||||||
|
diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm
|
||||||
|
new file mode 100644
|
||||||
|
index 0000000..e3251c4
|
||||||
|
--- /dev/null
|
||||||
|
+++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm
|
||||||
|
@@ -0,0 +1,26 @@
|
||||||
|
+package ExtUtils::CBuilder::Platform::linux;
|
||||||
|
+
|
||||||
|
+use strict;
|
||||||
|
+use ExtUtils::CBuilder::Platform::Unix;
|
||||||
|
+use File::Spec;
|
||||||
|
+
|
||||||
|
+use vars qw($VERSION @ISA);
|
||||||
|
+$VERSION = '0.280206';
|
||||||
|
+@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
|
||||||
|
+
|
||||||
|
+sub link {
|
||||||
|
+ my ($self, %args) = @_;
|
||||||
|
+ my $cf = $self->{config};
|
||||||
|
+
|
||||||
|
+ # Link XS modules to libperl.so explicitly because multiple
|
||||||
|
+ # dlopen(, RTLD_LOCAL) hides libperl symbols from XS module.
|
||||||
|
+ local $cf->{lddlflags} = $cf->{lddlflags};
|
||||||
|
+ if ($ENV{PERL_CORE}) {
|
||||||
|
+ $cf->{lddlflags} .= ' -L' . $self->perl_inc();
|
||||||
|
+ }
|
||||||
|
+ $cf->{lddlflags} .= ' -lperl';
|
||||||
|
+
|
||||||
|
+ return $self->SUPER::link(%args);
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+1;
|
||||||
|
--
|
||||||
|
1.8.1.4
|
||||||
|
|
@ -0,0 +1,52 @@
|
|||||||
|
From fc1f8ac36c34c35bad84fb7b99a26ab83c9ba075 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Wed, 3 Jul 2013 12:59:09 +0200
|
||||||
|
Subject: [PATCH] Link XS modules to libperl.so with EU::MM on Linux
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
<https://bugzilla.redhat.com/show_bug.cgi?id=960048>
|
||||||
|
<http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=327585#50>
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm | 8 +++++++-
|
||||||
|
1 file changed, 7 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
|
||||||
|
index a8b172f..a3fbce2 100644
|
||||||
|
--- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
|
||||||
|
+++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
|
||||||
|
@@ -31,6 +31,7 @@ BEGIN {
|
||||||
|
$Is{IRIX} = $^O eq 'irix';
|
||||||
|
$Is{NetBSD} = $^O eq 'netbsd';
|
||||||
|
$Is{Interix} = $^O eq 'interix';
|
||||||
|
+ $Is{Linux} = $^O eq 'linux';
|
||||||
|
$Is{SunOS4} = $^O eq 'sunos';
|
||||||
|
$Is{Solaris} = $^O eq 'solaris';
|
||||||
|
$Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
|
||||||
|
@@ -932,7 +933,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
|
||||||
|
|
||||||
|
my $libs = '$(LDLOADLIBS)';
|
||||||
|
|
||||||
|
- if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
|
||||||
|
+ if (($Is{Linux} || $Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
|
||||||
|
# Use nothing on static perl platforms, and to the flags needed
|
||||||
|
# to link against the shared libperl library on shared perl
|
||||||
|
# platforms. We peek at lddlflags to see if we need -Wl,-R
|
||||||
|
@@ -941,6 +942,11 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
|
||||||
|
# The Android linker will not recognize symbols from
|
||||||
|
# libperl unless the module explicitly depends on it.
|
||||||
|
$libs .= ' "-L$(PERL_INC)" -lperl';
|
||||||
|
+ } else {
|
||||||
|
+ if ($ENV{PERL_CORE}) {
|
||||||
|
+ $libs .= ' "-L$(PERL_INC)"';
|
||||||
|
+ }
|
||||||
|
+ $libs .= ' -lperl';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
--
|
||||||
|
1.8.1.4
|
||||||
|
|
52
SOURCES/perl-5.16.3-create_libperl_soname.patch
Normal file
52
SOURCES/perl-5.16.3-create_libperl_soname.patch
Normal file
@ -0,0 +1,52 @@
|
|||||||
|
From fa2f0dd5a7767223df10149d3f16d7ed7013e16f Mon Sep 17 00:00:00 2001
|
||||||
|
From: Torsten Veller <tove@gentoo.org>
|
||||||
|
Date: Sat, 14 Apr 2012 13:49:18 +0200
|
||||||
|
Subject: Set libperl soname
|
||||||
|
|
||||||
|
Bug-Gentoo: https://bugs.gentoo.org/286840
|
||||||
|
|
||||||
|
Patch-Name: gentoo/create_libperl_soname.diff
|
||||||
|
---
|
||||||
|
Makefile.SH | 9 +++++++--
|
||||||
|
1 file changed, 7 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/Makefile.SH b/Makefile.SH
|
||||||
|
index d1da0a0..7733a32 100755
|
||||||
|
--- a/Makefile.SH
|
||||||
|
+++ b/Makefile.SH
|
||||||
|
@@ -58,7 +58,7 @@ true)
|
||||||
|
${api_revision}.${api_version}.${api_subversion} \
|
||||||
|
-current_version \
|
||||||
|
${revision}.${patchlevel}.${subversion} \
|
||||||
|
- -install_name \$(shrpdir)/\$@"
|
||||||
|
+ -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
|
||||||
|
;;
|
||||||
|
cygwin*)
|
||||||
|
shrpldflags="$shrpldflags -Wl,--out-implib=libperl.dll.a -Wl,--image-base,0x52000000"
|
||||||
|
@@ -66,13 +66,15 @@ true)
|
||||||
|
;;
|
||||||
|
sunos*)
|
||||||
|
linklibperl="-lperl"
|
||||||
|
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
|
||||||
|
;;
|
||||||
|
netbsd*|freebsd[234]*|openbsd*|dragonfly*|bitrig*)
|
||||||
|
linklibperl="-L. -lperl"
|
||||||
|
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
|
||||||
|
;;
|
||||||
|
interix*)
|
||||||
|
linklibperl="-L. -lperl"
|
||||||
|
- shrpldflags="$shrpldflags -Wl,--image-base,0x57000000"
|
||||||
|
+ shrpldflags="$shrpldflags -Wl,--image-base,0x57000000 -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
|
||||||
|
;;
|
||||||
|
aix*)
|
||||||
|
case "$cc" in
|
||||||
|
@@ -110,6 +112,9 @@ true)
|
||||||
|
linklibperl='libperl.x'
|
||||||
|
DPERL_EXTERNAL_GLOB=''
|
||||||
|
;;
|
||||||
|
+ linux*)
|
||||||
|
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
|
||||||
|
+ ;;
|
||||||
|
esac
|
||||||
|
case "$ldlibpthname" in
|
||||||
|
'') ;;
|
@ -0,0 +1,30 @@
|
|||||||
|
From 862c89c81d26dae0dcef138e19df8b45615e69c9 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Mon, 2 Dec 2013 10:10:56 +0100
|
||||||
|
Subject: [PATCH] Document Math::BigInt::CalcEmu requires Math::BigInt
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
<https://rt.cpan.org/Public/Bug/Display.html?id=85015>
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm | 1 +
|
||||||
|
1 file changed, 1 insertion(+)
|
||||||
|
|
||||||
|
diff --git a/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm b/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||||
|
index c82e153..0c0b496 100644
|
||||||
|
--- a/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||||
|
+++ b/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||||
|
@@ -290,6 +290,7 @@ Math::BigInt::CalcEmu - Emulate low-level math with BigInt code
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
+ use Math::BigInt;
|
||||||
|
use Math::BigInt::CalcEmu;
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
--
|
||||||
|
1.8.3.1
|
||||||
|
|
@ -0,0 +1,233 @@
|
|||||||
|
From f793042f2bac2ace9a5c0030b47b41c4db561a5b Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Fri, 6 Jun 2014 14:31:59 +0200
|
||||||
|
Subject: [PATCH] Destroy {GDBM,NDBM,ODBM,SDBM}_File objects only from original
|
||||||
|
thread context
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This patch fixes a crash when destroing a hash tied to a *_File
|
||||||
|
database after spawning a thread:
|
||||||
|
|
||||||
|
use Fcntl;
|
||||||
|
use SDBM_File;
|
||||||
|
use threads;
|
||||||
|
tie(my %dbtest, 'SDBM_File', "test.db", O_RDWR|O_CREAT, 0666);
|
||||||
|
threads->new(sub {})->join;
|
||||||
|
|
||||||
|
This crashed or paniced depending on how perl was configured.
|
||||||
|
|
||||||
|
Closes RT#61912.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/GDBM_File/GDBM_File.xs | 16 ++++++++++------
|
||||||
|
ext/NDBM_File/NDBM_File.xs | 16 ++++++++++------
|
||||||
|
ext/ODBM_File/ODBM_File.xs | 18 +++++++++++-------
|
||||||
|
ext/SDBM_File/SDBM_File.xs | 4 +++-
|
||||||
|
t/lib/dbmt_common.pl | 35 +++++++++++++++++++++++++++++++++++
|
||||||
|
5 files changed, 69 insertions(+), 20 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
|
||||||
|
index 33e08e2..7160f54 100644
|
||||||
|
--- a/ext/GDBM_File/GDBM_File.xs
|
||||||
|
+++ b/ext/GDBM_File/GDBM_File.xs
|
||||||
|
@@ -13,6 +13,7 @@
|
||||||
|
#define store_value 3
|
||||||
|
|
||||||
|
typedef struct {
|
||||||
|
+ tTHX owner;
|
||||||
|
GDBM_FILE dbp ;
|
||||||
|
SV * filter[4];
|
||||||
|
int filtering ;
|
||||||
|
@@ -89,6 +90,7 @@ gdbm_TIEHASH(dbtype, name, read_write, mode)
|
||||||
|
if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode,
|
||||||
|
(FATALFUNC) croak_string))) {
|
||||||
|
RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type)) ;
|
||||||
|
+ RETVAL->owner = aTHX;
|
||||||
|
RETVAL->dbp = dbp ;
|
||||||
|
}
|
||||||
|
|
||||||
|
@@ -109,12 +111,14 @@ gdbm_DESTROY(db)
|
||||||
|
PREINIT:
|
||||||
|
int i = store_value;
|
||||||
|
CODE:
|
||||||
|
- gdbm_close(db);
|
||||||
|
- do {
|
||||||
|
- if (db->filter[i])
|
||||||
|
- SvREFCNT_dec(db->filter[i]);
|
||||||
|
- } while (i-- > 0);
|
||||||
|
- safefree(db);
|
||||||
|
+ if (db && db->owner == aTHX) {
|
||||||
|
+ gdbm_close(db);
|
||||||
|
+ do {
|
||||||
|
+ if (db->filter[i])
|
||||||
|
+ SvREFCNT_dec(db->filter[i]);
|
||||||
|
+ } while (i-- > 0);
|
||||||
|
+ safefree(db);
|
||||||
|
+ }
|
||||||
|
|
||||||
|
#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key)
|
||||||
|
datum_value
|
||||||
|
diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs
|
||||||
|
index 52e60fc..af223e5 100644
|
||||||
|
--- a/ext/NDBM_File/NDBM_File.xs
|
||||||
|
+++ b/ext/NDBM_File/NDBM_File.xs
|
||||||
|
@@ -33,6 +33,7 @@ END_EXTERN_C
|
||||||
|
#define store_value 3
|
||||||
|
|
||||||
|
typedef struct {
|
||||||
|
+ tTHX owner;
|
||||||
|
DBM * dbp ;
|
||||||
|
SV * filter[4];
|
||||||
|
int filtering ;
|
||||||
|
@@ -71,6 +72,7 @@ ndbm_TIEHASH(dbtype, filename, flags, mode)
|
||||||
|
RETVAL = NULL ;
|
||||||
|
if ((dbp = dbm_open(filename, flags, mode))) {
|
||||||
|
RETVAL = (NDBM_File)safecalloc(1, sizeof(NDBM_File_type));
|
||||||
|
+ RETVAL->owner = aTHX;
|
||||||
|
RETVAL->dbp = dbp ;
|
||||||
|
}
|
||||||
|
|
||||||
|
@@ -84,12 +86,14 @@ ndbm_DESTROY(db)
|
||||||
|
PREINIT:
|
||||||
|
int i = store_value;
|
||||||
|
CODE:
|
||||||
|
- dbm_close(db->dbp);
|
||||||
|
- do {
|
||||||
|
- if (db->filter[i])
|
||||||
|
- SvREFCNT_dec(db->filter[i]);
|
||||||
|
- } while (i-- > 0);
|
||||||
|
- safefree(db);
|
||||||
|
+ if (db && db->owner == aTHX) {
|
||||||
|
+ dbm_close(db->dbp);
|
||||||
|
+ do {
|
||||||
|
+ if (db->filter[i])
|
||||||
|
+ SvREFCNT_dec(db->filter[i]);
|
||||||
|
+ } while (i-- > 0);
|
||||||
|
+ safefree(db);
|
||||||
|
+ }
|
||||||
|
|
||||||
|
#define ndbm_FETCH(db,key) dbm_fetch(db->dbp,key)
|
||||||
|
datum_value
|
||||||
|
diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
|
||||||
|
index d1ece7f..f7e00a0 100644
|
||||||
|
--- a/ext/ODBM_File/ODBM_File.xs
|
||||||
|
+++ b/ext/ODBM_File/ODBM_File.xs
|
||||||
|
@@ -45,6 +45,7 @@ datum nextkey(datum key);
|
||||||
|
#define store_value 3
|
||||||
|
|
||||||
|
typedef struct {
|
||||||
|
+ tTHX owner;
|
||||||
|
void * dbp ;
|
||||||
|
SV * filter[4];
|
||||||
|
int filtering ;
|
||||||
|
@@ -112,6 +113,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
|
||||||
|
}
|
||||||
|
dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
|
||||||
|
RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
|
||||||
|
+ RETVAL->owner = aTHX;
|
||||||
|
RETVAL->dbp = dbp ;
|
||||||
|
}
|
||||||
|
OUTPUT:
|
||||||
|
@@ -124,13 +126,15 @@ DESTROY(db)
|
||||||
|
dMY_CXT;
|
||||||
|
int i = store_value;
|
||||||
|
CODE:
|
||||||
|
- dbmrefcnt--;
|
||||||
|
- dbmclose();
|
||||||
|
- do {
|
||||||
|
- if (db->filter[i])
|
||||||
|
- SvREFCNT_dec(db->filter[i]);
|
||||||
|
- } while (i-- > 0);
|
||||||
|
- safefree(db);
|
||||||
|
+ if (db && db->owner == aTHX) {
|
||||||
|
+ dbmrefcnt--;
|
||||||
|
+ dbmclose();
|
||||||
|
+ do {
|
||||||
|
+ if (db->filter[i])
|
||||||
|
+ SvREFCNT_dec(db->filter[i]);
|
||||||
|
+ } while (i-- > 0);
|
||||||
|
+ safefree(db);
|
||||||
|
+ }
|
||||||
|
|
||||||
|
datum_value
|
||||||
|
odbm_FETCH(db, key)
|
||||||
|
diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs
|
||||||
|
index 291e41b..0bdae9a 100644
|
||||||
|
--- a/ext/SDBM_File/SDBM_File.xs
|
||||||
|
+++ b/ext/SDBM_File/SDBM_File.xs
|
||||||
|
@@ -10,6 +10,7 @@
|
||||||
|
#define store_value 3
|
||||||
|
|
||||||
|
typedef struct {
|
||||||
|
+ tTHX owner;
|
||||||
|
DBM * dbp ;
|
||||||
|
SV * filter[4];
|
||||||
|
int filtering ;
|
||||||
|
@@ -49,6 +50,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
|
||||||
|
}
|
||||||
|
if (dbp) {
|
||||||
|
RETVAL = (SDBM_File)safecalloc(1, sizeof(SDBM_File_type));
|
||||||
|
+ RETVAL->owner = aTHX;
|
||||||
|
RETVAL->dbp = dbp ;
|
||||||
|
}
|
||||||
|
|
||||||
|
@@ -60,7 +62,7 @@ void
|
||||||
|
sdbm_DESTROY(db)
|
||||||
|
SDBM_File db
|
||||||
|
CODE:
|
||||||
|
- if (db) {
|
||||||
|
+ if (db && db->owner == aTHX) {
|
||||||
|
int i = store_value;
|
||||||
|
sdbm_close(db->dbp);
|
||||||
|
do {
|
||||||
|
diff --git a/t/lib/dbmt_common.pl b/t/lib/dbmt_common.pl
|
||||||
|
index 5d4098c..a0a4d52 100644
|
||||||
|
--- a/t/lib/dbmt_common.pl
|
||||||
|
+++ b/t/lib/dbmt_common.pl
|
||||||
|
@@ -511,5 +511,40 @@ unlink <Op_dbmx*>, $Dfile;
|
||||||
|
unlink <Op1_dbmx*>;
|
||||||
|
}
|
||||||
|
|
||||||
|
+{
|
||||||
|
+ # Check DBM back-ends do not destroy objects from then-spawned threads.
|
||||||
|
+ # RT#61912.
|
||||||
|
+ SKIP: {
|
||||||
|
+ my $threads_count = 2;
|
||||||
|
+ skip 'Threads are disabled', 3 + 2 * $threads_count
|
||||||
|
+ unless $Config{usethreads};
|
||||||
|
+ use_ok('threads');
|
||||||
|
+
|
||||||
|
+ my %h;
|
||||||
|
+ unlink <Op1_dbmx*>;
|
||||||
|
+
|
||||||
|
+ my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640;
|
||||||
|
+ isa_ok($db, $DBM_Class);
|
||||||
|
+
|
||||||
|
+ for (1 .. 2) {
|
||||||
|
+ ok(threads->create(
|
||||||
|
+ sub {
|
||||||
|
+ $SIG{'__WARN__'} = sub { fail(shift) }; # debugging perl panics
|
||||||
|
+ # report it by spurious TAP line
|
||||||
|
+ 1;
|
||||||
|
+ }), "Thread $_ created");
|
||||||
|
+ }
|
||||||
|
+ for (threads->list) {
|
||||||
|
+ is($_->join, 1, "A thread exited successfully");
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+ pass("Tied object survived exiting threads");
|
||||||
|
+
|
||||||
|
+ undef $db;
|
||||||
|
+ untie %h;
|
||||||
|
+ unlink <Op1_dbmx*>;
|
||||||
|
+ }
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
done_testing();
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
1.9.3
|
||||||
|
|
@ -0,0 +1,61 @@
|
|||||||
|
From 9644657c4 10326749fd321d9c24944ec25afad2f Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Thu, 20 Jun 2013 15:22:53 +0200
|
||||||
|
Subject: [PATCH] Install libperl.so to shrpdir on Linux
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
Configure | 7 ++++---
|
||||||
|
Makefile.SH | 2 +-
|
||||||
|
2 files changed, 5 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/Configure b/Configure
|
||||||
|
index 2f30261..825496e 100755
|
||||||
|
--- a/Configure
|
||||||
|
+++ b/Configure
|
||||||
|
@@ -8249,7 +8249,9 @@ esac
|
||||||
|
|
||||||
|
# Detect old use of shrpdir via undocumented Configure -Dshrpdir
|
||||||
|
case "$shrpdir" in
|
||||||
|
-'') ;;
|
||||||
|
+'')
|
||||||
|
+shrpdir=$archlibexp/CORE
|
||||||
|
+;;
|
||||||
|
*) $cat >&4 <<EOM
|
||||||
|
WARNING: Use of the shrpdir variable for the installation location of
|
||||||
|
the shared $libperl is not supported. It was never documented and
|
||||||
|
@@ -8279,7 +8281,6 @@ esac
|
||||||
|
# Add $xxx to ccdlflags.
|
||||||
|
# If we can't figure out a command-line option, use $shrpenv to
|
||||||
|
# set env LD_RUN_PATH. The main perl makefile uses this.
|
||||||
|
-shrpdir=$archlibexp/CORE
|
||||||
|
xxx=''
|
||||||
|
tmp_shrpenv=''
|
||||||
|
if "$useshrplib"; then
|
||||||
|
@@ -8294,7 +8295,7 @@ if "$useshrplib"; then
|
||||||
|
xxx="-Wl,-R$shrpdir"
|
||||||
|
;;
|
||||||
|
bsdos|linux|irix*|dec_osf|gnu*|haiku)
|
||||||
|
- xxx="-Wl,-rpath,$shrpdir"
|
||||||
|
+ # We want standard path
|
||||||
|
;;
|
||||||
|
hpux*)
|
||||||
|
# hpux doesn't like the default, either.
|
||||||
|
diff --git a/Makefile.SH b/Makefile.SH
|
||||||
|
index 7733a32..a481183 100755
|
||||||
|
--- a/Makefile.SH
|
||||||
|
+++ b/Makefile.SH
|
||||||
|
@@ -266,7 +266,7 @@ ranlib = $ranlib
|
||||||
|
# installman commandline.
|
||||||
|
bin = $installbin
|
||||||
|
scriptdir = $scriptdir
|
||||||
|
-shrpdir = $archlibexp/CORE
|
||||||
|
+shrpdir = $shrpdir
|
||||||
|
privlib = $installprivlib
|
||||||
|
man1dir = $man1dir
|
||||||
|
man1ext = $man1ext
|
||||||
|
--
|
||||||
|
1.8.1.4
|
@ -0,0 +1,44 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,110 @@
|
|||||||
|
From 9575301256f67116eccdbb99b38fc804ba3dcf53 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Mon, 18 Apr 2016 16:24:03 +0200
|
||||||
|
Subject: [PATCH] Provide ExtUtils::MM methods as standalone
|
||||||
|
ExtUtils::MM::Utils
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
If you cannot afford depending on ExtUtils::MakeMaker, you can
|
||||||
|
depend on ExtUtils::MM::Utils instead.
|
||||||
|
|
||||||
|
<https://bugzilla.redhat.com/show_bug.cgi?id=1129443>
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
MANIFEST | 1 +
|
||||||
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm | 68 ++++++++++++++++++++++++
|
||||||
|
2 files changed, 69 insertions(+)
|
||||||
|
create mode 100644 cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm
|
||||||
|
|
||||||
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
|
index 6af238c..d4f0c56 100644
|
||||||
|
--- a/MANIFEST
|
||||||
|
+++ b/MANIFEST
|
||||||
|
@@ -1045,6 +1045,7 @@ cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
|
||||||
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm MakeMaker adaptor class
|
||||||
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm MakeMaker methods for QNX
|
||||||
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm MakeMaker methods for Unix
|
||||||
|
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm Independed MM methods
|
||||||
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm MakeMaker methods for U/WIN
|
||||||
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm MakeMaker methods for VMS
|
||||||
|
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm MakeMaker methods for VOS
|
||||||
|
diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm
|
||||||
|
new file mode 100644
|
||||||
|
index 0000000..6bbc0d8
|
||||||
|
--- /dev/null
|
||||||
|
+++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm
|
||||||
|
@@ -0,0 +1,68 @@
|
||||||
|
+package ExtUtils::MM::Utils;
|
||||||
|
+
|
||||||
|
+require 5.006;
|
||||||
|
+
|
||||||
|
+use strict;
|
||||||
|
+use vars qw($VERSION);
|
||||||
|
+$VERSION = '7.11_06';
|
||||||
|
+$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
|
||||||
|
+
|
||||||
|
+=head1 NAME
|
||||||
|
+
|
||||||
|
+ExtUtils::MM::Utils - ExtUtils::MM methods without dependency on ExtUtils::MakeMaker
|
||||||
|
+
|
||||||
|
+=head1 SYNOPSIS
|
||||||
|
+
|
||||||
|
+ require ExtUtils::MM::Utils;
|
||||||
|
+ MM->maybe_command($file);
|
||||||
|
+
|
||||||
|
+=head1 DESCRIPTION
|
||||||
|
+
|
||||||
|
+This is a collection of L<ExtUtils::MM> subroutines that are used by many
|
||||||
|
+other modules but that do not need full-featured L<ExtUtils::MakeMaker>. The
|
||||||
|
+issue with L<ExtUtils::MakeMaker> is it pulls in Perl header files and that is
|
||||||
|
+an overkill for small subroutines.
|
||||||
|
+
|
||||||
|
+An example is the L<IPC::Cmd> that caused installing GCC just because of
|
||||||
|
+three-line I<maybe_command()> from L<ExtUtils::MM_Unix>.
|
||||||
|
+
|
||||||
|
+The intentions is to use L<ExtUtils::MM::Utils> instead of
|
||||||
|
+L<ExtUtils::MakeMaker> for these trivial methods. You can still call them via
|
||||||
|
+L<MM> class name.
|
||||||
|
+
|
||||||
|
+=head1 METHODS
|
||||||
|
+
|
||||||
|
+=over 4
|
||||||
|
+
|
||||||
|
+=item maybe_command
|
||||||
|
+
|
||||||
|
+Returns true, if the argument is likely to be a command.
|
||||||
|
+
|
||||||
|
+=cut
|
||||||
|
+
|
||||||
|
+if (!exists $INC{'ExtUtils/MM.pm'}) {
|
||||||
|
+ *MM::maybe_command = *ExtUtils::MM::maybe_command = \&maybe_command;
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+sub maybe_command {
|
||||||
|
+ my($self,$file) = @_;
|
||||||
|
+ return $file if -x $file && ! -d $file;
|
||||||
|
+ return;
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+1;
|
||||||
|
+
|
||||||
|
+=back
|
||||||
|
+
|
||||||
|
+=head1 BUGS
|
||||||
|
+
|
||||||
|
+These methods are copied from L<ExtUtils::MM_Unix>. Other operating systems
|
||||||
|
+are not supported yet. The reason is this
|
||||||
|
+L<a hack for Linux
|
||||||
|
+distributions|https://bugzilla.redhat.com/show_bug.cgi?id=1129443>.
|
||||||
|
+
|
||||||
|
+=head1 SEE ALSO
|
||||||
|
+
|
||||||
|
+L<ExtUtils::MakeMaker>, L<ExtUtils::MM>
|
||||||
|
+
|
||||||
|
+=cut
|
||||||
|
--
|
||||||
|
2.5.5
|
||||||
|
|
@ -0,0 +1,34 @@
|
|||||||
|
From 216ddd39adb0043930acad70ff242c30a1b0c6cf Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Mon, 18 Apr 2016 16:39:32 +0200
|
||||||
|
Subject: [PATCH] Replace EU::MM dependnecy with EU::MM::Utils in IPC::Cmd
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This allows to free from a run-time dependency on fat
|
||||||
|
ExtUtils::MakeMaker.
|
||||||
|
|
||||||
|
<https://bugzilla.redhat.com/show_bug.cgi?id=1129443>
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
cpan/IPC-Cmd/lib/IPC/Cmd.pm | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
|
||||||
|
index 6a82bdf..b6cd7ef 100644
|
||||||
|
--- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm
|
||||||
|
+++ b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
|
||||||
|
@@ -230,7 +230,7 @@ sub can_run {
|
||||||
|
}
|
||||||
|
|
||||||
|
require File::Spec;
|
||||||
|
- require ExtUtils::MakeMaker;
|
||||||
|
+ require ExtUtils::MM::Utils;
|
||||||
|
|
||||||
|
my @possibles;
|
||||||
|
|
||||||
|
--
|
||||||
|
2.5.5
|
||||||
|
|
73
SOURCES/perl-5.24.0-assertion-failure-in-.-or-0-x-0.patch
Normal file
73
SOURCES/perl-5.24.0-assertion-failure-in-.-or-0-x-0.patch
Normal file
@ -0,0 +1,73 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,94 @@
|
|||||||
|
From af04cb4d2503c5c75d2229e232b8a0bd5c210084 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 13 Sep 2016 23:06:07 +0200
|
||||||
|
Subject: [PATCH] clean up gv_fetchmethod_pvn_flags: introduce name_end
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.0:
|
||||||
|
|
||||||
|
commit 65308f87d02a1900e59f0002fa94c855d4d4c5df
|
||||||
|
Author: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue Sep 13 23:06:07 2016 +0200
|
||||||
|
|
||||||
|
clean up gv_fetchmethod_pvn_flags: introduce name_end
|
||||||
|
|
||||||
|
nend is used for too many things, this replaces various
|
||||||
|
uses of nend with name_end, which is constant.
|
||||||
|
|
||||||
|
this is a first step to fixing [perl #129267], which shouldnt
|
||||||
|
change any behavior
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
gv.c | 14 ++++++++------
|
||||||
|
1 file changed, 8 insertions(+), 6 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/gv.c b/gv.c
|
||||||
|
index 28396de..d738bf0 100644
|
||||||
|
--- a/gv.c
|
||||||
|
+++ b/gv.c
|
||||||
|
@@ -1014,6 +1014,8 @@ Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
|
||||||
|
GV *
|
||||||
|
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
|
||||||
|
{
|
||||||
|
+ const char * const origname = name;
|
||||||
|
+ const char * const name_end = name + len;
|
||||||
|
const char *nend;
|
||||||
|
const char *nsplit = NULL;
|
||||||
|
GV* gv;
|
||||||
|
@@ -1034,7 +1036,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
the error reporting code. */
|
||||||
|
}
|
||||||
|
|
||||||
|
- for (nend = name; *nend || nend != (origname + len); nend++) {
|
||||||
|
+ for (nend = name; *nend || nend != name_end; nend++) {
|
||||||
|
if (*nend == '\'') {
|
||||||
|
nsplit = nend;
|
||||||
|
name = nend + 1;
|
||||||
|
@@ -1065,13 +1067,13 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
ostash = stash;
|
||||||
|
}
|
||||||
|
|
||||||
|
- gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
|
||||||
|
+ gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
|
||||||
|
if (!gv) {
|
||||||
|
if (strEQ(name,"import") || strEQ(name,"unimport"))
|
||||||
|
gv = MUTABLE_GV(&PL_sv_yes);
|
||||||
|
else if (autoload)
|
||||||
|
gv = gv_autoload_pvn(
|
||||||
|
- ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
|
||||||
|
+ ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
|
||||||
|
);
|
||||||
|
if (!gv && do_croak) {
|
||||||
|
/* Right now this is exclusively for the benefit of S_method_common
|
||||||
|
@@ -1087,14 +1089,14 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
HV_FETCH_ISEXISTS, NULL, 0)
|
||||||
|
) {
|
||||||
|
require_pv("IO/File.pm");
|
||||||
|
- gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
|
||||||
|
+ gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
|
||||||
|
if (gv)
|
||||||
|
return gv;
|
||||||
|
}
|
||||||
|
Perl_croak(aTHX_
|
||||||
|
"Can't locate object method \"%"UTF8f
|
||||||
|
"\" via package \"%"HEKf"\"",
|
||||||
|
- UTF8fARG(is_utf8, nend - name, name),
|
||||||
|
+ UTF8fARG(is_utf8, name_end - name, name),
|
||||||
|
HEKfARG(HvNAME_HEK(stash)));
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
@@ -1111,7 +1113,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
"Can't locate object method \"%"UTF8f
|
||||||
|
"\" via package \"%"SVf"\""
|
||||||
|
" (perhaps you forgot to load \"%"SVf"\"?)",
|
||||||
|
- UTF8fARG(is_utf8, nend - name, name),
|
||||||
|
+ UTF8fARG(is_utf8, name_end - name, name),
|
||||||
|
SVfARG(packnamesv), SVfARG(packnamesv));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
94
SOURCES/perl-5.24.0-crash-on-explicit-return-from-s-e.patch
Normal file
94
SOURCES/perl-5.24.0-crash-on-explicit-return-from-s-e.patch
Normal file
@ -0,0 +1,94 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,66 @@
|
|||||||
|
From d47812b974b515e952dc093e692bf15f0a9afbc4 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 5 Sep 2016 15:40:11 +1000
|
||||||
|
Subject: [PATCH] (perl #129130) make chdir allocate the stack it needs
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.0:
|
||||||
|
|
||||||
|
commit 92c843fb4b4e1a1e0ac7ec0fe198dc77266838da
|
||||||
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon Sep 5 15:40:11 2016 +1000
|
||||||
|
|
||||||
|
(perl #129130) make chdir allocate the stack it needs
|
||||||
|
|
||||||
|
chdir with no argument didn't ensure there was stack space available
|
||||||
|
for its result.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_sys.c | 1 +
|
||||||
|
t/op/chdir.t | 8 +++++++-
|
||||||
|
2 files changed, 8 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index 3bf2673..d2cf872 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -3639,6 +3639,7 @@ PP(pp_chdir)
|
||||||
|
HV * const table = GvHVn(PL_envgv);
|
||||||
|
SV **svp;
|
||||||
|
|
||||||
|
+ EXTEND(SP, 1);
|
||||||
|
if ( (svp = hv_fetchs(table, "HOME", FALSE))
|
||||||
|
|| (svp = hv_fetchs(table, "LOGDIR", FALSE))
|
||||||
|
#ifdef VMS
|
||||||
|
diff --git a/t/op/chdir.t b/t/op/chdir.t
|
||||||
|
index a5ea76a..685e556 100644
|
||||||
|
--- a/t/op/chdir.t
|
||||||
|
+++ b/t/op/chdir.t
|
||||||
|
@@ -10,7 +10,7 @@ BEGIN {
|
||||||
|
# possibilities into @INC.
|
||||||
|
unshift @INC, qw(t . lib ../lib);
|
||||||
|
require "test.pl";
|
||||||
|
- plan(tests => 47);
|
||||||
|
+ plan(tests => 48);
|
||||||
|
}
|
||||||
|
|
||||||
|
use Config;
|
||||||
|
@@ -161,6 +161,12 @@ sub check_env {
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
+fresh_perl_is(<<'EOP', '', { stderr => 1 }, "check stack handling");
|
||||||
|
+for $x (map $_+1, 1 .. 100) {
|
||||||
|
+ map chdir, 1 .. $x;
|
||||||
|
+}
|
||||||
|
+EOP
|
||||||
|
+
|
||||||
|
my %Saved_Env = ();
|
||||||
|
sub clean_env {
|
||||||
|
foreach my $env (@magic_envs) {
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
79
SOURCES/perl-5.24.0-perl-129164-Crash-with-splice.patch
Normal file
79
SOURCES/perl-5.24.0-perl-129164-Crash-with-splice.patch
Normal file
@ -0,0 +1,79 @@
|
|||||||
|
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
|
||||||
|
|
134
SOURCES/perl-5.24.0-perl-129788-IO-Poll-fix-memory-leak.patch
Normal file
134
SOURCES/perl-5.24.0-perl-129788-IO-Poll-fix-memory-leak.patch
Normal file
@ -0,0 +1,134 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,97 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,92 @@
|
|||||||
|
From 03fcc0c44bc7972f2c92736daae5b63d601b7c49 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Dan Collins <dcollinsn@gmail.com>
|
||||||
|
Date: Fri, 23 Sep 2016 01:21:20 -0400
|
||||||
|
Subject: [PATCH] [rt #129336] #!perl -i u erroneously interpreted as -u
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.0:
|
||||||
|
|
||||||
|
commit f54cfdacff1f3744ef08fc70f1f3bc6c7d862e83
|
||||||
|
Author: Dan Collins <dcollinsn@gmail.com>
|
||||||
|
Date: Fri Sep 23 01:21:20 2016 -0400
|
||||||
|
|
||||||
|
[rt #129336] #!perl -i u erroneously interpreted as -u
|
||||||
|
|
||||||
|
Perl_moreswitches processes a single switch, and returns a pointer
|
||||||
|
to the start of the next switch. It can return either
|
||||||
|
the a pointer to the next flag itself:
|
||||||
|
|
||||||
|
#!perl -n -p
|
||||||
|
^ Can point here
|
||||||
|
|
||||||
|
Or, to the space before the next "arg":
|
||||||
|
|
||||||
|
#!perl -n -p
|
||||||
|
^ Can point here
|
||||||
|
|
||||||
|
(Where the next call to Perl_moreswitches will consume " -".)
|
||||||
|
|
||||||
|
In the case of -i[extension], the pointer is by default pointing at
|
||||||
|
the space after the end of the argument. The current code tries to
|
||||||
|
do the former, by unconditionally advancing the pointer, and then
|
||||||
|
advancing it again if it is on a '-'. But that is incorrect:
|
||||||
|
|
||||||
|
#!perl -i p
|
||||||
|
^ Will point here, but that isn't a flag
|
||||||
|
|
||||||
|
I could fix this by removing the unconditional s++, and having it
|
||||||
|
increment by 2 if *(s+1)=='-', but this work isn't actually
|
||||||
|
necessary - it's better to just leave it pointing at the space after
|
||||||
|
the argument.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
perl.c | 5 -----
|
||||||
|
t/op/lex.t | 9 ++++++++-
|
||||||
|
2 files changed, 8 insertions(+), 6 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/perl.c b/perl.c
|
||||||
|
index 228a0d8..5cc7d0b 100644
|
||||||
|
--- a/perl.c
|
||||||
|
+++ b/perl.c
|
||||||
|
@@ -3306,11 +3306,6 @@ Perl_moreswitches(pTHX_ const char *s)
|
||||||
|
|
||||||
|
PL_inplace = savepvn(start, s - start);
|
||||||
|
}
|
||||||
|
- if (*s) {
|
||||||
|
- ++s;
|
||||||
|
- if (*s == '-') /* Additional switches on #! line. */
|
||||||
|
- s++;
|
||||||
|
- }
|
||||||
|
return s;
|
||||||
|
case 'I': /* -I handled both here and in parse_body() */
|
||||||
|
forbid_setid('I', FALSE);
|
||||||
|
diff --git a/t/op/lex.t b/t/op/lex.t
|
||||||
|
index c515449..9ada592 100644
|
||||||
|
--- a/t/op/lex.t
|
||||||
|
+++ b/t/op/lex.t
|
||||||
|
@@ -7,7 +7,7 @@ use warnings;
|
||||||
|
|
||||||
|
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
|
||||||
|
|
||||||
|
-plan(tests => 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
|
||||||
|
|
@ -0,0 +1,94 @@
|
|||||||
|
From 27a8a9e2a55ccc148582006396a9c35bafa5f0b3 Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Wed, 30 Nov 2016 08:59:01 +0000
|
||||||
|
Subject: [PATCH] split was leaving PL_sv_undef in unused ary slots
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Petr Pisar: Ported to 5.24.0:
|
||||||
|
|
||||||
|
commit 71ca73e5fa9639ac33e9f2e74cd0c32288a5040d
|
||||||
|
Author: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Wed Nov 30 08:59:01 2016 +0000
|
||||||
|
|
||||||
|
split was leaving PL_sv_undef in unused ary slots
|
||||||
|
|
||||||
|
This:
|
||||||
|
|
||||||
|
@a = split(/-/,"-");
|
||||||
|
$a[1] = undef;
|
||||||
|
$a[0] = 0;
|
||||||
|
|
||||||
|
was giving
|
||||||
|
|
||||||
|
Modification of a read-only value attempted at foo line 3.
|
||||||
|
|
||||||
|
This is because:
|
||||||
|
|
||||||
|
1) unused slots in AvARRAY between AvFILL and AvMAX should always be
|
||||||
|
null; av_clear(), av_extend() etc do this; while av_store(), if storing
|
||||||
|
to a slot N somewhere between AvFILL and AvMAX, doesn't bother to clear
|
||||||
|
between (AvFILL+1)..(N-1) on the assumption that everyone else plays
|
||||||
|
nicely.
|
||||||
|
|
||||||
|
2) pp_split() when splitting directly to an array, sometimes over-splits
|
||||||
|
and has to null out the excess elements;
|
||||||
|
|
||||||
|
3) Since perl 5.19.4, unused AV slots are now marked with NULL rather than
|
||||||
|
&PL_sv_undef;
|
||||||
|
|
||||||
|
4) pp_split was still using &PL_sv_undef;
|
||||||
|
|
||||||
|
The fault was with (4), and is easily fixed.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp.c | 2 +-
|
||||||
|
t/op/split.t | 13 ++++++++++++-
|
||||||
|
2 files changed, 13 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index 4153482..70345ce 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -6212,7 +6212,7 @@ PP(pp_split)
|
||||||
|
while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
|
||||||
|
if (TOPs && !make_mortal)
|
||||||
|
sv_2mortal(TOPs);
|
||||||
|
- *SP-- = &PL_sv_undef;
|
||||||
|
+ *SP-- = NULL;
|
||||||
|
iters--;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
diff --git a/t/op/split.t b/t/op/split.t
|
||||||
|
index fb73271..b7846a1 100644
|
||||||
|
--- a/t/op/split.t
|
||||||
|
+++ b/t/op/split.t
|
||||||
|
@@ -7,7 +7,7 @@ BEGIN {
|
||||||
|
set_up_inc('../lib');
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 131;
|
||||||
|
+plan tests => 133;
|
||||||
|
|
||||||
|
$FS = ':';
|
||||||
|
|
||||||
|
@@ -523,3 +523,14 @@ is "@a", '1 2 3', 'assignment to split-to-array (pmtarget/package array)';
|
||||||
|
}
|
||||||
|
(@{\@a} = split //, "abc") = 1..10;
|
||||||
|
is "@a", '1 2 3', 'assignment to split-to-array (stacked)';
|
||||||
|
+
|
||||||
|
+# splitting directly to an array wasn't filling unused AvARRAY slots with
|
||||||
|
+# NULL
|
||||||
|
+
|
||||||
|
+{
|
||||||
|
+ my @a;
|
||||||
|
+ @a = split(/-/,"-");
|
||||||
|
+ $a[1] = 'b';
|
||||||
|
+ ok eval { $a[0] = 'a'; 1; }, "array split filling AvARRAY: assign 0";
|
||||||
|
+ is "@a", "a b", "array split filling AvARRAY: result";
|
||||||
|
+}
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,65 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,70 @@
|
|||||||
|
From 4e0fb37303b72ed9d38949139c304abdb73e223e Mon Sep 17 00:00:00 2001
|
||||||
|
From: Aaron Crane <arc@cpan.org>
|
||||||
|
Date: Tue, 24 Jan 2017 23:39:40 +0000
|
||||||
|
Subject: [PATCH] RT#130624: heap-use-after-free in 4-arg substr
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 41b1e858a075694f88057b9514f5fc78c80b5355
|
||||||
|
Author: Aaron Crane <arc@cpan.org>
|
||||||
|
Date: Tue Jan 24 23:39:40 2017 +0000
|
||||||
|
|
||||||
|
RT#130624: heap-use-after-free in 4-arg substr
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp.c | 4 +++-
|
||||||
|
t/op/substr.t | 14 +++++++++++++-
|
||||||
|
2 files changed, 16 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index 334b353..aa6cff0 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -3462,8 +3462,10 @@ PP(pp_substr)
|
||||||
|
tmps = SvPV_force_nomg(sv, curlen);
|
||||||
|
if (DO_UTF8(repl_sv) && repl_len) {
|
||||||
|
if (!DO_UTF8(sv)) {
|
||||||
|
+ /* Upgrade the dest, and recalculate tmps in case the buffer
|
||||||
|
+ * got reallocated; curlen may also have been changed */
|
||||||
|
sv_utf8_upgrade_nomg(sv);
|
||||||
|
- curlen = SvCUR(sv);
|
||||||
|
+ tmps = SvPV_nomg(sv, curlen);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (DO_UTF8(sv))
|
||||||
|
diff --git a/t/op/substr.t b/t/op/substr.t
|
||||||
|
index 01c36a9..f9fee48 100644
|
||||||
|
--- a/t/op/substr.t
|
||||||
|
+++ b/t/op/substr.t
|
||||||
|
@@ -22,7 +22,7 @@ $SIG{__WARN__} = sub {
|
||||||
|
}
|
||||||
|
};
|
||||||
|
|
||||||
|
-plan(389);
|
||||||
|
+plan(391);
|
||||||
|
|
||||||
|
run_tests() unless caller;
|
||||||
|
|
||||||
|
@@ -872,3 +872,15 @@ is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
|
||||||
|
|
||||||
|
# failed with ASAN
|
||||||
|
fresh_perl_is('$0 = "/usr/bin/perl"; substr($0, 0, 0, $0)', '', {}, "(perl #129340) substr() with source in target");
|
||||||
|
+
|
||||||
|
+
|
||||||
|
+# [perl #130624] - heap-use-after-free, observable under asan
|
||||||
|
+{
|
||||||
|
+ my $x = "\xE9zzzz";
|
||||||
|
+ my $y = "\x{100}";
|
||||||
|
+ my $z = substr $x, 0, 1, $y;
|
||||||
|
+ is $z, "\xE9", "RT#130624: heap-use-after-free in 4-arg substr (ret)";
|
||||||
|
+ is $x, "\x{100}zzzz", "RT#130624: heap-use-after-free in 4-arg substr (targ)";
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,93 @@
|
|||||||
|
From fd25d49cae6409a4ce901fd4d899a197541604b3 Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Sat, 4 Feb 2017 15:10:49 +0000
|
||||||
|
Subject: [PATCH] buffer overrun with format and 'use bytes'
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit e452bf1c9e9f30813b1f289188a6e8b0894575ba
|
||||||
|
Author: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Sat Feb 4 15:10:49 2017 +0000
|
||||||
|
|
||||||
|
buffer overrun with format and 'use bytes'
|
||||||
|
|
||||||
|
RT #130703
|
||||||
|
|
||||||
|
In the scope of 'use bytes', appending a string to a format where the
|
||||||
|
format is utf8 and the string is non-utf8 but contains lots of chars
|
||||||
|
with ords >= 128, the buffer could be overrun. This is due to all the
|
||||||
|
\x80-type chars going from being stored as 1 bytes to 2 bytes, without
|
||||||
|
growing PL_formtarget accordingly.
|
||||||
|
|
||||||
|
This commit contains a minimal fix; the next commit will more generally
|
||||||
|
tidy up the grow code in pp_formline.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_ctl.c | 3 +++
|
||||||
|
t/op/write.t | 18 +++++++++++++++++-
|
||||||
|
2 files changed, 20 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
|
index a1fc2f4..4d5ef2e 100644
|
||||||
|
--- a/pp_ctl.c
|
||||||
|
+++ b/pp_ctl.c
|
||||||
|
@@ -505,6 +505,8 @@ PP(pp_formline)
|
||||||
|
SvTAINTED_on(PL_formtarget);
|
||||||
|
if (DO_UTF8(PL_formtarget))
|
||||||
|
targ_is_utf8 = TRUE;
|
||||||
|
+ /* this is an initial estimate of how much output buffer space
|
||||||
|
+ * to allocate. It may be exceeded later */
|
||||||
|
linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
|
||||||
|
t = SvGROW(PL_formtarget, len + linemax + 1);
|
||||||
|
/* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
|
||||||
|
@@ -766,6 +768,7 @@ PP(pp_formline)
|
||||||
|
|
||||||
|
if (targ_is_utf8 && !item_is_utf8) {
|
||||||
|
source = tmp = bytes_to_utf8(source, &to_copy);
|
||||||
|
+ grow = to_copy;
|
||||||
|
} else {
|
||||||
|
if (item_is_utf8 && !targ_is_utf8) {
|
||||||
|
U8 *s;
|
||||||
|
diff --git a/t/op/write.t b/t/op/write.t
|
||||||
|
index ab2733f..ae4ddb5 100644
|
||||||
|
--- a/t/op/write.t
|
||||||
|
+++ b/t/op/write.t
|
||||||
|
@@ -98,7 +98,7 @@ for my $tref ( @NumTests ){
|
||||||
|
my $bas_tests = 21;
|
||||||
|
|
||||||
|
# number of tests in section 3
|
||||||
|
-my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 3;
|
||||||
|
+my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 4;
|
||||||
|
|
||||||
|
# number of tests in section 4
|
||||||
|
my $hmb_tests = 37;
|
||||||
|
@@ -1562,6 +1562,22 @@ ok defined *{$::{CmT}}{FORMAT}, "glob assign";
|
||||||
|
formline $format, $orig, 12345;
|
||||||
|
is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
|
||||||
|
|
||||||
|
+ # ...nor this (RT #130703).
|
||||||
|
+ # Under 'use bytes', the two bytes (c2, 80) making up each \x80 char
|
||||||
|
+ # each get expanded to two bytes (so four in total per \x80 char); the
|
||||||
|
+ # buffer growth wasn't accounting for this doubling in size
|
||||||
|
+
|
||||||
|
+ {
|
||||||
|
+ local $^A = '';
|
||||||
|
+ my $format = "X\n\x{100}" . ("\x80" x 200);
|
||||||
|
+ my $expected = $format;
|
||||||
|
+ utf8::encode($expected);
|
||||||
|
+ use bytes;
|
||||||
|
+ formline($format);
|
||||||
|
+ is $^A, $expected, "RT #130703";
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+
|
||||||
|
# make sure it can cope with formats > 64k
|
||||||
|
|
||||||
|
$format = 'x' x 65537;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,116 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,93 @@
|
|||||||
|
From fbb9dc823a06b4815ee8fd8632fc475b8034e379 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Fri, 27 Jan 2017 10:18:51 +0100
|
||||||
|
Subject: [PATCH] fix RT #130561 - recursion and optimising away impossible
|
||||||
|
quantifiers are not friends
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 31fc93954d1f379c7a49889d91436ce99818e1f6
|
||||||
|
Author: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Fri Jan 27 10:18:51 2017 +0100
|
||||||
|
|
||||||
|
fix RT #130561 - recursion and optimising away impossible quantifiers are not friends
|
||||||
|
|
||||||
|
Instead of optimising away impossible quantifiers like (foo){1,0} treat them
|
||||||
|
as unquantified, and guard them with an OPFAIL. Thus /(foo){1,0}/ is treated
|
||||||
|
the same as /(*FAIL)(foo)/ this is important in patterns like /(foo){1,0}|(?1)/
|
||||||
|
where the (?1) needs to be able to recurse into the (foo) even though the
|
||||||
|
(foo){1,0} can never match. It also resolves various issues (SEGVs) with patterns
|
||||||
|
like /((?1)){1,0}/.
|
||||||
|
|
||||||
|
This patch would have been easier if S_reginsert() documented that it is
|
||||||
|
the callers responsibility to properly set up the NEXT_OFF() of the inserted
|
||||||
|
node (if the node has a NEXT_OFF())
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 14 +++-----------
|
||||||
|
t/re/pat_rt_report.t | 11 ++++++++++-
|
||||||
|
2 files changed, 13 insertions(+), 12 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index bcb8db5..9f343d3 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -11497,19 +11497,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
nextchar(pRExC_state);
|
||||||
|
if (max < min) { /* If can't match, warn and optimize to fail
|
||||||
|
unconditionally */
|
||||||
|
- if (SIZE_ONLY) {
|
||||||
|
-
|
||||||
|
- /* We can't back off the size because we have to reserve
|
||||||
|
- * enough space for all the things we are about to throw
|
||||||
|
- * away, but we can shrink it by the amount we are about
|
||||||
|
- * to re-use here */
|
||||||
|
- RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
|
||||||
|
- }
|
||||||
|
- else {
|
||||||
|
+ if (PASS2) {
|
||||||
|
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
|
||||||
|
- RExC_emit = orig_emit;
|
||||||
|
}
|
||||||
|
- ret = reganode(pRExC_state, OPFAIL, 0);
|
||||||
|
+ reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
|
||||||
|
+ NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
|
||||||
|
return ret;
|
||||||
|
}
|
||||||
|
else if (min == max && *RExC_parse == '?')
|
||||||
|
diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
|
||||||
|
index cb02ad2..2c1dbc4 100644
|
||||||
|
--- a/t/re/pat_rt_report.t
|
||||||
|
+++ b/t/re/pat_rt_report.t
|
||||||
|
@@ -20,7 +20,7 @@ use warnings;
|
||||||
|
use 5.010;
|
||||||
|
use Config;
|
||||||
|
|
||||||
|
-plan tests => 2500; # Update this when adding/deleting tests.
|
||||||
|
+plan tests => 2502; # Update this when adding/deleting tests.
|
||||||
|
|
||||||
|
run_tests() unless caller;
|
||||||
|
|
||||||
|
@@ -1113,6 +1113,15 @@ EOP
|
||||||
|
my $s = "\x{1ff}" . "f" x 32;
|
||||||
|
ok($s =~ /\x{1ff}[[:alpha:]]+/gca, "POSIXA pointer wrap");
|
||||||
|
}
|
||||||
|
+ {
|
||||||
|
+ # rt
|
||||||
|
+ fresh_perl_is(
|
||||||
|
+ '"foo"=~/((?1)){8,0}/; print "ok"',
|
||||||
|
+ "ok", {}, 'RT #130561 - allowing impossible quantifier should not cause SEGVs');
|
||||||
|
+ my $s= "foo";
|
||||||
|
+ ok($s=~/(foo){1,0}|(?1)/,
|
||||||
|
+ "RT #130561 - allowing impossible quantifier should not break recursion");
|
||||||
|
+ }
|
||||||
|
} # End of sub run_tests
|
||||||
|
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
198
SOURCES/perl-5.24.1-fix-pad-scope-issue-in-re_evals.patch
Normal file
198
SOURCES/perl-5.24.1-fix-pad-scope-issue-in-re_evals.patch
Normal file
@ -0,0 +1,198 @@
|
|||||||
|
From f3704e62341b10824f503aa0c8029670d101a434 Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Sat, 11 Feb 2017 11:53:41 +0000
|
||||||
|
Subject: [PATCH] fix pad/scope issue in re_evals
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
commit 4b9c7caeaecf4e9df0be3a2e296644f763f775d6
|
||||||
|
Author: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Sat Feb 11 11:53:41 2017 +0000
|
||||||
|
|
||||||
|
fix pad/scope issue in re_evals
|
||||||
|
|
||||||
|
RT #129881 heap-buffer-overflow Perl_pad_sv
|
||||||
|
|
||||||
|
In some circumstances involving a pattern which has embedded code blocks
|
||||||
|
from more than one source, e.g.
|
||||||
|
|
||||||
|
my $r = qr{(?{1;}){2}X};
|
||||||
|
"" =~ /$r|(?{1;})/;
|
||||||
|
|
||||||
|
the wrong PL_comppad could be active while doing a LEAVE_SCOPE() or on
|
||||||
|
exit from the pattern.
|
||||||
|
|
||||||
|
This was mainly due to the big context stack changes in 5.24.0 - in
|
||||||
|
particular, since POP_MULTICALL() now does CX_LEAVE_SCOPE(cx) *before*
|
||||||
|
restoring PL_comppad, the (correct) unwinding of any SAVECOMPPAD's was
|
||||||
|
being followed by C<PL_comppad = cx->blk_sub.prevcomppad>, which wasn't
|
||||||
|
necessarily a sensible value.
|
||||||
|
|
||||||
|
To fix this, record the value of PL_savestack_ix at entry to S_regmatch(),
|
||||||
|
and set the cx->blk_oldsaveix of the MULTICALL to this value when pushed.
|
||||||
|
On exit from S_regmatch, we either POP_MULTICALL which will do a
|
||||||
|
LEAVE_SCOPE(cx->blk_oldsaveix), or in the absense of any EVAL, do the
|
||||||
|
explicit but equivalent LEAVE_SCOPE(orig_savestack_ix).
|
||||||
|
|
||||||
|
Note that this is a change in behaviour to S_regmatch() - formerly it
|
||||||
|
wouldn't necessarily clear the savestack completely back the point of
|
||||||
|
entry - that would get left to do by its caller, S_regtry(), or indirectly
|
||||||
|
by Perl_regexec_flags(). This shouldn't make any practical difference, but
|
||||||
|
is tidier and less likely to introduce bugs later.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regexec.c | 69 +++++++++++++++++++++++++++++++++++++++++++-----------
|
||||||
|
t/re/pat_re_eval.t | 20 +++++++++++++++-
|
||||||
|
2 files changed, 74 insertions(+), 15 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regexec.c b/regexec.c
|
||||||
|
index a7bc0c3..5656cdd 100644
|
||||||
|
--- a/regexec.c
|
||||||
|
+++ b/regexec.c
|
||||||
|
@@ -5233,6 +5233,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
|
||||||
|
_char_class_number classnum;
|
||||||
|
bool is_utf8_pat = reginfo->is_utf8_pat;
|
||||||
|
bool match = FALSE;
|
||||||
|
+ I32 orig_savestack_ix = PL_savestack_ix;
|
||||||
|
|
||||||
|
/* Solaris Studio 12.3 messes up fetching PL_charclass['\n'] */
|
||||||
|
#if (defined(__SUNPRO_C) && (__SUNPRO_C == 0x5120) && defined(__x86_64) && defined(USE_64_BIT_ALL))
|
||||||
|
@@ -6646,30 +6647,67 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
|
||||||
|
nop = (OP*)rexi->data->data[n];
|
||||||
|
}
|
||||||
|
|
||||||
|
- /* normally if we're about to execute code from the same
|
||||||
|
- * CV that we used previously, we just use the existing
|
||||||
|
- * CX stack entry. However, its possible that in the
|
||||||
|
- * meantime we may have backtracked, popped from the save
|
||||||
|
- * stack, and undone the SAVECOMPPAD(s) associated with
|
||||||
|
- * PUSH_MULTICALL; in which case PL_comppad no longer
|
||||||
|
- * points to newcv's pad. */
|
||||||
|
+ /* Some notes about MULTICALL and the context and save stacks.
|
||||||
|
+ *
|
||||||
|
+ * In something like
|
||||||
|
+ * /...(?{ my $x)}...(?{ my $z)}...(?{ my $z)}.../
|
||||||
|
+ * since codeblocks don't introduce a new scope (so that
|
||||||
|
+ * local() etc accumulate), at the end of a successful
|
||||||
|
+ * match there will be a SAVEt_CLEARSV on the savestack
|
||||||
|
+ * for each of $x, $y, $z. If the three code blocks above
|
||||||
|
+ * happen to have come from different CVs (e.g. via
|
||||||
|
+ * embedded qr//s), then we must ensure that during any
|
||||||
|
+ * savestack unwinding, PL_comppad always points to the
|
||||||
|
+ * right pad at each moment. We achieve this by
|
||||||
|
+ * interleaving SAVEt_COMPPAD's on the savestack whenever
|
||||||
|
+ * there is a change of pad.
|
||||||
|
+ * In theory whenever we call a code block, we should
|
||||||
|
+ * push a CXt_SUB context, then pop it on return from
|
||||||
|
+ * that code block. This causes a bit of an issue in that
|
||||||
|
+ * normally popping a context also clears the savestack
|
||||||
|
+ * back to cx->blk_oldsaveix, but here we specifically
|
||||||
|
+ * don't want to clear the save stack on exit from the
|
||||||
|
+ * code block.
|
||||||
|
+ * Also for efficiency we don't want to keep pushing and
|
||||||
|
+ * popping the single SUB context as we backtrack etc.
|
||||||
|
+ * So instead, we push a single context the first time
|
||||||
|
+ * we need, it, then hang onto it until the end of this
|
||||||
|
+ * function. Whenever we encounter a new code block, we
|
||||||
|
+ * update the CV etc if that's changed. During the times
|
||||||
|
+ * in this function where we're not executing a code
|
||||||
|
+ * block, having the SUB context still there is a bit
|
||||||
|
+ * naughty - but we hope that no-one notices.
|
||||||
|
+ * When the SUB context is initially pushed, we fake up
|
||||||
|
+ * cx->blk_oldsaveix to be as if we'd pushed this context
|
||||||
|
+ * on first entry to S_regmatch rather than at some random
|
||||||
|
+ * point during the regexe execution. That way if we
|
||||||
|
+ * croak, popping the context stack will ensure that
|
||||||
|
+ * *everything* SAVEd by this function is undone and then
|
||||||
|
+ * the context popped, rather than e.g., popping the
|
||||||
|
+ * context (and restoring the original PL_comppad) then
|
||||||
|
+ * popping more of the savestack and restoiring a bad
|
||||||
|
+ * PL_comppad.
|
||||||
|
+ */
|
||||||
|
+
|
||||||
|
+ /* If this is the first EVAL, push a MULTICALL. On
|
||||||
|
+ * subsequent calls, if we're executing a different CV, or
|
||||||
|
+ * if PL_comppad has got messed up from backtracking
|
||||||
|
+ * through SAVECOMPPADs, then refresh the context.
|
||||||
|
+ */
|
||||||
|
if (newcv != last_pushed_cv || PL_comppad != last_pad)
|
||||||
|
{
|
||||||
|
U8 flags = (CXp_SUB_RE |
|
||||||
|
((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0));
|
||||||
|
+ SAVECOMPPAD();
|
||||||
|
if (last_pushed_cv) {
|
||||||
|
- /* PUSH/POP_MULTICALL save and restore the
|
||||||
|
- * caller's PL_comppad; if we call multiple subs
|
||||||
|
- * using the same CX block, we have to save and
|
||||||
|
- * unwind the varying PL_comppad's ourselves,
|
||||||
|
- * especially restoring the right PL_comppad on
|
||||||
|
- * backtrack - so save it on the save stack */
|
||||||
|
- SAVECOMPPAD();
|
||||||
|
CHANGE_MULTICALL_FLAGS(newcv, flags);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
PUSH_MULTICALL_FLAGS(newcv, flags);
|
||||||
|
}
|
||||||
|
+ /* see notes above */
|
||||||
|
+ CX_CUR()->blk_oldsaveix = orig_savestack_ix;
|
||||||
|
+
|
||||||
|
last_pushed_cv = newcv;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
@@ -8456,9 +8494,12 @@ NULL
|
||||||
|
|
||||||
|
if (last_pushed_cv) {
|
||||||
|
dSP;
|
||||||
|
+ /* see "Some notes about MULTICALL" above */
|
||||||
|
POP_MULTICALL;
|
||||||
|
PERL_UNUSED_VAR(SP);
|
||||||
|
}
|
||||||
|
+ else
|
||||||
|
+ LEAVE_SCOPE(orig_savestack_ix);
|
||||||
|
|
||||||
|
assert(!result || locinput - reginfo->strbeg >= 0);
|
||||||
|
return result ? locinput - reginfo->strbeg : -1;
|
||||||
|
diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t
|
||||||
|
index e59b059..1a0b228 100644
|
||||||
|
--- a/t/re/pat_re_eval.t
|
||||||
|
+++ b/t/re/pat_re_eval.t
|
||||||
|
@@ -22,7 +22,7 @@ BEGIN {
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
-plan tests => 527; # Update this when adding/deleting tests.
|
||||||
|
+plan tests => 530; # Update this when adding/deleting tests.
|
||||||
|
|
||||||
|
run_tests() unless caller;
|
||||||
|
|
||||||
|
@@ -1232,6 +1232,24 @@ sub run_tests {
|
||||||
|
'padtmp swiping does not affect "$a$b" =~ /(??{})/'
|
||||||
|
}
|
||||||
|
|
||||||
|
+ # RT #129881
|
||||||
|
+ # on exit from a pattern with multiple code blocks from different
|
||||||
|
+ # CVs, PL_comppad wasn't being restored correctly
|
||||||
|
+
|
||||||
|
+ sub {
|
||||||
|
+ # give first few pad slots known values
|
||||||
|
+ my ($x1, $x2, $x3, $x4, $x5) = 101..105;
|
||||||
|
+ # these vars are in a separate pad
|
||||||
|
+ my $r = qr/((?{my ($y1, $y2) = 201..202; 1;})A){2}X/;
|
||||||
|
+ # the first alt fails, causing a switch to this anon
|
||||||
|
+ # sub's pad
|
||||||
|
+ "AAA" =~ /$r|(?{my ($z1, $z2) = 301..302; 1;})A/;
|
||||||
|
+ is $x1, 101, "RT #129881: x1";
|
||||||
|
+ is $x2, 102, "RT #129881: x2";
|
||||||
|
+ is $x3, 103, "RT #129881: x3";
|
||||||
|
+ }->();
|
||||||
|
+
|
||||||
|
+
|
||||||
|
} # End of sub run_tests
|
||||||
|
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
79
SOURCES/perl-5.24.1-fix-special-case-recreation-of.patch
Normal file
79
SOURCES/perl-5.24.1-fix-special-case-recreation-of.patch
Normal file
@ -0,0 +1,79 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,107 @@
|
|||||||
|
From 0c43d46cd570d2a19edfa54b9c637dea5c0a3514 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Thu, 19 Jan 2017 16:28:03 +1100
|
||||||
|
Subject: [PATCH] (perl #129125) copy form data if it might be freed
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 86191aed6f092273950ebdd48f886d4ec0c5e85e
|
||||||
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Thu Jan 19 16:28:03 2017 +1100
|
||||||
|
|
||||||
|
(perl #129125) copy form data if it might be freed
|
||||||
|
|
||||||
|
If the format SV also appeared as an argument, and the FF_CHOP
|
||||||
|
operator modified that argument, the magic and hence the compiled
|
||||||
|
format would be freed, and the next iteration of the processing
|
||||||
|
the compiled format would read freed memory.
|
||||||
|
|
||||||
|
Unlike my original patch this copies the formsv too, since
|
||||||
|
that is also stored in the magic, and is needed for presenting
|
||||||
|
literal text from the format.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_ctl.c | 18 ++++++++++++++++++
|
||||||
|
t/op/write.t | 19 ++++++++++++++++++-
|
||||||
|
2 files changed, 36 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
|
index b94c09a..e859e01 100644
|
||||||
|
--- a/pp_ctl.c
|
||||||
|
+++ b/pp_ctl.c
|
||||||
|
@@ -490,6 +490,7 @@ PP(pp_formline)
|
||||||
|
U8 *source; /* source of bytes to append */
|
||||||
|
STRLEN to_copy; /* how may bytes to append */
|
||||||
|
char trans; /* what chars to translate */
|
||||||
|
+ bool copied_form = false; /* have we duplicated the form? */
|
||||||
|
|
||||||
|
mg = doparseform(tmpForm);
|
||||||
|
|
||||||
|
@@ -687,6 +688,23 @@ PP(pp_formline)
|
||||||
|
case FF_CHOP: /* (for ^*) chop the current item */
|
||||||
|
if (sv != &PL_sv_no) {
|
||||||
|
const char *s = chophere;
|
||||||
|
+ if (!copied_form &&
|
||||||
|
+ ((sv == tmpForm || SvSMAGICAL(sv))
|
||||||
|
+ || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
|
||||||
|
+ /* sv and tmpForm are either the same SV, or magic might allow modification
|
||||||
|
+ of tmpForm when sv is modified, so copy */
|
||||||
|
+ SV *newformsv = sv_mortalcopy(formsv);
|
||||||
|
+ U32 *new_compiled;
|
||||||
|
+
|
||||||
|
+ f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
|
||||||
|
+ Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
|
||||||
|
+ memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
|
||||||
|
+ SAVEFREEPV(new_compiled);
|
||||||
|
+ fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
|
||||||
|
+ formsv = newformsv;
|
||||||
|
+
|
||||||
|
+ copied_form = true;
|
||||||
|
+ }
|
||||||
|
if (chopspace) {
|
||||||
|
while (isSPACE(*s))
|
||||||
|
s++;
|
||||||
|
diff --git a/t/op/write.t b/t/op/write.t
|
||||||
|
index 590d658..ab2733f 100644
|
||||||
|
--- a/t/op/write.t
|
||||||
|
+++ b/t/op/write.t
|
||||||
|
@@ -98,7 +98,7 @@ for my $tref ( @NumTests ){
|
||||||
|
my $bas_tests = 21;
|
||||||
|
|
||||||
|
# number of tests in section 3
|
||||||
|
-my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 11 + 3;
|
||||||
|
+my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 3;
|
||||||
|
|
||||||
|
# number of tests in section 4
|
||||||
|
my $hmb_tests = 37;
|
||||||
|
@@ -1637,6 +1637,23 @@ printf ">%s<\n", ref $zamm;
|
||||||
|
print "$zamm->[0]\n";
|
||||||
|
EOP
|
||||||
|
|
||||||
|
+# [perl #129125] - detected by -fsanitize=address or valgrind
|
||||||
|
+# the compiled format would be freed when the format string was modified
|
||||||
|
+# by the chop operator
|
||||||
|
+fresh_perl_is(<<'EOP', "^", { stderr => 1 }, '#129125 - chop on format');
|
||||||
|
+my $x = '^@';
|
||||||
|
+formline$x=>$x;
|
||||||
|
+print $^A;
|
||||||
|
+EOP
|
||||||
|
+
|
||||||
|
+fresh_perl_is(<<'EOP', '<^< xx AA><xx ^<><>', { stderr => 1 }, '#129125 - chop on format, later values');
|
||||||
|
+my $x = '^< xx ^<';
|
||||||
|
+my $y = 'AA';
|
||||||
|
+formline $x => $x, $y;
|
||||||
|
+print "<$^A><$x><$y>";
|
||||||
|
+EOP
|
||||||
|
+
|
||||||
|
+
|
||||||
|
# [perl #73690]
|
||||||
|
|
||||||
|
select +(select(RT73690), do {
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,70 @@
|
|||||||
|
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
|
||||||
|
|
@ -0,0 +1,49 @@
|
|||||||
|
From 92f8cd4e7b0ff3d09162139e3c99b1d9310bca81 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 10 Oct 2016 10:46:46 +1100
|
||||||
|
Subject: [PATCH] (perl #129281) test for buffer overflow issue
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit d2ba660af00f1bf2e7012741615eff7c19f29707
|
||||||
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon Oct 10 10:46:46 2016 +1100
|
||||||
|
|
||||||
|
(perl #129281) test for buffer overflow issue
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/re/pat.t | 7 ++++++-
|
||||||
|
1 file changed, 6 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/re/pat.t b/t/re/pat.t
|
||||||
|
index 749edd0..7b8e6f7 100644
|
||||||
|
--- a/t/re/pat.t
|
||||||
|
+++ b/t/re/pat.t
|
||||||
|
@@ -23,7 +23,7 @@ BEGIN {
|
||||||
|
skip_all_without_unicode_tables();
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 792; # Update this when adding/deleting tests.
|
||||||
|
+plan tests => 793; # Update this when adding/deleting tests.
|
||||||
|
|
||||||
|
run_tests() unless caller;
|
||||||
|
|
||||||
|
@@ -1779,6 +1779,11 @@ EOP
|
||||||
|
}msx, { stderr => 1 }, "Offsets in debug output are not negative");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
+ {
|
||||||
|
+ # [perl #129281] buffer write overflow, detected by ASAN, valgrind
|
||||||
|
+ local $::TODO = "whilem_c bumped too much";
|
||||||
|
+ fresh_perl_is('/0(?0)|^*0(?0)|^*(^*())0|/', '', {}, "don't bump whilem_c too much");
|
||||||
|
+ }
|
||||||
|
} # End of sub run_tests
|
||||||
|
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,104 @@
|
|||||||
|
From 4fe0e2d067ac5639d94f35f8c7e8ac4e0e3ab336 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 20 Feb 2017 11:02:21 +1100
|
||||||
|
Subject: [PATCH] (perl #129340) copy the source when inside the dest in
|
||||||
|
sv_insert_flags()
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit e7a8a8aac45d42d72d1586227ca51771f193f5dc
|
||||||
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon Feb 20 11:02:21 2017 +1100
|
||||||
|
|
||||||
|
(perl #129340) copy the source when inside the dest in sv_insert_flags()
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
embed.fnc | 2 +-
|
||||||
|
proto.h | 2 +-
|
||||||
|
sv.c | 12 +++++++++++-
|
||||||
|
t/op/substr.t | 5 ++++-
|
||||||
|
4 files changed, 17 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/embed.fnc b/embed.fnc
|
||||||
|
index a64ffba..2395efb 100644
|
||||||
|
--- a/embed.fnc
|
||||||
|
+++ b/embed.fnc
|
||||||
|
@@ -1437,7 +1437,7 @@ Amdb |void |sv_insert |NN SV *const bigstr|const STRLEN offset \
|
||||||
|
|const STRLEN len|NN const char *const little \
|
||||||
|
|const STRLEN littlelen
|
||||||
|
Apd |void |sv_insert_flags|NN SV *const bigstr|const STRLEN offset|const STRLEN len \
|
||||||
|
- |NN const char *const little|const STRLEN littlelen|const U32 flags
|
||||||
|
+ |NN const char *little|const STRLEN littlelen|const U32 flags
|
||||||
|
Apd |int |sv_isa |NULLOK SV* sv|NN const char *const name
|
||||||
|
Apd |int |sv_isobject |NULLOK SV* sv
|
||||||
|
Apd |STRLEN |sv_len |NULLOK SV *const sv
|
||||||
|
diff --git a/proto.h b/proto.h
|
||||||
|
index fb4ee29..2b2004a 100644
|
||||||
|
--- a/proto.h
|
||||||
|
+++ b/proto.h
|
||||||
|
@@ -3015,7 +3015,7 @@ PERL_CALLCONV void Perl_sv_inc_nomg(pTHX_ SV *const sv);
|
||||||
|
/* PERL_CALLCONV void Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen); */
|
||||||
|
#define PERL_ARGS_ASSERT_SV_INSERT \
|
||||||
|
assert(bigstr); assert(little)
|
||||||
|
-PERL_CALLCONV void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags);
|
||||||
|
+PERL_CALLCONV void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *little, const STRLEN littlelen, const U32 flags);
|
||||||
|
#define PERL_ARGS_ASSERT_SV_INSERT_FLAGS \
|
||||||
|
assert(bigstr); assert(little)
|
||||||
|
PERL_CALLCONV int Perl_sv_isa(pTHX_ SV* sv, const char *const name);
|
||||||
|
diff --git a/sv.c b/sv.c
|
||||||
|
index d1e84f0..697db41 100644
|
||||||
|
--- a/sv.c
|
||||||
|
+++ b/sv.c
|
||||||
|
@@ -6223,7 +6223,7 @@ C<SvPV_force_flags> that applies to C<bigstr>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
void
|
||||||
|
-Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
|
||||||
|
+Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *little, const STRLEN littlelen, const U32 flags)
|
||||||
|
{
|
||||||
|
char *big;
|
||||||
|
char *mid;
|
||||||
|
@@ -6236,6 +6236,16 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l
|
||||||
|
|
||||||
|
SvPV_force_flags(bigstr, curlen, flags);
|
||||||
|
(void)SvPOK_only_UTF8(bigstr);
|
||||||
|
+
|
||||||
|
+ if (little >= SvPVX(bigstr) &&
|
||||||
|
+ little < SvPVX(bigstr) + (SvLEN(bigstr) ? SvLEN(bigstr) : SvCUR(bigstr))) {
|
||||||
|
+ /* little is a pointer to within bigstr, since we can reallocate bigstr,
|
||||||
|
+ or little...little+littlelen might overlap offset...offset+len we make a copy
|
||||||
|
+ */
|
||||||
|
+ little = savepvn(little, littlelen);
|
||||||
|
+ SAVEFREEPV(little);
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
if (offset + len > curlen) {
|
||||||
|
SvGROW(bigstr, offset+len+1);
|
||||||
|
Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
|
||||||
|
diff --git a/t/op/substr.t b/t/op/substr.t
|
||||||
|
index eae2403..01c36a9 100644
|
||||||
|
--- a/t/op/substr.t
|
||||||
|
+++ b/t/op/substr.t
|
||||||
|
@@ -22,7 +22,7 @@ $SIG{__WARN__} = sub {
|
||||||
|
}
|
||||||
|
};
|
||||||
|
|
||||||
|
-plan(388);
|
||||||
|
+plan(389);
|
||||||
|
|
||||||
|
run_tests() unless caller;
|
||||||
|
|
||||||
|
@@ -869,3 +869,6 @@ is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
|
||||||
|
|
||||||
|
is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]");
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+# failed with ASAN
|
||||||
|
+fresh_perl_is('$0 = "/usr/bin/perl"; substr($0, 0, 0, $0)', '', {}, "(perl #129340) substr() with source in target");
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,73 @@
|
|||||||
|
From a26907949ed561dccd661fc8600889eddc6664ea Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Wed, 5 Oct 2016 14:53:27 +0100
|
||||||
|
Subject: [PATCH] [perl #129342] ensure range-start is set after error in tr///
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
t 59143e29a717d67a61b869a6c5bb49574f1ef43f
|
||||||
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Tue Jan 17 11:52:53 2017 +1100
|
||||||
|
|
||||||
|
(perl #129342) test for buffer overflow
|
||||||
|
|
||||||
|
commit 3dd4eaeb8ac39e08179145b86aedda36584a3509
|
||||||
|
Author: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Wed Oct 5 14:53:27 2016 +0100
|
||||||
|
|
||||||
|
[perl #129342] ensure range-start is set after error in tr///
|
||||||
|
|
||||||
|
A parse error due to invalid octal or hex escape in the range of a
|
||||||
|
transliteration must still ensure some kind of start and end values
|
||||||
|
are captured, since we don't stop on the first such error. Failure
|
||||||
|
to do so can cause invalid reads after "Here we have parsed a range".
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/lib/croak/toke | 7 +++++++
|
||||||
|
toke.c | 4 ++--
|
||||||
|
2 files changed, 9 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/lib/croak/toke b/t/lib/croak/toke
|
||||||
|
index 18dfa24..578a6da 100644
|
||||||
|
--- a/t/lib/croak/toke
|
||||||
|
+++ b/t/lib/croak/toke
|
||||||
|
@@ -302,3 +302,10 @@ Execution of - aborted due to compilation errors.
|
||||||
|
BEGIN <>
|
||||||
|
EXPECT
|
||||||
|
Illegal declaration of subroutine BEGIN at - line 1.
|
||||||
|
+########
|
||||||
|
+# NAME tr/// handling of mis-formatted \o characters
|
||||||
|
+# may only fail with ASAN
|
||||||
|
+tr/\o-0//;
|
||||||
|
+EXPECT
|
||||||
|
+Missing braces on \o{} at - line 2, within string
|
||||||
|
+Execution of - aborted due to compilation errors.
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index 288f372..576ce72 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -3338,7 +3338,7 @@ S_scan_const(pTHX_ char *start)
|
||||||
|
UTF);
|
||||||
|
if (! valid) {
|
||||||
|
yyerror(error);
|
||||||
|
- continue;
|
||||||
|
+ uv = 0; /* drop through to ensure range ends are set */
|
||||||
|
}
|
||||||
|
goto NUM_ESCAPE_INSERT;
|
||||||
|
}
|
||||||
|
@@ -3356,7 +3356,7 @@ S_scan_const(pTHX_ char *start)
|
||||||
|
UTF);
|
||||||
|
if (! valid) {
|
||||||
|
yyerror(error);
|
||||||
|
- continue;
|
||||||
|
+ uv = 0; /* drop through to ensure range ends are set */
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,107 @@
|
|||||||
|
From a08fa6fd157fd0d61da7f20f07b939fbc302c2c6 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Wed, 5 Oct 2016 12:56:05 +0100
|
||||||
|
Subject: [PATCH] [perl #129377] don't read past start of string for unmatched
|
||||||
|
backref
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 2dfc11ec3af312f4fa3eb244077c79dbb5fc2d85
|
||||||
|
Author: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Wed Oct 5 12:56:05 2016 +0100
|
||||||
|
|
||||||
|
[perl #129377] don't read past start of string for unmatched backref
|
||||||
|
|
||||||
|
We can have (start, end) == (0, -1) for an unmatched backref, we must
|
||||||
|
check for that.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regexec.c | 10 ++++++----
|
||||||
|
t/re/pat.t | 16 +++++++++++++++-
|
||||||
|
2 files changed, 21 insertions(+), 5 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regexec.c b/regexec.c
|
||||||
|
index a5d5db4..a7bc0c3 100644
|
||||||
|
--- a/regexec.c
|
||||||
|
+++ b/regexec.c
|
||||||
|
@@ -5179,6 +5179,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
|
||||||
|
regnode *next;
|
||||||
|
U32 n = 0; /* general value; init to avoid compiler warning */
|
||||||
|
SSize_t ln = 0; /* len or last; init to avoid compiler warning */
|
||||||
|
+ SSize_t endref = 0; /* offset of end of backref when ln is start */
|
||||||
|
char *locinput = startpos;
|
||||||
|
char *pushinput; /* where to continue after a PUSH */
|
||||||
|
I32 nextchr; /* is always set to UCHARAT(locinput), or -1 at EOS */
|
||||||
|
@@ -6489,10 +6490,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
|
||||||
|
|
||||||
|
do_nref_ref_common:
|
||||||
|
ln = rex->offs[n].start;
|
||||||
|
+ endref = rex->offs[n].end;
|
||||||
|
reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */
|
||||||
|
- if (rex->lastparen < n || ln == -1)
|
||||||
|
+ if (rex->lastparen < n || ln == -1 || endref == -1)
|
||||||
|
sayNO; /* Do not match unless seen CLOSEn. */
|
||||||
|
- if (ln == rex->offs[n].end)
|
||||||
|
+ if (ln == endref)
|
||||||
|
break;
|
||||||
|
|
||||||
|
s = reginfo->strbeg + ln;
|
||||||
|
@@ -6506,7 +6508,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
|
||||||
|
* not going off the end given by reginfo->strend, and
|
||||||
|
* returns in <limit> upon success, how much of the
|
||||||
|
* current input was matched */
|
||||||
|
- if (! foldEQ_utf8_flags(s, NULL, rex->offs[n].end - ln, utf8_target,
|
||||||
|
+ if (! foldEQ_utf8_flags(s, NULL, endref - ln, utf8_target,
|
||||||
|
locinput, &limit, 0, utf8_target, utf8_fold_flags))
|
||||||
|
{
|
||||||
|
sayNO;
|
||||||
|
@@ -6521,7 +6523,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
|
||||||
|
(type == REF ||
|
||||||
|
UCHARAT(s) != fold_array[nextchr]))
|
||||||
|
sayNO;
|
||||||
|
- ln = rex->offs[n].end - ln;
|
||||||
|
+ ln = endref - ln;
|
||||||
|
if (locinput + ln > reginfo->strend)
|
||||||
|
sayNO;
|
||||||
|
if (ln > 1 && (type == REF
|
||||||
|
diff --git a/t/re/pat.t b/t/re/pat.t
|
||||||
|
index 4aa77cf..749edd0 100644
|
||||||
|
--- a/t/re/pat.t
|
||||||
|
+++ b/t/re/pat.t
|
||||||
|
@@ -23,7 +23,7 @@ BEGIN {
|
||||||
|
skip_all_without_unicode_tables();
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 791; # Update this when adding/deleting tests.
|
||||||
|
+plan tests => 792; # Update this when adding/deleting tests.
|
||||||
|
|
||||||
|
run_tests() unless caller;
|
||||||
|
|
||||||
|
@@ -1765,6 +1765,20 @@ EOP
|
||||||
|
utf8::upgrade($str);
|
||||||
|
ok( $str =~ m{^(a|a\x{e4})$}, "fix [perl #129950] - utf8 case" );
|
||||||
|
}
|
||||||
|
+ {
|
||||||
|
+ # [perl #129377] backref to an unmatched capture should not cause
|
||||||
|
+ # reading before start of string.
|
||||||
|
+ SKIP: {
|
||||||
|
+ skip "no re-debug under miniperl" if is_miniperl;
|
||||||
|
+ my $prog = <<'EOP';
|
||||||
|
+use re qw(Debug EXECUTE);
|
||||||
|
+"x" =~ m{ () y | () \1 }x;
|
||||||
|
+EOP
|
||||||
|
+ fresh_perl_like($prog, qr{
|
||||||
|
+ \A (?! .* ^ \s+ - )
|
||||||
|
+ }msx, { stderr => 1 }, "Offsets in debug output are not negative");
|
||||||
|
+ }
|
||||||
|
+ }
|
||||||
|
} # End of sub run_tests
|
||||||
|
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,62 @@
|
|||||||
|
From 2bcb4a5888b1c26ee11bc447cc02b42290c707af Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 5 Dec 2016 11:48:14 +1100
|
||||||
|
Subject: [PATCH] (perl #130262) split scalar context stack overflow fix
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.14.1:
|
||||||
|
|
||||||
|
commit 02c161ef974f8f1efbb5632f741c1164adb6ca75
|
||||||
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon Dec 5 11:48:14 2016 +1100
|
||||||
|
|
||||||
|
(perl #130262) split scalar context stack overflow fix
|
||||||
|
|
||||||
|
pp_split didn't ensure there was space for its return value
|
||||||
|
in scalar context.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp.c | 2 +-
|
||||||
|
t/op/split.t | 6 +++++-
|
||||||
|
2 files changed, 6 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index 70345ce..334b353 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -6259,7 +6259,7 @@ PP(pp_split)
|
||||||
|
}
|
||||||
|
|
||||||
|
GETTARGET;
|
||||||
|
- PUSHi(iters);
|
||||||
|
+ XPUSHi(iters);
|
||||||
|
RETURN;
|
||||||
|
}
|
||||||
|
|
||||||
|
diff --git a/t/op/split.t b/t/op/split.t
|
||||||
|
index b7846a1..3e08841 100644
|
||||||
|
--- a/t/op/split.t
|
||||||
|
+++ b/t/op/split.t
|
||||||
|
@@ -7,7 +7,7 @@ BEGIN {
|
||||||
|
set_up_inc('../lib');
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 133;
|
||||||
|
+plan tests => 134;
|
||||||
|
|
||||||
|
$FS = ':';
|
||||||
|
|
||||||
|
@@ -534,3 +534,7 @@ is "@a", '1 2 3', 'assignment to split-to-array (stacked)';
|
||||||
|
ok eval { $a[0] = 'a'; 1; }, "array split filling AvARRAY: assign 0";
|
||||||
|
is "@a", "a b", "array split filling AvARRAY: result";
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+fresh_perl_is(<<'CODE', '', {}, "scalar split stack overflow");
|
||||||
|
+map{int"";split//.0>60for"0000000000000000"}split// for"00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
|
||||||
|
+CODE
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,50 @@
|
|||||||
|
From 9df34f9c4701104a366e768237ca694411136d2a Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Sun, 19 Feb 2017 10:46:09 +0000
|
||||||
|
Subject: [PATCH] update pointer into PL_linestr after lookahead
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to: 5.24.1:
|
||||||
|
|
||||||
|
commit 90f2cc9a600117a49f8ee3e30cc681f062350c24
|
||||||
|
Author: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Sun Feb 19 10:46:09 2017 +0000
|
||||||
|
|
||||||
|
[perl #130814] update pointer into PL_linestr after lookahead
|
||||||
|
|
||||||
|
Looking ahead for the "Missing $ on loop variable" diagnostic can reallocate
|
||||||
|
PL_linestr, invalidating our pointer. Save the offset so we can update it
|
||||||
|
in that case.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
toke.c | 4 ++++
|
||||||
|
1 file changed, 4 insertions(+)
|
||||||
|
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index 630fc59..029d2ea 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -7565,6 +7565,7 @@ Perl_yylex(pTHX)
|
||||||
|
s = skipspace(s);
|
||||||
|
if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
|
||||||
|
char *p = s;
|
||||||
|
+ SSize_t s_off = s - SvPVX(PL_linestr);
|
||||||
|
|
||||||
|
if ((PL_bufend - p) >= 3
|
||||||
|
&& strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
|
||||||
|
@@ -7582,6 +7583,9 @@ Perl_yylex(pTHX)
|
||||||
|
}
|
||||||
|
if (*p != '$')
|
||||||
|
Perl_croak(aTHX_ "Missing $ on loop variable");
|
||||||
|
+
|
||||||
|
+ /* The buffer may have been reallocated, update s */
|
||||||
|
+ s = SvPVX(PL_linestr) + s_off;
|
||||||
|
}
|
||||||
|
OPERATOR(FOR);
|
||||||
|
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,72 @@
|
|||||||
|
From be05b2f7a801ae1721641fd240e0d7d6fc018136 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Aaron Crane <arc@cpan.org>
|
||||||
|
Date: Sun, 19 Feb 2017 12:26:54 +0000
|
||||||
|
Subject: [PATCH] fix ck_return null-pointer deref on malformed code
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit e5c165a0b7551ffb94661aa7f18aabadba257782
|
||||||
|
Author: Aaron Crane <arc@cpan.org>
|
||||||
|
Date: Sun Feb 19 12:26:54 2017 +0000
|
||||||
|
|
||||||
|
[perl #130815] fix ck_return null-pointer deref on malformed code
|
||||||
|
|
||||||
|
commit 9de2a80ffc0eefb4d60e13766baf4bad129e0a92
|
||||||
|
Author: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Sun Feb 19 12:36:58 2017 +0000
|
||||||
|
|
||||||
|
bump test count in t/comp/parser.t
|
||||||
|
|
||||||
|
(the previous commit forgot to)
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
op.c | 2 +-
|
||||||
|
t/comp/parser.t | 8 +++++++-
|
||||||
|
2 files changed, 8 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/op.c b/op.c
|
||||||
|
index 018d90c..9a61ea7 100644
|
||||||
|
--- a/op.c
|
||||||
|
+++ b/op.c
|
||||||
|
@@ -10695,7 +10695,7 @@ Perl_ck_return(pTHX_ OP *o)
|
||||||
|
PERL_ARGS_ASSERT_CK_RETURN;
|
||||||
|
|
||||||
|
kid = OpSIBLING(cLISTOPo->op_first);
|
||||||
|
- if (CvLVALUE(PL_compcv)) {
|
||||||
|
+ if (PL_compcv && CvLVALUE(PL_compcv)) {
|
||||||
|
for (; kid; kid = OpSIBLING(kid))
|
||||||
|
op_lvalue(kid, OP_LEAVESUBLV);
|
||||||
|
}
|
||||||
|
diff --git a/t/comp/parser.t b/t/comp/parser.t
|
||||||
|
index 50f601c..5016509 100644
|
||||||
|
--- a/t/comp/parser.t
|
||||||
|
+++ b/t/comp/parser.t
|
||||||
|
@@ -8,7 +8,7 @@ BEGIN {
|
||||||
|
chdir 't' if -d 't';
|
||||||
|
}
|
||||||
|
|
||||||
|
-print "1..173\n";
|
||||||
|
+print "1..174\n";
|
||||||
|
|
||||||
|
sub failed {
|
||||||
|
my ($got, $expected, $name) = @_;
|
||||||
|
@@ -546,6 +546,12 @@ eval "grep+grep";
|
||||||
|
eval 'qq{@{0]}${}},{})';
|
||||||
|
is(1, 1, "RT #124207");
|
||||||
|
|
||||||
|
+# RT #130815: crash in ck_return for malformed code
|
||||||
|
+{
|
||||||
|
+ eval 'm(@{if(0){sub d{]]])}return';
|
||||||
|
+ like $@, qr/^syntax error at \(eval \d+\) line 1, near "\{\]"/,
|
||||||
|
+ 'RT #130815: null pointer deref';
|
||||||
|
+}
|
||||||
|
|
||||||
|
# Add new tests HERE (above this line)
|
||||||
|
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,81 @@
|
|||||||
|
From 0cefeca1fd2405ad1b5544a3919e0000377fde5e Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Tue, 21 Feb 2017 16:38:36 +1100
|
||||||
|
Subject: [PATCH] (perl #130822) fix an AV leak in Perl_reg_named_buff_fetch
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 853eb961c1a3b014b5a9510740abc15ccd4383b6
|
||||||
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Tue Feb 21 16:38:36 2017 +1100
|
||||||
|
|
||||||
|
(perl #130822) fix an AV leak in Perl_reg_named_buff_fetch
|
||||||
|
|
||||||
|
Originally noted as a scoping issue by Andy Lester.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 5 +----
|
||||||
|
t/op/svleak.t | 12 +++++++++++-
|
||||||
|
2 files changed, 12 insertions(+), 5 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 6329f6c..989c528 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -7849,21 +7849,18 @@ SV*
|
||||||
|
Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
|
||||||
|
const U32 flags)
|
||||||
|
{
|
||||||
|
- AV *retarray = NULL;
|
||||||
|
SV *ret;
|
||||||
|
struct regexp *const rx = ReANY(r);
|
||||||
|
|
||||||
|
PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
|
||||||
|
|
||||||
|
- if (flags & RXapif_ALL)
|
||||||
|
- retarray=newAV();
|
||||||
|
-
|
||||||
|
if (rx && RXp_PAREN_NAMES(rx)) {
|
||||||
|
HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
|
||||||
|
if (he_str) {
|
||||||
|
IV i;
|
||||||
|
SV* sv_dat=HeVAL(he_str);
|
||||||
|
I32 *nums=(I32*)SvPVX(sv_dat);
|
||||||
|
+ AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
|
||||||
|
for ( i=0; i<SvIVX(sv_dat); i++ ) {
|
||||||
|
if ((I32)(rx->nparens) >= nums[i]
|
||||||
|
&& rx->offs[nums[i]].start != -1
|
||||||
|
diff --git a/t/op/svleak.t b/t/op/svleak.t
|
||||||
|
index b0692ff..eeea7c1 100644
|
||||||
|
--- a/t/op/svleak.t
|
||||||
|
+++ b/t/op/svleak.t
|
||||||
|
@@ -15,7 +15,7 @@ BEGIN {
|
||||||
|
|
||||||
|
use Config;
|
||||||
|
|
||||||
|
-plan tests => 133;
|
||||||
|
+plan tests => 134;
|
||||||
|
|
||||||
|
# run some code N times. If the number of SVs at the end of loop N is
|
||||||
|
# greater than (N-1)*delta at the end of loop 1, we've got a leak
|
||||||
|
@@ -557,3 +557,13 @@ EOF
|
||||||
|
sub lk { { my $d = $op->hints_hash->HASH } }
|
||||||
|
::leak(3, 0, \&lk, q!B::RHE->HASH shoudln't leak!);
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+{
|
||||||
|
+ # Perl_reg_named_buff_fetch() leaks an AV when called with an RE
|
||||||
|
+ # with no named captures
|
||||||
|
+ sub named {
|
||||||
|
+ "x" =~ /x/;
|
||||||
|
+ re::regname("foo", 1);
|
||||||
|
+ }
|
||||||
|
+ ::leak(2, 0, \&named, "Perl_reg_named_buff_fetch() on no-name RE");
|
||||||
|
+}
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,61 @@
|
|||||||
|
From cba9aa759f7ce8a4a80e748eb451f679042cd74b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Fri, 7 Apr 2017 14:08:02 -0700
|
||||||
|
Subject: [PATCH] Crash with sub-in-stash
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 790acddeaa0d2c73524596048b129561225cf100
|
||||||
|
Author: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Fri Apr 7 14:08:02 2017 -0700
|
||||||
|
|
||||||
|
[perl #131085] Crash with sub-in-stash
|
||||||
|
|
||||||
|
$ perl -e '$::{"A"} = sub {}; \&{"A"}'
|
||||||
|
Segmentation fault (core dumped)
|
||||||
|
|
||||||
|
The code that vivifies a typeglob out of a code ref assumed that the
|
||||||
|
CV had a name hek, which is always the case when perl itself puts the
|
||||||
|
code ref there (via ‘sub A{}’), but is not necessarily the case if
|
||||||
|
someone is insinuating other stuff into the stash.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
gv.c | 2 +-
|
||||||
|
t/op/gv.t | 4 ++++
|
||||||
|
2 files changed, 5 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/gv.c b/gv.c
|
||||||
|
index 3fda9b9..6690b64 100644
|
||||||
|
--- a/gv.c
|
||||||
|
+++ b/gv.c
|
||||||
|
@@ -421,7 +421,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
|
||||||
|
/* Not actually a constant. Just a regular sub. */
|
||||||
|
CV * const cv = (CV *)has_constant;
|
||||||
|
GvCV_set(gv,cv);
|
||||||
|
- if (CvSTASH(cv) == stash && (
|
||||||
|
+ if (CvNAMED(cv) && CvSTASH(cv) == stash && (
|
||||||
|
CvNAME_HEK(cv) == GvNAME_HEK(gv)
|
||||||
|
|| ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
|
||||||
|
&& HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
|
||||||
|
diff --git a/t/op/gv.t b/t/op/gv.t
|
||||||
|
index 03ae46e..cdaaef5 100644
|
||||||
|
--- a/t/op/gv.t
|
||||||
|
+++ b/t/op/gv.t
|
||||||
|
@@ -1170,6 +1170,10 @@ SKIP: {
|
||||||
|
is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
|
||||||
|
}
|
||||||
|
|
||||||
|
+# [perl #131085] This used to crash; no ok() necessary.
|
||||||
|
+$::{"A131085"} = sub {}; \&{"A131085"};
|
||||||
|
+
|
||||||
|
+
|
||||||
|
__END__
|
||||||
|
Perl
|
||||||
|
Rules
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,266 @@
|
|||||||
|
From 30cba075ecbb662b392b2c6e896dec287ea49aa8 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 25 Apr 2017 15:17:06 +0200
|
||||||
|
Subject: [PATCH] fixup File::Glob degenerate matching
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 0db967b2e6a4093a6a5f649190159767e5d005e0
|
||||||
|
Author: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue Apr 25 15:17:06 2017 +0200
|
||||||
|
|
||||||
|
[perl #131211] fixup File::Glob degenerate matching
|
||||||
|
|
||||||
|
The old code would go quadratic with recursion and backtracking
|
||||||
|
when doing patterns like "a*a*a*a*a*a*a*x" on a file like
|
||||||
|
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa".
|
||||||
|
|
||||||
|
This patch changes the code to not recurse, and to not backtrack,
|
||||||
|
as per this article from Russ Cox: https://research.swtch.com/glob
|
||||||
|
|
||||||
|
It also adds a micro-optimisation for M_ONE and M_SET under the new code.
|
||||||
|
|
||||||
|
Thanks to Avar and Russ Cox for helping with this patch, along with
|
||||||
|
Jilles Tjoelker and the rest of the FreeBSD community.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
MANIFEST | 1 +
|
||||||
|
ext/File-Glob/bsd_glob.c | 64 +++++++++++++++++++++++--------
|
||||||
|
ext/File-Glob/t/rt131211.t | 94 ++++++++++++++++++++++++++++++++++++++++++++++
|
||||||
|
3 files changed, 144 insertions(+), 15 deletions(-)
|
||||||
|
create mode 100644 ext/File-Glob/t/rt131211.t
|
||||||
|
|
||||||
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
|
index fe045a7..be2a44f 100644
|
||||||
|
--- a/MANIFEST
|
||||||
|
+++ b/MANIFEST
|
||||||
|
@@ -3678,6 +3678,7 @@ ext/File-Glob/t/case.t See if File::Glob works
|
||||||
|
ext/File-Glob/t/global.t See if File::Glob works
|
||||||
|
ext/File-Glob/TODO File::Glob extension todo list
|
||||||
|
ext/File-Glob/t/rt114984.t See if File::Glob works
|
||||||
|
+ext/File-Glob/t/rt131211.t See if File::Glob works
|
||||||
|
ext/File-Glob/t/taint.t See if File::Glob works
|
||||||
|
ext/File-Glob/t/threads.t See if File::Glob + threads works
|
||||||
|
ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
|
||||||
|
diff --git a/ext/File-Glob/bsd_glob.c b/ext/File-Glob/bsd_glob.c
|
||||||
|
index 821ef20..e96fb73 100644
|
||||||
|
--- a/ext/File-Glob/bsd_glob.c
|
||||||
|
+++ b/ext/File-Glob/bsd_glob.c
|
||||||
|
@@ -563,8 +563,12 @@ glob0(const Char *pattern, glob_t *pglob)
|
||||||
|
break;
|
||||||
|
case BG_STAR:
|
||||||
|
pglob->gl_flags |= GLOB_MAGCHAR;
|
||||||
|
- /* collapse adjacent stars to one,
|
||||||
|
- * to avoid exponential behavior
|
||||||
|
+ /* Collapse adjacent stars to one.
|
||||||
|
+ * This is required to ensure that a pattern like
|
||||||
|
+ * "a**" matches a name like "a", as without this
|
||||||
|
+ * check when the first star matched everything it would
|
||||||
|
+ * cause the second star to return a match fail.
|
||||||
|
+ * As long ** is folded here this does not happen.
|
||||||
|
*/
|
||||||
|
if (bufnext == patbuf || bufnext[-1] != M_ALL)
|
||||||
|
*bufnext++ = M_ALL;
|
||||||
|
@@ -909,35 +913,56 @@ globextend(const Char *path, glob_t *pglob, size_t *limitp)
|
||||||
|
|
||||||
|
|
||||||
|
/*
|
||||||
|
- * pattern matching function for filenames. Each occurrence of the *
|
||||||
|
- * pattern causes a recursion level.
|
||||||
|
+ * pattern matching function for filenames using state machine to avoid
|
||||||
|
+ * recursion. We maintain a "nextp" and "nextn" to allow us to backtrack
|
||||||
|
+ * without additional callframes, and to do cleanly prune the backtracking
|
||||||
|
+ * state when multiple '*' (start) matches are included in the patter.
|
||||||
|
+ *
|
||||||
|
+ * Thanks to Russ Cox for the improved state machine logic to avoid quadratic
|
||||||
|
+ * matching on failure.
|
||||||
|
+ *
|
||||||
|
+ * https://research.swtch.com/glob
|
||||||
|
+ *
|
||||||
|
+ * An example would be a pattern
|
||||||
|
+ * ("a*" x 100) . "y"
|
||||||
|
+ * against a file name like
|
||||||
|
+ * ("a" x 100) . "x"
|
||||||
|
+ *
|
||||||
|
*/
|
||||||
|
static int
|
||||||
|
match(Char *name, Char *pat, Char *patend, int nocase)
|
||||||
|
{
|
||||||
|
int ok, negate_range;
|
||||||
|
Char c, k;
|
||||||
|
+ Char *nextp = NULL;
|
||||||
|
+ Char *nextn = NULL;
|
||||||
|
|
||||||
|
+ loop:
|
||||||
|
while (pat < patend) {
|
||||||
|
c = *pat++;
|
||||||
|
switch (c & M_MASK) {
|
||||||
|
case M_ALL:
|
||||||
|
if (pat == patend)
|
||||||
|
return(1);
|
||||||
|
- do
|
||||||
|
- if (match(name, pat, patend, nocase))
|
||||||
|
- return(1);
|
||||||
|
- while (*name++ != BG_EOS)
|
||||||
|
- ;
|
||||||
|
- return(0);
|
||||||
|
+ if (*name == BG_EOS)
|
||||||
|
+ return 0;
|
||||||
|
+ nextn = name + 1;
|
||||||
|
+ nextp = pat - 1;
|
||||||
|
+ break;
|
||||||
|
case M_ONE:
|
||||||
|
+ /* since * matches leftmost-shortest first *
|
||||||
|
+ * if we encounter the EOS then backtracking *
|
||||||
|
+ * will not help, so we can exit early here. */
|
||||||
|
if (*name++ == BG_EOS)
|
||||||
|
- return(0);
|
||||||
|
+ return 0;
|
||||||
|
break;
|
||||||
|
case M_SET:
|
||||||
|
ok = 0;
|
||||||
|
+ /* since * matches leftmost-shortest first *
|
||||||
|
+ * if we encounter the EOS then backtracking *
|
||||||
|
+ * will not help, so we can exit early here. */
|
||||||
|
if ((k = *name++) == BG_EOS)
|
||||||
|
- return(0);
|
||||||
|
+ return 0;
|
||||||
|
if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS)
|
||||||
|
++pat;
|
||||||
|
while (((c = *pat++) & M_MASK) != M_END)
|
||||||
|
@@ -953,16 +978,25 @@ match(Char *name, Char *pat, Char *patend, int nocase)
|
||||||
|
} else if (nocase ? (tolower(c) == tolower(k)) : (c == k))
|
||||||
|
ok = 1;
|
||||||
|
if (ok == negate_range)
|
||||||
|
- return(0);
|
||||||
|
+ goto fail;
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
k = *name++;
|
||||||
|
if (nocase ? (tolower(k) != tolower(c)) : (k != c))
|
||||||
|
- return(0);
|
||||||
|
+ goto fail;
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
- return(*name == BG_EOS);
|
||||||
|
+ if (*name == BG_EOS)
|
||||||
|
+ return 1;
|
||||||
|
+
|
||||||
|
+ fail:
|
||||||
|
+ if (nextn) {
|
||||||
|
+ pat = nextp;
|
||||||
|
+ name = nextn;
|
||||||
|
+ goto loop;
|
||||||
|
+ }
|
||||||
|
+ return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Free allocated data belonging to a glob_t structure. */
|
||||||
|
diff --git a/ext/File-Glob/t/rt131211.t b/ext/File-Glob/t/rt131211.t
|
||||||
|
new file mode 100644
|
||||||
|
index 0000000..c1bcbe0
|
||||||
|
--- /dev/null
|
||||||
|
+++ b/ext/File-Glob/t/rt131211.t
|
||||||
|
@@ -0,0 +1,94 @@
|
||||||
|
+use strict;
|
||||||
|
+use warnings;
|
||||||
|
+use v5.16.0;
|
||||||
|
+use File::Temp 'tempdir';
|
||||||
|
+use File::Spec::Functions;
|
||||||
|
+use Test::More;
|
||||||
|
+use Time::HiRes qw(time);
|
||||||
|
+
|
||||||
|
+plan tests => 13;
|
||||||
|
+
|
||||||
|
+my $path = tempdir uc cleanup => 1;
|
||||||
|
+my @files= (
|
||||||
|
+ "x".("a" x 50)."b", # 0
|
||||||
|
+ "abbbbbbbbbbbbc", # 1
|
||||||
|
+ "abbbbbbbbbbbbd", # 2
|
||||||
|
+ "aaabaaaabaaaabc", # 3
|
||||||
|
+ "pq", # 4
|
||||||
|
+ "r", # 5
|
||||||
|
+ "rttiiiiiii", # 6
|
||||||
|
+ "wewewewewewe", # 7
|
||||||
|
+ "weeeweeeweee", # 8
|
||||||
|
+ "weewweewweew", # 9
|
||||||
|
+ "wewewewewewewewewewewewewewewewewq", # 10
|
||||||
|
+ "wtttttttetttttttwr", # 11
|
||||||
|
+);
|
||||||
|
+
|
||||||
|
+
|
||||||
|
+foreach (@files) {
|
||||||
|
+ open(my $f, ">", catfile $path, $_);
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+my $elapsed_fail= 0;
|
||||||
|
+my $elapsed_match= 0;
|
||||||
|
+my @got_files;
|
||||||
|
+my @no_files;
|
||||||
|
+my $count = 0;
|
||||||
|
+
|
||||||
|
+while (++$count < 10) {
|
||||||
|
+ $elapsed_match -= time;
|
||||||
|
+ @got_files= glob catfile $path, "x".("a*" x $count) . "b";
|
||||||
|
+ $elapsed_match += time;
|
||||||
|
+
|
||||||
|
+ $elapsed_fail -= time;
|
||||||
|
+ @no_files= glob catfile $path, "x".("a*" x $count) . "c";
|
||||||
|
+ $elapsed_fail += time;
|
||||||
|
+ last if $elapsed_fail > $elapsed_match * 100;
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+is $count,10,
|
||||||
|
+ "tried all the patterns without bailing out";
|
||||||
|
+
|
||||||
|
+cmp_ok $elapsed_fail/$elapsed_match,"<",2,
|
||||||
|
+ "time to fail less than twice the time to match";
|
||||||
|
+is "@got_files", catfile($path, $files[0]),
|
||||||
|
+ "only got the expected file for xa*..b";
|
||||||
|
+is "@no_files", "", "shouldnt have files for xa*..c";
|
||||||
|
+
|
||||||
|
+
|
||||||
|
+@got_files= glob catfile $path, "a*b*b*b*bc";
|
||||||
|
+is "@got_files", catfile($path, $files[1]),
|
||||||
|
+ "only got the expected file for a*b*b*b*bc";
|
||||||
|
+
|
||||||
|
+@got_files= sort glob catfile $path, "a*b*b*bc";
|
||||||
|
+is "@got_files", catfile($path, $files[3])." ".catfile($path,$files[1]),
|
||||||
|
+ "got the expected two files for a*b*b*bc";
|
||||||
|
+
|
||||||
|
+@got_files= sort glob catfile $path, "p*";
|
||||||
|
+is "@got_files", catfile($path, $files[4]),
|
||||||
|
+ "p* matches pq";
|
||||||
|
+
|
||||||
|
+@got_files= sort glob catfile $path, "r*???????";
|
||||||
|
+is "@got_files", catfile($path, $files[6]),
|
||||||
|
+ "r*??????? works as expected";
|
||||||
|
+
|
||||||
|
+@got_files= sort glob catfile $path, "w*e*w??e";
|
||||||
|
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8)),
|
||||||
|
+ "w*e*w??e works as expected";
|
||||||
|
+
|
||||||
|
+@got_files= sort glob catfile $path, "w*e*we??";
|
||||||
|
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)),
|
||||||
|
+ "w*e*we?? works as expected";
|
||||||
|
+
|
||||||
|
+@got_files= sort glob catfile $path, "w**e**w";
|
||||||
|
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (9)),
|
||||||
|
+ "w**e**w works as expected";
|
||||||
|
+
|
||||||
|
+@got_files= sort glob catfile $path, "*wee*";
|
||||||
|
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (8,9)),
|
||||||
|
+ "*wee* works as expected";
|
||||||
|
+
|
||||||
|
+@got_files= sort glob catfile $path, "we*";
|
||||||
|
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)),
|
||||||
|
+ "we* works as expected";
|
||||||
|
+
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,72 @@
|
|||||||
|
From 064604f904546ae4ddada5a2aa30256faccee39c Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed, 7 Jun 2017 15:00:26 +1000
|
||||||
|
Subject: [PATCH] clear the UTF8 flag on a glob if it isn't UTF8
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 1097da16b21fe0a2257dba9937e55c0cca18f7e1
|
||||||
|
Author: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed Jun 7 15:00:26 2017 +1000
|
||||||
|
|
||||||
|
[perl #131263] clear the UTF8 flag on a glob if it isn't UTF8
|
||||||
|
|
||||||
|
Previously sv_2pv_flags() would set the UTF8 flag on a glob if it
|
||||||
|
had a UTF8 name, but wouldn't clear tha flag if it didn't.
|
||||||
|
|
||||||
|
This meant a name change, eg. if assigned another glob, from a UTF8
|
||||||
|
name to a non-UTF8 name would leave the flag set.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
sv.c | 2 ++
|
||||||
|
t/op/gv.t | 10 +++++++++-
|
||||||
|
2 files changed, 11 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/sv.c b/sv.c
|
||||||
|
index 12cbb5f..05584a2 100644
|
||||||
|
--- a/sv.c
|
||||||
|
+++ b/sv.c
|
||||||
|
@@ -3162,6 +3162,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
|
||||||
|
assert(SvPOK(buffer));
|
||||||
|
if (SvUTF8(buffer))
|
||||||
|
SvUTF8_on(sv);
|
||||||
|
+ else
|
||||||
|
+ SvUTF8_off(sv);
|
||||||
|
if (lp)
|
||||||
|
*lp = SvCUR(buffer);
|
||||||
|
return SvPVX(buffer);
|
||||||
|
diff --git a/t/op/gv.t b/t/op/gv.t
|
||||||
|
index cdaaef5..ea79e51 100644
|
||||||
|
--- a/t/op/gv.t
|
||||||
|
+++ b/t/op/gv.t
|
||||||
|
@@ -12,7 +12,7 @@ BEGIN {
|
||||||
|
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
-plan(tests => 277 );
|
||||||
|
+plan(tests => 279 );
|
||||||
|
|
||||||
|
# type coercion on assignment
|
||||||
|
$foo = 'foo';
|
||||||
|
@@ -1173,6 +1173,14 @@ SKIP: {
|
||||||
|
# [perl #131085] This used to crash; no ok() necessary.
|
||||||
|
$::{"A131085"} = sub {}; \&{"A131085"};
|
||||||
|
|
||||||
|
+{
|
||||||
|
+ # [perl #131263]
|
||||||
|
+ *sym = "\N{U+0080}";
|
||||||
|
+ ok(*sym eq "*main::\N{U+0080}", "utf8 flag properly set");
|
||||||
|
+ *sym = "\xC3\x80";
|
||||||
|
+ ok(*sym eq "*main::\xC3\x80", "utf8 flag properly cleared");
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
|
||||||
|
__END__
|
||||||
|
Perl
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,94 @@
|
|||||||
|
From 0a1ddbeaeeea3c690c2408bd4c3a61c05cb9695f Mon Sep 17 00:00:00 2001
|
||||||
|
From: Zefram <zefram@fysh.org>
|
||||||
|
Date: Mon, 23 Jan 2017 02:25:50 +0000
|
||||||
|
Subject: [PATCH] permit goto at top level of multicalled sub
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit 3c157b3cf0631c69ffa5aa2d55b9199bf93b22a9
|
||||||
|
Author: Zefram <zefram@fysh.org>
|
||||||
|
Date: Mon Jan 23 02:25:50 2017 +0000
|
||||||
|
|
||||||
|
permit goto at top level of multicalled sub
|
||||||
|
|
||||||
|
A multicalled sub is reckoned to be a pseudo block, out of which it is
|
||||||
|
not permissible to goto. However, the test for a pseudo block was being
|
||||||
|
applied too early, preventing not just escape from a multicalled sub but
|
||||||
|
also a goto at the top level within the sub. This is a bug similar, but
|
||||||
|
not identical, to [perl #113938]. Now the test is deferred, permitting
|
||||||
|
goto at the sub's top level but still forbidding goto out of it.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_ctl.c | 11 ++++++-----
|
||||||
|
t/op/goto.t | 11 ++++++++++-
|
||||||
|
2 files changed, 16 insertions(+), 6 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
|
index e859e01..a1fc2f4 100644
|
||||||
|
--- a/pp_ctl.c
|
||||||
|
+++ b/pp_ctl.c
|
||||||
|
@@ -2921,6 +2921,7 @@ PP(pp_goto)
|
||||||
|
OP *gotoprobe = NULL;
|
||||||
|
bool leaving_eval = FALSE;
|
||||||
|
bool in_block = FALSE;
|
||||||
|
+ bool pseudo_block = FALSE;
|
||||||
|
PERL_CONTEXT *last_eval_cx = NULL;
|
||||||
|
|
||||||
|
/* find label */
|
||||||
|
@@ -2959,11 +2960,9 @@ PP(pp_goto)
|
||||||
|
gotoprobe = PL_main_root;
|
||||||
|
break;
|
||||||
|
case CXt_SUB:
|
||||||
|
- if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
|
||||||
|
- gotoprobe = CvROOT(cx->blk_sub.cv);
|
||||||
|
- break;
|
||||||
|
- }
|
||||||
|
- /* FALLTHROUGH */
|
||||||
|
+ gotoprobe = CvROOT(cx->blk_sub.cv);
|
||||||
|
+ pseudo_block = cBOOL(CxMULTICALL(cx));
|
||||||
|
+ break;
|
||||||
|
case CXt_FORMAT:
|
||||||
|
case CXt_NULL:
|
||||||
|
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
|
||||||
|
@@ -2992,6 +2991,8 @@ PP(pp_goto)
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
+ if (pseudo_block)
|
||||||
|
+ DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
|
||||||
|
PL_lastgotoprobe = gotoprobe;
|
||||||
|
}
|
||||||
|
if (!retop)
|
||||||
|
diff --git a/t/op/goto.t b/t/op/goto.t
|
||||||
|
index aa2f24f..07bd6fb 100644
|
||||||
|
--- a/t/op/goto.t
|
||||||
|
+++ b/t/op/goto.t
|
||||||
|
@@ -10,7 +10,7 @@ BEGIN {
|
||||||
|
|
||||||
|
use warnings;
|
||||||
|
use strict;
|
||||||
|
-plan tests => 98;
|
||||||
|
+plan tests => 99;
|
||||||
|
our $TODO;
|
||||||
|
|
||||||
|
my $deprecated = 0;
|
||||||
|
@@ -774,3 +774,12 @@ sub FETCH { $_[0][0] }
|
||||||
|
tie my $t, "", sub { "cluck up porridge" };
|
||||||
|
is eval { sub { goto $t }->() }//$@, 'cluck up porridge',
|
||||||
|
'tied arg returning sub ref';
|
||||||
|
+
|
||||||
|
+sub revnumcmp ($$) {
|
||||||
|
+ goto FOO;
|
||||||
|
+ die;
|
||||||
|
+ FOO:
|
||||||
|
+ return $_[1] <=> $_[0];
|
||||||
|
+}
|
||||||
|
+is eval { join(":", sort revnumcmp (9,5,1,3,7)) }, "9:7:5:3:1",
|
||||||
|
+ "can goto at top level of multicalled sub";
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
68
SOURCES/perl-5.24.1-sprintf-add-memory-wrap-tests.patch
Normal file
68
SOURCES/perl-5.24.1-sprintf-add-memory-wrap-tests.patch
Normal file
@ -0,0 +1,68 @@
|
|||||||
|
From 08bc282a248b21c92ff45e49490fb95e24358213 Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Tue, 9 May 2017 14:29:11 +0100
|
||||||
|
Subject: [PATCH] sprintf(): add memory wrap tests
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.1:
|
||||||
|
|
||||||
|
commit d729f63cc94318c248eab95844cfbed5298a7ecd
|
||||||
|
Author: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Tue May 9 14:29:11 2017 +0100
|
||||||
|
|
||||||
|
sprintf(): add memory wrap tests
|
||||||
|
|
||||||
|
In various places Perl_sv_vcatpvfn_flags() does croak_memory_wrap()
|
||||||
|
(including a couple added by the previous commit to fix RT #131260),
|
||||||
|
but there don't appear to be any tests for them.
|
||||||
|
|
||||||
|
So this commit adds some tests.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/op/sprintf2.t | 29 ++++++++++++++++++++++++++++-
|
||||||
|
1 file changed, 28 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
||||||
|
index 43ed919..ef8a743 100644
|
||||||
|
--- a/t/op/sprintf2.t
|
||||||
|
+++ b/t/op/sprintf2.t
|
||||||
|
@@ -749,6 +749,33 @@ SKIP: {
|
||||||
|
"non-canonical form");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+# check all calls to croak_memory_wrap()
|
||||||
|
+# RT #131260
|
||||||
|
+
|
||||||
|
+{
|
||||||
|
+ my $s = 8 * $Config{sizesize};
|
||||||
|
+ my $i = 1;
|
||||||
|
+ my $max;
|
||||||
|
+ while ($s--) { $max |= $i; $i <<= 1; }
|
||||||
|
+ my $max40 = $max - 40; # see the magic fudge factor in sv_vcatpvfn_flags()
|
||||||
|
+
|
||||||
|
+ my @tests = (
|
||||||
|
+ # format, arg
|
||||||
|
+ ["%.${max}a", 1.1 ],
|
||||||
|
+ ["%.${max40}a", 1.1 ],
|
||||||
|
+ ["%.${max}i", 1 ],
|
||||||
|
+ ["%.${max}i", -1 ],
|
||||||
|
+ );
|
||||||
|
+
|
||||||
|
+ for my $test (@tests) {
|
||||||
|
+ my ($fmt, $arg) = @$test;
|
||||||
|
+ eval { my $s = sprintf $fmt, $arg; };
|
||||||
|
+ like("$@", qr/panic: memory wrap/, qq{memory wrap: "$fmt", "$arg"});
|
||||||
|
+ }
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+
|
||||||
|
|
||||||
|
# These are IEEE 754 64-bit subnormals (formerly known as denormals).
|
||||||
|
# Keep these as strings so that non-IEEE-754 don't trip over them.
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
75
SOURCES/perl-5.24.3-Carp-Don-t-choke-on-ISA-constant.patch
Normal file
75
SOURCES/perl-5.24.3-Carp-Don-t-choke-on-ISA-constant.patch
Normal file
@ -0,0 +1,75 @@
|
|||||||
|
From ab3bb20383d6dbf9baa811d06414ee474bb8f91e Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Wed, 1 Nov 2017 13:11:27 -0700
|
||||||
|
Subject: [PATCH] =?UTF-8?q?Carp:=20Don=E2=80=99t=20choke=20on=20ISA=20cons?=
|
||||||
|
=?UTF-8?q?tant?=
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This broke some time between 1.29 (perl 5.18) and 1.3301 (perl 5.20):
|
||||||
|
|
||||||
|
$ perl5.20.1 -e 'package Foo { use constant ISA => 42; Bar::f() } package Bar { use Carp; sub f { carp "tun syn" } }'
|
||||||
|
Not a GLOB reference at /usr/local/lib/perl5/5.20.1/Carp.pm line 560.
|
||||||
|
|
||||||
|
and still persisted in bleadperl (Carp 1.43) until this commit.
|
||||||
|
|
||||||
|
The code that goes poking through the symbol table needs to take into
|
||||||
|
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>
|
||||||
|
---
|
||||||
|
dist/Carp/lib/Carp.pm | 3 ++-
|
||||||
|
dist/Carp/t/Carp.t | 13 ++++++++++++-
|
||||||
|
2 files changed, 14 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
|
||||||
|
index 92f8866..f94b9d4 100644
|
||||||
|
--- a/dist/Carp/lib/Carp.pm
|
||||||
|
+++ b/dist/Carp/lib/Carp.pm
|
||||||
|
@@ -594,7 +594,8 @@ sub trusts_directly {
|
||||||
|
for my $var (qw/ CARP_NOT ISA /) {
|
||||||
|
# Don't try using the variable until we know it exists,
|
||||||
|
# to avoid polluting the caller's namespace.
|
||||||
|
- if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
|
||||||
|
+ if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
|
||||||
|
+ && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
|
||||||
|
return @{$stash->{$var}}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
diff --git a/dist/Carp/t/Carp.t b/dist/Carp/t/Carp.t
|
||||||
|
index 9ecdf88..f981005 100644
|
||||||
|
--- a/dist/Carp/t/Carp.t
|
||||||
|
+++ b/dist/Carp/t/Carp.t
|
||||||
|
@@ -3,7 +3,7 @@ no warnings "once";
|
||||||
|
use Config;
|
||||||
|
|
||||||
|
use IPC::Open3 1.0103 qw(open3);
|
||||||
|
-use Test::More tests => 66;
|
||||||
|
+use Test::More tests => 67;
|
||||||
|
|
||||||
|
sub runperl {
|
||||||
|
my(%args) = @_;
|
||||||
|
@@ -478,6 +478,17 @@ SKIP:
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
+{
|
||||||
|
+ package Mpar;
|
||||||
|
+ sub f { Carp::croak "tun syn" }
|
||||||
|
+
|
||||||
|
+ package Phou;
|
||||||
|
+ $Phou::{ISA} = \42;
|
||||||
|
+ eval { Mpar::f };
|
||||||
|
+}
|
||||||
|
+like $@, qr/tun syn/, 'Carp can handle non-glob ISA stash elems';
|
||||||
|
+
|
||||||
|
+
|
||||||
|
# New tests go here
|
||||||
|
|
||||||
|
# line 1 "XA"
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,48 @@
|
|||||||
|
From 2657358b67ba3eadd1be99bd7e732a8d68f1f95d Mon Sep 17 00:00:00 2001
|
||||||
|
From: John Lightsey <lightsey@debian.org>
|
||||||
|
Date: Tue, 31 Oct 2017 18:12:26 -0500
|
||||||
|
Subject: [PATCH] Fix deparsing of transliterations with unprintable
|
||||||
|
characters.
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
RT #132405
|
||||||
|
|
||||||
|
Signed-off-by: Nicolas R <atoomic@cpan.org>
|
||||||
|
Petr Písař: Port to 5.24.3.
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
lib/B/Deparse.pm | 2 +-
|
||||||
|
lib/B/Deparse.t | 5 +++++
|
||||||
|
2 files changed, 6 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
|
||||||
|
index 9879d67..f5f7d82 100644
|
||||||
|
--- a/lib/B/Deparse.pm
|
||||||
|
+++ b/lib/B/Deparse.pm
|
||||||
|
@@ -5047,7 +5047,7 @@ sub pchr { # ASCII
|
||||||
|
} elsif ($n == ord "\r") {
|
||||||
|
return '\\r';
|
||||||
|
} elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
|
||||||
|
- return '\\c' . unctrl{chr $n};
|
||||||
|
+ return '\\c' . $unctrl{chr $n};
|
||||||
|
} else {
|
||||||
|
# return '\x' . sprintf("%02x", $n);
|
||||||
|
return '\\' . sprintf("%03o", $n);
|
||||||
|
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
|
||||||
|
index 19db404..45b1ff3 100644
|
||||||
|
--- a/lib/B/Deparse.t
|
||||||
|
+++ b/lib/B/Deparse.t
|
||||||
|
@@ -2488,3 +2488,8 @@ $_ ^= $_;
|
||||||
|
$_ |.= $_;
|
||||||
|
$_ &.= $_;
|
||||||
|
$_ ^.= $_;
|
||||||
|
+####
|
||||||
|
+# tr with unprintable characters
|
||||||
|
+my $str;
|
||||||
|
+$str = 'foo';
|
||||||
|
+$str =~ tr/\cA//;
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,69 @@
|
|||||||
|
From 86ecc4da0ec0cea8f9b6af4191b87e4c454aa17c Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Sun, 10 Sep 2017 10:59:05 +0200
|
||||||
|
Subject: [PATCH] fix #132017 - OPFAIL insert needs to set flags to 0
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
why reginsert doesnt do this stuff I dont know.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.3.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 6 +++++-
|
||||||
|
t/re/pat.t | 5 ++++-
|
||||||
|
2 files changed, 9 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 6dcc58a..374032c 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -11498,6 +11498,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
if (max < min) { /* If can't match, warn and optimize to fail
|
||||||
|
unconditionally */
|
||||||
|
reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
|
||||||
|
+ orig_emit->flags = 0;
|
||||||
|
if (PASS2) {
|
||||||
|
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
|
||||||
|
NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
|
||||||
|
@@ -19046,8 +19047,11 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_
|
||||||
|
|
||||||
|
/* add on the verb argument if there is one */
|
||||||
|
if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
|
||||||
|
- Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
|
||||||
|
+ if ( ARG(o) )
|
||||||
|
+ Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
|
||||||
|
SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
|
||||||
|
+ else
|
||||||
|
+ sv_catpvs(sv, ":NULL");
|
||||||
|
}
|
||||||
|
#else
|
||||||
|
PERL_UNUSED_CONTEXT;
|
||||||
|
diff --git a/t/re/pat.t b/t/re/pat.t
|
||||||
|
index 007f11d..6ff8b0b 100644
|
||||||
|
--- a/t/re/pat.t
|
||||||
|
+++ b/t/re/pat.t
|
||||||
|
@@ -23,7 +23,7 @@ BEGIN {
|
||||||
|
skip_all_without_unicode_tables();
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 794; # Update this when adding/deleting tests.
|
||||||
|
+plan tests => 795; # Update this when adding/deleting tests.
|
||||||
|
|
||||||
|
run_tests() unless caller;
|
||||||
|
|
||||||
|
@@ -1793,6 +1793,9 @@ EOP
|
||||||
|
pos($text) = 3;
|
||||||
|
ok(scalar($text !~ m{(~*=[a-z]=)}g), "RT #131575");
|
||||||
|
}
|
||||||
|
+ {
|
||||||
|
+ fresh_perl_is('"AA" =~ m/AA{1,0}/','',{},"handle OPFAIL insert properly");
|
||||||
|
+ }
|
||||||
|
|
||||||
|
} # End of sub run_tests
|
||||||
|
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,594 @@
|
|||||||
|
From a56b6643ac9d2bae70dc93d49a08ba1eafa62c30 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Zefram <zefram@fysh.org>
|
||||||
|
Date: Sun, 19 Nov 2017 09:15:53 +0000
|
||||||
|
Subject: [PATCH] fix tainting of s/// with overloaded replacement
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
The substitution code was trying to track the taintedness of the
|
||||||
|
replacement string itself, but it didn't account for the replacement
|
||||||
|
being an untainted object with overloading that returns a tainted
|
||||||
|
stringification. It looked at the taintedness of the object value, not
|
||||||
|
realising that taint could arise during the string concatenation per se.
|
||||||
|
Change the taint checks to look at the actual TAINT_get flag after string
|
||||||
|
concatenation. This may falsely ascribe to the replacement taint that
|
||||||
|
actually came from somewhere else, but the end result is the same anyway:
|
||||||
|
there's no visible behaviour that distinguishes taint specifically from
|
||||||
|
the replacement. Also remove a related taint check that seems to be
|
||||||
|
not needed at all. Fixes [perl #115266].
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.3.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_ctl.c | 4 +-
|
||||||
|
pp_hot.c | 4 +-
|
||||||
|
t/op/taint.t | 429 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
|
||||||
|
3 files changed, 423 insertions(+), 14 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
|
index 9150142..97a4607 100644
|
||||||
|
--- a/pp_ctl.c
|
||||||
|
+++ b/pp_ctl.c
|
||||||
|
@@ -218,9 +218,9 @@ PP(pp_substcont)
|
||||||
|
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
|
||||||
|
|
||||||
|
/* See "how taint works" above pp_subst() */
|
||||||
|
- if (SvTAINTED(TOPs))
|
||||||
|
- cx->sb_rxtainted |= SUBST_TAINT_REPL;
|
||||||
|
sv_catsv_nomg(dstr, POPs);
|
||||||
|
+ if (UNLIKELY(TAINT_get))
|
||||||
|
+ cx->sb_rxtainted |= SUBST_TAINT_REPL;
|
||||||
|
if (CxONCE(cx) || s < orig ||
|
||||||
|
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
|
||||||
|
(s == m), cx->sb_targ, NULL,
|
||||||
|
diff --git a/pp_hot.c b/pp_hot.c
|
||||||
|
index 243f43a..e80d991 100644
|
||||||
|
--- a/pp_hot.c
|
||||||
|
+++ b/pp_hot.c
|
||||||
|
@@ -3004,7 +3004,7 @@ PP(pp_subst)
|
||||||
|
doutf8 = DO_UTF8(dstr);
|
||||||
|
}
|
||||||
|
|
||||||
|
- if (SvTAINTED(dstr))
|
||||||
|
+ if (UNLIKELY(TAINT_get))
|
||||||
|
rxtainted |= SUBST_TAINT_REPL;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
@@ -3181,8 +3181,6 @@ PP(pp_subst)
|
||||||
|
sv_catsv(dstr, nsv);
|
||||||
|
}
|
||||||
|
else sv_catsv(dstr, repl);
|
||||||
|
- if (UNLIKELY(SvTAINTED(repl)))
|
||||||
|
- rxtainted |= SUBST_TAINT_REPL;
|
||||||
|
}
|
||||||
|
if (once)
|
||||||
|
break;
|
||||||
|
diff --git a/t/op/taint.t b/t/op/taint.t
|
||||||
|
index 846ac23..dbcc418 100644
|
||||||
|
--- a/t/op/taint.t
|
||||||
|
+++ b/t/op/taint.t
|
||||||
|
@@ -17,7 +17,7 @@ BEGIN {
|
||||||
|
use strict;
|
||||||
|
use Config;
|
||||||
|
|
||||||
|
-plan tests => 812;
|
||||||
|
+plan tests => 1024;
|
||||||
|
|
||||||
|
$| = 1;
|
||||||
|
|
||||||
|
@@ -83,6 +83,8 @@ EndOfCleanup
|
||||||
|
# Sources of taint:
|
||||||
|
# The empty tainted value, for tainting strings
|
||||||
|
my $TAINT = substr($^X, 0, 0);
|
||||||
|
+# A tainted non-empty string
|
||||||
|
+my $TAINTXYZ = "xyz".$TAINT;
|
||||||
|
# A tainted zero, useful for tainting numbers
|
||||||
|
my $TAINT0;
|
||||||
|
{
|
||||||
|
@@ -565,7 +567,7 @@ my $TEST = 'TEST';
|
||||||
|
is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
}
|
||||||
|
|
||||||
|
- $desc = "substitution with replacement tainted";
|
||||||
|
+ $desc = "substitution with partial replacement tainted";
|
||||||
|
|
||||||
|
$s = 'abcd';
|
||||||
|
$res = $s =~ s/(.+)/xyz$TAINT/;
|
||||||
|
@@ -577,7 +579,7 @@ my $TEST = 'TEST';
|
||||||
|
is($res, 1, "$desc: res value");
|
||||||
|
is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
|
||||||
|
- $desc = "substitution /g with replacement tainted";
|
||||||
|
+ $desc = "substitution /g with partial replacement tainted";
|
||||||
|
|
||||||
|
$s = 'abcd';
|
||||||
|
$res = $s =~ s/(.)/x$TAINT/g;
|
||||||
|
@@ -589,7 +591,7 @@ my $TEST = 'TEST';
|
||||||
|
is($res, 4, "$desc: res value");
|
||||||
|
is($one, 'd', "$desc: \$1 value");
|
||||||
|
|
||||||
|
- $desc = "substitution /ge with replacement tainted";
|
||||||
|
+ $desc = "substitution /ge with partial replacement tainted";
|
||||||
|
|
||||||
|
$s = 'abc';
|
||||||
|
{
|
||||||
|
@@ -618,7 +620,7 @@ my $TEST = 'TEST';
|
||||||
|
is($res, 3, "$desc: res value");
|
||||||
|
is($one, 'c', "$desc: \$1 value");
|
||||||
|
|
||||||
|
- $desc = "substitution /r with replacement tainted";
|
||||||
|
+ $desc = "substitution /r with partial replacement tainted";
|
||||||
|
|
||||||
|
$s = 'abcd';
|
||||||
|
$res = $s =~ s/(.+)/xyz$TAINT/r;
|
||||||
|
@@ -630,6 +632,71 @@ my $TEST = 'TEST';
|
||||||
|
is($res, 'xyz', "$desc: res value");
|
||||||
|
is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
|
||||||
|
+ $desc = "substitution with whole replacement tainted";
|
||||||
|
+
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$TAINTXYZ/;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyz', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /g with whole replacement tainted";
|
||||||
|
+
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/$TAINTXYZ/g;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyz' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /ge with whole replacement tainted";
|
||||||
|
+
|
||||||
|
+ $s = 'abc';
|
||||||
|
+ {
|
||||||
|
+ my $i = 0;
|
||||||
|
+ my $j;
|
||||||
|
+ $res = $s =~ s{(.)}{
|
||||||
|
+ $j = $i; # make sure code not tainted
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($j, "$desc: code not tainted within /e");
|
||||||
|
+ $i++;
|
||||||
|
+ if ($i == 1) {
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted loop 1");
|
||||||
|
+ }
|
||||||
|
+ else {
|
||||||
|
+ is_tainted($s, "$desc: s tainted loop $i");
|
||||||
|
+ }
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted within /e");
|
||||||
|
+ $TAINTXYZ;
|
||||||
|
+ }ge;
|
||||||
|
+ $one = $1;
|
||||||
|
+ }
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyz' x 3, "$desc: s value");
|
||||||
|
+ is($res, 3, "$desc: res value");
|
||||||
|
+ is($one, 'c', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /r with whole replacement tainted";
|
||||||
|
+
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$TAINTXYZ/r;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ is_tainted($res, "$desc: res tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'abcd', "$desc: s value");
|
||||||
|
+ is($res, 'xyz', "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
{
|
||||||
|
# now do them all again with "use re 'taint"
|
||||||
|
|
||||||
|
@@ -955,7 +1022,7 @@ my $TEST = 'TEST';
|
||||||
|
is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
}
|
||||||
|
|
||||||
|
- $desc = "use re 'taint': substitution with replacement tainted";
|
||||||
|
+ $desc = "use re 'taint': substitution with partial replacement tainted";
|
||||||
|
|
||||||
|
$s = 'abcd';
|
||||||
|
$res = $s =~ s/(.+)/xyz$TAINT/;
|
||||||
|
@@ -967,7 +1034,7 @@ my $TEST = 'TEST';
|
||||||
|
is($res, 1, "$desc: res value");
|
||||||
|
is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
|
||||||
|
- $desc = "use re 'taint': substitution /g with replacement tainted";
|
||||||
|
+ $desc = "use re 'taint': substitution /g with partial replacement tainted";
|
||||||
|
|
||||||
|
$s = 'abcd';
|
||||||
|
$res = $s =~ s/(.)/x$TAINT/g;
|
||||||
|
@@ -979,7 +1046,7 @@ my $TEST = 'TEST';
|
||||||
|
is($res, 4, "$desc: res value");
|
||||||
|
is($one, 'd', "$desc: \$1 value");
|
||||||
|
|
||||||
|
- $desc = "use re 'taint': substitution /ge with replacement tainted";
|
||||||
|
+ $desc = "use re 'taint': substitution /ge with partial replacement tainted";
|
||||||
|
|
||||||
|
$s = 'abc';
|
||||||
|
{
|
||||||
|
@@ -1008,7 +1075,7 @@ my $TEST = 'TEST';
|
||||||
|
is($res, 3, "$desc: res value");
|
||||||
|
is($one, 'c', "$desc: \$1 value");
|
||||||
|
|
||||||
|
- $desc = "use re 'taint': substitution /r with replacement tainted";
|
||||||
|
+ $desc = "use re 'taint': substitution /r with partial replacement tainted";
|
||||||
|
|
||||||
|
$s = 'abcd';
|
||||||
|
$res = $s =~ s/(.+)/xyz$TAINT/r;
|
||||||
|
@@ -1020,6 +1087,71 @@ my $TEST = 'TEST';
|
||||||
|
is($res, 'xyz', "$desc: res value");
|
||||||
|
is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
|
||||||
|
+ $desc = "use re 'taint': substitution with whole replacement tainted";
|
||||||
|
+
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$TAINTXYZ/;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyz', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "use re 'taint': substitution /g with whole replacement tainted";
|
||||||
|
+
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/$TAINTXYZ/g;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyz' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "use re 'taint': substitution /ge with whole replacement tainted";
|
||||||
|
+
|
||||||
|
+ $s = 'abc';
|
||||||
|
+ {
|
||||||
|
+ my $i = 0;
|
||||||
|
+ my $j;
|
||||||
|
+ $res = $s =~ s{(.)}{
|
||||||
|
+ $j = $i; # make sure code not tainted
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($j, "$desc: code not tainted within /e");
|
||||||
|
+ $i++;
|
||||||
|
+ if ($i == 1) {
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted loop 1");
|
||||||
|
+ }
|
||||||
|
+ else {
|
||||||
|
+ is_tainted($s, "$desc: s tainted loop $i");
|
||||||
|
+ }
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ $TAINTXYZ;
|
||||||
|
+ }ge;
|
||||||
|
+ $one = $1;
|
||||||
|
+ }
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyz' x 3, "$desc: s value");
|
||||||
|
+ is($res, 3, "$desc: res value");
|
||||||
|
+ is($one, 'c', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "use re 'taint': substitution /r with whole replacement tainted";
|
||||||
|
+
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$TAINTXYZ/r;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ is_tainted($res, "$desc: res tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'abcd', "$desc: s value");
|
||||||
|
+ is($res, 'xyz', "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
# [perl #121854] match taintedness became sticky
|
||||||
|
# when one match has a taintess result, subseqent matches
|
||||||
|
# using the same pattern shouldn't necessarily be tainted
|
||||||
|
@@ -2408,6 +2540,285 @@ is eval { eval $::x.1 }, 1, 'reset does not taint undef';
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
+# taint passing through overloading
|
||||||
|
+package OvTaint {
|
||||||
|
+ sub new { bless({ t => $_[1] }, $_[0]) }
|
||||||
|
+ use overload '""' => sub { $_[0]->{t} ? "hi".$TAINT : "hello" };
|
||||||
|
+}
|
||||||
|
+my $ovclean = OvTaint->new(0);
|
||||||
|
+my $ovtaint = OvTaint->new(1);
|
||||||
|
+isnt_tainted("$ovclean", "overload preserves cleanliness");
|
||||||
|
+is_tainted("$ovtaint", "overload preserves taint");
|
||||||
|
+
|
||||||
|
+# substitutions with overloaded replacement
|
||||||
|
+{
|
||||||
|
+ my ($desc, $s, $res, $one);
|
||||||
|
+
|
||||||
|
+ $desc = "substitution with partial replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/xyz$ovclean/;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyzhello', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution with partial replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/xyz$ovtaint/;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyzhi', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution with whole replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$ovclean/;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hello', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution with whole replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$ovtaint/;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hi', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /e with partial replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/"xyz".$ovclean/e;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyzhello', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /e with partial replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/"xyz".$ovtaint/e;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyzhi', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /e with whole replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$ovclean/e;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hello', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /e with whole replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$ovtaint/e;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hi', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /e with extra code and partial replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/(my $z++), "xyz".$ovclean/e;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyzhello', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /e with extra code and partial replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/(my $z++), "xyz".$ovtaint/e;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xyzhi', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /e with extra code and whole replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/(my $z++), $ovclean/e;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hello', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /e with extra code and whole replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/(my $z++), $ovtaint/e;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hi', "$desc: s value");
|
||||||
|
+ is($res, 1, "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /r with partial replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/xyz$ovclean/r;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'abcd', "$desc: s value");
|
||||||
|
+ is($res, 'xyzhello', "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /r with partial replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/xyz$ovtaint/r;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ is_tainted($res, "$desc: res tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'abcd', "$desc: s value");
|
||||||
|
+ is($res, 'xyzhi', "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /r with whole replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$ovclean/r;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'abcd', "$desc: s value");
|
||||||
|
+ is($res, 'hello', "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /r with whole replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.+)/$ovtaint/r;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ is_tainted($res, "$desc: res tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'abcd', "$desc: s value");
|
||||||
|
+ is($res, 'hi', "$desc: res value");
|
||||||
|
+ is($one, 'abcd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /g with partial replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/x$ovclean/g;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xhello' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /g with partial replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/x$ovtaint/g;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xhi' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /g with whole replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/$ovclean/g;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hello' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /g with whole replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/$ovtaint/g;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hi' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /ge with partial replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/"x".$ovclean/ge;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xhello' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /ge with partial replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/"x".$ovtaint/ge;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'xhi' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /ge with whole replacement overloaded and clean";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/$ovclean/ge;
|
||||||
|
+ $one = $1;
|
||||||
|
+ isnt_tainted($s, "$desc: s not tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hello' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+
|
||||||
|
+ $desc = "substitution /ge with whole replacement overloaded and tainted";
|
||||||
|
+ $s = 'abcd';
|
||||||
|
+ $res = $s =~ s/(.)/$ovtaint/ge;
|
||||||
|
+ $one = $1;
|
||||||
|
+ is_tainted($s, "$desc: s tainted");
|
||||||
|
+ isnt_tainted($res, "$desc: res not tainted");
|
||||||
|
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||||
|
+ is($s, 'hi' x 4, "$desc: s value");
|
||||||
|
+ is($res, 4, "$desc: res value");
|
||||||
|
+ is($one, 'd', "$desc: \$1 value");
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
# This may bomb out with the alarm signal so keep it last
|
||||||
|
SKIP: {
|
||||||
|
skip "No alarm()" unless $Config{d_alarm};
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,64 @@
|
|||||||
|
From b890486ff0c482cbdec59a0f9beb28275aeee19b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 19 Jun 2017 14:59:53 +1000
|
||||||
|
Subject: [PATCH] (perl #131597) ensure the GV slot is filled for our [%$@]foo:
|
||||||
|
attr
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.3.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
op.c | 6 +++---
|
||||||
|
t/op/attrs.t | 18 ++++++++++++++++++
|
||||||
|
2 files changed, 21 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/op.c b/op.c
|
||||||
|
index 2960dd5..8a5fc3f 100644
|
||||||
|
--- a/op.c
|
||||||
|
+++ b/op.c
|
||||||
|
@@ -3671,9 +3671,9 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
|
||||||
|
PL_parser->in_my = FALSE;
|
||||||
|
PL_parser->in_my_stash = NULL;
|
||||||
|
apply_attrs(GvSTASH(gv),
|
||||||
|
- (type == OP_RV2SV ? GvSV(gv) :
|
||||||
|
- type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
|
||||||
|
- type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
|
||||||
|
+ (type == OP_RV2SV ? GvSVn(gv) :
|
||||||
|
+ type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
|
||||||
|
+ type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
|
||||||
|
attrs);
|
||||||
|
}
|
||||||
|
o->op_private |= OPpOUR_INTRO;
|
||||||
|
diff --git a/t/op/attrs.t b/t/op/attrs.t
|
||||||
|
index 219db03..b038c87 100644
|
||||||
|
--- a/t/op/attrs.t
|
||||||
|
+++ b/t/op/attrs.t
|
||||||
|
@@ -447,4 +447,22 @@ package P126257 {
|
||||||
|
::is $@, "", "RT 126257 sub";
|
||||||
|
}
|
||||||
|
|
||||||
|
+fresh_perl_is('sub dummy {} our $dummy : Dummy', <<EOS, {},
|
||||||
|
+Invalid SCALAR attribute: Dummy at - line 1.
|
||||||
|
+BEGIN failed--compilation aborted at - line 1.
|
||||||
|
+EOS
|
||||||
|
+ "attribute on our scalar with sub of same name");
|
||||||
|
+
|
||||||
|
+fresh_perl_is('sub dummy {} our @dummy : Dummy', <<EOS, {},
|
||||||
|
+Invalid ARRAY attribute: Dummy at - line 1.
|
||||||
|
+BEGIN failed--compilation aborted at - line 1.
|
||||||
|
+EOS
|
||||||
|
+ "attribute on our array with sub of same name");
|
||||||
|
+
|
||||||
|
+fresh_perl_is('sub dummy {} our %dummy : Dummy', <<EOS, {},
|
||||||
|
+Invalid HASH attribute: Dummy at - line 1.
|
||||||
|
+BEGIN failed--compilation aborted at - line 1.
|
||||||
|
+EOS
|
||||||
|
+ "attribute on our hash with sub of same name");
|
||||||
|
+
|
||||||
|
done_testing();
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,223 @@
|
|||||||
|
From 9a4826e0881f8c5498a0fd5f24ed2a0fefb771b7 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Thu, 2 Nov 2017 20:18:56 +0000
|
||||||
|
Subject: [PATCH] (perl #131895) fail stat on names with \0 embedded
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Also lstat() and the file test ops.
|
||||||
|
|
||||||
|
Petr Písař: Port to 5.24.3.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
doio.c | 21 ++++++++++++++++-----
|
||||||
|
pp_sys.c | 29 +++++++++++++++++++++++------
|
||||||
|
t/lib/warnings/pp_sys | 14 ++++++++++++++
|
||||||
|
t/op/filetest.t | 10 +++++++++-
|
||||||
|
t/op/stat.t | 12 +++++++++++-
|
||||||
|
5 files changed, 73 insertions(+), 13 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/doio.c b/doio.c
|
||||||
|
index 6704862..2792c66 100644
|
||||||
|
--- a/doio.c
|
||||||
|
+++ b/doio.c
|
||||||
|
@@ -1458,7 +1458,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
|
return PL_laststatval;
|
||||||
|
else {
|
||||||
|
SV* const sv = TOPs;
|
||||||
|
- const char *s;
|
||||||
|
+ const char *s, *d;
|
||||||
|
STRLEN len;
|
||||||
|
if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
|
||||||
|
goto do_fstat;
|
||||||
|
@@ -1472,9 +1472,14 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
|
s = SvPV_flags_const(sv, len, flags);
|
||||||
|
PL_statgv = NULL;
|
||||||
|
sv_setpvn(PL_statname, s, len);
|
||||||
|
- s = SvPVX_const(PL_statname); /* s now NUL-terminated */
|
||||||
|
+ d = SvPVX_const(PL_statname); /* s now NUL-terminated */
|
||||||
|
PL_laststype = OP_STAT;
|
||||||
|
- PL_laststatval = PerlLIO_stat(s, &PL_statcache);
|
||||||
|
+ if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
|
||||||
|
+ PL_laststatval = -1;
|
||||||
|
+ }
|
||||||
|
+ else {
|
||||||
|
+ PL_laststatval = PerlLIO_stat(d, &PL_statcache);
|
||||||
|
+ }
|
||||||
|
if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
|
||||||
|
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
|
||||||
|
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
|
||||||
|
@@ -1491,6 +1496,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||||
|
static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
|
||||||
|
dSP;
|
||||||
|
const char *file;
|
||||||
|
+ STRLEN len;
|
||||||
|
SV* const sv = TOPs;
|
||||||
|
bool isio = FALSE;
|
||||||
|
if (PL_op->op_flags & OPf_REF) {
|
||||||
|
@@ -1534,9 +1540,14 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||||
|
HEKfARG(GvENAME_HEK((const GV *)
|
||||||
|
(SvROK(sv) ? SvRV(sv) : sv))));
|
||||||
|
}
|
||||||
|
- file = SvPV_flags_const_nolen(sv, flags);
|
||||||
|
+ file = SvPV_flags_const(sv, len, flags);
|
||||||
|
sv_setpv(PL_statname,file);
|
||||||
|
- PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
|
||||||
|
+ if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
|
||||||
|
+ PL_laststatval = -1;
|
||||||
|
+ }
|
||||||
|
+ else {
|
||||||
|
+ PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
|
||||||
|
+ }
|
||||||
|
if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
|
||||||
|
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
|
||||||
|
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index bd55043..1a72e60 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -2927,19 +2927,24 @@ PP(pp_stat)
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
const char *file;
|
||||||
|
+ const char *temp;
|
||||||
|
+ STRLEN len;
|
||||||
|
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
|
||||||
|
io = MUTABLE_IO(SvRV(sv));
|
||||||
|
if (PL_op->op_type == OP_LSTAT)
|
||||||
|
goto do_fstat_warning_check;
|
||||||
|
goto do_fstat_have_io;
|
||||||
|
}
|
||||||
|
-
|
||||||
|
SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
|
||||||
|
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
|
||||||
|
+ temp = SvPV_nomg_const(sv, len);
|
||||||
|
+ sv_setpv(PL_statname, temp);
|
||||||
|
PL_statgv = NULL;
|
||||||
|
PL_laststype = PL_op->op_type;
|
||||||
|
file = SvPV_nolen_const(PL_statname);
|
||||||
|
- if (PL_op->op_type == OP_LSTAT)
|
||||||
|
+ if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
|
||||||
|
+ PL_laststatval = -1;
|
||||||
|
+ }
|
||||||
|
+ else if (PL_op->op_type == OP_LSTAT)
|
||||||
|
PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
|
||||||
|
else
|
||||||
|
PL_laststatval = PerlLIO_stat(file, &PL_statcache);
|
||||||
|
@@ -3175,8 +3180,12 @@ PP(pp_ftrread)
|
||||||
|
|
||||||
|
if (use_access) {
|
||||||
|
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
|
||||||
|
- const char *name = SvPV_nolen(*PL_stack_sp);
|
||||||
|
- if (effective) {
|
||||||
|
+ STRLEN len;
|
||||||
|
+ const char *name = SvPV(*PL_stack_sp, len);
|
||||||
|
+ if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
|
||||||
|
+ result = -1;
|
||||||
|
+ }
|
||||||
|
+ else if (effective) {
|
||||||
|
# ifdef PERL_EFF_ACCESS
|
||||||
|
result = PERL_EFF_ACCESS(name, access_mode);
|
||||||
|
# else
|
||||||
|
@@ -3501,10 +3510,18 @@ PP(pp_fttext)
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
const char *file;
|
||||||
|
+ const char *temp;
|
||||||
|
+ STRLEN temp_len;
|
||||||
|
int fd;
|
||||||
|
|
||||||
|
assert(sv);
|
||||||
|
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
|
||||||
|
+ temp = SvPV_nomg_const(sv, temp_len);
|
||||||
|
+ sv_setpv(PL_statname, temp);
|
||||||
|
+ if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
|
||||||
|
+ PL_laststatval = -1;
|
||||||
|
+ PL_laststype = OP_STAT;
|
||||||
|
+ FT_RETURNUNDEF;
|
||||||
|
+ }
|
||||||
|
really_filename:
|
||||||
|
file = SvPVX_const(PL_statname);
|
||||||
|
PL_statgv = NULL;
|
||||||
|
diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
|
||||||
|
index 6338964..ded5d7d 100644
|
||||||
|
--- a/t/lib/warnings/pp_sys
|
||||||
|
+++ b/t/lib/warnings/pp_sys
|
||||||
|
@@ -962,3 +962,17 @@ close $fh;
|
||||||
|
unlink $file;
|
||||||
|
EXPECT
|
||||||
|
syswrite() is deprecated on :utf8 handles at - line 6.
|
||||||
|
+########
|
||||||
|
+# NAME stat on name with \0
|
||||||
|
+use warnings;
|
||||||
|
+my @x = stat("./\0-");
|
||||||
|
+my @y = lstat("./\0-");
|
||||||
|
+-T ".\0-";
|
||||||
|
+-x ".\0-";
|
||||||
|
+-l ".\0-";
|
||||||
|
+EXPECT
|
||||||
|
+Invalid \0 character in pathname for stat: ./\0- at - line 2.
|
||||||
|
+Invalid \0 character in pathname for lstat: ./\0- at - line 3.
|
||||||
|
+Invalid \0 character in pathname for fttext: .\0- at - line 4.
|
||||||
|
+Invalid \0 character in pathname for fteexec: .\0- at - line 5.
|
||||||
|
+Invalid \0 character in pathname for ftlink: .\0- at - line 6.
|
||||||
|
diff --git a/t/op/filetest.t b/t/op/filetest.t
|
||||||
|
index 8883381..bd1d08c 100644
|
||||||
|
--- a/t/op/filetest.t
|
||||||
|
+++ b/t/op/filetest.t
|
||||||
|
@@ -9,7 +9,7 @@ BEGIN {
|
||||||
|
set_up_inc(qw '../lib ../cpan/Perl-OSType/lib');
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan(tests => 53 + 27*14);
|
||||||
|
+plan(tests => 57 + 27*14);
|
||||||
|
|
||||||
|
if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) {
|
||||||
|
require Win32; # for IsAdminUser()
|
||||||
|
@@ -393,3 +393,11 @@ SKIP: {
|
||||||
|
is $failed_stat2, $failed_stat1,
|
||||||
|
'failed -r($gv_with_io_but_no_fp) with and w/out fatal warnings';
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+{
|
||||||
|
+ # [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
|
||||||
|
+ ok(!-T "TEST\0-", '-T on name with \0');
|
||||||
|
+ ok(!-B "TEST\0-", '-B on name with \0');
|
||||||
|
+ ok(!-f "TEST\0-", '-f 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
|
||||||
|
index 637a902..71193ad 100644
|
||||||
|
--- a/t/op/stat.t
|
||||||
|
+++ b/t/op/stat.t
|
||||||
|
@@ -25,7 +25,7 @@ if ($^O eq 'MSWin32') {
|
||||||
|
${^WIN32_SLOPPY_STAT} = 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 118;
|
||||||
|
+plan tests => 120;
|
||||||
|
|
||||||
|
my $Perl = which_perl();
|
||||||
|
|
||||||
|
@@ -651,6 +651,16 @@ SKIP:
|
||||||
|
'stat on an array of valid paths should return ENOENT';
|
||||||
|
}
|
||||||
|
|
||||||
|
+# [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
|
||||||
|
+ok !stat("TEST\0-"), 'stat on filename with \0';
|
||||||
|
+SKIP: {
|
||||||
|
+ my $link = "TEST.symlink.$$";
|
||||||
|
+ my $can_symlink = eval { symlink "TEST", $link };
|
||||||
|
+ skip "cannot symlink", 1 unless $can_symlink;
|
||||||
|
+ ok !lstat("$link\0-"), 'lstat on filename with \0';
|
||||||
|
+ unlink $link;
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
END {
|
||||||
|
chmod 0666, $tmpfile;
|
||||||
|
unlink_all $tmpfile;
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,52 @@
|
|||||||
|
From 86a48d83a7caf38c553000a250ed1359c235f55e Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Thu, 19 Oct 2017 10:46:04 +1100
|
||||||
|
Subject: [PATCH] (perl #132245) don't try to process a char range with no
|
||||||
|
preceding char
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
A range like \N{}-0 eventually results in compilation failing, but
|
||||||
|
before that, get_and_check_backslash_N_name() attempts to treat
|
||||||
|
the memory before the empty output of \N{} as a character.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.3.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/lib/warnings/toke | 5 +++++
|
||||||
|
toke.c | 4 ++--
|
||||||
|
2 files changed, 7 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
|
||||||
|
index 493c8a2..4a521e0 100644
|
||||||
|
--- a/t/lib/warnings/toke
|
||||||
|
+++ b/t/lib/warnings/toke
|
||||||
|
@@ -1509,3 +1509,8 @@ my $v = 𝛃 - 5;
|
||||||
|
EXPECT
|
||||||
|
OPTION regex
|
||||||
|
(Wide character.*\n)?Warning: Use of "𝛃" without parentheses is ambiguous
|
||||||
|
+########
|
||||||
|
+# NAME tr/// range with empty \N{} at the start
|
||||||
|
+tr//\N{}-0/;
|
||||||
|
+EXPECT
|
||||||
|
+Unknown charname '' is deprecated at - line 1.
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index f2310cc..3d93fac 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -2906,8 +2906,8 @@ 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
|
||||||
|
* don't bother if we're too close to the end for the minus to
|
||||||
|
- * mean that. */
|
||||||
|
- if (*s != '-' || s >= send - 1 || s == start) {
|
||||||
|
+ * mean that, or if we haven't output any characters yet. */
|
||||||
|
+ if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
|
||||||
|
|
||||||
|
/* A regular character. Process like any other, but first
|
||||||
|
* clear any flags */
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,107 @@
|
|||||||
|
From 264472b6e83dd1a9d0e0e58d75f7162471a5b29b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Tue, 14 Nov 2017 18:55:55 -0800
|
||||||
|
Subject: [PATCH] Fix stack with do {my sub l; 1}
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
A block in perl usually compiles to a leave op with an enter inside
|
||||||
|
it, followed by the statements:
|
||||||
|
|
||||||
|
leave
|
||||||
|
enter
|
||||||
|
nextstate
|
||||||
|
... expr ...
|
||||||
|
nextstate
|
||||||
|
... expr ...
|
||||||
|
|
||||||
|
If a block contains only one statement, and that statement is suffic-
|
||||||
|
iently innocuous, then the enter/leave pair to create the scope at run
|
||||||
|
time get skipped, and instead we have a simple scope op which is not
|
||||||
|
even executed:
|
||||||
|
|
||||||
|
scope
|
||||||
|
ex-nextstate
|
||||||
|
... expr ...
|
||||||
|
|
||||||
|
The nextstate in this case also gets nulled.
|
||||||
|
|
||||||
|
In the case of do { my sub l; 1 } we were getting a variation of the
|
||||||
|
latter, that looked like this:
|
||||||
|
|
||||||
|
scope
|
||||||
|
introcv
|
||||||
|
clonecv
|
||||||
|
nextstate
|
||||||
|
... expr ...
|
||||||
|
|
||||||
|
The problem here is that nextstate resets the stack, even though a new
|
||||||
|
scope has not been pushed, so we end up with all existing stack items
|
||||||
|
from the *outer* scope getting clobbered.
|
||||||
|
|
||||||
|
One can have fun with this and erase everything pushed on to the stack
|
||||||
|
so far in a given statement:
|
||||||
|
|
||||||
|
$ ./perl -le 'print join "-", 1..10, do {my sub l; ","}, 11..20'
|
||||||
|
11,12,13,14,15,16,17,18,19,20
|
||||||
|
|
||||||
|
Here I replaced the first argument to join() from within the do{}
|
||||||
|
block, after having cleared the stack.
|
||||||
|
|
||||||
|
Why was the op tree was getting muddled up like this? The ‘my sub’
|
||||||
|
declaration does not immediately add any ops to the op tree; those ops
|
||||||
|
get added when the current scope finishing compiling, since those ops
|
||||||
|
must be inserted at the beginning of the block.
|
||||||
|
|
||||||
|
I have not fully looked into the order that things happen, and why the
|
||||||
|
nextstate op does not get nulled; but it did not matter, because of
|
||||||
|
the simple fix: Treat lexical sub declarations as ‘not innocuous’ by
|
||||||
|
setting the HINT_BLOCK_SCOPE flag when a lexical sub is declared.
|
||||||
|
Thus, we end up with an enter/leave pair, which creates a
|
||||||
|
proper scope.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.3.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
op.c | 2 ++
|
||||||
|
t/op/lexsub.t | 5 ++++-
|
||||||
|
2 files changed, 6 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/op.c b/op.c
|
||||||
|
index 8a5fc3f..695bfa4 100644
|
||||||
|
--- a/op.c
|
||||||
|
+++ b/op.c
|
||||||
|
@@ -7936,6 +7936,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
|
||||||
|
|
||||||
|
PERL_ARGS_ASSERT_NEWMYSUB;
|
||||||
|
|
||||||
|
+ PL_hints |= HINT_BLOCK_SCOPE;
|
||||||
|
+
|
||||||
|
/* Find the pad slot for storing the new sub.
|
||||||
|
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-
|
||||||
|
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
|
||||||
|
index adccf4c..cf90a76 100644
|
||||||
|
--- a/t/op/lexsub.t
|
||||||
|
+++ b/t/op/lexsub.t
|
||||||
|
@@ -7,7 +7,7 @@ BEGIN {
|
||||||
|
*bar::is = *is;
|
||||||
|
*bar::like = *like;
|
||||||
|
}
|
||||||
|
-plan 151;
|
||||||
|
+plan 152;
|
||||||
|
|
||||||
|
# -------------------- Errors with feature disabled -------------------- #
|
||||||
|
|
||||||
|
@@ -967,3 +967,6 @@ like runperl(
|
||||||
|
{
|
||||||
|
my sub h; sub{my $x; sub{h}}
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+is join("-", qw(aa bb), do { my sub lleexx; 123 }, qw(cc dd)),
|
||||||
|
+ "aa-bb-123-cc-dd", 'do { my sub...} in a list [perl #132442]';
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
211
SOURCES/perl-5.24.3-set-when-statting-a-closed-filehandle.patch
Normal file
211
SOURCES/perl-5.24.3-set-when-statting-a-closed-filehandle.patch
Normal file
@ -0,0 +1,211 @@
|
|||||||
|
From 0a41ca5a68626a0f44e0d552e460e86567e47140 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Zefram <zefram@fysh.org>
|
||||||
|
Date: Wed, 15 Nov 2017 08:11:37 +0000
|
||||||
|
Subject: [PATCH] set $! when statting a closed filehandle
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
When a stat fails because it's on a closed or otherwise invalid
|
||||||
|
filehandle, $! was often not being set, depending on the operation
|
||||||
|
and the nature of the invalidity. Consistently set it to EBADF.
|
||||||
|
Fixes [perl #108288].
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.3.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
MANIFEST | 1 +
|
||||||
|
doio.c | 10 +++++++++-
|
||||||
|
pp_sys.c | 22 ++++++++++++---------
|
||||||
|
t/op/stat_errors.t | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||||
|
4 files changed, 80 insertions(+), 10 deletions(-)
|
||||||
|
create mode 100644 t/op/stat_errors.t
|
||||||
|
|
||||||
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
|
index fcf7eae..3077142 100644
|
||||||
|
--- a/MANIFEST
|
||||||
|
+++ b/MANIFEST
|
||||||
|
@@ -5394,6 +5394,7 @@ t/op/sselect.t See if 4 argument select works
|
||||||
|
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_errors.t See if stat and file tests handle threshold errors
|
||||||
|
t/op/study.t See if study works
|
||||||
|
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
|
||||||
|
index 2792c66..f2934c5 100644
|
||||||
|
--- a/doio.c
|
||||||
|
+++ b/doio.c
|
||||||
|
@@ -1429,8 +1429,11 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
|
if (PL_op->op_flags & OPf_REF) {
|
||||||
|
gv = cGVOP_gv;
|
||||||
|
do_fstat:
|
||||||
|
- if (gv == PL_defgv)
|
||||||
|
+ if (gv == PL_defgv) {
|
||||||
|
+ if (PL_laststatval < 0)
|
||||||
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
return PL_laststatval;
|
||||||
|
+ }
|
||||||
|
io = GvIO(gv);
|
||||||
|
do_fstat_have_io:
|
||||||
|
PL_laststype = OP_STAT;
|
||||||
|
@@ -1441,6 +1444,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
|
int fd = PerlIO_fileno(IoIFP(io));
|
||||||
|
if (fd < 0) {
|
||||||
|
/* E.g. PerlIO::scalar has no real fd. */
|
||||||
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
return (PL_laststatval = -1);
|
||||||
|
} else {
|
||||||
|
return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
|
||||||
|
@@ -1451,6 +1455,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||||
|
}
|
||||||
|
PL_laststatval = -1;
|
||||||
|
report_evil_fh(gv);
|
||||||
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
return -1;
|
||||||
|
}
|
||||||
|
else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
|
||||||
|
@@ -1503,6 +1508,8 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||||
|
if (cGVOP_gv == PL_defgv) {
|
||||||
|
if (PL_laststype != OP_LSTAT)
|
||||||
|
Perl_croak(aTHX_ "%s", no_prev_lstat);
|
||||||
|
+ if (PL_laststatval < 0)
|
||||||
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
return PL_laststatval;
|
||||||
|
}
|
||||||
|
PL_laststatval = -1;
|
||||||
|
@@ -1512,6 +1519,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||||
|
"Use of -l on filehandle %"HEKf,
|
||||||
|
HEKfARG(GvENAME_HEK(cGVOP_gv)));
|
||||||
|
}
|
||||||
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
return -1;
|
||||||
|
}
|
||||||
|
if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index 5e0993d..2fcc219 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -2889,10 +2889,11 @@ PP(pp_stat)
|
||||||
|
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
|
||||||
|
}
|
||||||
|
|
||||||
|
- if (gv != PL_defgv) {
|
||||||
|
- bool havefp;
|
||||||
|
+ if (gv == PL_defgv) {
|
||||||
|
+ if (PL_laststatval < 0)
|
||||||
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
+ } else {
|
||||||
|
do_fstat_have_io:
|
||||||
|
- havefp = FALSE;
|
||||||
|
PL_laststype = OP_STAT;
|
||||||
|
PL_statgv = gv ? gv : (GV *)io;
|
||||||
|
sv_setpvs(PL_statname, "");
|
||||||
|
@@ -2903,22 +2904,25 @@ PP(pp_stat)
|
||||||
|
if (IoIFP(io)) {
|
||||||
|
int fd = PerlIO_fileno(IoIFP(io));
|
||||||
|
if (fd < 0) {
|
||||||
|
+ report_evil_fh(gv);
|
||||||
|
PL_laststatval = -1;
|
||||||
|
SETERRNO(EBADF,RMS_IFI);
|
||||||
|
} else {
|
||||||
|
PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
|
||||||
|
- havefp = TRUE;
|
||||||
|
}
|
||||||
|
} else if (IoDIRP(io)) {
|
||||||
|
PL_laststatval =
|
||||||
|
PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
|
||||||
|
- havefp = TRUE;
|
||||||
|
} else {
|
||||||
|
+ report_evil_fh(gv);
|
||||||
|
PL_laststatval = -1;
|
||||||
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
}
|
||||||
|
- }
|
||||||
|
- else PL_laststatval = -1;
|
||||||
|
- if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
|
||||||
|
+ } else {
|
||||||
|
+ report_evil_fh(gv);
|
||||||
|
+ PL_laststatval = -1;
|
||||||
|
+ SETERRNO(EBADF,RMS_IFI);
|
||||||
|
+ }
|
||||||
|
}
|
||||||
|
|
||||||
|
if (PL_laststatval < 0) {
|
||||||
|
@@ -3415,7 +3419,7 @@ PP(pp_fttty)
|
||||||
|
else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
|
||||||
|
fd = (int)uv;
|
||||||
|
else
|
||||||
|
- FT_RETURNUNDEF;
|
||||||
|
+ fd = -1;
|
||||||
|
if (fd < 0) {
|
||||||
|
SETERRNO(EBADF,RMS_IFI);
|
||||||
|
FT_RETURNUNDEF;
|
||||||
|
diff --git a/t/op/stat_errors.t b/t/op/stat_errors.t
|
||||||
|
new file mode 100644
|
||||||
|
index 0000000..e043c61
|
||||||
|
--- /dev/null
|
||||||
|
+++ b/t/op/stat_errors.t
|
||||||
|
@@ -0,0 +1,57 @@
|
||||||
|
+#!./perl
|
||||||
|
+
|
||||||
|
+BEGIN {
|
||||||
|
+ chdir 't' if -d 't';
|
||||||
|
+ require './test.pl';
|
||||||
|
+ set_up_inc('../lib');
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+plan(tests => 2*11*29);
|
||||||
|
+
|
||||||
|
+use Errno qw(EBADF ENOENT);
|
||||||
|
+
|
||||||
|
+open(SCALARFILE, "<", \"wibble") or die $!;
|
||||||
|
+open(CLOSEDFILE, "<", "./test.pl") or die $!;
|
||||||
|
+close(CLOSEDFILE) or die $!;
|
||||||
|
+opendir(CLOSEDDIR, "../lib") or die $!;
|
||||||
|
+closedir(CLOSEDDIR) or die $!;
|
||||||
|
+
|
||||||
|
+foreach my $op (
|
||||||
|
+ qw(stat lstat),
|
||||||
|
+ (map { "-$_" } qw(r w x o R W X O e z s f d l p S b c t u g k T B M A C)),
|
||||||
|
+) {
|
||||||
|
+ foreach my $arg (
|
||||||
|
+ (map { ($_, "\\*$_") }
|
||||||
|
+ qw(NEVEROPENED SCALARFILE CLOSEDFILE CLOSEDDIR _)),
|
||||||
|
+ "\"tmpnotexist\"",
|
||||||
|
+ ) {
|
||||||
|
+ my $argdesc = $arg;
|
||||||
|
+ if ($arg eq "_") {
|
||||||
|
+ my @z = lstat "tmpnotexist";
|
||||||
|
+ $argdesc .= " with prior stat fail";
|
||||||
|
+ }
|
||||||
|
+ SKIP: {
|
||||||
|
+ if ($op eq "-l" && $arg =~ /\A\\/) {
|
||||||
|
+ # The op weirdly stringifies the globref and uses it as
|
||||||
|
+ # a filename, rather than treating it as a file handle.
|
||||||
|
+ # That might be a bug, but while that behaviour exists it
|
||||||
|
+ # needs to be exempted from these tests.
|
||||||
|
+ skip "-l on globref", 2;
|
||||||
|
+ }
|
||||||
|
+ if ($op eq "-t" && $arg eq "\"tmpnotexist\"") {
|
||||||
|
+ # The op doesn't operate on filenames.
|
||||||
|
+ skip "-t on filename", 2;
|
||||||
|
+ }
|
||||||
|
+ $! = 0;
|
||||||
|
+ my $res = eval "$op $arg";
|
||||||
|
+ my $err = $!;
|
||||||
|
+ is $res, $op =~ /\A-/ ? undef : !!0, "result of $op $arg";
|
||||||
|
+ is 0+$err,
|
||||||
|
+ $arg eq "\"tmpnotexist\"" ||
|
||||||
|
+ ($op =~ /\A-[TB]\z/ && $arg =~ /_\z/) ? ENOENT : EBADF,
|
||||||
|
+ "error from $op $arg";
|
||||||
|
+ }
|
||||||
|
+ }
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+1;
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
94
SOURCES/perl-5.24.4-Remove-ext-GDBM_File-t-fatal.t.patch
Normal file
94
SOURCES/perl-5.24.4-Remove-ext-GDBM_File-t-fatal.t.patch
Normal file
@ -0,0 +1,94 @@
|
|||||||
|
From 0711044bfd02bbd7d2967ba96c6fdcae5b7132d6 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Mon, 9 Jul 2018 16:18:36 +0200
|
||||||
|
Subject: [PATCH] Remove ext/GDBM_File/t/fatal.t
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
gdbm-1.15 defaults to a memory-mapped I/O and does not report any I/O
|
||||||
|
errors on store and close operations. Thus ext/GDBM_File/t/fatal.t
|
||||||
|
test that expects these fatal error reports fails. Because there is
|
||||||
|
no other way to provoke a fatal error in gdbm-1.15 this patch
|
||||||
|
removes the test. Future gdbm version promisses reporting a regular
|
||||||
|
error on closing a database.
|
||||||
|
|
||||||
|
RT#133295
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
MANIFEST | 1 -
|
||||||
|
ext/GDBM_File/t/fatal.t | 49 -------------------------------------------------
|
||||||
|
2 files changed, 50 deletions(-)
|
||||||
|
delete mode 100644 ext/GDBM_File/t/fatal.t
|
||||||
|
|
||||||
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
|
index a1a5320..ed5d05f 100644
|
||||||
|
--- a/MANIFEST
|
||||||
|
+++ b/MANIFEST
|
||||||
|
@@ -3719,7 +3719,6 @@ ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
|
||||||
|
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/Makefile.PL GDBM extension makefile writer
|
||||||
|
-ext/GDBM_File/t/fatal.t Test the fatal_func argument to gdbm_open
|
||||||
|
ext/GDBM_File/t/gdbm.t See if GDBM_File works
|
||||||
|
ext/GDBM_File/typemap GDBM extension interface types
|
||||||
|
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
|
||||||
|
deleted file mode 100644
|
||||||
|
index b7045ba..0000000
|
||||||
|
--- a/ext/GDBM_File/t/fatal.t
|
||||||
|
+++ /dev/null
|
||||||
|
@@ -1,49 +0,0 @@
|
||||||
|
-#!./perl -w
|
||||||
|
-use strict;
|
||||||
|
-
|
||||||
|
-use Test::More;
|
||||||
|
-use Config;
|
||||||
|
-
|
||||||
|
-BEGIN {
|
||||||
|
- plan(skip_all => "GDBM_File was not built")
|
||||||
|
- unless $Config{extensions} =~ /\bGDBM_File\b/;
|
||||||
|
-
|
||||||
|
- # https://rt.perl.org/Public/Bug/Display.html?id=117967
|
||||||
|
- plan(skip_all => "GDBM_File is flaky in $^O")
|
||||||
|
- if $^O =~ /darwin/;
|
||||||
|
-
|
||||||
|
- plan(tests => 8);
|
||||||
|
- use_ok('GDBM_File');
|
||||||
|
-}
|
||||||
|
-
|
||||||
|
-unlink <Op_dbmx*>;
|
||||||
|
-
|
||||||
|
-open my $fh, $^X or die "Can't open $^X: $!";
|
||||||
|
-my $fileno = fileno $fh;
|
||||||
|
-isnt($fileno, undef, "Can find next available file descriptor");
|
||||||
|
-close $fh or die $!;
|
||||||
|
-
|
||||||
|
-is((open $fh, "<&=$fileno"), undef,
|
||||||
|
- "Check that we cannot open fileno $fileno. \$! is $!");
|
||||||
|
-
|
||||||
|
-umask(0);
|
||||||
|
-my %h;
|
||||||
|
-isa_ok(tie(%h, 'GDBM_File', 'Op_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
|
||||||
|
-
|
||||||
|
-isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno")
|
||||||
|
- or diag("\$! = $!");
|
||||||
|
-isnt(close $fh, undef,
|
||||||
|
- "close fileno $fileno, out from underneath the GDBM_File");
|
||||||
|
-is(eval {
|
||||||
|
- $h{Perl} = 'Rules';
|
||||||
|
- untie %h;
|
||||||
|
- 1;
|
||||||
|
-}, undef, 'Trapped error when attempting to write to knobbled GDBM_File');
|
||||||
|
-
|
||||||
|
-# Observed "File write error" and "lseek error" from two different systems.
|
||||||
|
-# So there might be more variants. Important part was that we trapped the error
|
||||||
|
-# via croak.
|
||||||
|
-like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/,
|
||||||
|
- 'expected error message from GDBM_File');
|
||||||
|
-
|
||||||
|
-unlink <Op_dbmx*>;
|
||||||
|
--
|
||||||
|
2.14.4
|
||||||
|
|
@ -0,0 +1,90 @@
|
|||||||
|
From bee36f5b5aad82c566311cf8785aa67ba3696155 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Zefram <zefram@fysh.org>
|
||||||
|
Date: Sat, 16 Dec 2017 05:33:20 +0000
|
||||||
|
Subject: [PATCH] perform system() arg processing before fork
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
A lot of things can happen when stringifying an argument list: side
|
||||||
|
effects, warnings, exceptions. In the case of system(), these effects
|
||||||
|
should happen in the context of the parent process. The stringification
|
||||||
|
can also depend on which process it happens in, as in the case of
|
||||||
|
$$, and in that case it should also happen in the parent process.
|
||||||
|
Therefore reduce the argument scalars to strings first thing in pp_system.
|
||||||
|
Fixes [perl #121105].
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.4 from
|
||||||
|
64def2aeaeb63f92dadc6dfa33486c1d7b311963.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_sys.c | 16 ++++++++++------
|
||||||
|
t/op/exec.t | 15 ++++++++++++++-
|
||||||
|
2 files changed, 24 insertions(+), 7 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index 2fcc219..4ce8540 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -4343,14 +4343,18 @@ PP(pp_system)
|
||||||
|
int result;
|
||||||
|
# endif
|
||||||
|
|
||||||
|
+ while (++MARK <= SP) {
|
||||||
|
+ SV *origsv = *MARK;
|
||||||
|
+ STRLEN len;
|
||||||
|
+ char *pv;
|
||||||
|
+ pv = SvPV(origsv, len);
|
||||||
|
+ *MARK = newSVpvn_flags(pv, len,
|
||||||
|
+ (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
|
||||||
|
+ }
|
||||||
|
+ MARK = ORIGMARK;
|
||||||
|
+
|
||||||
|
if (TAINTING_get) {
|
||||||
|
TAINT_ENV();
|
||||||
|
- while (++MARK <= SP) {
|
||||||
|
- (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
|
||||||
|
- if (TAINT_get)
|
||||||
|
- break;
|
||||||
|
- }
|
||||||
|
- MARK = ORIGMARK;
|
||||||
|
TAINT_PROPER("system");
|
||||||
|
}
|
||||||
|
PERL_FLUSHALL_FOR_CHILD;
|
||||||
|
diff --git a/t/op/exec.t b/t/op/exec.t
|
||||||
|
index 726f548..e43dd6e 100644
|
||||||
|
--- a/t/op/exec.t
|
||||||
|
+++ b/t/op/exec.t
|
||||||
|
@@ -36,7 +36,7 @@ $ENV{LANGUAGE} = 'C'; # Ditto in GNU.
|
||||||
|
my $Is_VMS = $^O eq 'VMS';
|
||||||
|
my $Is_Win32 = $^O eq 'MSWin32';
|
||||||
|
|
||||||
|
-plan(tests => 33);
|
||||||
|
+plan(tests => 36);
|
||||||
|
|
||||||
|
my $Perl = which_perl();
|
||||||
|
|
||||||
|
@@ -173,6 +173,19 @@ TODO: {
|
||||||
|
"exec failure doesn't terminate process");
|
||||||
|
}
|
||||||
|
|
||||||
|
+package CountRead {
|
||||||
|
+ sub TIESCALAR { bless({ n => 0 }, $_[0]) }
|
||||||
|
+ sub FETCH { ++$_[0]->{n} }
|
||||||
|
+}
|
||||||
|
+my $cr;
|
||||||
|
+tie $cr, "CountRead";
|
||||||
|
+is system($^X, "-e", "exit(\$ARGV[0] eq '1' ? 0 : 1)", $cr), 0,
|
||||||
|
+ "system args have magic processed exactly once";
|
||||||
|
+is tied($cr)->{n}, 1, "system args have magic processed before fork";
|
||||||
|
+
|
||||||
|
+is system($^X, "-e", "exit(\$ARGV[0] eq \$ARGV[1] ? 0 : 1)", "$$", $$), 0,
|
||||||
|
+ "system args have magic processed before fork";
|
||||||
|
+
|
||||||
|
my $test = curr_test();
|
||||||
|
exec $Perl, '-le', qq{${quote}print 'ok $test - exec PROG, LIST'${quote}};
|
||||||
|
fail("This should never be reached if the exec() worked");
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
@ -0,0 +1,65 @@
|
|||||||
|
From cd6b0f4e030d55ff077e9bc8fbcf156ab79dceb1 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed, 7 Sep 2016 16:51:39 +1000
|
||||||
|
Subject: [PATCH] (perl #129149) avoid a heap buffer overflow with pack "W"...
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.4:
|
||||||
|
|
||||||
|
From bf4a926a29374161655548b149d1cb37300bcc05 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed, 7 Sep 2016 16:51:39 +1000
|
||||||
|
Subject: [PATCH] (perl #129149) avoid a heap buffer overflow with pack "W"...
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_pack.c | 2 +-
|
||||||
|
t/op/pack.t | 13 ++++++++++++-
|
||||||
|
2 files changed, 13 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp_pack.c b/pp_pack.c
|
||||||
|
index c0de5ab..29fdb01 100644
|
||||||
|
--- a/pp_pack.c
|
||||||
|
+++ b/pp_pack.c
|
||||||
|
@@ -2598,7 +2598,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
|
||||||
|
if (in_bytes) auv = auv % 0x100;
|
||||||
|
if (utf8) {
|
||||||
|
W_utf8:
|
||||||
|
- if (cur > end) {
|
||||||
|
+ if (cur >= end) {
|
||||||
|
*cur = '\0';
|
||||||
|
SvCUR_set(cat, cur - start);
|
||||||
|
|
||||||
|
diff --git a/t/op/pack.t b/t/op/pack.t
|
||||||
|
index a480c3a..cf5ae78 100644
|
||||||
|
--- a/t/op/pack.t
|
||||||
|
+++ b/t/op/pack.t
|
||||||
|
@@ -12,7 +12,7 @@ my $no_endianness = $] > 5.009 ? '' :
|
||||||
|
my $no_signedness = $] > 5.009 ? '' :
|
||||||
|
"Signed/unsigned pack modifiers not available on this perl";
|
||||||
|
|
||||||
|
-plan tests => 14716;
|
||||||
|
+plan tests => 14717;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings qw(FATAL all);
|
||||||
|
@@ -2066,3 +2066,14 @@ SKIP:
|
||||||
|
fresh_perl_like('pack "c10f1073741824"', qr/Out of memory during pack/, { stderr => 1 },
|
||||||
|
"integer overflow calculating allocation (multiply)");
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+{
|
||||||
|
+ # [perl #129149] the code below would write one past the end of the output
|
||||||
|
+ # buffer, only detected by ASAN, not by valgrind
|
||||||
|
+ $Config{ivsize} >= 8
|
||||||
|
+ or skip "[perl #129149] need 64-bit for this test", 1;
|
||||||
|
+ fresh_perl_is(<<'EOS', "ok\n", { stderr => 1 }, "pack W overflow");
|
||||||
|
+print pack("ucW", "0000", 0, 140737488355327) eq "\$,#`P,```\n\0\x{7fffffffffff}"
|
||||||
|
+ ? "ok\n" : "not ok\n";
|
||||||
|
+EOS
|
||||||
|
+}
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
@ -0,0 +1,37 @@
|
|||||||
|
From 308112b17f3d093c11cc25408a421c86364de828 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Tue, 17 Jan 2017 15:36:31 +1100
|
||||||
|
Subject: [PATCH] (perl #129149) fix the test so skip has a SKIP: to work with
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Thanks to bulk88 for pointing this out.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.24.4 from:
|
||||||
|
|
||||||
|
From 30be69c851a7fa7e29d85c9b6e070273df82f3e7 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Tue, 17 Jan 2017 15:36:31 +1100
|
||||||
|
Subject: [PATCH] (perl #129149) fix the test so skip has a SKIP: to work with
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/op/pack.t | 1 +
|
||||||
|
1 file changed, 1 insertion(+)
|
||||||
|
|
||||||
|
diff --git a/t/op/pack.t b/t/op/pack.t
|
||||||
|
index cf5ae78..e399f7e 100644
|
||||||
|
--- a/t/op/pack.t
|
||||||
|
+++ b/t/op/pack.t
|
||||||
|
@@ -2067,6 +2067,7 @@ SKIP:
|
||||||
|
"integer overflow calculating allocation (multiply)");
|
||||||
|
}
|
||||||
|
|
||||||
|
+SKIP:
|
||||||
|
{
|
||||||
|
# [perl #129149] the code below would write one past the end of the output
|
||||||
|
# buffer, only detected by ASAN, not by valgrind
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
@ -0,0 +1,56 @@
|
|||||||
|
From f34cc5af94622240abbf730ac82c4f91cc4ffb83 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Tue, 4 Oct 2016 14:40:11 +0100
|
||||||
|
Subject: [PATCH] anchored/floating substrings must be utf8 if target is
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.24.4:
|
||||||
|
|
||||||
|
commit 2814f4b3549f665a6f9203ac9e890ae1e415e0dc
|
||||||
|
Author: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Tue Oct 4 14:40:11 2016 +0100
|
||||||
|
|
||||||
|
[perl #129350] anchored/floating substrings must be utf8 if target is
|
||||||
|
|
||||||
|
If the target is utf8 and either the anchored or floating substrings
|
||||||
|
are not, we need to create utf8 copies to check against. The state
|
||||||
|
of the two substrings may not be the same, but we were only testing
|
||||||
|
whichever we planned to check first.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regexec.c | 3 ++-
|
||||||
|
t/re/re_tests | 1 +
|
||||||
|
2 files changed, 3 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/regexec.c b/regexec.c
|
||||||
|
index ff8e89c..6904546 100644
|
||||||
|
--- a/regexec.c
|
||||||
|
+++ b/regexec.c
|
||||||
|
@@ -703,7 +703,8 @@ Perl_re_intuit_start(pTHX_
|
||||||
|
reginfo->poscache_maxiter = 0;
|
||||||
|
|
||||||
|
if (utf8_target) {
|
||||||
|
- if (!prog->check_utf8 && prog->check_substr)
|
||||||
|
+ if ((!prog->anchored_utf8 && prog->anchored_substr)
|
||||||
|
+ || (!prog->float_utf8 && prog->float_substr))
|
||||||
|
to_utf8_substr(prog);
|
||||||
|
check = prog->check_utf8;
|
||||||
|
} else {
|
||||||
|
diff --git a/t/re/re_tests b/t/re/re_tests
|
||||||
|
index ab7ddbb..8b0feaa 100644
|
||||||
|
--- a/t/re/re_tests
|
||||||
|
+++ b/t/re/re_tests
|
||||||
|
@@ -1969,6 +1969,7 @@ ab(?#Comment){2}c abbc y $& abbc
|
||||||
|
aa$|a(?R)a|a aaa y $& aaa # [perl 128420] recursive matches
|
||||||
|
(?:\1|a)([bcd])\1(?:(?R)|e)\1 abbaccaddedcb y $& abbaccaddedcb # [perl 128420] recursive match with backreferences
|
||||||
|
(?il)\x{100}|\x{100}|\x{FF} \xFF y $& \xFF
|
||||||
|
+\b\z0*\x{100} .\x{100} n - - # [perl #129350] crashed in intuit_start
|
||||||
|
|
||||||
|
# Keep these lines at the end of the file
|
||||||
|
# vim: softtabstop=0 noexpandtab
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
@ -0,0 +1,53 @@
|
|||||||
|
From 7ec44a7b6adbc0221150969fc61134322fd5ed85 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Mon, 12 Dec 2016 15:15:06 +0000
|
||||||
|
Subject: [PATCH] Correctly unwind on cache hit
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Petr Pisar: Ported to 5.24.4:
|
||||||
|
|
||||||
|
commit d3c48e81594c1d64ba9833495e45d8951b42027c
|
||||||
|
Author: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Mon Dec 12 15:15:06 2016 +0000
|
||||||
|
|
||||||
|
[perl #130307] Correctly unwind on cache hit
|
||||||
|
|
||||||
|
We've already incremented curlyx.count in the WHILEM branch before
|
||||||
|
we check for a hit in the super-linear cache, so must reverse that
|
||||||
|
on the sayNO.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regexec.c | 1 +
|
||||||
|
t/re/re_tests | 1 +
|
||||||
|
2 files changed, 2 insertions(+)
|
||||||
|
|
||||||
|
diff --git a/regexec.c b/regexec.c
|
||||||
|
index 6904546..25ea3a3 100644
|
||||||
|
--- a/regexec.c
|
||||||
|
+++ b/regexec.c
|
||||||
|
@@ -7334,6 +7334,7 @@ NULL
|
||||||
|
DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: (cache) already tried at this position...\n",
|
||||||
|
depth)
|
||||||
|
);
|
||||||
|
+ cur_curlyx->u.curlyx.count--;
|
||||||
|
sayNO; /* cache records failure */
|
||||||
|
}
|
||||||
|
ST.cache_offset = offset;
|
||||||
|
diff --git a/t/re/re_tests b/t/re/re_tests
|
||||||
|
index 8b0feaa..6717b85 100644
|
||||||
|
--- a/t/re/re_tests
|
||||||
|
+++ b/t/re/re_tests
|
||||||
|
@@ -1970,6 +1970,7 @@ aa$|a(?R)a|a aaa y $& aaa # [perl 128420] recursive matches
|
||||||
|
(?:\1|a)([bcd])\1(?:(?R)|e)\1 abbaccaddedcb y $& abbaccaddedcb # [perl 128420] recursive match with backreferences
|
||||||
|
(?il)\x{100}|\x{100}|\x{FF} \xFF y $& \xFF
|
||||||
|
\b\z0*\x{100} .\x{100} n - - # [perl #129350] crashed in intuit_start
|
||||||
|
+(X{2,}[-X]{1,4}){3,}X{2,} XXX-XXX-XXX-- n - - # [perl #130307]
|
||||||
|
|
||||||
|
# Keep these lines at the end of the file
|
||||||
|
# vim: softtabstop=0 noexpandtab
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
44
SOURCES/perl-5.25.10-fix-VMS-test-fail.patch
Normal file
44
SOURCES/perl-5.25.10-fix-VMS-test-fail.patch
Normal file
@ -0,0 +1,44 @@
|
|||||||
|
From bce4a2abeb8652d19e97d3bf07dd2580a3cc2e6c Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Sat, 25 Feb 2017 10:42:17 +0000
|
||||||
|
Subject: [PATCH] fix VMS test fail
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
d7186add added a runperl() test that breaks command line length limits for
|
||||||
|
VMS. Switch to fresh_perl() instead, so the prog is put in a file for us.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/comp/parser_run.t | 12 ++++++------
|
||||||
|
1 file changed, 6 insertions(+), 6 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/comp/parser_run.t b/t/comp/parser_run.t
|
||||||
|
index 2543f49..e74644d 100644
|
||||||
|
--- a/t/comp/parser_run.t
|
||||||
|
+++ b/t/comp/parser_run.t
|
||||||
|
@@ -14,14 +14,14 @@ plan(1);
|
||||||
|
|
||||||
|
# [perl #130814] can reallocate lineptr while looking ahead for
|
||||||
|
# "Missing $ on loop variable" diagnostic.
|
||||||
|
-my $result = runperl(
|
||||||
|
- prog => " foreach m0\n\$" . ("0" x 0x2000),
|
||||||
|
- stderr => 1,
|
||||||
|
+my $result = fresh_perl(
|
||||||
|
+ " foreach m0\n\$" . ("0" x 0x2000),
|
||||||
|
+ { stderr => 1 },
|
||||||
|
);
|
||||||
|
-is($result, <<EXPECT);
|
||||||
|
-syntax error at -e line 3, near "foreach m0
|
||||||
|
+is($result . "\n", <<EXPECT);
|
||||||
|
+syntax error at - line 3, near "foreach m0
|
||||||
|
"
|
||||||
|
-Identifier too long at -e line 3.
|
||||||
|
+Identifier too long at - line 3.
|
||||||
|
EXPECT
|
||||||
|
|
||||||
|
__END__
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,55 @@
|
|||||||
|
From d7186addd1b477f6bdcef5e9d24f2125691a9082 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Sun, 19 Feb 2017 11:15:38 +0000
|
||||||
|
Subject: [PATCH] [perl #130814] Add testcase, and new testfile
|
||||||
|
t/comp/parser_run.t
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Sometimes it's useful to have test.pl around, but it seems inappropriate
|
||||||
|
to pollute the existing t/comp/parser.t with that.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/comp/parser_run.t | 28 ++++++++++++++++++++++++++++
|
||||||
|
1 file changed, 28 insertions(+)
|
||||||
|
create mode 100644 t/comp/parser_run.t
|
||||||
|
|
||||||
|
diff --git a/t/comp/parser_run.t b/t/comp/parser_run.t
|
||||||
|
new file mode 100644
|
||||||
|
index 0000000..2543f49
|
||||||
|
--- /dev/null
|
||||||
|
+++ b/t/comp/parser_run.t
|
||||||
|
@@ -0,0 +1,28 @@
|
||||||
|
+#!./perl
|
||||||
|
+
|
||||||
|
+# Parser tests that want test.pl, eg to use runperl() for tests to show
|
||||||
|
+# reads through invalid pointers.
|
||||||
|
+# Note that this should still be runnable under miniperl.
|
||||||
|
+
|
||||||
|
+BEGIN {
|
||||||
|
+ @INC = qw(. ../lib );
|
||||||
|
+ chdir 't' if -d 't';
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+require './test.pl';
|
||||||
|
+plan(1);
|
||||||
|
+
|
||||||
|
+# [perl #130814] can reallocate lineptr while looking ahead for
|
||||||
|
+# "Missing $ on loop variable" diagnostic.
|
||||||
|
+my $result = runperl(
|
||||||
|
+ prog => " foreach m0\n\$" . ("0" x 0x2000),
|
||||||
|
+ stderr => 1,
|
||||||
|
+);
|
||||||
|
+is($result, <<EXPECT);
|
||||||
|
+syntax error at -e line 3, near "foreach m0
|
||||||
|
+"
|
||||||
|
+Identifier too long at -e line 3.
|
||||||
|
+EXPECT
|
||||||
|
+
|
||||||
|
+__END__
|
||||||
|
+# ex: set ts=8 sts=4 sw=4 et:
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,76 @@
|
|||||||
|
From fc0fe26a7d286480c1bb25f57e469ece575bb68d Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Thu, 7 Jul 2016 17:03:29 +0100
|
||||||
|
Subject: [PATCH] SEGV in "Subroutine redefined" warning
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
RT #128257
|
||||||
|
|
||||||
|
The following SEGVed:
|
||||||
|
|
||||||
|
sub P::f{}
|
||||||
|
undef *P::;
|
||||||
|
*P::f =sub{};
|
||||||
|
|
||||||
|
due to the code which generates the "Subroutine STASH::NAME redefined"
|
||||||
|
warning assuming that the GV always has a stash. Make it so that if it
|
||||||
|
hasn't, the message changes to "Subroutine NAME redefined" rather than
|
||||||
|
just crashing.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
sv.c | 18 +++++++++++-------
|
||||||
|
t/lib/warnings/sv | 8 ++++++++
|
||||||
|
2 files changed, 19 insertions(+), 7 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/sv.c b/sv.c
|
||||||
|
index 1b7a283..0cbe371 100644
|
||||||
|
--- a/sv.c
|
||||||
|
+++ b/sv.c
|
||||||
|
@@ -4074,14 +4074,18 @@ Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
|
||||||
|
CvCONST((const CV *)sref)
|
||||||
|
? cv_const_sv((const CV *)sref)
|
||||||
|
: NULL;
|
||||||
|
+ HV * const stash = GvSTASH((const GV *)dstr);
|
||||||
|
report_redefined_cv(
|
||||||
|
- sv_2mortal(Perl_newSVpvf(aTHX_
|
||||||
|
- "%"HEKf"::%"HEKf,
|
||||||
|
- HEKfARG(
|
||||||
|
- HvNAME_HEK(GvSTASH((const GV *)dstr))
|
||||||
|
- ),
|
||||||
|
- HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
|
||||||
|
- )),
|
||||||
|
+ sv_2mortal(
|
||||||
|
+ stash
|
||||||
|
+ ? Perl_newSVpvf(aTHX_
|
||||||
|
+ "%"HEKf"::%"HEKf,
|
||||||
|
+ HEKfARG(HvNAME_HEK(stash)),
|
||||||
|
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
|
||||||
|
+ : Perl_newSVpvf(aTHX_
|
||||||
|
+ "%"HEKf,
|
||||||
|
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
|
||||||
|
+ ),
|
||||||
|
cv,
|
||||||
|
CvCONST((const CV *)sref) ? &new_const_sv : NULL
|
||||||
|
);
|
||||||
|
diff --git a/t/lib/warnings/sv b/t/lib/warnings/sv
|
||||||
|
index 5ddd4fe..c8e0e62 100644
|
||||||
|
--- a/t/lib/warnings/sv
|
||||||
|
+++ b/t/lib/warnings/sv
|
||||||
|
@@ -413,3 +413,11 @@ Argument "a_c" isn't numeric in preincrement (++) at - line 5.
|
||||||
|
Argument "(?^:abc)" isn't numeric in preincrement (++) at - line 6.
|
||||||
|
Argument "123x" isn't numeric in preincrement (++) at - line 7.
|
||||||
|
Argument "123e" isn't numeric in preincrement (++) at - line 8.
|
||||||
|
+########
|
||||||
|
+# RT #128257 This used to SEGV
|
||||||
|
+use warnings;
|
||||||
|
+sub Foo::f {}
|
||||||
|
+undef *Foo::;
|
||||||
|
+*Foo::f =sub {};
|
||||||
|
+EXPECT
|
||||||
|
+Subroutine f redefined at - line 5.
|
||||||
|
--
|
||||||
|
2.5.5
|
||||||
|
|
@ -0,0 +1,64 @@
|
|||||||
|
From e7acdfe976f01ee0d1ba31b3b1db61454a72d6c9 Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Tue, 21 Jun 2016 17:06:52 +0100
|
||||||
|
Subject: [PATCH] only treat stash entries with .*:: as sub-stashes
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
RT #128238
|
||||||
|
|
||||||
|
%: = 0 would cause an assertion failure in Perl_gv_check(), since when
|
||||||
|
it searched a stash for substashes, it assumed anything ending in ':' was
|
||||||
|
a substash, whereas substashes end in '::'. So check for a double colon
|
||||||
|
before recursing.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
gv.c | 5 ++++-
|
||||||
|
t/op/stash.t | 9 ++++++++-
|
||||||
|
2 files changed, 12 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/gv.c b/gv.c
|
||||||
|
index 4df3bce..2b3bdfa 100644
|
||||||
|
--- a/gv.c
|
||||||
|
+++ b/gv.c
|
||||||
|
@@ -2423,7 +2423,10 @@ Perl_gv_check(pTHX_ HV *stash)
|
||||||
|
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
|
||||||
|
GV *gv;
|
||||||
|
HV *hv;
|
||||||
|
- if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
|
||||||
|
+ STRLEN keylen = HeKLEN(entry);
|
||||||
|
+ const char * const key = HeKEY(entry);
|
||||||
|
+
|
||||||
|
+ if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' &&
|
||||||
|
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
|
||||||
|
{
|
||||||
|
if (hv != PL_defstash && hv != stash
|
||||||
|
diff --git a/t/op/stash.t b/t/op/stash.t
|
||||||
|
index b8e0f34..ec795a9 100644
|
||||||
|
--- a/t/op/stash.t
|
||||||
|
+++ b/t/op/stash.t
|
||||||
|
@@ -7,7 +7,7 @@ BEGIN {
|
||||||
|
|
||||||
|
BEGIN { require "./test.pl"; }
|
||||||
|
|
||||||
|
-plan( tests => 52 );
|
||||||
|
+plan( tests => 53 );
|
||||||
|
|
||||||
|
# Used to segfault (bug #15479)
|
||||||
|
fresh_perl_like(
|
||||||
|
@@ -341,3 +341,10 @@ is runperl(
|
||||||
|
),
|
||||||
|
"ok\n",
|
||||||
|
'[perl #128086] no crash from assigning hash to *:::::: & deleting it';
|
||||||
|
+
|
||||||
|
+is runperl(
|
||||||
|
+ prog => 'BEGIN { %: = 0; $^W=1}; print qq|ok\n|',
|
||||||
|
+ stderr => 1,
|
||||||
|
+ ),
|
||||||
|
+ "ok\n",
|
||||||
|
+ "[perl #128238] don't treat %: as a stash (needs 2 colons)"
|
||||||
|
--
|
||||||
|
2.5.5
|
||||||
|
|
@ -0,0 +1,66 @@
|
|||||||
|
From 9e5cda6b852ca831004628051cf32c1576146452 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Thu, 23 Jun 2016 21:57:09 -0700
|
||||||
|
Subject: [PATCH] [perl #128238] Crash with non-stash in stash
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This is a follow-up to e7acdfe976f. Even if the name of the stash
|
||||||
|
entry ends with ::, it may not itself contain a real stash (though
|
||||||
|
this only happens with code that assigns directly to stash entries,
|
||||||
|
which has undefined behaviour according to perlmod), so skip hashes
|
||||||
|
that are not stashes.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
gv.c | 4 ++--
|
||||||
|
t/op/stash.t | 11 +++++++++--
|
||||||
|
2 files changed, 11 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/gv.c b/gv.c
|
||||||
|
index 2b3bdfa..dff611e 100644
|
||||||
|
--- a/gv.c
|
||||||
|
+++ b/gv.c
|
||||||
|
@@ -2411,10 +2411,10 @@ Perl_gv_check(pTHX_ HV *stash)
|
||||||
|
|
||||||
|
PERL_ARGS_ASSERT_GV_CHECK;
|
||||||
|
|
||||||
|
- if (!HvARRAY(stash))
|
||||||
|
+ if (!SvOOK(stash))
|
||||||
|
return;
|
||||||
|
|
||||||
|
- assert(SvOOK(stash));
|
||||||
|
+ assert(HvARRAY(stash));
|
||||||
|
|
||||||
|
for (i = 0; i <= (I32) HvMAX(stash); i++) {
|
||||||
|
const HE *entry;
|
||||||
|
diff --git a/t/op/stash.t b/t/op/stash.t
|
||||||
|
index 1591dbf..fe42700 100644
|
||||||
|
--- a/t/op/stash.t
|
||||||
|
+++ b/t/op/stash.t
|
||||||
|
@@ -7,7 +7,7 @@ BEGIN {
|
||||||
|
|
||||||
|
BEGIN { require "./test.pl"; }
|
||||||
|
|
||||||
|
-plan( tests => 53 );
|
||||||
|
+plan( tests => 54 );
|
||||||
|
|
||||||
|
# Used to segfault (bug #15479)
|
||||||
|
fresh_perl_like(
|
||||||
|
@@ -342,4 +342,11 @@ is runperl(
|
||||||
|
stderr => 1,
|
||||||
|
),
|
||||||
|
"ok\n",
|
||||||
|
- "[perl #128238] don't treat %: as a stash (needs 2 colons)"
|
||||||
|
+ "[perl #128238] don't treat %: as a stash (needs 2 colons)";
|
||||||
|
+
|
||||||
|
+is runperl(
|
||||||
|
+ prog => 'BEGIN { $::{q|foo::|}=*ENV; $^W=1}; print qq|ok\n|',
|
||||||
|
+ stderr => 1,
|
||||||
|
+ ),
|
||||||
|
+ "ok\n",
|
||||||
|
+ "[perl #128238] non-stashes in stashes";
|
||||||
|
--
|
||||||
|
2.5.5
|
||||||
|
|
@ -0,0 +1,60 @@
|
|||||||
|
From 63aab7ecaa6e826f845c405894bd8c4b6f601b39 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Sun, 3 Jul 2016 22:23:34 -0700
|
||||||
|
Subject: [PATCH] [perl #128532] Crash vivifying stub in deleted pkg
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
v5.17.0-515-g186a5ba, which added newSTUB, did not take into account
|
||||||
|
that a GV may have a null GvSTASH pointer, if its stash has been
|
||||||
|
freed, so this crashes:
|
||||||
|
|
||||||
|
delete $My::{"Foo::"}; \&My::Foo::foo
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
op.c | 2 +-
|
||||||
|
t/op/ref.t | 6 +++++-
|
||||||
|
2 files changed, 6 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/op.c b/op.c
|
||||||
|
index 46e76ac..4735d1b 100644
|
||||||
|
--- a/op.c
|
||||||
|
+++ b/op.c
|
||||||
|
@@ -9081,7 +9081,7 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake)
|
||||||
|
assert(!GvCVu(gv));
|
||||||
|
GvCV_set(gv, cv);
|
||||||
|
GvCVGEN(gv) = 0;
|
||||||
|
- if (!fake && HvENAME_HEK(GvSTASH(gv)))
|
||||||
|
+ if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
|
||||||
|
gv_method_changed(gv);
|
||||||
|
if (SvFAKE(gv)) {
|
||||||
|
cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
|
||||||
|
diff --git a/t/op/ref.t b/t/op/ref.t
|
||||||
|
index 19a44bb..84d9217 100644
|
||||||
|
--- a/t/op/ref.t
|
||||||
|
+++ b/t/op/ref.t
|
||||||
|
@@ -8,7 +8,7 @@ BEGIN {
|
||||||
|
|
||||||
|
use strict qw(refs subs);
|
||||||
|
|
||||||
|
-plan(235);
|
||||||
|
+plan(236);
|
||||||
|
|
||||||
|
# Test this first before we extend the stack with other operations.
|
||||||
|
# This caused an asan failure due to a bad write past the end of the stack.
|
||||||
|
@@ -124,6 +124,10 @@ is (join(':',@{$spring2{"foo"}}), "1:2:3:4");
|
||||||
|
is ($called, 1);
|
||||||
|
}
|
||||||
|
is ref eval {\&{""}}, "CODE", 'reference to &{""} [perl #94476]';
|
||||||
|
+delete $My::{"Foo::"};
|
||||||
|
+is ref \&My::Foo::foo, "CODE",
|
||||||
|
+ 'creating stub with \&deleted_stash::foo [perl #128532]';
|
||||||
|
+
|
||||||
|
|
||||||
|
# Test references to return values of operators (TARGs/PADTMPs)
|
||||||
|
{
|
||||||
|
--
|
||||||
|
2.5.5
|
||||||
|
|
74
SOURCES/perl-5.25.2-t-test.pl-Add-fresh_perl-function.patch
Normal file
74
SOURCES/perl-5.25.2-t-test.pl-Add-fresh_perl-function.patch
Normal file
@ -0,0 +1,74 @@
|
|||||||
|
From f6203e997f3012b8aab4cd35fe49f58e4d71fb8c Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Sun, 10 Jul 2016 22:06:12 -0600
|
||||||
|
Subject: [PATCH] t/test.pl: Add fresh_perl() function
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This will be useful for cases where the results don't readily fall into
|
||||||
|
fresh_perl_is and fresh_perl_like, such as when a bunch of massaging of
|
||||||
|
the results is needed before it is convenient to test them.
|
||||||
|
fresh_perl_like() could be used, but in the case of failure there could
|
||||||
|
be lines and lines of noise output.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/test.pl | 25 +++++++++++++++++++++----
|
||||||
|
1 file changed, 21 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/test.pl b/t/test.pl
|
||||||
|
index 41b77f4..20d08e9 100644
|
||||||
|
--- a/t/test.pl
|
||||||
|
+++ b/t/test.pl
|
||||||
|
@@ -953,11 +953,16 @@ sub register_tempfile {
|
||||||
|
return $count;
|
||||||
|
}
|
||||||
|
|
||||||
|
-# This is the temporary file for _fresh_perl
|
||||||
|
+# This is the temporary file for fresh_perl
|
||||||
|
my $tmpfile = tempfile();
|
||||||
|
|
||||||
|
-sub _fresh_perl {
|
||||||
|
- my($prog, $action, $expect, $runperl_args, $name) = @_;
|
||||||
|
+sub fresh_perl {
|
||||||
|
+ my($prog, $runperl_args) = @_;
|
||||||
|
+
|
||||||
|
+ # Run 'runperl' with the complete perl program contained in '$prog', and
|
||||||
|
+ # arguments in the hash referred to by '$runperl_args'. The results are
|
||||||
|
+ # returned, with $? set to the exit code. Unless overridden, stderr is
|
||||||
|
+ # redirected to stdout.
|
||||||
|
|
||||||
|
# Given the choice of the mis-parsable {}
|
||||||
|
# (we want an anon hash, but a borked lexer might think that it's a block)
|
||||||
|
@@ -975,7 +980,8 @@ sub _fresh_perl {
|
||||||
|
close TEST or die "Cannot close $tmpfile: $!";
|
||||||
|
|
||||||
|
my $results = runperl(%$runperl_args);
|
||||||
|
- my $status = $?;
|
||||||
|
+ my $status = $?; # Not necessary to save this, but it makes it clear to
|
||||||
|
+ # future maintainers.
|
||||||
|
|
||||||
|
# Clean up the results into something a bit more predictable.
|
||||||
|
$results =~ s/\n+$//;
|
||||||
|
@@ -994,6 +1000,17 @@ sub _fresh_perl {
|
||||||
|
$results =~ s/\n\n/\n/g;
|
||||||
|
}
|
||||||
|
|
||||||
|
+ $? = $status;
|
||||||
|
+ return $results;
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+
|
||||||
|
+sub _fresh_perl {
|
||||||
|
+ my($prog, $action, $expect, $runperl_args, $name) = @_;
|
||||||
|
+
|
||||||
|
+ my $results = fresh_perl($prog, $runperl_args);
|
||||||
|
+ my $status = $?;
|
||||||
|
+
|
||||||
|
# Use the first line of the program as a name if none was given
|
||||||
|
unless( $name ) {
|
||||||
|
($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,74 @@
|
|||||||
|
From 55b6481ff87f84626ba01275708297a42a6537b1 Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Tue, 21 Jun 2016 15:23:20 +0100
|
||||||
|
Subject: [PATCH] uninit warning from $h{\const} coredumped
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
The code that printed the the name and subscript of a hash element
|
||||||
|
in an "uninitialized variable" warning assumed that a constant
|
||||||
|
hash subscript would be SvPOK. Something like \1 is a constant,
|
||||||
|
but is ROK, not POK. SEGVs ensured.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
sv.c | 5 ++++-
|
||||||
|
t/op/hashwarn.t | 19 ++++++++++++++++++-
|
||||||
|
2 files changed, 22 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/sv.c b/sv.c
|
||||||
|
index 535ee8d..b0fdd15 100644
|
||||||
|
--- a/sv.c
|
||||||
|
+++ b/sv.c
|
||||||
|
@@ -15683,9 +15683,12 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
|
||||||
|
|
||||||
|
if (subscript_type == FUV_SUBSCRIPT_HASH) {
|
||||||
|
SV * const sv = newSV(0);
|
||||||
|
+ STRLEN len;
|
||||||
|
+ const char * const pv = SvPV_nomg_const((SV*)keyname, len);
|
||||||
|
+
|
||||||
|
*SvPVX(name) = '$';
|
||||||
|
Perl_sv_catpvf(aTHX_ name, "{%s}",
|
||||||
|
- pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
|
||||||
|
+ pv_pretty(sv, pv, len, 32, NULL, NULL,
|
||||||
|
PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
|
||||||
|
SvREFCNT_dec_NN(sv);
|
||||||
|
}
|
||||||
|
diff --git a/t/op/hashwarn.t b/t/op/hashwarn.t
|
||||||
|
index a6a1de9..6d72244 100644
|
||||||
|
--- a/t/op/hashwarn.t
|
||||||
|
+++ b/t/op/hashwarn.t
|
||||||
|
@@ -6,7 +6,7 @@ BEGIN {
|
||||||
|
}
|
||||||
|
|
||||||
|
require './test.pl';
|
||||||
|
-plan( tests => 16 );
|
||||||
|
+plan( tests => 18 );
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
@@ -71,3 +71,20 @@ my $fail_not_hr = 'Not a HASH reference at ';
|
||||||
|
cmp_ok(scalar(@warnings),'==',0,'pseudo-hash 2 count');
|
||||||
|
cmp_ok(substr($@,0,length($fail_not_hr)),'eq',$fail_not_hr,'pseudo-hash 2 msg');
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+# RT #128189
|
||||||
|
+# this used to coredump
|
||||||
|
+
|
||||||
|
+{
|
||||||
|
+ @warnings = ();
|
||||||
|
+ my %h;
|
||||||
|
+
|
||||||
|
+ no warnings;
|
||||||
|
+ use warnings qw(uninitialized);
|
||||||
|
+
|
||||||
|
+ my $x = "$h{\1}";
|
||||||
|
+ is(scalar @warnings, 1, "RT #128189 - 1 warning");
|
||||||
|
+ like("@warnings",
|
||||||
|
+ qr/Use of uninitialized value \$h\{"SCALAR\(0x[\da-f]+\)"\}/,
|
||||||
|
+ "RT #128189 correct warning");
|
||||||
|
+}
|
||||||
|
--
|
||||||
|
2.5.5
|
||||||
|
|
@ -0,0 +1,32 @@
|
|||||||
|
From d5ea0ef8623c7d7ba5f42d239787aa71393e2054 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 13 Sep 2016 23:06:58 +0200
|
||||||
|
Subject: [PATCH 2/5] clean up gv_fetchmethod_pvn_flags: move origname init to
|
||||||
|
function start
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
so it is more obvious that it is a constant copy of the
|
||||||
|
original name.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
gv.c | 1 -
|
||||||
|
1 file changed, 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/gv.c b/gv.c
|
||||||
|
index b0221e0..fe38d44 100644
|
||||||
|
--- a/gv.c
|
||||||
|
+++ b/gv.c
|
||||||
|
@@ -1014,7 +1014,6 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
const char *nsplit = NULL;
|
||||||
|
GV* gv;
|
||||||
|
HV* ostash = stash;
|
||||||
|
- const char * const origname = name;
|
||||||
|
SV *const error_report = MUTABLE_SV(stash);
|
||||||
|
const U32 autoload = flags & GV_AUTOLOAD;
|
||||||
|
const U32 do_croak = flags & GV_CROAK;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,92 @@
|
|||||||
|
From e2cace1e9e89525afbca257742ddb36630b7fbc3 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 13 Sep 2016 23:10:48 +0200
|
||||||
|
Subject: [PATCH 3/5] clean up gv_fetchmethod_pvn_flags: rename nsplit to
|
||||||
|
last_separator
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
nsplit if set points at the first char of the last separator
|
||||||
|
in name, so rename it so it is more comprehensible what it means.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
gv.c | 24 ++++++++++++------------
|
||||||
|
1 file changed, 12 insertions(+), 12 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/gv.c b/gv.c
|
||||||
|
index fe38d44..07709a0 100644
|
||||||
|
--- a/gv.c
|
||||||
|
+++ b/gv.c
|
||||||
|
@@ -1011,7 +1011,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
const char * const origname = name;
|
||||||
|
const char * const name_end = name + len;
|
||||||
|
const char *nend;
|
||||||
|
- const char *nsplit = NULL;
|
||||||
|
+ const char *last_separator = NULL;
|
||||||
|
GV* gv;
|
||||||
|
HV* ostash = stash;
|
||||||
|
SV *const error_report = MUTABLE_SV(stash);
|
||||||
|
@@ -1024,38 +1024,38 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
if (SvTYPE(stash) < SVt_PVHV)
|
||||||
|
stash = NULL;
|
||||||
|
else {
|
||||||
|
- /* The only way stash can become NULL later on is if nsplit is set,
|
||||||
|
+ /* The only way stash can become NULL later on is if last_separator is set,
|
||||||
|
which in turn means that there is no need for a SVt_PVHV case
|
||||||
|
the error reporting code. */
|
||||||
|
}
|
||||||
|
|
||||||
|
for (nend = name; *nend || nend != name_end; nend++) {
|
||||||
|
if (*nend == '\'') {
|
||||||
|
- nsplit = nend;
|
||||||
|
+ last_separator = nend;
|
||||||
|
name = nend + 1;
|
||||||
|
}
|
||||||
|
else if (*nend == ':' && *(nend + 1) == ':') {
|
||||||
|
- nsplit = nend++;
|
||||||
|
+ last_separator = nend++;
|
||||||
|
name = nend + 1;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
- if (nsplit) {
|
||||||
|
- if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
|
||||||
|
+ if (last_separator) {
|
||||||
|
+ if ((last_separator - origname) == 5 && memEQ(origname, "SUPER", 5)) {
|
||||||
|
/* ->SUPER::method should really be looked up in original stash */
|
||||||
|
stash = CopSTASH(PL_curcop);
|
||||||
|
flags |= GV_SUPER;
|
||||||
|
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
|
||||||
|
origname, HvENAME_get(stash), name) );
|
||||||
|
}
|
||||||
|
- else if ((nsplit - origname) >= 7 &&
|
||||||
|
- strnEQ(nsplit - 7, "::SUPER", 7)) {
|
||||||
|
+ else if ((last_separator - origname) >= 7 &&
|
||||||
|
+ strnEQ(last_separator - 7, "::SUPER", 7)) {
|
||||||
|
/* don't autovifify if ->NoSuchStash::SUPER::method */
|
||||||
|
- stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
|
||||||
|
+ stash = gv_stashpvn(origname, last_separator - origname - 7, is_utf8);
|
||||||
|
if (stash) flags |= GV_SUPER;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
/* don't autovifify if ->NoSuchStash::method */
|
||||||
|
- stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
|
||||||
|
+ stash = gv_stashpvn(origname, last_separator - origname, is_utf8);
|
||||||
|
}
|
||||||
|
ostash = stash;
|
||||||
|
}
|
||||||
|
@@ -1098,8 +1098,8 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
else {
|
||||||
|
SV* packnamesv;
|
||||||
|
|
||||||
|
- if (nsplit) {
|
||||||
|
- packnamesv = newSVpvn_flags(origname, nsplit - origname,
|
||||||
|
+ if (last_separator) {
|
||||||
|
+ packnamesv = newSVpvn_flags(origname, last_separator - origname,
|
||||||
|
SVs_TEMP | is_utf8);
|
||||||
|
} else {
|
||||||
|
packnamesv = error_report;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,81 @@
|
|||||||
|
From cfb736762c1becf344ce6beaa701ff2e1abd5f9c Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 13 Sep 2016 23:14:49 +0200
|
||||||
|
Subject: [PATCH 4/5] fix #129267: rework gv_fetchmethod_pvn_flags separator
|
||||||
|
parsing
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
With previous code we could overrun the end of the name when
|
||||||
|
the last char in the string was a colon. This reworks the code
|
||||||
|
so it is more clear what is going on, and so it more similar
|
||||||
|
to other code that also parses out package separaters in gv.c.
|
||||||
|
|
||||||
|
This is a rework of the reverted patches:
|
||||||
|
243ca72 rename "nend" name_cursor in Perl_gv_fetchmethod_pvn_flags
|
||||||
|
b053c93 fix: [perl #129267] Possible string overrun with invalid len in gv.c
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
gv.c | 36 ++++++++++++++++++++++++++----------
|
||||||
|
1 file changed, 26 insertions(+), 10 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/gv.c b/gv.c
|
||||||
|
index 07709a0..3237c53 100644
|
||||||
|
--- a/gv.c
|
||||||
|
+++ b/gv.c
|
||||||
|
@@ -1010,7 +1010,6 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
{
|
||||||
|
const char * const origname = name;
|
||||||
|
const char * const name_end = name + len;
|
||||||
|
- const char *nend;
|
||||||
|
const char *last_separator = NULL;
|
||||||
|
GV* gv;
|
||||||
|
HV* ostash = stash;
|
||||||
|
@@ -1029,16 +1028,33 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
|
||||||
|
the error reporting code. */
|
||||||
|
}
|
||||||
|
|
||||||
|
- for (nend = name; *nend || nend != name_end; nend++) {
|
||||||
|
- if (*nend == '\'') {
|
||||||
|
- last_separator = nend;
|
||||||
|
- name = nend + 1;
|
||||||
|
- }
|
||||||
|
- else if (*nend == ':' && *(nend + 1) == ':') {
|
||||||
|
- last_separator = nend++;
|
||||||
|
- name = nend + 1;
|
||||||
|
- }
|
||||||
|
+ {
|
||||||
|
+ /* check if the method name is fully qualified or
|
||||||
|
+ * not, and separate the package name from the actual
|
||||||
|
+ * method name.
|
||||||
|
+ *
|
||||||
|
+ * leaves last_separator pointing to the beginning of the
|
||||||
|
+ * last package separator (either ' or ::) or 0
|
||||||
|
+ * if none was found.
|
||||||
|
+ *
|
||||||
|
+ * leaves name pointing at the beginning of the
|
||||||
|
+ * method name.
|
||||||
|
+ */
|
||||||
|
+ const char *name_cursor = name;
|
||||||
|
+ const char * const name_em1 = name_end - 1; /* name_end minus 1 */
|
||||||
|
+ for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
|
||||||
|
+ if (*name_cursor == '\'') {
|
||||||
|
+ last_separator = name_cursor;
|
||||||
|
+ name = name_cursor + 1;
|
||||||
|
+ }
|
||||||
|
+ else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
|
||||||
|
+ last_separator = name_cursor++;
|
||||||
|
+ name = name_cursor + 1;
|
||||||
|
+ }
|
||||||
|
+ }
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+ /* did we find a separator? */
|
||||||
|
if (last_separator) {
|
||||||
|
if ((last_separator - origname) == 5 && memEQ(origname, "SUPER", 5)) {
|
||||||
|
/* ->SUPER::method should really be looked up in original stash */
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,44 @@
|
|||||||
|
From 1665b718d8fbd58705dbe6376fa51f8c1a02d887 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Tue, 13 Sep 2016 22:38:59 -0700
|
||||||
|
Subject: [PATCH 5/5] [perl #129267] Test for gv_fetchmethod buffer overrun
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/XS-APItest/APItest.xs | 3 +++
|
||||||
|
ext/XS-APItest/t/gv_fetchmethod_flags.t | 5 +++++
|
||||||
|
2 files changed, 8 insertions(+)
|
||||||
|
|
||||||
|
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
|
||||||
|
index 992b6a5..4602cee 100644
|
||||||
|
--- a/ext/XS-APItest/APItest.xs
|
||||||
|
+++ b/ext/XS-APItest/APItest.xs
|
||||||
|
@@ -2571,6 +2571,9 @@ gv_fetchmethod_flags_type(stash, methname, type, flags)
|
||||||
|
gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
+ case 4:
|
||||||
|
+ gv = gv_fetchmethod_pvn_flags(stash, SvPV_nolen(methname),
|
||||||
|
+ flags, SvUTF8(methname));
|
||||||
|
}
|
||||||
|
XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
|
||||||
|
|
||||||
|
diff --git a/ext/XS-APItest/t/gv_fetchmethod_flags.t b/ext/XS-APItest/t/gv_fetchmethod_flags.t
|
||||||
|
index 15d1c41..2da3b70 100644
|
||||||
|
--- a/ext/XS-APItest/t/gv_fetchmethod_flags.t
|
||||||
|
+++ b/ext/XS-APItest/t/gv_fetchmethod_flags.t
|
||||||
|
@@ -49,3 +49,8 @@ is XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 2, 0), "*m
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+# [perl #129267] Buffer overrun when argument name ends with colon and
|
||||||
|
+# there is a colon past the end. This used to segv.
|
||||||
|
+XS::APItest::gv_fetchmethod_flags_type(\%::, "method:::::", 4, 7);
|
||||||
|
+ # With type 4, 7 is the length
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
64
SOURCES/perl-5.25.4-perl-129287-Make-UTF8-append-null.patch
Normal file
64
SOURCES/perl-5.25.4-perl-129287-Make-UTF8-append-null.patch
Normal file
@ -0,0 +1,64 @@
|
|||||||
|
From b43665fffa48dd179eba1b5616d4ca35b4def876 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Sun, 18 Sep 2016 20:17:08 -0700
|
||||||
|
Subject: [PATCH] [perl #129287] Make UTF8 & append null
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
The & and &. operators were not appending a null byte to the string
|
||||||
|
in utf8 mode.
|
||||||
|
|
||||||
|
(The internal function that they use is the same. I used &. in the
|
||||||
|
test just because its intent is clearer.)
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
doop.c | 1 +
|
||||||
|
t/op/bop.t | 14 +++++++++++++-
|
||||||
|
2 files changed, 14 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/doop.c b/doop.c
|
||||||
|
index ad9172a..234a425 100644
|
||||||
|
--- a/doop.c
|
||||||
|
+++ b/doop.c
|
||||||
|
@@ -1093,6 +1093,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
|
||||||
|
if (sv == left || sv == right)
|
||||||
|
(void)sv_usepvn(sv, dcorig, needlen);
|
||||||
|
SvCUR_set(sv, dc - dcorig);
|
||||||
|
+ *SvEND(sv) = 0;
|
||||||
|
break;
|
||||||
|
case OP_BIT_XOR:
|
||||||
|
while (lulen && rulen) {
|
||||||
|
diff --git a/t/op/bop.t b/t/op/bop.t
|
||||||
|
index 2afb8d7..1f96e9b 100644
|
||||||
|
--- a/t/op/bop.t
|
||||||
|
+++ b/t/op/bop.t
|
||||||
|
@@ -19,7 +19,7 @@ BEGIN {
|
||||||
|
# If you find tests are failing, please try adding names to tests to track
|
||||||
|
# down where the failure is, and supply your new names as a patch.
|
||||||
|
# (Just-in-time test naming)
|
||||||
|
-plan tests => 192 + (10*13*2) + 5 + 29;
|
||||||
|
+plan tests => 192 + (10*13*2) + 5 + 30;
|
||||||
|
|
||||||
|
# numerics
|
||||||
|
ok ((0xdead & 0xbeef) == 0x9ead);
|
||||||
|
@@ -664,3 +664,15 @@ is $^A, "123", '~v0 clears vstring magic on retval';
|
||||||
|
is(-1 >> $w + 1, -1, "IV -1 right shift $w + 1 == -1");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
+
|
||||||
|
+# [perl #129287] UTF8 & was not providing a trailing null byte.
|
||||||
|
+# This test is a bit convoluted, as we want to make sure that the string
|
||||||
|
+# allocated for &’s target contains memory initialised to something other
|
||||||
|
+# than a null byte. Uninitialised memory does not make for a reliable
|
||||||
|
+# test. So we do &. on a longer non-utf8 string first.
|
||||||
|
+for (["aaa","aaa"],[substr ("a\x{100}",0,1), "a"]) {
|
||||||
|
+ use feature "bitwise";
|
||||||
|
+ no warnings "experimental::bitwise", "pack";
|
||||||
|
+ $byte = substr unpack("P2", pack "P", $$_[0] &. $$_[1]), -1;
|
||||||
|
+}
|
||||||
|
+is $byte, "\0", "utf8 &. appends null byte";
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,32 @@
|
|||||||
|
From 9ce5bf4c39e28441410672f39b5ee1c4569967f8 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Fri, 28 Oct 2016 13:27:23 +0100
|
||||||
|
Subject: [PATCH] [perl #130001] h2xs: avoid infinite loop for enums
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
'typedef enum x { ... } x' causes h2xs to enter a substitution loop while
|
||||||
|
trying to write the typemap file.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
utils/h2xs.PL | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/utils/h2xs.PL b/utils/h2xs.PL
|
||||||
|
index 8fda87b..f9063cb 100644
|
||||||
|
--- a/utils/h2xs.PL
|
||||||
|
+++ b/utils/h2xs.PL
|
||||||
|
@@ -1034,7 +1034,7 @@ if( ! $opt_X ){ # use XS, unless it was disabled
|
||||||
|
}
|
||||||
|
}
|
||||||
|
{ local $" = '|';
|
||||||
|
- $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
|
||||||
|
+ $typedef_rex = qr(\b(?<!struct )(?<!enum )(?:@good_td)\b) if @good_td;
|
||||||
|
}
|
||||||
|
%known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
|
||||||
|
if ($fmask) {
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
61
SOURCES/perl-5.25.7-Fix-Storable-segfaults.patch
Normal file
61
SOURCES/perl-5.25.7-Fix-Storable-segfaults.patch
Normal file
@ -0,0 +1,61 @@
|
|||||||
|
From fecd3be8dbdb747b9cbf4cbb9299ce40faabc8e6 Mon Sep 17 00:00:00 2001
|
||||||
|
From: John Lightsey <lightsey@debian.org>
|
||||||
|
Date: Mon, 14 Nov 2016 11:56:15 +0100
|
||||||
|
Subject: [PATCH] Fix Storable segfaults.
|
||||||
|
|
||||||
|
Fix a null pointed dereference segfault in storable when the
|
||||||
|
retrieve_code logic was unable to read the string that contained
|
||||||
|
the code.
|
||||||
|
|
||||||
|
Also fix several locations where retrieve_other was called with a
|
||||||
|
null context pointer. This also resulted in a null pointer
|
||||||
|
dereference.
|
||||||
|
---
|
||||||
|
dist/Storable/Storable.xs | 10 +++++++---
|
||||||
|
1 file changed, 7 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
|
||||||
|
index 053951c..caa489c 100644
|
||||||
|
--- a/dist/Storable/Storable.xs
|
||||||
|
+++ b/dist/Storable/Storable.xs
|
||||||
|
@@ -5647,6 +5647,10 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
|
||||||
|
CROAK(("Unexpected type %d in retrieve_code\n", type));
|
||||||
|
}
|
||||||
|
|
||||||
|
+ if (!text) {
|
||||||
|
+ CROAK(("Unable to retrieve code\n"));
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
/*
|
||||||
|
* prepend "sub " to the source
|
||||||
|
*/
|
||||||
|
@@ -5767,7 +5771,7 @@ static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname)
|
||||||
|
continue; /* av_extend() already filled us with undef */
|
||||||
|
}
|
||||||
|
if (c != SX_ITEM)
|
||||||
|
- (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
|
||||||
|
+ (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
|
||||||
|
TRACEME(("(#%d) item", i));
|
||||||
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
|
||||||
|
if (!sv)
|
||||||
|
@@ -5844,7 +5848,7 @@ static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
|
||||||
|
if (!sv)
|
||||||
|
return (SV *) 0;
|
||||||
|
} else
|
||||||
|
- (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
|
||||||
|
+ (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
|
||||||
|
|
||||||
|
/*
|
||||||
|
* Get key.
|
||||||
|
@@ -5855,7 +5859,7 @@ static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
|
||||||
|
|
||||||
|
GETMARK(c);
|
||||||
|
if (c != SX_KEY)
|
||||||
|
- (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
|
||||||
|
+ (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
|
||||||
|
RLEN(size); /* Get key size */
|
||||||
|
KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
|
||||||
|
if (size)
|
||||||
|
--
|
||||||
|
2.10.2
|
||||||
|
|
124
SOURCES/perl-5.25.7-Fix-const-correctness-in-hv_func.h.patch
Normal file
124
SOURCES/perl-5.25.7-Fix-const-correctness-in-hv_func.h.patch
Normal file
@ -0,0 +1,124 @@
|
|||||||
|
From 463ddf34c08f2c97199b1bb242da1f17494d4d1a Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Thu, 24 Nov 2016 16:34:09 +0100
|
||||||
|
Subject: [PATCH] Fix const correctness in hv_func.h
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Building an XS code with -Wcast-qual yielded warnings about discarding
|
||||||
|
const qualifiers from pointer targets like:
|
||||||
|
|
||||||
|
$ printf '#include "EXTERN.h"\n#include "perl.h"\n' | gcc -Wcast-qual -I/usr/lib64/perl5/CORE -c -x c -
|
||||||
|
In file included from /usr/lib64/perl5/CORE/hv.h:629:0,
|
||||||
|
from /usr/lib64/perl5/CORE/perl.h:3740,
|
||||||
|
from <stdin>:2:
|
||||||
|
/usr/lib64/perl5/CORE/hv_func.h: In function ‘S_perl_hash_siphash_2_4’:
|
||||||
|
/usr/lib64/perl5/CORE/hv_func.h:213:17: warning: cast discards ‘const’ qualifier from pointer target type [-Wcast-qual]
|
||||||
|
U64TYPE k0 = ((U64TYPE*)seed)[0];
|
||||||
|
^
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
hv_func.h | 22 +++++++++++-----------
|
||||||
|
1 file changed, 11 insertions(+), 11 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/hv_func.h b/hv_func.h
|
||||||
|
index 8866db9..57b1ed1 100644
|
||||||
|
--- a/hv_func.h
|
||||||
|
+++ b/hv_func.h
|
||||||
|
@@ -118,7 +118,7 @@
|
||||||
|
|
||||||
|
#if (BYTEORDER == 0x1234 || BYTEORDER == 0x12345678) && U32SIZE == 4
|
||||||
|
/* CPU endian matches murmurhash algorithm, so read 32-bit word directly */
|
||||||
|
- #define U8TO32_LE(ptr) (*((U32*)(ptr)))
|
||||||
|
+ #define U8TO32_LE(ptr) (*((const U32*)(ptr)))
|
||||||
|
#elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
|
||||||
|
/* TODO: Add additional cases below where a compiler provided bswap32 is available */
|
||||||
|
#if defined(__GNUC__) && (__GNUC__>4 || (__GNUC__==4 && __GNUC_MINOR__>=3))
|
||||||
|
@@ -210,8 +210,8 @@ S_perl_hash_siphash_2_4(const unsigned char * const seed, const unsigned char *i
|
||||||
|
U64 v3 = UINT64_C(0x7465646279746573);
|
||||||
|
|
||||||
|
U64 b;
|
||||||
|
- U64 k0 = ((U64*)seed)[0];
|
||||||
|
- U64 k1 = ((U64*)seed)[1];
|
||||||
|
+ U64 k0 = ((const U64*)seed)[0];
|
||||||
|
+ U64 k1 = ((const U64*)seed)[1];
|
||||||
|
U64 m;
|
||||||
|
const int left = inlen & 7;
|
||||||
|
const U8 *end = in + inlen - left;
|
||||||
|
@@ -269,7 +269,7 @@ S_perl_hash_siphash_2_4(const unsigned char * const seed, const unsigned char *i
|
||||||
|
|
||||||
|
PERL_STATIC_INLINE U32
|
||||||
|
S_perl_hash_superfast(const unsigned char * const seed, const unsigned char *str, STRLEN len) {
|
||||||
|
- U32 hash = *((U32*)seed) + (U32)len;
|
||||||
|
+ U32 hash = *((const U32*)seed) + (U32)len;
|
||||||
|
U32 tmp;
|
||||||
|
int rem= len & 3;
|
||||||
|
len >>= 2;
|
||||||
|
@@ -373,7 +373,7 @@ S_perl_hash_superfast(const unsigned char * const seed, const unsigned char *str
|
||||||
|
/* now we create the hash function */
|
||||||
|
PERL_STATIC_INLINE U32
|
||||||
|
S_perl_hash_murmur3(const unsigned char * const seed, const unsigned char *ptr, STRLEN len) {
|
||||||
|
- U32 h1 = *((U32*)seed);
|
||||||
|
+ U32 h1 = *((const U32*)seed);
|
||||||
|
U32 k1;
|
||||||
|
U32 carry = 0;
|
||||||
|
|
||||||
|
@@ -467,7 +467,7 @@ S_perl_hash_murmur3(const unsigned char * const seed, const unsigned char *ptr,
|
||||||
|
PERL_STATIC_INLINE U32
|
||||||
|
S_perl_hash_djb2(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
|
||||||
|
const unsigned char * const end = (const unsigned char *)str + len;
|
||||||
|
- U32 hash = *((U32*)seed) + (U32)len;
|
||||||
|
+ U32 hash = *((const U32*)seed) + (U32)len;
|
||||||
|
while (str < end) {
|
||||||
|
hash = ((hash << 5) + hash) + *str++;
|
||||||
|
}
|
||||||
|
@@ -477,7 +477,7 @@ S_perl_hash_djb2(const unsigned char * const seed, const unsigned char *str, con
|
||||||
|
PERL_STATIC_INLINE U32
|
||||||
|
S_perl_hash_sdbm(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
|
||||||
|
const unsigned char * const end = (const unsigned char *)str + len;
|
||||||
|
- U32 hash = *((U32*)seed) + (U32)len;
|
||||||
|
+ U32 hash = *((const U32*)seed) + (U32)len;
|
||||||
|
while (str < end) {
|
||||||
|
hash = (hash << 6) + (hash << 16) - hash + *str++;
|
||||||
|
}
|
||||||
|
@@ -503,7 +503,7 @@ S_perl_hash_sdbm(const unsigned char * const seed, const unsigned char *str, con
|
||||||
|
PERL_STATIC_INLINE U32
|
||||||
|
S_perl_hash_one_at_a_time(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
|
||||||
|
const unsigned char * const end = (const unsigned char *)str + len;
|
||||||
|
- U32 hash = *((U32*)seed) + (U32)len;
|
||||||
|
+ U32 hash = *((const U32*)seed) + (U32)len;
|
||||||
|
while (str < end) {
|
||||||
|
hash += *str++;
|
||||||
|
hash += (hash << 10);
|
||||||
|
@@ -518,7 +518,7 @@ S_perl_hash_one_at_a_time(const unsigned char * const seed, const unsigned char
|
||||||
|
PERL_STATIC_INLINE U32
|
||||||
|
S_perl_hash_one_at_a_time_hard(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
|
||||||
|
const unsigned char * const end = (const unsigned char *)str + len;
|
||||||
|
- U32 hash = *((U32*)seed) + (U32)len;
|
||||||
|
+ U32 hash = *((const U32*)seed) + (U32)len;
|
||||||
|
|
||||||
|
while (str < end) {
|
||||||
|
hash += (hash << 10);
|
||||||
|
@@ -553,7 +553,7 @@ S_perl_hash_one_at_a_time_hard(const unsigned char * const seed, const unsigned
|
||||||
|
PERL_STATIC_INLINE U32
|
||||||
|
S_perl_hash_old_one_at_a_time(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
|
||||||
|
const unsigned char * const end = (const unsigned char *)str + len;
|
||||||
|
- U32 hash = *((U32*)seed);
|
||||||
|
+ U32 hash = *((const U32*)seed);
|
||||||
|
while (str < end) {
|
||||||
|
hash += *str++;
|
||||||
|
hash += (hash << 10);
|
||||||
|
@@ -581,7 +581,7 @@ S_perl_hash_murmur_hash_64a (const unsigned char * const seed, const unsigned ch
|
||||||
|
{
|
||||||
|
const U64 m = UINT64_C(0xc6a4a7935bd1e995);
|
||||||
|
const int r = 47;
|
||||||
|
- U64 h = *((U64*)seed) ^ len;
|
||||||
|
+ U64 h = *((const U64*)seed) ^ len;
|
||||||
|
const U64 * data = (const U64 *)str;
|
||||||
|
const U64 * end = data + (len/8);
|
||||||
|
const unsigned char * data2;
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,38 @@
|
|||||||
|
From bb78386f13c18a1a7dae932b9b36e977056b13c7 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Fri, 27 Jan 2017 16:57:40 +0100
|
||||||
|
Subject: [PATCH] only mess with NEXT_OFF() when we are in PASS2
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
In 31fc93954d1f379c7a49889d91436ce99818e1f6 I added code that would modify
|
||||||
|
NEXT_OFF() when we were not in PASS2, when we should not do so. Strangly this
|
||||||
|
did not segfault when I tested, but this fix is required.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 4 ++--
|
||||||
|
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 322d230..d5ce63f 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -11709,11 +11709,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
nextchar(pRExC_state);
|
||||||
|
if (max < min) { /* If can't match, warn and optimize to fail
|
||||||
|
unconditionally */
|
||||||
|
+ reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
|
||||||
|
if (PASS2) {
|
||||||
|
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
|
||||||
|
+ NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
|
||||||
|
}
|
||||||
|
- reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
|
||||||
|
- NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
|
||||||
|
return ret;
|
||||||
|
}
|
||||||
|
else if (min == max && *RExC_parse == '?')
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,69 @@
|
|||||||
|
From 42e9b60980bb8e29e76629e14c6aa945194c0647 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Hugo van der Sanden <hv@crypt.org>
|
||||||
|
Date: Wed, 5 Oct 2016 02:20:26 +0100
|
||||||
|
Subject: [PATCH] [perl #129061] CURLYX nodes can be studied more than once
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
study_chunk() for CURLYX is used to set flags on the linked WHILEM
|
||||||
|
node to say it is the whilem_c'th of whilem_seen. However it assumes
|
||||||
|
each CURLYX can be studied only once, which is not the case - there
|
||||||
|
are various cases such as GOSUB which call study_chunk() recursively
|
||||||
|
on already-visited parts of the program.
|
||||||
|
|
||||||
|
Storing the wrong index can cause the super-linear cache handling in
|
||||||
|
regmatch() to read/write the byte after the end of poscache.
|
||||||
|
|
||||||
|
Also reported in [perl #129281].
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 12 +++++++++---
|
||||||
|
t/re/pat.t | 1 -
|
||||||
|
2 files changed, 9 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 850a6c1..48c8d8d 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -5218,15 +5218,21 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||||
|
However, this time it's not a subexpression
|
||||||
|
we care about, but the expression itself. */
|
||||||
|
&& (maxcount == REG_INFTY)
|
||||||
|
- && data && ++data->whilem_c < 16) {
|
||||||
|
+ && data) {
|
||||||
|
/* This stays as CURLYX, we can put the count/of pair. */
|
||||||
|
/* Find WHILEM (as in regexec.c) */
|
||||||
|
regnode *nxt = oscan + NEXT_OFF(oscan);
|
||||||
|
|
||||||
|
if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
|
||||||
|
nxt += ARG(nxt);
|
||||||
|
- PREVOPER(nxt)->flags = (U8)(data->whilem_c
|
||||||
|
- | (RExC_whilem_seen << 4)); /* On WHILEM */
|
||||||
|
+ nxt = PREVOPER(nxt);
|
||||||
|
+ if (nxt->flags & 0xf) {
|
||||||
|
+ /* we've already set whilem count on this node */
|
||||||
|
+ } else if (++data->whilem_c < 16) {
|
||||||
|
+ assert(data->whilem_c <= RExC_whilem_seen);
|
||||||
|
+ nxt->flags = (U8)(data->whilem_c
|
||||||
|
+ | (RExC_whilem_seen << 4)); /* On WHILEM */
|
||||||
|
+ }
|
||||||
|
}
|
||||||
|
if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
|
||||||
|
pars++;
|
||||||
|
diff --git a/t/re/pat.t b/t/re/pat.t
|
||||||
|
index ecd3af1..16bfc8e 100644
|
||||||
|
--- a/t/re/pat.t
|
||||||
|
+++ b/t/re/pat.t
|
||||||
|
@@ -1909,7 +1909,6 @@ EOP
|
||||||
|
}
|
||||||
|
{
|
||||||
|
# [perl #129281] buffer write overflow, detected by ASAN, valgrind
|
||||||
|
- local $::TODO = "whilem_c bumped too much";
|
||||||
|
fresh_perl_is('/0(?0)|^*0(?0)|^*(^*())0|/', '', {}, "don't bump whilem_c too much");
|
||||||
|
}
|
||||||
|
} # End of sub run_tests
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
@ -0,0 +1,34 @@
|
|||||||
|
From 923e23bad0514e1bd29112650fb78aa4ea69e1b7 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Sat, 28 Jan 2017 15:13:17 +0100
|
||||||
|
Subject: [PATCH] silence warnings from tests about impossible quantifiers
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
thanks to Dave M for noticing....
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/re/pat_rt_report.t | 3 ++-
|
||||||
|
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
|
||||||
|
index 21aff58..dd740e7 100644
|
||||||
|
--- a/t/re/pat_rt_report.t
|
||||||
|
+++ b/t/re/pat_rt_report.t
|
||||||
|
@@ -1134,9 +1134,10 @@ EOP
|
||||||
|
{
|
||||||
|
# rt
|
||||||
|
fresh_perl_is(
|
||||||
|
- '"foo"=~/((?1)){8,0}/; print "ok"',
|
||||||
|
+ 'no warnings "regexp"; "foo"=~/((?1)){8,0}/; print "ok"',
|
||||||
|
"ok", {}, 'RT #130561 - allowing impossible quantifier should not cause SEGVs');
|
||||||
|
my $s= "foo";
|
||||||
|
+ no warnings 'regexp';
|
||||||
|
ok($s=~/(foo){1,0}|(?1)/,
|
||||||
|
"RT #130561 - allowing impossible quantifier should not break recursion");
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.7.4
|
||||||
|
|
111
SOURCES/perl-5.26.1-fix-do-dir-returning-no.patch
Normal file
111
SOURCES/perl-5.26.1-fix-do-dir-returning-no.patch
Normal file
@ -0,0 +1,111 @@
|
|||||||
|
From 3dfcac940930a8aa6779f5debea6ea6357372419 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Daniel Dragan <bulk88@hotmail.com>
|
||||||
|
Date: Sun, 16 Aug 2015 04:30:23 -0400
|
||||||
|
Subject: [PATCH] fix do dir returning no $!
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
do()ing a directory was returning false/empty string in $!, which isn't
|
||||||
|
an error, yet documentation says $! should have the error code in it.
|
||||||
|
Fix this by returning EISDIR for dirs, and EINVAL for block devices.
|
||||||
|
[perl #125774]
|
||||||
|
|
||||||
|
Remove "errno = 0" and comment added in b2da7ead68, since now there is no
|
||||||
|
scenario where errno is uninitialized, since the dir and block device
|
||||||
|
failure branches now set errno, where previously they didn't.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.1.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_ctl.c | 25 +++++++++++++++++--------
|
||||||
|
t/op/do.t | 14 +++++++++++++-
|
||||||
|
2 files changed, 30 insertions(+), 9 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
|
index e24d7b6..f136f91 100644
|
||||||
|
--- a/pp_ctl.c
|
||||||
|
+++ b/pp_ctl.c
|
||||||
|
@@ -3534,15 +3534,22 @@ S_check_type_and_open(pTHX_ SV *name)
|
||||||
|
errno EACCES, so only do a stat to separate a dir from a real EACCES
|
||||||
|
caused by user perms */
|
||||||
|
#ifndef WIN32
|
||||||
|
- /* we use the value of errno later to see how stat() or open() failed.
|
||||||
|
- * We don't want it set if the stat succeeded but we still failed,
|
||||||
|
- * such as if the name exists, but is a directory */
|
||||||
|
- errno = 0;
|
||||||
|
-
|
||||||
|
st_rc = PerlLIO_stat(p, &st);
|
||||||
|
|
||||||
|
- if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
|
||||||
|
+ if (st_rc < 0)
|
||||||
|
return NULL;
|
||||||
|
+ else {
|
||||||
|
+ int eno;
|
||||||
|
+ if(S_ISBLK(st.st_mode)) {
|
||||||
|
+ eno = EINVAL;
|
||||||
|
+ goto not_file;
|
||||||
|
+ }
|
||||||
|
+ else if(S_ISDIR(st.st_mode)) {
|
||||||
|
+ eno = EISDIR;
|
||||||
|
+ not_file:
|
||||||
|
+ errno = eno;
|
||||||
|
+ return NULL;
|
||||||
|
+ }
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
@@ -3554,8 +3561,10 @@ S_check_type_and_open(pTHX_ SV *name)
|
||||||
|
int eno;
|
||||||
|
st_rc = PerlLIO_stat(p, &st);
|
||||||
|
if (st_rc >= 0) {
|
||||||
|
- if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
|
||||||
|
- eno = 0;
|
||||||
|
+ if(S_ISDIR(st.st_mode))
|
||||||
|
+ eno = EISDIR;
|
||||||
|
+ else if(S_ISBLK(st.st_mode))
|
||||||
|
+ eno = EINVAL;
|
||||||
|
else
|
||||||
|
eno = EACCES;
|
||||||
|
errno = eno;
|
||||||
|
diff --git a/t/op/do.t b/t/op/do.t
|
||||||
|
index 78d8800..1c54f0b 100644
|
||||||
|
--- a/t/op/do.t
|
||||||
|
+++ b/t/op/do.t
|
||||||
|
@@ -7,6 +7,7 @@ BEGIN {
|
||||||
|
}
|
||||||
|
use strict;
|
||||||
|
no warnings 'void';
|
||||||
|
+use Errno qw(ENOENT EISDIR);
|
||||||
|
|
||||||
|
my $called;
|
||||||
|
my $result = do{ ++$called; 'value';};
|
||||||
|
@@ -247,7 +248,7 @@ SKIP: {
|
||||||
|
my $saved_errno = $!;
|
||||||
|
ok(!$rv, "do returns false on io errror");
|
||||||
|
ok(!$saved_error, "\$\@ not set on io error");
|
||||||
|
- ok($saved_errno, "\$! set on io error");
|
||||||
|
+ ok($saved_errno == ENOENT, "\$! is ENOENT for nonexistent file");
|
||||||
|
}
|
||||||
|
|
||||||
|
# do subname should not be do "subname"
|
||||||
|
@@ -305,4 +306,15 @@ SKIP: {
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
+# do file $!s must be correct
|
||||||
|
+{
|
||||||
|
+ local @INC = ('.'); #want EISDIR not ENOENT
|
||||||
|
+ my $rv = do 'op'; # /t/op dir
|
||||||
|
+ my $saved_error = $@;
|
||||||
|
+ my $saved_errno = $!+0;
|
||||||
|
+ ok(!$rv, "do dir returns false");
|
||||||
|
+ ok(!$saved_error, "\$\@ is false on do dir");
|
||||||
|
+ ok($saved_errno == EISDIR, "\$! is EISDIR on do dir");
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
done_testing();
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
24
SOURCES/perl-5.26.1-guard_old_libcrypt_fix.patch
Normal file
24
SOURCES/perl-5.26.1-guard_old_libcrypt_fix.patch
Normal file
@ -0,0 +1,24 @@
|
|||||||
|
commit 13e70b397dcb0d1bf4a869b670f041c1d7b730d0
|
||||||
|
Author: Björn Esser <besser82@fedoraproject.org>
|
||||||
|
Date: Sat Jan 20 20:22:53 2018 +0100
|
||||||
|
|
||||||
|
pp: Guard fix for really old bug in glibc libcrypt
|
||||||
|
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index d50ad7ddbf..6510c7b15c 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -3650,8 +3650,12 @@ PP(pp_crypt)
|
||||||
|
#if defined(__GLIBC__) || defined(__EMX__)
|
||||||
|
if (PL_reentrant_buffer->_crypt_struct_buffer) {
|
||||||
|
PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
|
||||||
|
- /* work around glibc-2.2.5 bug */
|
||||||
|
+#if (defined(__GLIBC__) && __GLIBC__ == 2) && \
|
||||||
|
+ (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
|
||||||
|
+ /* work around glibc-2.2.5 bug, has been fixed at some
|
||||||
|
+ * time in glibc-2.3.X */
|
||||||
|
PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
|
||||||
|
+#endif
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
}
|
@ -0,0 +1,107 @@
|
|||||||
|
From 7a962424149cc60f3a187d0213a12689dd5e806b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 14 Aug 2017 11:52:39 +1000
|
||||||
|
Subject: [PATCH] (perl #131746) avoid undefined behaviour in Copy() etc
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
These functions depend on C library functions which have undefined
|
||||||
|
behaviour when passed NULL pointers, even when passed a zero 'n' value.
|
||||||
|
|
||||||
|
Some compilers use this information, ie. assume the pointers are
|
||||||
|
non-NULL when optimizing any following code, so we do need to
|
||||||
|
prevent such unguarded calls.
|
||||||
|
|
||||||
|
My initial thought was to add conditionals to each macro to skip the
|
||||||
|
call to the library function when n is zero, but this adds a cost to
|
||||||
|
every use of these macros, even when the n value is always true.
|
||||||
|
|
||||||
|
So instead I added asserts() which will give us a much more visible
|
||||||
|
indicator of such broken code and revealed the pp_caller and Glob.xs
|
||||||
|
issues also patched here.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.1 from
|
||||||
|
f14cf3632059d421de83cf901c7e849adc1fcd03.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/File-Glob/Glob.xs | 2 +-
|
||||||
|
handy.h | 14 +++++++-------
|
||||||
|
pp_ctl.c | 3 ++-
|
||||||
|
pp_hot.c | 3 ++-
|
||||||
|
4 files changed, 12 insertions(+), 10 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
|
||||||
|
index e0a3681..9779d54 100644
|
||||||
|
--- a/ext/File-Glob/Glob.xs
|
||||||
|
+++ b/ext/File-Glob/Glob.xs
|
||||||
|
@@ -121,7 +121,7 @@ iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, boo
|
||||||
|
|
||||||
|
/* chuck it all out, quick or slow */
|
||||||
|
if (gimme == G_ARRAY) {
|
||||||
|
- if (!on_stack) {
|
||||||
|
+ if (!on_stack && AvFILLp(entries) + 1) {
|
||||||
|
EXTEND(SP, AvFILLp(entries)+1);
|
||||||
|
Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
|
||||||
|
SP += AvFILLp(entries)+1;
|
||||||
|
diff --git a/handy.h b/handy.h
|
||||||
|
index 80f9cf4..88b5b55 100644
|
||||||
|
--- a/handy.h
|
||||||
|
+++ b/handy.h
|
||||||
|
@@ -2409,17 +2409,17 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe
|
||||||
|
#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d)))
|
||||||
|
#endif
|
||||||
|
|
||||||
|
-#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
+#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
|
||||||
|
-#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
#ifdef HAS_MEMSET
|
||||||
|
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
#else
|
||||||
|
/* Using bzero(), which returns void. */
|
||||||
|
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)),d)
|
||||||
|
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)),d)
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)))
|
||||||
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
|
index 15c193b..f1c57bc 100644
|
||||||
|
--- a/pp_ctl.c
|
||||||
|
+++ b/pp_ctl.c
|
||||||
|
@@ -1971,7 +1971,8 @@ PP(pp_caller)
|
||||||
|
|
||||||
|
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
|
||||||
|
av_extend(PL_dbargs, AvFILLp(ary) + off);
|
||||||
|
- Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
|
||||||
|
+ if (AvFILLp(ary) + 1 + off)
|
||||||
|
+ Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
|
||||||
|
AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
|
||||||
|
}
|
||||||
|
mPUSHi(CopHINTS_get(cx->blk_oldcop));
|
||||||
|
diff --git a/pp_hot.c b/pp_hot.c
|
||||||
|
index 5899413..66b79ea 100644
|
||||||
|
--- a/pp_hot.c
|
||||||
|
+++ b/pp_hot.c
|
||||||
|
@@ -4138,7 +4138,8 @@ PP(pp_entersub)
|
||||||
|
AvARRAY(av) = ary;
|
||||||
|
}
|
||||||
|
|
||||||
|
- Copy(MARK+1,AvARRAY(av),items,SV*);
|
||||||
|
+ if (items)
|
||||||
|
+ Copy(MARK+1,AvARRAY(av),items,SV*);
|
||||||
|
AvFILLp(av) = items - 1;
|
||||||
|
}
|
||||||
|
if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,33 @@
|
|||||||
|
From 2c2da8e7f0f6325fab643997a536072633fa0cf8 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Thu, 1 Jun 2017 14:51:44 +0200
|
||||||
|
Subject: [PATCH] Fix #131190 - UTF8 code improperly casting negative integer
|
||||||
|
to U8 in comparison
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This reverts commit b4972372a75776de3c9e6bd234a398d103677316,
|
||||||
|
effectively restoring commit ca7eb79a236b41b7722c6800527f95cd76843eed,
|
||||||
|
and commit 85fde2b7c3f5631fd982f5db735b84dc9224bec0.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regexec.c | 1 +
|
||||||
|
1 file changed, 1 insertion(+)
|
||||||
|
|
||||||
|
diff --git a/regexec.c b/regexec.c
|
||||||
|
index 82128a7..35b88d7 100644
|
||||||
|
--- a/regexec.c
|
||||||
|
+++ b/regexec.c
|
||||||
|
@@ -5593,6 +5593,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
|
||||||
|
if (scan->flags == EXACTL || scan->flags == EXACTFLU8) {
|
||||||
|
_CHECK_AND_WARN_PROBLEMATIC_LOCALE;
|
||||||
|
if (utf8_target
|
||||||
|
+ && nextchr >= 0 /* guard against negative EOS value in nextchr */
|
||||||
|
&& UTF8_IS_ABOVE_LATIN1(nextchr)
|
||||||
|
&& scan->flags == EXACTL)
|
||||||
|
{
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,135 @@
|
|||||||
|
From bab0f8e933b383b6bef406d79c2da340bbcded33 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Sun, 18 Jun 2017 20:45:30 +0200
|
||||||
|
Subject: [PATCH 1/2] Resolve Perl #131522: Spurious "Assuming NOT a POSIX
|
||||||
|
class" warning
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 30 ++++++++++++++++++------------
|
||||||
|
1 file changed, 18 insertions(+), 12 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 8921eed..0a4ea78 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -13991,6 +13991,13 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
|
||||||
|
REPORT_LOCATION_ARGS(p))); \
|
||||||
|
} \
|
||||||
|
} STMT_END
|
||||||
|
+#define CLEAR_POSIX_WARNINGS() \
|
||||||
|
+ if (posix_warnings && RExC_warn_text) \
|
||||||
|
+ av_clear(RExC_warn_text)
|
||||||
|
+
|
||||||
|
+#define CLEAR_POSIX_WARNINGS_AND_RETURN(ret) \
|
||||||
|
+ CLEAR_POSIX_WARNINGS(); \
|
||||||
|
+ return ret
|
||||||
|
|
||||||
|
STATIC int
|
||||||
|
S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
@@ -14063,7 +14070,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
*
|
||||||
|
* The syntax for a legal posix class is:
|
||||||
|
*
|
||||||
|
- * qr/(?xa: \[ : \^? [:lower:]{4,6} : \] )/
|
||||||
|
+ * qr/(?xa: \[ : \^? [[:lower:]]{4,6} : \] )/
|
||||||
|
*
|
||||||
|
* What this routine considers syntactically to be an intended posix class
|
||||||
|
* is this (the comments indicate some restrictions that the pattern
|
||||||
|
@@ -14088,7 +14095,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
* # for it to be considered to be
|
||||||
|
* # an intended posix class.
|
||||||
|
* \h*
|
||||||
|
- * [:punct:]? # The closing class character,
|
||||||
|
+ * [[:punct:]]? # The closing class character,
|
||||||
|
* # possibly omitted. If not a colon
|
||||||
|
* # nor semi colon, the class name
|
||||||
|
* # must be even closer to a valid
|
||||||
|
@@ -14131,8 +14138,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
|
||||||
|
PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
|
||||||
|
|
||||||
|
- if (posix_warnings && RExC_warn_text)
|
||||||
|
- av_clear(RExC_warn_text);
|
||||||
|
+ CLEAR_POSIX_WARNINGS();
|
||||||
|
|
||||||
|
if (p >= e) {
|
||||||
|
return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||||
|
@@ -14224,7 +14230,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
*updated_parse_ptr = (char *) temp_ptr;
|
||||||
|
}
|
||||||
|
|
||||||
|
- return OOB_NAMEDCLASS;
|
||||||
|
+ CLEAR_POSIX_WARNINGS_AND_RETURN(OOB_NAMEDCLASS);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
@@ -14294,7 +14300,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
/* We consider something like [^:^alnum:]] to not have been intended to
|
||||||
|
* be a posix class, but XXX maybe we should */
|
||||||
|
if (complement) {
|
||||||
|
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||||
|
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||||
|
}
|
||||||
|
|
||||||
|
complement = 1;
|
||||||
|
@@ -14321,7 +14327,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
* this leaves this construct looking like [:] or [:^], which almost
|
||||||
|
* certainly weren't intended to be posix classes */
|
||||||
|
if (has_opening_bracket) {
|
||||||
|
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||||
|
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* But this function can be called when we parse the colon for
|
||||||
|
@@ -14338,7 +14344,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
/* XXX We are currently very restrictive here, so this code doesn't
|
||||||
|
* consider the possibility that, say, /[alpha.]]/ was intended to
|
||||||
|
* be a posix class. */
|
||||||
|
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||||
|
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Here we have something like 'foo:]'. There was no initial colon,
|
||||||
|
@@ -14508,7 +14514,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Otherwise, it can't have meant to have been a class */
|
||||||
|
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||||
|
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* If we ran off the end, and the final character was a punctuation
|
||||||
|
@@ -14558,7 +14564,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
* class name. (We can do this on the first pass, as any second pass
|
||||||
|
* will yield an even shorter name) */
|
||||||
|
if (name_len < 3) {
|
||||||
|
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||||
|
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Find which class it is. Initially switch on the length of the name.
|
||||||
|
@@ -14717,7 +14723,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Here neither pass found a close-enough class name */
|
||||||
|
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||||
|
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||||
|
}
|
||||||
|
|
||||||
|
probably_meant_to_be:
|
||||||
|
@@ -14759,7 +14765,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||||
|
/* If it is a known class, return the class. The class number
|
||||||
|
* #defines are structured so each complement is +1 to the normal
|
||||||
|
* one */
|
||||||
|
- return class_number + complement;
|
||||||
|
+ CLEAR_POSIX_WARNINGS_AND_RETURN(class_number + complement);
|
||||||
|
}
|
||||||
|
else if (! check_only) {
|
||||||
|
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,39 @@
|
|||||||
|
From d730a80128abafff1e47e2506c23a8c1a06cfef4 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Sun, 18 Jun 2017 23:44:07 +0200
|
||||||
|
Subject: [PATCH 2/2] add test for [perl #131522] and fix test for (related)
|
||||||
|
[perl #127581]
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/re/reg_mesg.t | 4 ++--
|
||||||
|
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t
|
||||||
|
index 090eccb..a0b78c4 100644
|
||||||
|
--- a/t/re/reg_mesg.t
|
||||||
|
+++ b/t/re/reg_mesg.t
|
||||||
|
@@ -221,7 +221,6 @@ my @death =
|
||||||
|
'/(?[[[::]]])/' => "Syntax error in (?[...]) in regex m/(?[[[::]]])/",
|
||||||
|
'/(?[[[:w:]]])/' => "Syntax error in (?[...]) in regex m/(?[[[:w:]]])/",
|
||||||
|
'/(?[[:w:]])/' => "",
|
||||||
|
- '/[][[:alpha:]]' => "", # [perl #127581]
|
||||||
|
'/([.].*)[.]/' => "", # [perl #127582]
|
||||||
|
'/[.].*[.]/' => "", # [perl #127604]
|
||||||
|
'/(?[a])/' => 'Unexpected character {#} m/(?[a{#}])/',
|
||||||
|
@@ -587,7 +586,8 @@ my @warning = (
|
||||||
|
'Assuming NOT a POSIX class since a semi-colon was found instead of a colon {#} m/[foo;{#}punct;]]\x{100}/',
|
||||||
|
'Assuming NOT a POSIX class since a semi-colon was found instead of a colon {#} m/[foo;punct;]{#}]\x{100}/',
|
||||||
|
],
|
||||||
|
-
|
||||||
|
+ '/[][[:alpha:]]/' => "", # [perl #127581]
|
||||||
|
+ '/[][[:alpha:]\\@\\\\^_?]/' => "", # [perl #131522]
|
||||||
|
); # See comments before this for why '\x{100}' is generally needed
|
||||||
|
|
||||||
|
# These need the character 'ネ' as a marker for mark_as_utf8()
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,32 @@
|
|||||||
|
From e80af1fd276d83858d27742ea887415e3263960b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed, 12 Oct 2016 10:42:47 +1100
|
||||||
|
Subject: [PATCH] (perl 129183) don't treat \ as an escape in PATH for -S
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
util.c | 5 ++---
|
||||||
|
1 file changed, 2 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/util.c b/util.c
|
||||||
|
index 5bb0dfc..6bc2fe5 100644
|
||||||
|
--- a/util.c
|
||||||
|
+++ b/util.c
|
||||||
|
@@ -3352,9 +3352,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
|
||||||
|
if (len < sizeof tmpbuf)
|
||||||
|
tmpbuf[len] = '\0';
|
||||||
|
# else
|
||||||
|
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
|
||||||
|
- ':',
|
||||||
|
- &len);
|
||||||
|
+ s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
|
||||||
|
+ ':', &len);
|
||||||
|
# endif
|
||||||
|
if (s < bufend)
|
||||||
|
s++;
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,299 @@
|
|||||||
|
From 99b847695211f825df6299aa9da91f9494f741e2 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Thu, 1 Jun 2017 15:11:27 +1000
|
||||||
|
Subject: [PATCH] [perl #131221] improve duplication of :via handles
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Previously duplication (as with open ... ">&...") would fail
|
||||||
|
unless the user supplied a GETARG, which wasn't documented, and
|
||||||
|
resulted in an attempt to free and unreferened scalar if supplied.
|
||||||
|
|
||||||
|
Cloning on thread creation was simply broken.
|
||||||
|
|
||||||
|
We now handle GETARG correctly, and provide a useful default if it
|
||||||
|
returns nothing.
|
||||||
|
|
||||||
|
Cloning on thread creation now duplicates the appropriate parts of the
|
||||||
|
parent thread's handle.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
MANIFEST | 1 +
|
||||||
|
ext/PerlIO-via/t/thread.t | 73 +++++++++++++++++++++++++++++++++++++++++++++++
|
||||||
|
ext/PerlIO-via/t/via.t | 56 +++++++++++++++++++++++++++++++++++-
|
||||||
|
ext/PerlIO-via/via.pm | 2 +-
|
||||||
|
ext/PerlIO-via/via.xs | 55 +++++++++++++++++++++++++++++++----
|
||||||
|
5 files changed, 179 insertions(+), 8 deletions(-)
|
||||||
|
create mode 100644 ext/PerlIO-via/t/thread.t
|
||||||
|
|
||||||
|
diff --git a/MANIFEST b/MANIFEST
|
||||||
|
index 8c4950e..d39f992 100644
|
||||||
|
--- a/MANIFEST
|
||||||
|
+++ b/MANIFEST
|
||||||
|
@@ -4056,6 +4056,7 @@ ext/PerlIO-scalar/scalar.xs PerlIO layer for scalars
|
||||||
|
ext/PerlIO-scalar/t/scalar.t See if PerlIO::scalar works
|
||||||
|
ext/PerlIO-scalar/t/scalar_ungetc.t Tests for PerlIO layer for scalars
|
||||||
|
ext/PerlIO-via/hints/aix.pl Hint for PerlIO::via for named architecture
|
||||||
|
+ext/PerlIO-via/t/thread.t See if PerlIO::via works with threads
|
||||||
|
ext/PerlIO-via/t/via.t See if PerlIO::via works
|
||||||
|
ext/PerlIO-via/via.pm PerlIO layer for layers in perl
|
||||||
|
ext/PerlIO-via/via.xs PerlIO layer for layers in perl
|
||||||
|
diff --git a/ext/PerlIO-via/t/thread.t b/ext/PerlIO-via/t/thread.t
|
||||||
|
new file mode 100644
|
||||||
|
index 0000000..e4358f9
|
||||||
|
--- /dev/null
|
||||||
|
+++ b/ext/PerlIO-via/t/thread.t
|
||||||
|
@@ -0,0 +1,73 @@
|
||||||
|
+#!perl
|
||||||
|
+BEGIN {
|
||||||
|
+ unless (find PerlIO::Layer 'perlio') {
|
||||||
|
+ print "1..0 # Skip: not perlio\n";
|
||||||
|
+ exit 0;
|
||||||
|
+ }
|
||||||
|
+ require Config;
|
||||||
|
+ unless ($Config::Config{'usethreads'}) {
|
||||||
|
+ print "1..0 # Skip -- need threads for this test\n";
|
||||||
|
+ exit 0;
|
||||||
|
+ }
|
||||||
|
+ if (($Config::Config{'extensions'} !~ m!\bPerlIO/via\b!) ){
|
||||||
|
+ print "1..0 # Skip -- Perl configured without PerlIO::via module\n";
|
||||||
|
+ exit 0;
|
||||||
|
+ }
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+use strict;
|
||||||
|
+use warnings;
|
||||||
|
+use threads;
|
||||||
|
+
|
||||||
|
+my $tmp = "via$$";
|
||||||
|
+
|
||||||
|
+END {
|
||||||
|
+ 1 while unlink $tmp;
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+use Test::More tests => 2;
|
||||||
|
+
|
||||||
|
+our $push_count = 0;
|
||||||
|
+
|
||||||
|
+{
|
||||||
|
+ open my $fh, ">:via(Test1)", $tmp
|
||||||
|
+ or die "Cannot open $tmp: $!";
|
||||||
|
+ $fh->autoflush;
|
||||||
|
+
|
||||||
|
+ print $fh "AXAX";
|
||||||
|
+
|
||||||
|
+ # previously this would crash
|
||||||
|
+ threads->create(
|
||||||
|
+ sub {
|
||||||
|
+ print $fh "XZXZ";
|
||||||
|
+ })->join;
|
||||||
|
+
|
||||||
|
+ print $fh "BXBX";
|
||||||
|
+ close $fh;
|
||||||
|
+
|
||||||
|
+ open my $in, "<", $tmp;
|
||||||
|
+ my $line = <$in>;
|
||||||
|
+ close $in;
|
||||||
|
+
|
||||||
|
+ is($line, "AYAYYZYZBYBY", "check thread data delivered");
|
||||||
|
+
|
||||||
|
+ is($push_count, 1, "PUSHED not called for dup on thread creation");
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+package PerlIO::via::Test1;
|
||||||
|
+
|
||||||
|
+sub PUSHED {
|
||||||
|
+ my ($class) = @_;
|
||||||
|
+ ++$main::push_count;
|
||||||
|
+ bless {}, $class;
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+sub WRITE {
|
||||||
|
+ my ($self, $data, $fh) = @_;
|
||||||
|
+ $data =~ tr/X/Y/;
|
||||||
|
+ $fh->autoflush;
|
||||||
|
+ print $fh $data;
|
||||||
|
+ return length $data;
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
+
|
||||||
|
diff --git a/ext/PerlIO-via/t/via.t b/ext/PerlIO-via/t/via.t
|
||||||
|
index 6787e11..80577df 100644
|
||||||
|
--- a/ext/PerlIO-via/t/via.t
|
||||||
|
+++ b/ext/PerlIO-via/t/via.t
|
||||||
|
@@ -17,7 +17,7 @@ use warnings;
|
||||||
|
|
||||||
|
my $tmp = "via$$";
|
||||||
|
|
||||||
|
-use Test::More tests => 18;
|
||||||
|
+use Test::More tests => 26;
|
||||||
|
|
||||||
|
my $fh;
|
||||||
|
my $a = join("", map { chr } 0..255) x 10;
|
||||||
|
@@ -84,6 +84,60 @@ is( $obj, 'Foo', 'search for package Foo' );
|
||||||
|
open $fh, '<:via(Bar)', "bar";
|
||||||
|
is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' );
|
||||||
|
|
||||||
|
+{
|
||||||
|
+ # [perl #131221]
|
||||||
|
+ ok(open(my $fh1, ">", $tmp), "open $tmp");
|
||||||
|
+ ok(binmode($fh1, ":via(XXX)"), "binmode :via(XXX) onto it");
|
||||||
|
+ ok(open(my $fh2, ">&", $fh1), "dup it");
|
||||||
|
+ close $fh1;
|
||||||
|
+ close $fh2;
|
||||||
|
+
|
||||||
|
+ # make sure the old workaround still works
|
||||||
|
+ ok(open($fh1, ">", $tmp), "open $tmp");
|
||||||
|
+ ok(binmode($fh1, ":via(YYY)"), "binmode :via(YYY) onto it");
|
||||||
|
+ ok(open($fh2, ">&", $fh1), "dup it");
|
||||||
|
+ print $fh2 "XZXZ";
|
||||||
|
+ close $fh1;
|
||||||
|
+ close $fh2;
|
||||||
|
+
|
||||||
|
+ ok(open($fh1, "<", $tmp), "open $tmp for check");
|
||||||
|
+ { local $/; $b = <$fh1> }
|
||||||
|
+ close $fh1;
|
||||||
|
+ is($b, "XZXZ", "check result is from non-filtering class");
|
||||||
|
+
|
||||||
|
+ package PerlIO::via::XXX;
|
||||||
|
+
|
||||||
|
+ sub PUSHED {
|
||||||
|
+ my $class = shift;
|
||||||
|
+ bless {}, $class;
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+ sub WRITE {
|
||||||
|
+ my ($self, $buffer, $handle) = @_;
|
||||||
|
+
|
||||||
|
+ print $handle $buffer;
|
||||||
|
+ return length($buffer);
|
||||||
|
+ }
|
||||||
|
+ package PerlIO::via::YYY;
|
||||||
|
+
|
||||||
|
+ sub PUSHED {
|
||||||
|
+ my $class = shift;
|
||||||
|
+ bless {}, $class;
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+ sub WRITE {
|
||||||
|
+ my ($self, $buffer, $handle) = @_;
|
||||||
|
+
|
||||||
|
+ $buffer =~ tr/X/Y/;
|
||||||
|
+ print $handle $buffer;
|
||||||
|
+ return length($buffer);
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+ sub GETARG {
|
||||||
|
+ "XXX";
|
||||||
|
+ }
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
END {
|
||||||
|
1 while unlink $tmp;
|
||||||
|
}
|
||||||
|
diff --git a/ext/PerlIO-via/via.pm b/ext/PerlIO-via/via.pm
|
||||||
|
index e477dcc..30083fe 100644
|
||||||
|
--- a/ext/PerlIO-via/via.pm
|
||||||
|
+++ b/ext/PerlIO-via/via.pm
|
||||||
|
@@ -1,5 +1,5 @@
|
||||||
|
package PerlIO::via;
|
||||||
|
-our $VERSION = '0.16';
|
||||||
|
+our $VERSION = '0.17';
|
||||||
|
require XSLoader;
|
||||||
|
XSLoader::load();
|
||||||
|
1;
|
||||||
|
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
|
||||||
|
index 8a7f1fc..61953c8 100644
|
||||||
|
--- a/ext/PerlIO-via/via.xs
|
||||||
|
+++ b/ext/PerlIO-via/via.xs
|
||||||
|
@@ -38,6 +38,8 @@ typedef struct
|
||||||
|
CV *UTF8;
|
||||||
|
} PerlIOVia;
|
||||||
|
|
||||||
|
+static const MGVTBL PerlIOVia_tag = { 0, 0, 0, 0, 0, 0, 0, 0 };
|
||||||
|
+
|
||||||
|
#define MYMethod(x) #x,&s->x
|
||||||
|
|
||||||
|
static CV *
|
||||||
|
@@ -131,8 +133,14 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
|
||||||
|
PerlIO_funcs * tab)
|
||||||
|
{
|
||||||
|
IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
|
||||||
|
+
|
||||||
|
+ if (SvTYPE(arg) >= SVt_PVMG
|
||||||
|
+ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
|
||||||
|
+ return code;
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
if (code == 0) {
|
||||||
|
- PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
|
||||||
|
+ PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
|
||||||
|
if (!arg) {
|
||||||
|
if (ckWARN(WARN_LAYER))
|
||||||
|
Perl_warner(aTHX_ packWARN(WARN_LAYER),
|
||||||
|
@@ -583,20 +591,55 @@ static SV *
|
||||||
|
PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
|
||||||
|
{
|
||||||
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
|
||||||
|
- PERL_UNUSED_ARG(param);
|
||||||
|
+ SV *arg;
|
||||||
|
PERL_UNUSED_ARG(flags);
|
||||||
|
- return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
|
||||||
|
+
|
||||||
|
+ /* During cloning, return an undef token object so that _pushed() knows
|
||||||
|
+ * that it should not call methods and wait for _dup() to actually dup the
|
||||||
|
+ * object. */
|
||||||
|
+ if (param) {
|
||||||
|
+ SV *sv = newSV(0);
|
||||||
|
+ sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOVia_tag, 0, 0);
|
||||||
|
+ return sv;
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+ arg = PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
|
||||||
|
+ if (arg) {
|
||||||
|
+ /* arg is a temp, and PerlIOBase_dup() will explicitly free it */
|
||||||
|
+ SvREFCNT_inc(arg);
|
||||||
|
+ }
|
||||||
|
+ else {
|
||||||
|
+ arg = newSVpvn(HvNAME(s->stash), HvNAMELEN(s->stash));
|
||||||
|
+ }
|
||||||
|
+
|
||||||
|
+ return arg;
|
||||||
|
}
|
||||||
|
|
||||||
|
static PerlIO *
|
||||||
|
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
|
||||||
|
int flags)
|
||||||
|
{
|
||||||
|
- if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
|
||||||
|
- /* Most of the fields will lazily set themselves up as needed
|
||||||
|
- stash and obj have been set up by the implied push
|
||||||
|
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)) && param) {
|
||||||
|
+ /* For a non-interpreter dup stash and obj have been set up
|
||||||
|
+ by the implied push.
|
||||||
|
+
|
||||||
|
+ But if this is a clone for a new interpreter we need to
|
||||||
|
+ translate the objects to their dups.
|
||||||
|
*/
|
||||||
|
+
|
||||||
|
+ PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
|
||||||
|
+ PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
|
||||||
|
+
|
||||||
|
+ fs->obj = sv_dup_inc(os->obj, param);
|
||||||
|
+ fs->stash = (HV*)sv_dup((SV*)os->stash, param);
|
||||||
|
+ fs->var = sv_dup_inc(os->var, param);
|
||||||
|
+ fs->cnt = os->cnt;
|
||||||
|
+
|
||||||
|
+ /* fh, io, cached CVs left as NULL, PerlIOVia_method()
|
||||||
|
+ will reinitialize them if needed */
|
||||||
|
}
|
||||||
|
+ /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
|
||||||
|
+
|
||||||
|
return f;
|
||||||
|
}
|
||||||
|
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,71 @@
|
|||||||
|
From 7b3443d31f11c15859593e5b710c301795a6de01 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Thu, 8 Jun 2017 11:06:39 +1000
|
||||||
|
Subject: [PATCH] [perl #131221] sv_dup/sv_dup_inc are only available under
|
||||||
|
threads
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/PerlIO-via/via.xs | 42 +++++++++++++++++++++++-------------------
|
||||||
|
1 file changed, 23 insertions(+), 19 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
|
||||||
|
index 61953c8..d91c685 100644
|
||||||
|
--- a/ext/PerlIO-via/via.xs
|
||||||
|
+++ b/ext/PerlIO-via/via.xs
|
||||||
|
@@ -619,26 +619,30 @@ static PerlIO *
|
||||||
|
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
|
||||||
|
int flags)
|
||||||
|
{
|
||||||
|
- if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)) && param) {
|
||||||
|
- /* For a non-interpreter dup stash and obj have been set up
|
||||||
|
- by the implied push.
|
||||||
|
-
|
||||||
|
- But if this is a clone for a new interpreter we need to
|
||||||
|
- translate the objects to their dups.
|
||||||
|
- */
|
||||||
|
-
|
||||||
|
- PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
|
||||||
|
- PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
|
||||||
|
-
|
||||||
|
- fs->obj = sv_dup_inc(os->obj, param);
|
||||||
|
- fs->stash = (HV*)sv_dup((SV*)os->stash, param);
|
||||||
|
- fs->var = sv_dup_inc(os->var, param);
|
||||||
|
- fs->cnt = os->cnt;
|
||||||
|
-
|
||||||
|
- /* fh, io, cached CVs left as NULL, PerlIOVia_method()
|
||||||
|
- will reinitialize them if needed */
|
||||||
|
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
|
||||||
|
+#ifdef USE_ITHREADS
|
||||||
|
+ if (param) {
|
||||||
|
+ /* For a non-interpreter dup stash and obj have been set up
|
||||||
|
+ by the implied push.
|
||||||
|
+
|
||||||
|
+ But if this is a clone for a new interpreter we need to
|
||||||
|
+ translate the objects to their dups.
|
||||||
|
+ */
|
||||||
|
+
|
||||||
|
+ PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
|
||||||
|
+ PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
|
||||||
|
+
|
||||||
|
+ fs->obj = sv_dup_inc(os->obj, param);
|
||||||
|
+ fs->stash = (HV*)sv_dup((SV*)os->stash, param);
|
||||||
|
+ fs->var = sv_dup_inc(os->var, param);
|
||||||
|
+ fs->cnt = os->cnt;
|
||||||
|
+
|
||||||
|
+ /* fh, io, cached CVs left as NULL, PerlIOVia_method()
|
||||||
|
+ will reinitialize them if needed */
|
||||||
|
+ }
|
||||||
|
+#endif
|
||||||
|
+ /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
|
||||||
|
}
|
||||||
|
- /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
|
||||||
|
|
||||||
|
return f;
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,37 @@
|
|||||||
|
From 9604fbf0722bd97ca6031a263c50ad52b6633db7 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed, 14 Jun 2017 09:42:31 +1000
|
||||||
|
Subject: [PATCH] (perl #131526) don't go beyond the end of the NUL in my_atof2
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Perl_my_atof2() calls GROK_NUMERIC_RADIX() to detect and skip past
|
||||||
|
a decimal point and then can increment the parse pointer (s) before
|
||||||
|
checking what it points at, so skipping the terminating NUL if the
|
||||||
|
decimal point is immediately before the NUL.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
numeric.c | 4 ++--
|
||||||
|
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/numeric.c b/numeric.c
|
||||||
|
index 6ea6968..5771907 100644
|
||||||
|
--- a/numeric.c
|
||||||
|
+++ b/numeric.c
|
||||||
|
@@ -1485,9 +1485,9 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
|
||||||
|
else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
|
||||||
|
seen_dp = 1;
|
||||||
|
if (sig_digits > MAX_SIG_DIGITS) {
|
||||||
|
- do {
|
||||||
|
+ while (isDIGIT(*s)) {
|
||||||
|
++s;
|
||||||
|
- } while (isDIGIT(*s));
|
||||||
|
+ }
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
@ -0,0 +1,60 @@
|
|||||||
|
From 45908e4d120d33a558a8b052036c56cd0c90b898 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Wed, 13 Sep 2017 13:30:25 +0200
|
||||||
|
Subject: [PATCH] avoid 'the address of ... will always evaluate as ...' warns
|
||||||
|
in mem macros
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
In f14cf363205 we added asserts to our memory macros (Copy(), Zero() etc)
|
||||||
|
to ensure that the target is non-null. These asserts throw warnings like
|
||||||
|
|
||||||
|
perl.c: In function ‘Perl_eval_sv’:
|
||||||
|
perl.c:2976:264: warning: the address of ‘myop’ will always evaluate
|
||||||
|
as ‘true’ [-Waddress]
|
||||||
|
Zero(&myop, 1, UNOP);
|
||||||
|
|
||||||
|
which is annoying. This patch changes how these asserts are coded so
|
||||||
|
we avoid the warning. Thanks to Zefram for the fix.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
handy.h | 17 ++++++++++-------
|
||||||
|
1 file changed, 10 insertions(+), 7 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/handy.h b/handy.h
|
||||||
|
index 31afaae65e..85e8f70721 100644
|
||||||
|
--- a/handy.h
|
||||||
|
+++ b/handy.h
|
||||||
|
@@ -2409,17 +2409,20 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe
|
||||||
|
#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d)))
|
||||||
|
#endif
|
||||||
|
|
||||||
|
-#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
+#define perl_assert_ptr(p) assert( ((void*)(p)) != 0 )
|
||||||
|
|
||||||
|
-#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+
|
||||||
|
+#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
+
|
||||||
|
+#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
#ifdef HAS_MEMSET
|
||||||
|
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
#else
|
||||||
|
/* Using bzero(), which returns void. */
|
||||||
|
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)),d)
|
||||||
|
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), memzero((char*)(d), (n) * sizeof(t)),d)
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)))
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,32 @@
|
|||||||
|
From e7e69c85c7e8e0cb75b831e606ad4f26f18b11ff Mon Sep 17 00:00:00 2001
|
||||||
|
From: Nicolas R <atoomic@cpan.org>
|
||||||
|
Date: Mon, 31 Oct 2016 11:53:17 -0600
|
||||||
|
Subject: [PATCH] Avoid a segfault when untying an object
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Check if the tied object has a stash set
|
||||||
|
before calling UNTIE method.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_sys.c | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index 672e7de08e..6d4dd86b7f 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -1017,7 +1017,7 @@ PP(pp_untie)
|
||||||
|
|
||||||
|
if ((mg = SvTIED_mg(sv, how))) {
|
||||||
|
SV * const obj = SvRV(SvTIED_obj(sv, mg));
|
||||||
|
- if (obj) {
|
||||||
|
+ if (obj && SvSTASH(obj)) {
|
||||||
|
GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
|
||||||
|
CV *cv;
|
||||||
|
if (gv && isGV(gv) && (cv = GvCV(gv))) {
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,34 @@
|
|||||||
|
From 8e7c2faafb74d3b07e8a5818608dfe065e361604 Mon Sep 17 00:00:00 2001
|
||||||
|
From: "Craig A. Berry" <craigberry@mac.com>
|
||||||
|
Date: Mon, 1 Jan 2018 10:10:33 -0600
|
||||||
|
Subject: [PATCH] Reenable numeric first argument of system() on VMS.
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This was broken in 64def2aeaeb63f92dadc6dfa334, and fixed for Win32
|
||||||
|
only in 8fe3452cc6ac7af8c08. But VMS also uses a numeric first
|
||||||
|
argument to system() as a flag indicating spawn without waiting for
|
||||||
|
completion.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_sys.c | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index 0c9147bc4e..5154b9baa8 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -4375,7 +4375,7 @@ PP(pp_system)
|
||||||
|
STRLEN len;
|
||||||
|
char *pv;
|
||||||
|
SvGETMAGIC(origsv);
|
||||||
|
-#ifdef WIN32
|
||||||
|
+#if defined(WIN32) || defined(__VMS)
|
||||||
|
/*
|
||||||
|
* Because of a nasty platform-specific variation on the meaning
|
||||||
|
* of arguments to this op, we must preserve numeric arguments
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,73 @@
|
|||||||
|
From 8fe3452cc6ac7af8c08c2044cd3757018a9c8887 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Zefram <zefram@fysh.org>
|
||||||
|
Date: Fri, 22 Dec 2017 05:32:41 +0000
|
||||||
|
Subject: [PATCH] preserve numericness of system() args on Win32
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
On Windows there's a nasty variation in the meaning of arguments
|
||||||
|
to Perl's system(), in which a numeric first argument isn't used as
|
||||||
|
part of the command to run, but instead selects between two different
|
||||||
|
operations to perform with the command (whether to wait for the command
|
||||||
|
to complete or not). Therefore the reduction of argument scalars to
|
||||||
|
their operative values in the parent process, which was added in commit
|
||||||
|
64def2aeaeb63f92dadc6dfa33486c1d7b311963, needs to preserve numericness
|
||||||
|
of arguments on Windows. Fixes [perl #132633].
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_sys.c | 35 +++++++++++++++++++++++++++++++----
|
||||||
|
1 file changed, 31 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index beb60da4c6..0649794104 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -4393,12 +4393,39 @@ PP(pp_system)
|
||||||
|
# endif
|
||||||
|
|
||||||
|
while (++MARK <= SP) {
|
||||||
|
- SV *origsv = *MARK;
|
||||||
|
+ SV *origsv = *MARK, *copysv;
|
||||||
|
STRLEN len;
|
||||||
|
char *pv;
|
||||||
|
- pv = SvPV(origsv, len);
|
||||||
|
- *MARK = newSVpvn_flags(pv, len,
|
||||||
|
- (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
|
||||||
|
+ SvGETMAGIC(origsv);
|
||||||
|
+#ifdef WIN32
|
||||||
|
+ /*
|
||||||
|
+ * Because of a nasty platform-specific variation on the meaning
|
||||||
|
+ * of arguments to this op, we must preserve numeric arguments
|
||||||
|
+ * as numeric, not just retain the string value.
|
||||||
|
+ */
|
||||||
|
+ if (SvNIOK(origsv) || SvNIOKp(origsv)) {
|
||||||
|
+ copysv = newSV_type(SVt_PVNV);
|
||||||
|
+ sv_2mortal(copysv);
|
||||||
|
+ if (SvPOK(origsv) || SvPOKp(origsv)) {
|
||||||
|
+ pv = SvPV_nomg(origsv, len);
|
||||||
|
+ sv_setpvn(copysv, pv, len);
|
||||||
|
+ SvPOK_off(copysv);
|
||||||
|
+ }
|
||||||
|
+ if (SvIOK(origsv) || SvIOKp(origsv))
|
||||||
|
+ SvIV_set(copysv, SvIVX(origsv));
|
||||||
|
+ if (SvNOK(origsv) || SvNOKp(origsv))
|
||||||
|
+ SvNV_set(copysv, SvNVX(origsv));
|
||||||
|
+ SvFLAGS(copysv) |= SvFLAGS(origsv) &
|
||||||
|
+ (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK|
|
||||||
|
+ SVf_UTF8|SVf_IVisUV);
|
||||||
|
+ } else
|
||||||
|
+#endif
|
||||||
|
+ {
|
||||||
|
+ pv = SvPV_nomg(origsv, len);
|
||||||
|
+ copysv = newSVpvn_flags(pv, len,
|
||||||
|
+ (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
|
||||||
|
+ }
|
||||||
|
+ *MARK = copysv;
|
||||||
|
}
|
||||||
|
MARK = ORIGMARK;
|
||||||
|
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
@ -0,0 +1,61 @@
|
|||||||
|
From f6bc8fb3d26892ba1a84ba2df76beedd51998dd2 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Mon, 29 Jan 2018 16:34:17 +0100
|
||||||
|
Subject: [PATCH] hints/linux: Add -lphtread to lddlflags
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Passing -z defs to linker flags causes perl to fail to build if threads are
|
||||||
|
enabled:
|
||||||
|
|
||||||
|
gcc -shared -Wl,-z,relro -Wl,-z,defs -specs=/usr/lib/rpm/redhat/redhat-hardened-ld -L/usr/local/lib -fstack-protector-strong Bzip2.o -o ../../lib/auto/Compress/Raw/Bzip2/Bzip2.so \
|
||||||
|
-L/usr/lib64 -lbz2 "-L../.." -lperl \
|
||||||
|
|
||||||
|
Bzip2.o: In function `deRef':
|
||||||
|
/builddir/build/BUILD/perl-5.26.1/cpan/Compress-Raw-Bzip2/Bzip2.xs:256: undefined reference to `pthread_getspecific'
|
||||||
|
|
||||||
|
The reason is Bzip2.xs calls dTHX macro included from thread.h via perl.h that
|
||||||
|
expands to pthread_getspecific() function call that is defined in pthread
|
||||||
|
library. But the pthread library is not explicitly linked to Bzip.so (see the
|
||||||
|
gcc command). This is exactly what -z defs linker flag enforces.
|
||||||
|
|
||||||
|
Underlinking ELFs can be dangerous because in case of versioned
|
||||||
|
symbols it can cause run-time binding to an improper version symbol or
|
||||||
|
even to an symbold from different library.
|
||||||
|
|
||||||
|
This patch fixes hints for Linux by adding -lpthreads to lddlflags. It
|
||||||
|
also adds -shared there because Configure.sh adds it only hints return
|
||||||
|
lddlflags empty.
|
||||||
|
|
||||||
|
<https://lists.fedoraproject.org/archives/list/devel@lists.fedoraproject.org/message/3RHZEHLRUHJFF2XGHI5RB6YPDNLDR4HG/>
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
hints/linux.sh | 4 ++++
|
||||||
|
1 file changed, 4 insertions(+)
|
||||||
|
|
||||||
|
diff --git a/hints/linux.sh b/hints/linux.sh
|
||||||
|
index 3f38ea07f1..9ec3bc02ef 100644
|
||||||
|
--- a/hints/linux.sh
|
||||||
|
+++ b/hints/linux.sh
|
||||||
|
@@ -353,12 +353,16 @@ if [ -f /etc/synoinfo.conf -a -d /usr/syno ]; then
|
||||||
|
echo "$libswanted" >&4
|
||||||
|
fi
|
||||||
|
|
||||||
|
+# Flags needed to produce shared libraries.
|
||||||
|
+lddlflags='-shared'
|
||||||
|
+
|
||||||
|
# This script UU/usethreads.cbu will get 'called-back' by Configure
|
||||||
|
# after it has prompted the user for whether to use threads.
|
||||||
|
cat > UU/usethreads.cbu <<'EOCBU'
|
||||||
|
case "$usethreads" in
|
||||||
|
$define|true|[yY]*)
|
||||||
|
ccflags="-D_REENTRANT -D_GNU_SOURCE $ccflags"
|
||||||
|
+ lddlflags="-lpthread $lddlflags"
|
||||||
|
if echo $libswanted | grep -v pthread >/dev/null
|
||||||
|
then
|
||||||
|
set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user