Compare commits

...

41 Commits
master ... f26

Author SHA1 Message Date
Petr Písař 9acafa0017 5.24.4 bump 2018-04-16 15:53:36 +02:00
Petr Písař ed84ca79fb Correct ldconfig_scriptlets invocation 2018-02-09 12:49:31 +01:00
Petr Písař af584242cb Call ldconfig scriptlets using a macro 2018-02-09 12:48:53 +01:00
Petr Písař 7dc2be1a40 Teach rpmlint 2018-02-09 12:47:53 +01:00
Petr Písař 1513c70404 Fix parsing braced subscript after parentheses 2018-02-09 12:47:51 +01:00
Petr Písař 6a8ffe8306 Correct shell bangs in tests
Again we cannot do it in prep because the tests would execute perl
from the system during check phase.
2018-02-09 12:36:34 +01:00
Petr Písař add9802af3 Link XS modules to pthread library to fix linking with -z defs
This changes lddlflags. Maybe we should change ExtUtils::CBuilder etc.
instead as we do in Link-XS-modules-to-libperl.so patches to link to
libperl.so explictly.
2018-02-09 12:36:34 +01:00
Petr Písař 5f908d3dad Move guard_old_libcrypt_fix patch 2018-02-09 12:36:26 +01:00
Björn Esser a16306bdad Add patch to conditionalize a fix for an old and long fixed bug
in libcrypt / glibc (rhbz#1536752)
2018-02-08 17:48:02 +01:00
Petr Písař 03a611eadc Avoid undefined behavior when copying memory in Glob and pp_caller (RT#131746) 2018-02-08 17:39:37 +01:00
Petr Písař 3a55cfeede Expand system() arguments before a fork 2018-02-08 17:36:30 +01:00
Petr Písař 7ec83d774e Fix tainting of s/// with overloaded replacement 2018-02-08 17:23:37 +01:00
Petr Písař 70ede7b722 Fix setting $! when statting a closed filehandle 2018-02-08 17:07:00 +01:00
Petr Písař 3fc1541175 Fix stack manipulation when a lexical subroutine is defined in a do block in as a member of an iteration list 2018-02-08 16:52:32 +01:00
Petr Písař 7b312973a6 Fix error reporting on do() on a directory 2018-02-08 16:24:49 +01:00
Petr Písař 68ee54ae7c Fix deparsing of transliterations with unprintable characters 2018-02-08 16:20:31 +01:00
Petr Písař d8c6281129 Fix a crash when untying an object witout a stash 2018-02-08 16:08:46 +01:00
Petr Písař 72ef0117ba Fix an overflow when parsing a character range with no preceding character 2018-02-08 16:06:31 +01:00
Petr Písař ba9487de02 Fix walking symbol table for ISA in Carp 2018-02-08 15:50:45 +01:00
Petr Písař 365c36a6b1 Fix an overflow when parsing a character range with no preceding character 2018-02-08 15:19:46 +01:00
Petr Písař 8ef95dada9 Fix a crash when a match for inversely repeated group fails 2018-02-08 14:51:02 +01:00
Petr Písař c8a361caf9 Remove invalid macro definitions from macros.perl
From: Panu Matilainen <pmatilai@redhat.com>

These two lines are trying to redefine macro named "global", which is
obviously wrong, but additionally the thing they're *trying* to do is also
wrong in rpm >= 4.9 world, so best just remove them.
2018-02-08 12:31:50 +01:00
Petr Písař 72f7aefbc2 Link libresolv.patch to a bug report 2018-02-08 12:27:49 +01:00
Petr Písař d029d1fe21 Fix handling attribute specification on our variables 2018-02-08 10:59:48 +01:00
Petr Písař ed7f4943ca Remove obsolete Group tags 2018-02-06 16:40:48 +01:00
Jitka Plesnikova f0b226fcd5 Update perl(:MODULE_COMPAT_*) 2017-09-25 16:14:48 +02:00
Jitka Plesnikova 0bfe068e00 5.24.3 bump 2017-09-25 14:21:15 +02:00
Jitka Plesnikova a4c750bfc3 Remove unused patch; Fixed version in changelog 2017-07-17 15:00:30 +02:00
Jitka Plesnikova 58632ac371 5.24.2 bump 2017-07-17 13:42:05 +02:00
Petr Písař 1996df3a7d Provide perl-interpreter RPM dependency symbol
The perl-interpreter will turn into a normal package in the future.
2017-06-19 17:51:31 +02:00
Petr Písař a6ed865e85 Fix spurious "Assuming NOT a POSIX class" warning 2017-06-19 17:50:32 +02:00
Petr Písař 16e15391b2 Fix a conditional jump on uninitilized memory in re_intuit_start() 2017-06-19 17:42:41 +02:00
Petr Písař d2b13403e6 Fix handling backslashes in PATH environment variable when executing "perl -S" 2017-06-19 17:38:22 +02:00
Petr Písař 466f7336ba Fix checks for tainted directory in $ENV{PATH} if a backslash escape presents 2017-06-19 17:32:34 +02:00
Petr Písař 068fd059be Fix a buffer overflow in my_atof2() 2017-06-19 16:53:32 +02:00
Petr Písař c297bdefcd Fix UTF-8 flag on a glob reassignment 2017-06-19 16:51:09 +02:00
Petr Písař 43027d83df Fix cloning :via handles on thread creation 2017-06-19 16:43:19 +02:00
Petr Písař 0f8b73dfcd Fix improper casting of a negative interger to unsigned eith-bit type 2017-06-19 16:35:28 +02:00
Petr Písař 12af1e2279 Fix a crash when calling a subroutine from a stash 2017-06-19 16:31:46 +02:00
Petr Písař 1a87698423 Fix a memory wrap in sv_vcatpvfn_flags() 2017-06-19 16:20:59 +02:00
Petr Písař 5ef9dfa611 Make File::Glob more resistant against degenerative matching 2017-06-19 15:30:59 +02:00
56 changed files with 8030 additions and 1131 deletions

4
.gitignore vendored
View File

@ -23,3 +23,7 @@ perl-5.12.1.tar.gz
/perl-5.22.2.tar.bz2
/perl-5.24.0.tar.bz2
/perl-5.24.1.tar.bz2
/perl-5.24.2.tar.bz2
/perl-5.24.3.tar.bz2
/perl-5.24.4-RC1.tar.bz2
/perl-5.24.4.tar.bz2

View File

@ -1,2 +1,2 @@
from Config import *
addFilter("spelling-error .* (awk|groff|sed)");
addFilter("spelling-error .* (awk|groff|metapackage|sed|usr)");

View File

@ -67,14 +67,14 @@ Provides: perl(B) = 1.62 \
Provides: perl(B::Concise) = 0.996 \
Provides: perl(B::Deparse) = 1.37 \
Provides: perl(B::OBJECT) \
Provides: perl(B::Op_private) = 5.024000 \
Provides: perl(B::Op_private) = 5.024004 \
Provides: perl(B::Showlex) = 1.05 \
Provides: perl(B::Terse) = 1.06 \
Provides: perl(B::Xref) = 1.05 \
Provides: perl(Benchmark) = 1.22 \
Provides: perl(Class::Struct) = 0.65 \
Provides: perl(Class::Struct::Tie_ISA) \
Provides: perl(Config) = 5.024000 \
Provides: perl(Config) = 5.024004 \
Provides: perl(Config::Extensions) = 0.01 \
Provides: perl(DB) = 1.08 \
Provides: perl(DBM_Filter) = 0.06 \
@ -140,7 +140,7 @@ Provides: perl(PerlIO) = 1.09 \
Provides: perl(PerlIO::encoding) = 0.24 \
Provides: perl(PerlIO::mmap) = 0.016 \
Provides: perl(PerlIO::scalar) = 0.24 \
Provides: perl(PerlIO::via) = 0.16 \
Provides: perl(PerlIO::via) = 0.17 \
Provides: perl(Pod::Functions) = 1.10 \
Provides: perl(SDBM_File) = 1.14 \
Provides: perl(Safe) = 2.39 \
@ -213,7 +213,7 @@ Provides: perl(subs) = 1.02 \
Provides: perl(vars) = 1.03 \
Provides: perl(vmsish) = 1.04 \
Provides: perl(warnings::register) = 1.04 \
Provides: perl(x86-64) = 4:5.24.0-364.fc25 \
Provides: perl(x86-64) = 4:5.24.4-397.RC1.fc26 \
%{nil}
%global gendep_perl_Archive_Tar \
Requires: perl(:VERSION) >= 5.5.0 \
@ -1167,9 +1167,9 @@ Requires: perl(strict) \
Requires: perl(vars) \
Requires: perl(version) \
Requires: perl(warnings) \
Provides: perl(Module::CoreList) = 5.20160506 \
Provides: perl(Module::CoreList::TieHashDelta) = 5.20160506 \
Provides: perl(Module::CoreList::Utils) = 5.20160506 \
Provides: perl(Module::CoreList) = 5.20180414 \
Provides: perl(Module::CoreList::TieHashDelta) = 5.20180414 \
Provides: perl(Module::CoreList::Utils) = 5.20180414 \
%{nil}
%global gendep_perl_Module_CoreList_tools \
Requires: perl(Getopt::Long) \
@ -1311,7 +1311,7 @@ Requires: perl(parent) \
Requires: perl(strict) \
Requires: perl(vars) \
Requires: perl(warnings) \
Provides: perl(Pod::Html) = 1.22 \
Provides: perl(Pod::Html) = 1.2201 \
Provides: perl(Pod::Simple::XHTML::LocalPodLinks) \
%{nil}
%global gendep_perl_Pod_Parser \
@ -1699,7 +1699,7 @@ Provides: perl(Thread::Queue) = 3.09 \
Requires: perl(DynaLoader) \
Requires: perl(Exporter) \
Requires: perl(strict) \
Provides: perl(Time::HiRes) = 1.9733 \
Provides: perl(Time::HiRes) = 1.9741 \
%{nil}
%global gendep_perl_Time_Local \
Requires: perl(Carp) \
@ -1885,7 +1885,11 @@ Requires: perl(integer) \
Requires: perl(strict) \
Requires: perl(warnings) \
Provides: perl(:MODULE_COMPAT_5.24.0) \
Provides: perl(:VERSION) = 5.24.0 \
Provides: perl(:MODULE_COMPAT_5.24.1) \
Provides: perl(:MODULE_COMPAT_5.24.2) \
Provides: perl(:MODULE_COMPAT_5.24.3) \
Provides: perl(:MODULE_COMPAT_5.24.4) \
Provides: perl(:VERSION) = 5.24.4 \
Provides: perl(:WITH_ITHREADS) \
Provides: perl(:WITH_LARGEFILES) \
Provides: perl(:WITH_PERLIO) \

View File

@ -30,10 +30,6 @@ export PERL_MM_USE_DEFAULT=1
%perl_default_filter_revision 3
# Perl provides/requeries are generated by external generators.
%global __perl_provides /usr/lib/rpm/perl.prov
%global __perl_requires /usr/lib/rpm/perl.req
# 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

View File

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

View File

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

View File

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

View File

@ -65,14 +65,14 @@ index 26a78c7..c039cc4 100644
require './loc_tools.pl';
}
-plan( tests => 270 );
+plan( tests => 271 );
-plan( tests => 271 );
+plan( tests => 272 );
$_ = 'david';
$a = s/david/rules/r;
@@ -1102,3 +1102,18 @@ SKIP: {
$s =~ s/..\G//g;
is($s, "\x{123}", "#RT 126260 gofs");
@@ -1119,3 +1119,15 @@ SKIP: {
{stderr => 1 },
'[perl #129038 ] s/\xff//l no longer crashes');
}
+
+# [perl #130188] crash on return from substitution in subroutine

View File

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

View File

@ -71,8 +71,8 @@ index c515449..9ada592 100644
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 25);
+plan(tests => 26);
-plan(tests => 26);
+plan(tests => 27);
{
no warnings 'deprecated';

View File

@ -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

View File

@ -28,12 +28,12 @@ index 9ada592..d679d7c 100644
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 26);
+plan(tests => 27);
-plan(tests => 27);
+plan(tests => 28);
{
no warnings 'deprecated';
@@ -216,3 +216,16 @@ fresh_perl_like(
@@ -223,3 +223,16 @@ fresh_perl_like(
{},
'[perl #129336] - #!perl -i argument handling'
);

View File

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

View File

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

View File

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

View File

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

View 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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View 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

View File

@ -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

View File

@ -1,4 +1,4 @@
From bf4a926a29374161655548b149d1cb37300bcc05 Mon Sep 17 00:00:00 2001
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"...
@ -6,6 +6,13 @@ 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 +-
@ -13,10 +20,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
2 files changed, 13 insertions(+), 2 deletions(-)
diff --git a/pp_pack.c b/pp_pack.c
index ee4c69e..737e019 100644
index c0de5ab..29fdb01 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2587,7 +2587,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
@@ -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:
@ -26,21 +33,21 @@ index ee4c69e..737e019 100644
SvCUR_set(cat, cur - start);
diff --git a/t/op/pack.t b/t/op/pack.t
index 3fc12e4..47d1216 100644
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 => 14712;
+plan tests => 14713;
-plan tests => 14716;
+plan tests => 14717;
use strict;
use warnings qw(FATAL all);
@@ -2047,3 +2047,14 @@ ok(1, "argument underflow did not crash");
is(pack("H40", $up_nul), $twenty_nuls,
"check pack H zero fills (utf8 source)");
@@ -2066,3 +2066,14 @@ SKIP:
fresh_perl_like('pack "c10f1073741824"', qr/Out of memory during pack/, { stderr => 1 },
"integer overflow calculating allocation (multiply)");
}
+
+{
@ -54,5 +61,5 @@ index 3fc12e4..47d1216 100644
+EOS
+}
--
2.7.4
2.14.3

View File

@ -1,4 +1,4 @@
From 30be69c851a7fa7e29d85c9b6e070273df82f3e7 Mon Sep 17 00:00:00 2001
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
@ -8,17 +8,24 @@ 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 47d1216..919e4c5 100644
index cf5ae78..e399f7e 100644
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -2048,6 +2048,7 @@ ok(1, "argument underflow did not crash");
"check pack H zero fills (utf8 source)");
@@ -2067,6 +2067,7 @@ SKIP:
"integer overflow calculating allocation (multiply)");
}
+SKIP:
@ -26,5 +33,5 @@ index 47d1216..919e4c5 100644
# [perl #129149] the code below would write one past the end of the output
# buffer, only detected by ASAN, not by valgrind
--
2.7.4
2.14.3

View File

@ -1,4 +1,4 @@
From 62130748594f803da49b6abf3e352e51148a3886 Mon Sep 17 00:00:00 2001
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
@ -6,7 +6,7 @@ MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.24.0:
Ported to 5.24.4:
commit 2814f4b3549f665a6f9203ac9e890ae1e415e0dc
Author: Hugo van der Sanden <hv@crypt.org>
@ -26,7 +26,7 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
2 files changed, 3 insertions(+), 1 deletion(-)
diff --git a/regexec.c b/regexec.c
index cdaa95c..38ff44a 100644
index ff8e89c..6904546 100644
--- a/regexec.c
+++ b/regexec.c
@@ -703,7 +703,8 @@ Perl_re_intuit_start(pTHX_
@ -40,17 +40,17 @@ index cdaa95c..38ff44a 100644
check = prog->check_utf8;
} else {
diff --git a/t/re/re_tests b/t/re/re_tests
index 7e8522d..2f4d00c 100644
index ab7ddbb..8b0feaa 100644
--- a/t/re/re_tests
+++ b/t/re/re_tests
@@ -1968,6 +1968,7 @@ ab(?#Comment){2}c abbc y $& abbc
(?:.||)(?|)000000000@ 000000000@ y $& 000000000@ # [perl #126405]
@@ -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.7.4
2.14.3

View File

@ -1,4 +1,4 @@
From 95ec90ac7c7c5fb158401eb65721bbeaae1949ab Mon Sep 17 00:00:00 2001
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
@ -6,7 +6,7 @@ MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Pisar: Ported to 5.24.0:
Petr Pisar: Ported to 5.24.4:
commit d3c48e81594c1d64ba9833495e45d8951b42027c
Author: Hugo van der Sanden <hv@crypt.org>
@ -25,10 +25,10 @@ Signed-off-by: Petr Písař <ppisar@redhat.com>
2 files changed, 2 insertions(+)
diff --git a/regexec.c b/regexec.c
index 38ff44a..a5d5db4 100644
index 6904546..25ea3a3 100644
--- a/regexec.c
+++ b/regexec.c
@@ -7322,6 +7322,7 @@ NULL
@@ -7334,6 +7334,7 @@ NULL
DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: (cache) already tried at this position...\n",
depth)
);
@ -37,17 +37,17 @@ index 38ff44a..a5d5db4 100644
}
ST.cache_offset = offset;
diff --git a/t/re/re_tests b/t/re/re_tests
index 2f4d00c..c81f67f 100644
index 8b0feaa..6717b85 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
@@ -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.7.4
2.14.3

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View 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

View 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
}

View File

@ -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

View File

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

View File

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

View File

@ -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

View File

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

View File

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

View File

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

View File

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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

432
perl.spec

File diff suppressed because it is too large Load Diff

View File

@ -1 +1 @@
SHA512 (perl-5.24.1.tar.bz2) = 5a6e5f5fcd65e7add7ba2126d530a8e2a912cb076cfe61bbf7e49b28e4e63aa0d474183a6f8a388c67d03ea6a44f367efb3b3a768e971ef52b769e737eeb048b
SHA512 (perl-5.24.4.tar.bz2) = 3bae714aaa3ac81f4be09c24cf708f339253b2cd3f6195cf60bf91e0e8a025a226ba527c11dfabdba33a642ce885c4c1979b9602367a6915a32a2b4c2c64bb38