Compare commits
41 Commits
Author | SHA1 | Date |
---|---|---|
Petr Písař | 9acafa0017 | |
Petr Písař | ed84ca79fb | |
Petr Písař | af584242cb | |
Petr Písař | 7dc2be1a40 | |
Petr Písař | 1513c70404 | |
Petr Písař | 6a8ffe8306 | |
Petr Písař | add9802af3 | |
Petr Písař | 5f908d3dad | |
Björn Esser | a16306bdad | |
Petr Písař | 03a611eadc | |
Petr Písař | 3a55cfeede | |
Petr Písař | 7ec83d774e | |
Petr Písař | 70ede7b722 | |
Petr Písař | 3fc1541175 | |
Petr Písař | 7b312973a6 | |
Petr Písař | 68ee54ae7c | |
Petr Písař | d8c6281129 | |
Petr Písař | 72ef0117ba | |
Petr Písař | ba9487de02 | |
Petr Písař | 365c36a6b1 | |
Petr Písař | 8ef95dada9 | |
Petr Písař | c8a361caf9 | |
Petr Písař | 72f7aefbc2 | |
Petr Písař | d029d1fe21 | |
Petr Písař | ed7f4943ca | |
Jitka Plesnikova | f0b226fcd5 | |
Jitka Plesnikova | 0bfe068e00 | |
Jitka Plesnikova | a4c750bfc3 | |
Jitka Plesnikova | 58632ac371 | |
Petr Písař | 1996df3a7d | |
Petr Písař | a6ed865e85 | |
Petr Písař | 16e15391b2 | |
Petr Písař | d2b13403e6 | |
Petr Písař | 466f7336ba | |
Petr Písař | 068fd059be | |
Petr Písař | c297bdefcd | |
Petr Písař | 43027d83df | |
Petr Písař | 0f8b73dfcd | |
Petr Písař | 12af1e2279 | |
Petr Písař | 1a87698423 | |
Petr Písař | 5ef9dfa611 |
|
@ -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
|
||||
|
|
2
.rpmlint
2
.rpmlint
|
@ -1,2 +1,2 @@
|
|||
from Config import *
|
||||
addFilter("spelling-error .* (awk|groff|sed)");
|
||||
addFilter("spelling-error .* (awk|groff|metapackage|sed|usr)");
|
||||
|
|
|
@ -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) \
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
@ -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';
|
||||
|
|
|
@ -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
|
||||
|
|
@ -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'
|
||||
);
|
||||
|
|
|
@ -0,0 +1,61 @@
|
|||
From cba9aa759f7ce8a4a80e748eb451f679042cd74b Mon Sep 17 00:00:00 2001
|
||||
From: Father Chrysostomos <sprout@cpan.org>
|
||||
Date: Fri, 7 Apr 2017 14:08:02 -0700
|
||||
Subject: [PATCH] Crash with sub-in-stash
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Ported to 5.24.1:
|
||||
|
||||
commit 790acddeaa0d2c73524596048b129561225cf100
|
||||
Author: Father Chrysostomos <sprout@cpan.org>
|
||||
Date: Fri Apr 7 14:08:02 2017 -0700
|
||||
|
||||
[perl #131085] Crash with sub-in-stash
|
||||
|
||||
$ perl -e '$::{"A"} = sub {}; \&{"A"}'
|
||||
Segmentation fault (core dumped)
|
||||
|
||||
The code that vivifies a typeglob out of a code ref assumed that the
|
||||
CV had a name hek, which is always the case when perl itself puts the
|
||||
code ref there (via ‘sub A{}’), but is not necessarily the case if
|
||||
someone is insinuating other stuff into the stash.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
gv.c | 2 +-
|
||||
t/op/gv.t | 4 ++++
|
||||
2 files changed, 5 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/gv.c b/gv.c
|
||||
index 3fda9b9..6690b64 100644
|
||||
--- a/gv.c
|
||||
+++ b/gv.c
|
||||
@@ -421,7 +421,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
|
||||
/* Not actually a constant. Just a regular sub. */
|
||||
CV * const cv = (CV *)has_constant;
|
||||
GvCV_set(gv,cv);
|
||||
- if (CvSTASH(cv) == stash && (
|
||||
+ if (CvNAMED(cv) && CvSTASH(cv) == stash && (
|
||||
CvNAME_HEK(cv) == GvNAME_HEK(gv)
|
||||
|| ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
|
||||
&& HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
|
||||
diff --git a/t/op/gv.t b/t/op/gv.t
|
||||
index 03ae46e..cdaaef5 100644
|
||||
--- a/t/op/gv.t
|
||||
+++ b/t/op/gv.t
|
||||
@@ -1170,6 +1170,10 @@ SKIP: {
|
||||
is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
|
||||
}
|
||||
|
||||
+# [perl #131085] This used to crash; no ok() necessary.
|
||||
+$::{"A131085"} = sub {}; \&{"A131085"};
|
||||
+
|
||||
+
|
||||
__END__
|
||||
Perl
|
||||
Rules
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,266 @@
|
|||
From 30cba075ecbb662b392b2c6e896dec287ea49aa8 Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Tue, 25 Apr 2017 15:17:06 +0200
|
||||
Subject: [PATCH] fixup File::Glob degenerate matching
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Ported to 5.24.1:
|
||||
|
||||
commit 0db967b2e6a4093a6a5f649190159767e5d005e0
|
||||
Author: Yves Orton <demerphq@gmail.com>
|
||||
Date: Tue Apr 25 15:17:06 2017 +0200
|
||||
|
||||
[perl #131211] fixup File::Glob degenerate matching
|
||||
|
||||
The old code would go quadratic with recursion and backtracking
|
||||
when doing patterns like "a*a*a*a*a*a*a*x" on a file like
|
||||
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa".
|
||||
|
||||
This patch changes the code to not recurse, and to not backtrack,
|
||||
as per this article from Russ Cox: https://research.swtch.com/glob
|
||||
|
||||
It also adds a micro-optimisation for M_ONE and M_SET under the new code.
|
||||
|
||||
Thanks to Avar and Russ Cox for helping with this patch, along with
|
||||
Jilles Tjoelker and the rest of the FreeBSD community.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 1 +
|
||||
ext/File-Glob/bsd_glob.c | 64 +++++++++++++++++++++++--------
|
||||
ext/File-Glob/t/rt131211.t | 94 ++++++++++++++++++++++++++++++++++++++++++++++
|
||||
3 files changed, 144 insertions(+), 15 deletions(-)
|
||||
create mode 100644 ext/File-Glob/t/rt131211.t
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index fe045a7..be2a44f 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -3678,6 +3678,7 @@ ext/File-Glob/t/case.t See if File::Glob works
|
||||
ext/File-Glob/t/global.t See if File::Glob works
|
||||
ext/File-Glob/TODO File::Glob extension todo list
|
||||
ext/File-Glob/t/rt114984.t See if File::Glob works
|
||||
+ext/File-Glob/t/rt131211.t See if File::Glob works
|
||||
ext/File-Glob/t/taint.t See if File::Glob works
|
||||
ext/File-Glob/t/threads.t See if File::Glob + threads works
|
||||
ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
|
||||
diff --git a/ext/File-Glob/bsd_glob.c b/ext/File-Glob/bsd_glob.c
|
||||
index 821ef20..e96fb73 100644
|
||||
--- a/ext/File-Glob/bsd_glob.c
|
||||
+++ b/ext/File-Glob/bsd_glob.c
|
||||
@@ -563,8 +563,12 @@ glob0(const Char *pattern, glob_t *pglob)
|
||||
break;
|
||||
case BG_STAR:
|
||||
pglob->gl_flags |= GLOB_MAGCHAR;
|
||||
- /* collapse adjacent stars to one,
|
||||
- * to avoid exponential behavior
|
||||
+ /* Collapse adjacent stars to one.
|
||||
+ * This is required to ensure that a pattern like
|
||||
+ * "a**" matches a name like "a", as without this
|
||||
+ * check when the first star matched everything it would
|
||||
+ * cause the second star to return a match fail.
|
||||
+ * As long ** is folded here this does not happen.
|
||||
*/
|
||||
if (bufnext == patbuf || bufnext[-1] != M_ALL)
|
||||
*bufnext++ = M_ALL;
|
||||
@@ -909,35 +913,56 @@ globextend(const Char *path, glob_t *pglob, size_t *limitp)
|
||||
|
||||
|
||||
/*
|
||||
- * pattern matching function for filenames. Each occurrence of the *
|
||||
- * pattern causes a recursion level.
|
||||
+ * pattern matching function for filenames using state machine to avoid
|
||||
+ * recursion. We maintain a "nextp" and "nextn" to allow us to backtrack
|
||||
+ * without additional callframes, and to do cleanly prune the backtracking
|
||||
+ * state when multiple '*' (start) matches are included in the patter.
|
||||
+ *
|
||||
+ * Thanks to Russ Cox for the improved state machine logic to avoid quadratic
|
||||
+ * matching on failure.
|
||||
+ *
|
||||
+ * https://research.swtch.com/glob
|
||||
+ *
|
||||
+ * An example would be a pattern
|
||||
+ * ("a*" x 100) . "y"
|
||||
+ * against a file name like
|
||||
+ * ("a" x 100) . "x"
|
||||
+ *
|
||||
*/
|
||||
static int
|
||||
match(Char *name, Char *pat, Char *patend, int nocase)
|
||||
{
|
||||
int ok, negate_range;
|
||||
Char c, k;
|
||||
+ Char *nextp = NULL;
|
||||
+ Char *nextn = NULL;
|
||||
|
||||
+ loop:
|
||||
while (pat < patend) {
|
||||
c = *pat++;
|
||||
switch (c & M_MASK) {
|
||||
case M_ALL:
|
||||
if (pat == patend)
|
||||
return(1);
|
||||
- do
|
||||
- if (match(name, pat, patend, nocase))
|
||||
- return(1);
|
||||
- while (*name++ != BG_EOS)
|
||||
- ;
|
||||
- return(0);
|
||||
+ if (*name == BG_EOS)
|
||||
+ return 0;
|
||||
+ nextn = name + 1;
|
||||
+ nextp = pat - 1;
|
||||
+ break;
|
||||
case M_ONE:
|
||||
+ /* since * matches leftmost-shortest first *
|
||||
+ * if we encounter the EOS then backtracking *
|
||||
+ * will not help, so we can exit early here. */
|
||||
if (*name++ == BG_EOS)
|
||||
- return(0);
|
||||
+ return 0;
|
||||
break;
|
||||
case M_SET:
|
||||
ok = 0;
|
||||
+ /* since * matches leftmost-shortest first *
|
||||
+ * if we encounter the EOS then backtracking *
|
||||
+ * will not help, so we can exit early here. */
|
||||
if ((k = *name++) == BG_EOS)
|
||||
- return(0);
|
||||
+ return 0;
|
||||
if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS)
|
||||
++pat;
|
||||
while (((c = *pat++) & M_MASK) != M_END)
|
||||
@@ -953,16 +978,25 @@ match(Char *name, Char *pat, Char *patend, int nocase)
|
||||
} else if (nocase ? (tolower(c) == tolower(k)) : (c == k))
|
||||
ok = 1;
|
||||
if (ok == negate_range)
|
||||
- return(0);
|
||||
+ goto fail;
|
||||
break;
|
||||
default:
|
||||
k = *name++;
|
||||
if (nocase ? (tolower(k) != tolower(c)) : (k != c))
|
||||
- return(0);
|
||||
+ goto fail;
|
||||
break;
|
||||
}
|
||||
}
|
||||
- return(*name == BG_EOS);
|
||||
+ if (*name == BG_EOS)
|
||||
+ return 1;
|
||||
+
|
||||
+ fail:
|
||||
+ if (nextn) {
|
||||
+ pat = nextp;
|
||||
+ name = nextn;
|
||||
+ goto loop;
|
||||
+ }
|
||||
+ return 0;
|
||||
}
|
||||
|
||||
/* Free allocated data belonging to a glob_t structure. */
|
||||
diff --git a/ext/File-Glob/t/rt131211.t b/ext/File-Glob/t/rt131211.t
|
||||
new file mode 100644
|
||||
index 0000000..c1bcbe0
|
||||
--- /dev/null
|
||||
+++ b/ext/File-Glob/t/rt131211.t
|
||||
@@ -0,0 +1,94 @@
|
||||
+use strict;
|
||||
+use warnings;
|
||||
+use v5.16.0;
|
||||
+use File::Temp 'tempdir';
|
||||
+use File::Spec::Functions;
|
||||
+use Test::More;
|
||||
+use Time::HiRes qw(time);
|
||||
+
|
||||
+plan tests => 13;
|
||||
+
|
||||
+my $path = tempdir uc cleanup => 1;
|
||||
+my @files= (
|
||||
+ "x".("a" x 50)."b", # 0
|
||||
+ "abbbbbbbbbbbbc", # 1
|
||||
+ "abbbbbbbbbbbbd", # 2
|
||||
+ "aaabaaaabaaaabc", # 3
|
||||
+ "pq", # 4
|
||||
+ "r", # 5
|
||||
+ "rttiiiiiii", # 6
|
||||
+ "wewewewewewe", # 7
|
||||
+ "weeeweeeweee", # 8
|
||||
+ "weewweewweew", # 9
|
||||
+ "wewewewewewewewewewewewewewewewewq", # 10
|
||||
+ "wtttttttetttttttwr", # 11
|
||||
+);
|
||||
+
|
||||
+
|
||||
+foreach (@files) {
|
||||
+ open(my $f, ">", catfile $path, $_);
|
||||
+}
|
||||
+
|
||||
+my $elapsed_fail= 0;
|
||||
+my $elapsed_match= 0;
|
||||
+my @got_files;
|
||||
+my @no_files;
|
||||
+my $count = 0;
|
||||
+
|
||||
+while (++$count < 10) {
|
||||
+ $elapsed_match -= time;
|
||||
+ @got_files= glob catfile $path, "x".("a*" x $count) . "b";
|
||||
+ $elapsed_match += time;
|
||||
+
|
||||
+ $elapsed_fail -= time;
|
||||
+ @no_files= glob catfile $path, "x".("a*" x $count) . "c";
|
||||
+ $elapsed_fail += time;
|
||||
+ last if $elapsed_fail > $elapsed_match * 100;
|
||||
+}
|
||||
+
|
||||
+is $count,10,
|
||||
+ "tried all the patterns without bailing out";
|
||||
+
|
||||
+cmp_ok $elapsed_fail/$elapsed_match,"<",2,
|
||||
+ "time to fail less than twice the time to match";
|
||||
+is "@got_files", catfile($path, $files[0]),
|
||||
+ "only got the expected file for xa*..b";
|
||||
+is "@no_files", "", "shouldnt have files for xa*..c";
|
||||
+
|
||||
+
|
||||
+@got_files= glob catfile $path, "a*b*b*b*bc";
|
||||
+is "@got_files", catfile($path, $files[1]),
|
||||
+ "only got the expected file for a*b*b*b*bc";
|
||||
+
|
||||
+@got_files= sort glob catfile $path, "a*b*b*bc";
|
||||
+is "@got_files", catfile($path, $files[3])." ".catfile($path,$files[1]),
|
||||
+ "got the expected two files for a*b*b*bc";
|
||||
+
|
||||
+@got_files= sort glob catfile $path, "p*";
|
||||
+is "@got_files", catfile($path, $files[4]),
|
||||
+ "p* matches pq";
|
||||
+
|
||||
+@got_files= sort glob catfile $path, "r*???????";
|
||||
+is "@got_files", catfile($path, $files[6]),
|
||||
+ "r*??????? works as expected";
|
||||
+
|
||||
+@got_files= sort glob catfile $path, "w*e*w??e";
|
||||
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8)),
|
||||
+ "w*e*w??e works as expected";
|
||||
+
|
||||
+@got_files= sort glob catfile $path, "w*e*we??";
|
||||
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)),
|
||||
+ "w*e*we?? works as expected";
|
||||
+
|
||||
+@got_files= sort glob catfile $path, "w**e**w";
|
||||
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (9)),
|
||||
+ "w**e**w works as expected";
|
||||
+
|
||||
+@got_files= sort glob catfile $path, "*wee*";
|
||||
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (8,9)),
|
||||
+ "*wee* works as expected";
|
||||
+
|
||||
+@got_files= sort glob catfile $path, "we*";
|
||||
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)),
|
||||
+ "we* works as expected";
|
||||
+
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
From 064604f904546ae4ddada5a2aa30256faccee39c Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 7 Jun 2017 15:00:26 +1000
|
||||
Subject: [PATCH] clear the UTF8 flag on a glob if it isn't UTF8
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Ported to 5.24.1:
|
||||
|
||||
commit 1097da16b21fe0a2257dba9937e55c0cca18f7e1
|
||||
Author: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed Jun 7 15:00:26 2017 +1000
|
||||
|
||||
[perl #131263] clear the UTF8 flag on a glob if it isn't UTF8
|
||||
|
||||
Previously sv_2pv_flags() would set the UTF8 flag on a glob if it
|
||||
had a UTF8 name, but wouldn't clear tha flag if it didn't.
|
||||
|
||||
This meant a name change, eg. if assigned another glob, from a UTF8
|
||||
name to a non-UTF8 name would leave the flag set.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
sv.c | 2 ++
|
||||
t/op/gv.t | 10 +++++++++-
|
||||
2 files changed, 11 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/sv.c b/sv.c
|
||||
index 12cbb5f..05584a2 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -3162,6 +3162,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
|
||||
assert(SvPOK(buffer));
|
||||
if (SvUTF8(buffer))
|
||||
SvUTF8_on(sv);
|
||||
+ else
|
||||
+ SvUTF8_off(sv);
|
||||
if (lp)
|
||||
*lp = SvCUR(buffer);
|
||||
return SvPVX(buffer);
|
||||
diff --git a/t/op/gv.t b/t/op/gv.t
|
||||
index cdaaef5..ea79e51 100644
|
||||
--- a/t/op/gv.t
|
||||
+++ b/t/op/gv.t
|
||||
@@ -12,7 +12,7 @@ BEGIN {
|
||||
|
||||
use warnings;
|
||||
|
||||
-plan(tests => 277 );
|
||||
+plan(tests => 279 );
|
||||
|
||||
# type coercion on assignment
|
||||
$foo = 'foo';
|
||||
@@ -1173,6 +1173,14 @@ SKIP: {
|
||||
# [perl #131085] This used to crash; no ok() necessary.
|
||||
$::{"A131085"} = sub {}; \&{"A131085"};
|
||||
|
||||
+{
|
||||
+ # [perl #131263]
|
||||
+ *sym = "\N{U+0080}";
|
||||
+ ok(*sym eq "*main::\N{U+0080}", "utf8 flag properly set");
|
||||
+ *sym = "\xC3\x80";
|
||||
+ ok(*sym eq "*main::\xC3\x80", "utf8 flag properly cleared");
|
||||
+}
|
||||
+
|
||||
|
||||
__END__
|
||||
Perl
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,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
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
From ab3bb20383d6dbf9baa811d06414ee474bb8f91e Mon Sep 17 00:00:00 2001
|
||||
From: Father Chrysostomos <sprout@cpan.org>
|
||||
Date: Wed, 1 Nov 2017 13:11:27 -0700
|
||||
Subject: [PATCH] =?UTF-8?q?Carp:=20Don=E2=80=99t=20choke=20on=20ISA=20cons?=
|
||||
=?UTF-8?q?tant?=
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This broke some time between 1.29 (perl 5.18) and 1.3301 (perl 5.20):
|
||||
|
||||
$ perl5.20.1 -e 'package Foo { use constant ISA => 42; Bar::f() } package Bar { use Carp; sub f { carp "tun syn" } }'
|
||||
Not a GLOB reference at /usr/local/lib/perl5/5.20.1/Carp.pm line 560.
|
||||
|
||||
and still persisted in bleadperl (Carp 1.43) until this commit.
|
||||
|
||||
The code that goes poking through the symbol table needs to take into
|
||||
account that not all stash elements are globs.
|
||||
|
||||
Petr Písař: Ported to 5.24.3.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/Carp/lib/Carp.pm | 3 ++-
|
||||
dist/Carp/t/Carp.t | 13 ++++++++++++-
|
||||
2 files changed, 14 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
|
||||
index 92f8866..f94b9d4 100644
|
||||
--- a/dist/Carp/lib/Carp.pm
|
||||
+++ b/dist/Carp/lib/Carp.pm
|
||||
@@ -594,7 +594,8 @@ sub trusts_directly {
|
||||
for my $var (qw/ CARP_NOT ISA /) {
|
||||
# Don't try using the variable until we know it exists,
|
||||
# to avoid polluting the caller's namespace.
|
||||
- if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
|
||||
+ if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
|
||||
+ && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
|
||||
return @{$stash->{$var}}
|
||||
}
|
||||
}
|
||||
diff --git a/dist/Carp/t/Carp.t b/dist/Carp/t/Carp.t
|
||||
index 9ecdf88..f981005 100644
|
||||
--- a/dist/Carp/t/Carp.t
|
||||
+++ b/dist/Carp/t/Carp.t
|
||||
@@ -3,7 +3,7 @@ no warnings "once";
|
||||
use Config;
|
||||
|
||||
use IPC::Open3 1.0103 qw(open3);
|
||||
-use Test::More tests => 66;
|
||||
+use Test::More tests => 67;
|
||||
|
||||
sub runperl {
|
||||
my(%args) = @_;
|
||||
@@ -478,6 +478,17 @@ SKIP:
|
||||
);
|
||||
}
|
||||
|
||||
+{
|
||||
+ package Mpar;
|
||||
+ sub f { Carp::croak "tun syn" }
|
||||
+
|
||||
+ package Phou;
|
||||
+ $Phou::{ISA} = \42;
|
||||
+ eval { Mpar::f };
|
||||
+}
|
||||
+like $@, qr/tun syn/, 'Carp can handle non-glob ISA stash elems';
|
||||
+
|
||||
+
|
||||
# New tests go here
|
||||
|
||||
# line 1 "XA"
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
From 2657358b67ba3eadd1be99bd7e732a8d68f1f95d Mon Sep 17 00:00:00 2001
|
||||
From: John Lightsey <lightsey@debian.org>
|
||||
Date: Tue, 31 Oct 2017 18:12:26 -0500
|
||||
Subject: [PATCH] Fix deparsing of transliterations with unprintable
|
||||
characters.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
RT #132405
|
||||
|
||||
Signed-off-by: Nicolas R <atoomic@cpan.org>
|
||||
Petr Písař: Port to 5.24.3.
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
lib/B/Deparse.pm | 2 +-
|
||||
lib/B/Deparse.t | 5 +++++
|
||||
2 files changed, 6 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
|
||||
index 9879d67..f5f7d82 100644
|
||||
--- a/lib/B/Deparse.pm
|
||||
+++ b/lib/B/Deparse.pm
|
||||
@@ -5047,7 +5047,7 @@ sub pchr { # ASCII
|
||||
} elsif ($n == ord "\r") {
|
||||
return '\\r';
|
||||
} elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
|
||||
- return '\\c' . unctrl{chr $n};
|
||||
+ return '\\c' . $unctrl{chr $n};
|
||||
} else {
|
||||
# return '\x' . sprintf("%02x", $n);
|
||||
return '\\' . sprintf("%03o", $n);
|
||||
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
|
||||
index 19db404..45b1ff3 100644
|
||||
--- a/lib/B/Deparse.t
|
||||
+++ b/lib/B/Deparse.t
|
||||
@@ -2488,3 +2488,8 @@ $_ ^= $_;
|
||||
$_ |.= $_;
|
||||
$_ &.= $_;
|
||||
$_ ^.= $_;
|
||||
+####
|
||||
+# tr with unprintable characters
|
||||
+my $str;
|
||||
+$str = 'foo';
|
||||
+$str =~ tr/\cA//;
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
From 86ecc4da0ec0cea8f9b6af4191b87e4c454aa17c Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Sun, 10 Sep 2017 10:59:05 +0200
|
||||
Subject: [PATCH] fix #132017 - OPFAIL insert needs to set flags to 0
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
why reginsert doesnt do this stuff I dont know.
|
||||
|
||||
Petr Písař: Ported to 5.24.3.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 6 +++++-
|
||||
t/re/pat.t | 5 ++++-
|
||||
2 files changed, 9 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 6dcc58a..374032c 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -11498,6 +11498,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
if (max < min) { /* If can't match, warn and optimize to fail
|
||||
unconditionally */
|
||||
reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
|
||||
+ orig_emit->flags = 0;
|
||||
if (PASS2) {
|
||||
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
|
||||
NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
|
||||
@@ -19046,8 +19047,11 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_
|
||||
|
||||
/* add on the verb argument if there is one */
|
||||
if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
|
||||
- Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
|
||||
+ if ( ARG(o) )
|
||||
+ Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
|
||||
SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
|
||||
+ else
|
||||
+ sv_catpvs(sv, ":NULL");
|
||||
}
|
||||
#else
|
||||
PERL_UNUSED_CONTEXT;
|
||||
diff --git a/t/re/pat.t b/t/re/pat.t
|
||||
index 007f11d..6ff8b0b 100644
|
||||
--- a/t/re/pat.t
|
||||
+++ b/t/re/pat.t
|
||||
@@ -23,7 +23,7 @@ BEGIN {
|
||||
skip_all_without_unicode_tables();
|
||||
}
|
||||
|
||||
-plan tests => 794; # Update this when adding/deleting tests.
|
||||
+plan tests => 795; # Update this when adding/deleting tests.
|
||||
|
||||
run_tests() unless caller;
|
||||
|
||||
@@ -1793,6 +1793,9 @@ EOP
|
||||
pos($text) = 3;
|
||||
ok(scalar($text !~ m{(~*=[a-z]=)}g), "RT #131575");
|
||||
}
|
||||
+ {
|
||||
+ fresh_perl_is('"AA" =~ m/AA{1,0}/','',{},"handle OPFAIL insert properly");
|
||||
+ }
|
||||
|
||||
} # End of sub run_tests
|
||||
|
||||
--
|
||||
2.13.6
|
||||
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,594 @@
|
|||
From a56b6643ac9d2bae70dc93d49a08ba1eafa62c30 Mon Sep 17 00:00:00 2001
|
||||
From: Zefram <zefram@fysh.org>
|
||||
Date: Sun, 19 Nov 2017 09:15:53 +0000
|
||||
Subject: [PATCH] fix tainting of s/// with overloaded replacement
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The substitution code was trying to track the taintedness of the
|
||||
replacement string itself, but it didn't account for the replacement
|
||||
being an untainted object with overloading that returns a tainted
|
||||
stringification. It looked at the taintedness of the object value, not
|
||||
realising that taint could arise during the string concatenation per se.
|
||||
Change the taint checks to look at the actual TAINT_get flag after string
|
||||
concatenation. This may falsely ascribe to the replacement taint that
|
||||
actually came from somewhere else, but the end result is the same anyway:
|
||||
there's no visible behaviour that distinguishes taint specifically from
|
||||
the replacement. Also remove a related taint check that seems to be
|
||||
not needed at all. Fixes [perl #115266].
|
||||
|
||||
Petr Písař: Ported to 5.24.3.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp_ctl.c | 4 +-
|
||||
pp_hot.c | 4 +-
|
||||
t/op/taint.t | 429 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
|
||||
3 files changed, 423 insertions(+), 14 deletions(-)
|
||||
|
||||
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||
index 9150142..97a4607 100644
|
||||
--- a/pp_ctl.c
|
||||
+++ b/pp_ctl.c
|
||||
@@ -218,9 +218,9 @@ PP(pp_substcont)
|
||||
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
|
||||
|
||||
/* See "how taint works" above pp_subst() */
|
||||
- if (SvTAINTED(TOPs))
|
||||
- cx->sb_rxtainted |= SUBST_TAINT_REPL;
|
||||
sv_catsv_nomg(dstr, POPs);
|
||||
+ if (UNLIKELY(TAINT_get))
|
||||
+ cx->sb_rxtainted |= SUBST_TAINT_REPL;
|
||||
if (CxONCE(cx) || s < orig ||
|
||||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
|
||||
(s == m), cx->sb_targ, NULL,
|
||||
diff --git a/pp_hot.c b/pp_hot.c
|
||||
index 243f43a..e80d991 100644
|
||||
--- a/pp_hot.c
|
||||
+++ b/pp_hot.c
|
||||
@@ -3004,7 +3004,7 @@ PP(pp_subst)
|
||||
doutf8 = DO_UTF8(dstr);
|
||||
}
|
||||
|
||||
- if (SvTAINTED(dstr))
|
||||
+ if (UNLIKELY(TAINT_get))
|
||||
rxtainted |= SUBST_TAINT_REPL;
|
||||
}
|
||||
else {
|
||||
@@ -3181,8 +3181,6 @@ PP(pp_subst)
|
||||
sv_catsv(dstr, nsv);
|
||||
}
|
||||
else sv_catsv(dstr, repl);
|
||||
- if (UNLIKELY(SvTAINTED(repl)))
|
||||
- rxtainted |= SUBST_TAINT_REPL;
|
||||
}
|
||||
if (once)
|
||||
break;
|
||||
diff --git a/t/op/taint.t b/t/op/taint.t
|
||||
index 846ac23..dbcc418 100644
|
||||
--- a/t/op/taint.t
|
||||
+++ b/t/op/taint.t
|
||||
@@ -17,7 +17,7 @@ BEGIN {
|
||||
use strict;
|
||||
use Config;
|
||||
|
||||
-plan tests => 812;
|
||||
+plan tests => 1024;
|
||||
|
||||
$| = 1;
|
||||
|
||||
@@ -83,6 +83,8 @@ EndOfCleanup
|
||||
# Sources of taint:
|
||||
# The empty tainted value, for tainting strings
|
||||
my $TAINT = substr($^X, 0, 0);
|
||||
+# A tainted non-empty string
|
||||
+my $TAINTXYZ = "xyz".$TAINT;
|
||||
# A tainted zero, useful for tainting numbers
|
||||
my $TAINT0;
|
||||
{
|
||||
@@ -565,7 +567,7 @@ my $TEST = 'TEST';
|
||||
is($one, 'abcd', "$desc: \$1 value");
|
||||
}
|
||||
|
||||
- $desc = "substitution with replacement tainted";
|
||||
+ $desc = "substitution with partial replacement tainted";
|
||||
|
||||
$s = 'abcd';
|
||||
$res = $s =~ s/(.+)/xyz$TAINT/;
|
||||
@@ -577,7 +579,7 @@ my $TEST = 'TEST';
|
||||
is($res, 1, "$desc: res value");
|
||||
is($one, 'abcd', "$desc: \$1 value");
|
||||
|
||||
- $desc = "substitution /g with replacement tainted";
|
||||
+ $desc = "substitution /g with partial replacement tainted";
|
||||
|
||||
$s = 'abcd';
|
||||
$res = $s =~ s/(.)/x$TAINT/g;
|
||||
@@ -589,7 +591,7 @@ my $TEST = 'TEST';
|
||||
is($res, 4, "$desc: res value");
|
||||
is($one, 'd', "$desc: \$1 value");
|
||||
|
||||
- $desc = "substitution /ge with replacement tainted";
|
||||
+ $desc = "substitution /ge with partial replacement tainted";
|
||||
|
||||
$s = 'abc';
|
||||
{
|
||||
@@ -618,7 +620,7 @@ my $TEST = 'TEST';
|
||||
is($res, 3, "$desc: res value");
|
||||
is($one, 'c', "$desc: \$1 value");
|
||||
|
||||
- $desc = "substitution /r with replacement tainted";
|
||||
+ $desc = "substitution /r with partial replacement tainted";
|
||||
|
||||
$s = 'abcd';
|
||||
$res = $s =~ s/(.+)/xyz$TAINT/r;
|
||||
@@ -630,6 +632,71 @@ my $TEST = 'TEST';
|
||||
is($res, 'xyz', "$desc: res value");
|
||||
is($one, 'abcd', "$desc: \$1 value");
|
||||
|
||||
+ $desc = "substitution with whole replacement tainted";
|
||||
+
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$TAINTXYZ/;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyz', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /g with whole replacement tainted";
|
||||
+
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/$TAINTXYZ/g;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyz' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /ge with whole replacement tainted";
|
||||
+
|
||||
+ $s = 'abc';
|
||||
+ {
|
||||
+ my $i = 0;
|
||||
+ my $j;
|
||||
+ $res = $s =~ s{(.)}{
|
||||
+ $j = $i; # make sure code not tainted
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($j, "$desc: code not tainted within /e");
|
||||
+ $i++;
|
||||
+ if ($i == 1) {
|
||||
+ isnt_tainted($s, "$desc: s not tainted loop 1");
|
||||
+ }
|
||||
+ else {
|
||||
+ is_tainted($s, "$desc: s tainted loop $i");
|
||||
+ }
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted within /e");
|
||||
+ $TAINTXYZ;
|
||||
+ }ge;
|
||||
+ $one = $1;
|
||||
+ }
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyz' x 3, "$desc: s value");
|
||||
+ is($res, 3, "$desc: res value");
|
||||
+ is($one, 'c', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /r with whole replacement tainted";
|
||||
+
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$TAINTXYZ/r;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ is_tainted($res, "$desc: res tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'abcd', "$desc: s value");
|
||||
+ is($res, 'xyz', "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
{
|
||||
# now do them all again with "use re 'taint"
|
||||
|
||||
@@ -955,7 +1022,7 @@ my $TEST = 'TEST';
|
||||
is($one, 'abcd', "$desc: \$1 value");
|
||||
}
|
||||
|
||||
- $desc = "use re 'taint': substitution with replacement tainted";
|
||||
+ $desc = "use re 'taint': substitution with partial replacement tainted";
|
||||
|
||||
$s = 'abcd';
|
||||
$res = $s =~ s/(.+)/xyz$TAINT/;
|
||||
@@ -967,7 +1034,7 @@ my $TEST = 'TEST';
|
||||
is($res, 1, "$desc: res value");
|
||||
is($one, 'abcd', "$desc: \$1 value");
|
||||
|
||||
- $desc = "use re 'taint': substitution /g with replacement tainted";
|
||||
+ $desc = "use re 'taint': substitution /g with partial replacement tainted";
|
||||
|
||||
$s = 'abcd';
|
||||
$res = $s =~ s/(.)/x$TAINT/g;
|
||||
@@ -979,7 +1046,7 @@ my $TEST = 'TEST';
|
||||
is($res, 4, "$desc: res value");
|
||||
is($one, 'd', "$desc: \$1 value");
|
||||
|
||||
- $desc = "use re 'taint': substitution /ge with replacement tainted";
|
||||
+ $desc = "use re 'taint': substitution /ge with partial replacement tainted";
|
||||
|
||||
$s = 'abc';
|
||||
{
|
||||
@@ -1008,7 +1075,7 @@ my $TEST = 'TEST';
|
||||
is($res, 3, "$desc: res value");
|
||||
is($one, 'c', "$desc: \$1 value");
|
||||
|
||||
- $desc = "use re 'taint': substitution /r with replacement tainted";
|
||||
+ $desc = "use re 'taint': substitution /r with partial replacement tainted";
|
||||
|
||||
$s = 'abcd';
|
||||
$res = $s =~ s/(.+)/xyz$TAINT/r;
|
||||
@@ -1020,6 +1087,71 @@ my $TEST = 'TEST';
|
||||
is($res, 'xyz', "$desc: res value");
|
||||
is($one, 'abcd', "$desc: \$1 value");
|
||||
|
||||
+ $desc = "use re 'taint': substitution with whole replacement tainted";
|
||||
+
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$TAINTXYZ/;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyz', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "use re 'taint': substitution /g with whole replacement tainted";
|
||||
+
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/$TAINTXYZ/g;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyz' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "use re 'taint': substitution /ge with whole replacement tainted";
|
||||
+
|
||||
+ $s = 'abc';
|
||||
+ {
|
||||
+ my $i = 0;
|
||||
+ my $j;
|
||||
+ $res = $s =~ s{(.)}{
|
||||
+ $j = $i; # make sure code not tainted
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($j, "$desc: code not tainted within /e");
|
||||
+ $i++;
|
||||
+ if ($i == 1) {
|
||||
+ isnt_tainted($s, "$desc: s not tainted loop 1");
|
||||
+ }
|
||||
+ else {
|
||||
+ is_tainted($s, "$desc: s tainted loop $i");
|
||||
+ }
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ $TAINTXYZ;
|
||||
+ }ge;
|
||||
+ $one = $1;
|
||||
+ }
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyz' x 3, "$desc: s value");
|
||||
+ is($res, 3, "$desc: res value");
|
||||
+ is($one, 'c', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "use re 'taint': substitution /r with whole replacement tainted";
|
||||
+
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$TAINTXYZ/r;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ is_tainted($res, "$desc: res tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'abcd', "$desc: s value");
|
||||
+ is($res, 'xyz', "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
# [perl #121854] match taintedness became sticky
|
||||
# when one match has a taintess result, subseqent matches
|
||||
# using the same pattern shouldn't necessarily be tainted
|
||||
@@ -2408,6 +2540,285 @@ is eval { eval $::x.1 }, 1, 'reset does not taint undef';
|
||||
}
|
||||
|
||||
|
||||
+# taint passing through overloading
|
||||
+package OvTaint {
|
||||
+ sub new { bless({ t => $_[1] }, $_[0]) }
|
||||
+ use overload '""' => sub { $_[0]->{t} ? "hi".$TAINT : "hello" };
|
||||
+}
|
||||
+my $ovclean = OvTaint->new(0);
|
||||
+my $ovtaint = OvTaint->new(1);
|
||||
+isnt_tainted("$ovclean", "overload preserves cleanliness");
|
||||
+is_tainted("$ovtaint", "overload preserves taint");
|
||||
+
|
||||
+# substitutions with overloaded replacement
|
||||
+{
|
||||
+ my ($desc, $s, $res, $one);
|
||||
+
|
||||
+ $desc = "substitution with partial replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/xyz$ovclean/;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyzhello', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution with partial replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/xyz$ovtaint/;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyzhi', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution with whole replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$ovclean/;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hello', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution with whole replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$ovtaint/;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hi', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /e with partial replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/"xyz".$ovclean/e;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyzhello', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /e with partial replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/"xyz".$ovtaint/e;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyzhi', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /e with whole replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$ovclean/e;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hello', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /e with whole replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$ovtaint/e;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hi', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /e with extra code and partial replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/(my $z++), "xyz".$ovclean/e;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyzhello', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /e with extra code and partial replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/(my $z++), "xyz".$ovtaint/e;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xyzhi', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /e with extra code and whole replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/(my $z++), $ovclean/e;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hello', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /e with extra code and whole replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/(my $z++), $ovtaint/e;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hi', "$desc: s value");
|
||||
+ is($res, 1, "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /r with partial replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/xyz$ovclean/r;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'abcd', "$desc: s value");
|
||||
+ is($res, 'xyzhello', "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /r with partial replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/xyz$ovtaint/r;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ is_tainted($res, "$desc: res tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'abcd', "$desc: s value");
|
||||
+ is($res, 'xyzhi', "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /r with whole replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$ovclean/r;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'abcd', "$desc: s value");
|
||||
+ is($res, 'hello', "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /r with whole replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.+)/$ovtaint/r;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ is_tainted($res, "$desc: res tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'abcd', "$desc: s value");
|
||||
+ is($res, 'hi', "$desc: res value");
|
||||
+ is($one, 'abcd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /g with partial replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/x$ovclean/g;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xhello' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /g with partial replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/x$ovtaint/g;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xhi' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /g with whole replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/$ovclean/g;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hello' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /g with whole replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/$ovtaint/g;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hi' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /ge with partial replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/"x".$ovclean/ge;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xhello' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /ge with partial replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/"x".$ovtaint/ge;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'xhi' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /ge with whole replacement overloaded and clean";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/$ovclean/ge;
|
||||
+ $one = $1;
|
||||
+ isnt_tainted($s, "$desc: s not tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hello' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+
|
||||
+ $desc = "substitution /ge with whole replacement overloaded and tainted";
|
||||
+ $s = 'abcd';
|
||||
+ $res = $s =~ s/(.)/$ovtaint/ge;
|
||||
+ $one = $1;
|
||||
+ is_tainted($s, "$desc: s tainted");
|
||||
+ isnt_tainted($res, "$desc: res not tainted");
|
||||
+ isnt_tainted($one, "$desc: \$1 not tainted");
|
||||
+ is($s, 'hi' x 4, "$desc: s value");
|
||||
+ is($res, 4, "$desc: res value");
|
||||
+ is($one, 'd', "$desc: \$1 value");
|
||||
+}
|
||||
+
|
||||
# This may bomb out with the alarm signal so keep it last
|
||||
SKIP: {
|
||||
skip "No alarm()" unless $Config{d_alarm};
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
From b890486ff0c482cbdec59a0f9beb28275aeee19b Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 19 Jun 2017 14:59:53 +1000
|
||||
Subject: [PATCH] (perl #131597) ensure the GV slot is filled for our [%$@]foo:
|
||||
attr
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Petr Písař: Ported to 5.24.3.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 6 +++---
|
||||
t/op/attrs.t | 18 ++++++++++++++++++
|
||||
2 files changed, 21 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index 2960dd5..8a5fc3f 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -3671,9 +3671,9 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
|
||||
PL_parser->in_my = FALSE;
|
||||
PL_parser->in_my_stash = NULL;
|
||||
apply_attrs(GvSTASH(gv),
|
||||
- (type == OP_RV2SV ? GvSV(gv) :
|
||||
- type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
|
||||
- type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
|
||||
+ (type == OP_RV2SV ? GvSVn(gv) :
|
||||
+ type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
|
||||
+ type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
|
||||
attrs);
|
||||
}
|
||||
o->op_private |= OPpOUR_INTRO;
|
||||
diff --git a/t/op/attrs.t b/t/op/attrs.t
|
||||
index 219db03..b038c87 100644
|
||||
--- a/t/op/attrs.t
|
||||
+++ b/t/op/attrs.t
|
||||
@@ -447,4 +447,22 @@ package P126257 {
|
||||
::is $@, "", "RT 126257 sub";
|
||||
}
|
||||
|
||||
+fresh_perl_is('sub dummy {} our $dummy : Dummy', <<EOS, {},
|
||||
+Invalid SCALAR attribute: Dummy at - line 1.
|
||||
+BEGIN failed--compilation aborted at - line 1.
|
||||
+EOS
|
||||
+ "attribute on our scalar with sub of same name");
|
||||
+
|
||||
+fresh_perl_is('sub dummy {} our @dummy : Dummy', <<EOS, {},
|
||||
+Invalid ARRAY attribute: Dummy at - line 1.
|
||||
+BEGIN failed--compilation aborted at - line 1.
|
||||
+EOS
|
||||
+ "attribute on our array with sub of same name");
|
||||
+
|
||||
+fresh_perl_is('sub dummy {} our %dummy : Dummy', <<EOS, {},
|
||||
+Invalid HASH attribute: Dummy at - line 1.
|
||||
+BEGIN failed--compilation aborted at - line 1.
|
||||
+EOS
|
||||
+ "attribute on our hash with sub of same name");
|
||||
+
|
||||
done_testing();
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,223 @@
|
|||
From 9a4826e0881f8c5498a0fd5f24ed2a0fefb771b7 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 2 Nov 2017 20:18:56 +0000
|
||||
Subject: [PATCH] (perl #131895) fail stat on names with \0 embedded
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Also lstat() and the file test ops.
|
||||
|
||||
Petr Písař: Port to 5.24.3.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
doio.c | 21 ++++++++++++++++-----
|
||||
pp_sys.c | 29 +++++++++++++++++++++++------
|
||||
t/lib/warnings/pp_sys | 14 ++++++++++++++
|
||||
t/op/filetest.t | 10 +++++++++-
|
||||
t/op/stat.t | 12 +++++++++++-
|
||||
5 files changed, 73 insertions(+), 13 deletions(-)
|
||||
|
||||
diff --git a/doio.c b/doio.c
|
||||
index 6704862..2792c66 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -1458,7 +1458,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||
return PL_laststatval;
|
||||
else {
|
||||
SV* const sv = TOPs;
|
||||
- const char *s;
|
||||
+ const char *s, *d;
|
||||
STRLEN len;
|
||||
if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
|
||||
goto do_fstat;
|
||||
@@ -1472,9 +1472,14 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
|
||||
s = SvPV_flags_const(sv, len, flags);
|
||||
PL_statgv = NULL;
|
||||
sv_setpvn(PL_statname, s, len);
|
||||
- s = SvPVX_const(PL_statname); /* s now NUL-terminated */
|
||||
+ d = SvPVX_const(PL_statname); /* s now NUL-terminated */
|
||||
PL_laststype = OP_STAT;
|
||||
- PL_laststatval = PerlLIO_stat(s, &PL_statcache);
|
||||
+ if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
|
||||
+ PL_laststatval = -1;
|
||||
+ }
|
||||
+ else {
|
||||
+ PL_laststatval = PerlLIO_stat(d, &PL_statcache);
|
||||
+ }
|
||||
if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
|
||||
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
|
||||
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
|
||||
@@ -1491,6 +1496,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||
static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
|
||||
dSP;
|
||||
const char *file;
|
||||
+ STRLEN len;
|
||||
SV* const sv = TOPs;
|
||||
bool isio = FALSE;
|
||||
if (PL_op->op_flags & OPf_REF) {
|
||||
@@ -1534,9 +1540,14 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||
HEKfARG(GvENAME_HEK((const GV *)
|
||||
(SvROK(sv) ? SvRV(sv) : sv))));
|
||||
}
|
||||
- file = SvPV_flags_const_nolen(sv, flags);
|
||||
+ file = SvPV_flags_const(sv, len, flags);
|
||||
sv_setpv(PL_statname,file);
|
||||
- PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
|
||||
+ if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
|
||||
+ PL_laststatval = -1;
|
||||
+ }
|
||||
+ else {
|
||||
+ PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
|
||||
+ }
|
||||
if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
|
||||
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
|
||||
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
|
||||
diff --git a/pp_sys.c b/pp_sys.c
|
||||
index bd55043..1a72e60 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -2927,19 +2927,24 @@ PP(pp_stat)
|
||||
}
|
||||
else {
|
||||
const char *file;
|
||||
+ const char *temp;
|
||||
+ STRLEN len;
|
||||
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
|
||||
io = MUTABLE_IO(SvRV(sv));
|
||||
if (PL_op->op_type == OP_LSTAT)
|
||||
goto do_fstat_warning_check;
|
||||
goto do_fstat_have_io;
|
||||
}
|
||||
-
|
||||
SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
|
||||
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
|
||||
+ temp = SvPV_nomg_const(sv, len);
|
||||
+ sv_setpv(PL_statname, temp);
|
||||
PL_statgv = NULL;
|
||||
PL_laststype = PL_op->op_type;
|
||||
file = SvPV_nolen_const(PL_statname);
|
||||
- if (PL_op->op_type == OP_LSTAT)
|
||||
+ if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
|
||||
+ PL_laststatval = -1;
|
||||
+ }
|
||||
+ else if (PL_op->op_type == OP_LSTAT)
|
||||
PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
|
||||
else
|
||||
PL_laststatval = PerlLIO_stat(file, &PL_statcache);
|
||||
@@ -3175,8 +3180,12 @@ PP(pp_ftrread)
|
||||
|
||||
if (use_access) {
|
||||
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
|
||||
- const char *name = SvPV_nolen(*PL_stack_sp);
|
||||
- if (effective) {
|
||||
+ STRLEN len;
|
||||
+ const char *name = SvPV(*PL_stack_sp, len);
|
||||
+ if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
|
||||
+ result = -1;
|
||||
+ }
|
||||
+ else if (effective) {
|
||||
# ifdef PERL_EFF_ACCESS
|
||||
result = PERL_EFF_ACCESS(name, access_mode);
|
||||
# else
|
||||
@@ -3501,10 +3510,18 @@ PP(pp_fttext)
|
||||
}
|
||||
else {
|
||||
const char *file;
|
||||
+ const char *temp;
|
||||
+ STRLEN temp_len;
|
||||
int fd;
|
||||
|
||||
assert(sv);
|
||||
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
|
||||
+ temp = SvPV_nomg_const(sv, temp_len);
|
||||
+ sv_setpv(PL_statname, temp);
|
||||
+ if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
|
||||
+ PL_laststatval = -1;
|
||||
+ PL_laststype = OP_STAT;
|
||||
+ FT_RETURNUNDEF;
|
||||
+ }
|
||||
really_filename:
|
||||
file = SvPVX_const(PL_statname);
|
||||
PL_statgv = NULL;
|
||||
diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
|
||||
index 6338964..ded5d7d 100644
|
||||
--- a/t/lib/warnings/pp_sys
|
||||
+++ b/t/lib/warnings/pp_sys
|
||||
@@ -962,3 +962,17 @@ close $fh;
|
||||
unlink $file;
|
||||
EXPECT
|
||||
syswrite() is deprecated on :utf8 handles at - line 6.
|
||||
+########
|
||||
+# NAME stat on name with \0
|
||||
+use warnings;
|
||||
+my @x = stat("./\0-");
|
||||
+my @y = lstat("./\0-");
|
||||
+-T ".\0-";
|
||||
+-x ".\0-";
|
||||
+-l ".\0-";
|
||||
+EXPECT
|
||||
+Invalid \0 character in pathname for stat: ./\0- at - line 2.
|
||||
+Invalid \0 character in pathname for lstat: ./\0- at - line 3.
|
||||
+Invalid \0 character in pathname for fttext: .\0- at - line 4.
|
||||
+Invalid \0 character in pathname for fteexec: .\0- at - line 5.
|
||||
+Invalid \0 character in pathname for ftlink: .\0- at - line 6.
|
||||
diff --git a/t/op/filetest.t b/t/op/filetest.t
|
||||
index 8883381..bd1d08c 100644
|
||||
--- a/t/op/filetest.t
|
||||
+++ b/t/op/filetest.t
|
||||
@@ -9,7 +9,7 @@ BEGIN {
|
||||
set_up_inc(qw '../lib ../cpan/Perl-OSType/lib');
|
||||
}
|
||||
|
||||
-plan(tests => 53 + 27*14);
|
||||
+plan(tests => 57 + 27*14);
|
||||
|
||||
if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) {
|
||||
require Win32; # for IsAdminUser()
|
||||
@@ -393,3 +393,11 @@ SKIP: {
|
||||
is $failed_stat2, $failed_stat1,
|
||||
'failed -r($gv_with_io_but_no_fp) with and w/out fatal warnings';
|
||||
}
|
||||
+
|
||||
+{
|
||||
+ # [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
|
||||
+ ok(!-T "TEST\0-", '-T on name with \0');
|
||||
+ ok(!-B "TEST\0-", '-B on name with \0');
|
||||
+ ok(!-f "TEST\0-", '-f on name with \0');
|
||||
+ ok(!-r "TEST\0-", '-r on name with \0');
|
||||
+}
|
||||
diff --git a/t/op/stat.t b/t/op/stat.t
|
||||
index 637a902..71193ad 100644
|
||||
--- a/t/op/stat.t
|
||||
+++ b/t/op/stat.t
|
||||
@@ -25,7 +25,7 @@ if ($^O eq 'MSWin32') {
|
||||
${^WIN32_SLOPPY_STAT} = 0;
|
||||
}
|
||||
|
||||
-plan tests => 118;
|
||||
+plan tests => 120;
|
||||
|
||||
my $Perl = which_perl();
|
||||
|
||||
@@ -651,6 +651,16 @@ SKIP:
|
||||
'stat on an array of valid paths should return ENOENT';
|
||||
}
|
||||
|
||||
+# [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
|
||||
+ok !stat("TEST\0-"), 'stat on filename with \0';
|
||||
+SKIP: {
|
||||
+ my $link = "TEST.symlink.$$";
|
||||
+ my $can_symlink = eval { symlink "TEST", $link };
|
||||
+ skip "cannot symlink", 1 unless $can_symlink;
|
||||
+ ok !lstat("$link\0-"), 'lstat on filename with \0';
|
||||
+ unlink $link;
|
||||
+}
|
||||
+
|
||||
END {
|
||||
chmod 0666, $tmpfile;
|
||||
unlink_all $tmpfile;
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
From 86a48d83a7caf38c553000a250ed1359c235f55e Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 19 Oct 2017 10:46:04 +1100
|
||||
Subject: [PATCH] (perl #132245) don't try to process a char range with no
|
||||
preceding char
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
A range like \N{}-0 eventually results in compilation failing, but
|
||||
before that, get_and_check_backslash_N_name() attempts to treat
|
||||
the memory before the empty output of \N{} as a character.
|
||||
|
||||
Petr Písař: Ported to 5.24.3.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/lib/warnings/toke | 5 +++++
|
||||
toke.c | 4 ++--
|
||||
2 files changed, 7 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
|
||||
index 493c8a2..4a521e0 100644
|
||||
--- a/t/lib/warnings/toke
|
||||
+++ b/t/lib/warnings/toke
|
||||
@@ -1509,3 +1509,8 @@ my $v = 𝛃 - 5;
|
||||
EXPECT
|
||||
OPTION regex
|
||||
(Wide character.*\n)?Warning: Use of "𝛃" without parentheses is ambiguous
|
||||
+########
|
||||
+# NAME tr/// range with empty \N{} at the start
|
||||
+tr//\N{}-0/;
|
||||
+EXPECT
|
||||
+Unknown charname '' is deprecated at - line 1.
|
||||
diff --git a/toke.c b/toke.c
|
||||
index f2310cc..3d93fac 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -2906,8 +2906,8 @@ S_scan_const(pTHX_ char *start)
|
||||
* at least one character, then see if this next one is a '-',
|
||||
* indicating the previous one was the start of a range. But
|
||||
* don't bother if we're too close to the end for the minus to
|
||||
- * mean that. */
|
||||
- if (*s != '-' || s >= send - 1 || s == start) {
|
||||
+ * mean that, or if we haven't output any characters yet. */
|
||||
+ if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
|
||||
|
||||
/* A regular character. Process like any other, but first
|
||||
* clear any flags */
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
From 264472b6e83dd1a9d0e0e58d75f7162471a5b29b Mon Sep 17 00:00:00 2001
|
||||
From: Father Chrysostomos <sprout@cpan.org>
|
||||
Date: Tue, 14 Nov 2017 18:55:55 -0800
|
||||
Subject: [PATCH] Fix stack with do {my sub l; 1}
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
A block in perl usually compiles to a leave op with an enter inside
|
||||
it, followed by the statements:
|
||||
|
||||
leave
|
||||
enter
|
||||
nextstate
|
||||
... expr ...
|
||||
nextstate
|
||||
... expr ...
|
||||
|
||||
If a block contains only one statement, and that statement is suffic-
|
||||
iently innocuous, then the enter/leave pair to create the scope at run
|
||||
time get skipped, and instead we have a simple scope op which is not
|
||||
even executed:
|
||||
|
||||
scope
|
||||
ex-nextstate
|
||||
... expr ...
|
||||
|
||||
The nextstate in this case also gets nulled.
|
||||
|
||||
In the case of do { my sub l; 1 } we were getting a variation of the
|
||||
latter, that looked like this:
|
||||
|
||||
scope
|
||||
introcv
|
||||
clonecv
|
||||
nextstate
|
||||
... expr ...
|
||||
|
||||
The problem here is that nextstate resets the stack, even though a new
|
||||
scope has not been pushed, so we end up with all existing stack items
|
||||
from the *outer* scope getting clobbered.
|
||||
|
||||
One can have fun with this and erase everything pushed on to the stack
|
||||
so far in a given statement:
|
||||
|
||||
$ ./perl -le 'print join "-", 1..10, do {my sub l; ","}, 11..20'
|
||||
11,12,13,14,15,16,17,18,19,20
|
||||
|
||||
Here I replaced the first argument to join() from within the do{}
|
||||
block, after having cleared the stack.
|
||||
|
||||
Why was the op tree was getting muddled up like this? The ‘my sub’
|
||||
declaration does not immediately add any ops to the op tree; those ops
|
||||
get added when the current scope finishing compiling, since those ops
|
||||
must be inserted at the beginning of the block.
|
||||
|
||||
I have not fully looked into the order that things happen, and why the
|
||||
nextstate op does not get nulled; but it did not matter, because of
|
||||
the simple fix: Treat lexical sub declarations as ‘not innocuous’ by
|
||||
setting the HINT_BLOCK_SCOPE flag when a lexical sub is declared.
|
||||
Thus, we end up with an enter/leave pair, which creates a
|
||||
proper scope.
|
||||
|
||||
Petr Písař: Ported to 5.24.3.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 2 ++
|
||||
t/op/lexsub.t | 5 ++++-
|
||||
2 files changed, 6 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index 8a5fc3f..695bfa4 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -7936,6 +7936,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
|
||||
|
||||
PERL_ARGS_ASSERT_NEWMYSUB;
|
||||
|
||||
+ PL_hints |= HINT_BLOCK_SCOPE;
|
||||
+
|
||||
/* Find the pad slot for storing the new sub.
|
||||
We cannot use PL_comppad, as it is the pad owned by the new sub. We
|
||||
need to look in CvOUTSIDE and find the pad belonging to the enclos-
|
||||
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
|
||||
index adccf4c..cf90a76 100644
|
||||
--- a/t/op/lexsub.t
|
||||
+++ b/t/op/lexsub.t
|
||||
@@ -7,7 +7,7 @@ BEGIN {
|
||||
*bar::is = *is;
|
||||
*bar::like = *like;
|
||||
}
|
||||
-plan 151;
|
||||
+plan 152;
|
||||
|
||||
# -------------------- Errors with feature disabled -------------------- #
|
||||
|
||||
@@ -967,3 +967,6 @@ like runperl(
|
||||
{
|
||||
my sub h; sub{my $x; sub{h}}
|
||||
}
|
||||
+
|
||||
+is join("-", qw(aa bb), do { my sub lleexx; 123 }, qw(cc dd)),
|
||||
+ "aa-bb-123-cc-dd", 'do { my sub...} in a list [perl #132442]';
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
From 60a26c797bbff039ea7f861903732e7cceae415a Mon Sep 17 00:00:00 2001
|
||||
From: Hugo van der Sanden <hv@crypt.org>
|
||||
Date: Sun, 15 May 2016 13:48:58 -0700
|
||||
Subject: [PATCH 1/2] [perl #128086] Fix precedence in hv_ename_delete
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
A stash’s array of names may have null for the first entry, in which
|
||||
case it is not one of the effective names, and the name count will
|
||||
be negative.
|
||||
|
||||
The ‘count > 0’ is meant to prevent hv_ename_delete from trying to
|
||||
read that entry, but a precedence problem introduced in 4643eb699
|
||||
stopped it from doing that.
|
||||
|
||||
[This commit message was written by the committer.]
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
hv.c | 3 ++-
|
||||
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/hv.c b/hv.c
|
||||
index 7b5ad95..5523475 100644
|
||||
--- a/hv.c
|
||||
+++ b/hv.c
|
||||
@@ -2476,9 +2476,10 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
|
||||
return;
|
||||
}
|
||||
if (
|
||||
- count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
|
||||
+ count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8))
|
||||
? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
|
||||
: (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
|
||||
+ )
|
||||
) {
|
||||
aux->xhv_name_count = -count;
|
||||
}
|
||||
--
|
||||
2.5.5
|
||||
|
||||
From 7f1bd063e5aa5aeb26ed9c39db6864cc0ecd7a73 Mon Sep 17 00:00:00 2001
|
||||
From: Father Chrysostomos <sprout@cpan.org>
|
||||
Date: Sun, 15 May 2016 13:49:33 -0700
|
||||
Subject: [PATCH 2/2] [perl #128086] Test the prev commit
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/stash.t | 9 ++++++++-
|
||||
1 file changed, 8 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/op/stash.t b/t/op/stash.t
|
||||
index 151b729..b8e0f34 100644
|
||||
--- a/t/op/stash.t
|
||||
+++ b/t/op/stash.t
|
||||
@@ -7,7 +7,7 @@ BEGIN {
|
||||
|
||||
BEGIN { require "./test.pl"; }
|
||||
|
||||
-plan( tests => 51 );
|
||||
+plan( tests => 52 );
|
||||
|
||||
# Used to segfault (bug #15479)
|
||||
fresh_perl_like(
|
||||
@@ -334,3 +334,10 @@ is runperl(
|
||||
),
|
||||
"ok\n",
|
||||
'[perl #123847] no crash from *foo::=*bar::=*glob_with_hash';
|
||||
+
|
||||
+is runperl(
|
||||
+ prog => '%h; *::::::=*h; delete $::{q|::|}; print qq|ok\n|',
|
||||
+ stderr => 1,
|
||||
+ ),
|
||||
+ "ok\n",
|
||||
+ '[perl #128086] no crash from assigning hash to *:::::: & deleting it';
|
||||
--
|
||||
2.5.5
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
commit 13e70b397dcb0d1bf4a869b670f041c1d7b730d0
|
||||
Author: Björn Esser <besser82@fedoraproject.org>
|
||||
Date: Sat Jan 20 20:22:53 2018 +0100
|
||||
|
||||
pp: Guard fix for really old bug in glibc libcrypt
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index d50ad7ddbf..6510c7b15c 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -3650,8 +3650,12 @@ PP(pp_crypt)
|
||||
#if defined(__GLIBC__) || defined(__EMX__)
|
||||
if (PL_reentrant_buffer->_crypt_struct_buffer) {
|
||||
PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
|
||||
- /* work around glibc-2.2.5 bug */
|
||||
+#if (defined(__GLIBC__) && __GLIBC__ == 2) && \
|
||||
+ (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
|
||||
+ /* work around glibc-2.2.5 bug, has been fixed at some
|
||||
+ * time in glibc-2.3.X */
|
||||
PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
|
||||
+#endif
|
||||
}
|
||||
#endif
|
||||
}
|
|
@ -0,0 +1,107 @@
|
|||
From 7a962424149cc60f3a187d0213a12689dd5e806b Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 14 Aug 2017 11:52:39 +1000
|
||||
Subject: [PATCH] (perl #131746) avoid undefined behaviour in Copy() etc
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
These functions depend on C library functions which have undefined
|
||||
behaviour when passed NULL pointers, even when passed a zero 'n' value.
|
||||
|
||||
Some compilers use this information, ie. assume the pointers are
|
||||
non-NULL when optimizing any following code, so we do need to
|
||||
prevent such unguarded calls.
|
||||
|
||||
My initial thought was to add conditionals to each macro to skip the
|
||||
call to the library function when n is zero, but this adds a cost to
|
||||
every use of these macros, even when the n value is always true.
|
||||
|
||||
So instead I added asserts() which will give us a much more visible
|
||||
indicator of such broken code and revealed the pp_caller and Glob.xs
|
||||
issues also patched here.
|
||||
|
||||
Petr Písař: Ported to 5.26.1 from
|
||||
f14cf3632059d421de83cf901c7e849adc1fcd03.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/File-Glob/Glob.xs | 2 +-
|
||||
handy.h | 14 +++++++-------
|
||||
pp_ctl.c | 3 ++-
|
||||
pp_hot.c | 3 ++-
|
||||
4 files changed, 12 insertions(+), 10 deletions(-)
|
||||
|
||||
diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
|
||||
index e0a3681..9779d54 100644
|
||||
--- a/ext/File-Glob/Glob.xs
|
||||
+++ b/ext/File-Glob/Glob.xs
|
||||
@@ -121,7 +121,7 @@ iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, boo
|
||||
|
||||
/* chuck it all out, quick or slow */
|
||||
if (gimme == G_ARRAY) {
|
||||
- if (!on_stack) {
|
||||
+ if (!on_stack && AvFILLp(entries) + 1) {
|
||||
EXTEND(SP, AvFILLp(entries)+1);
|
||||
Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
|
||||
SP += AvFILLp(entries)+1;
|
||||
diff --git a/handy.h b/handy.h
|
||||
index 80f9cf4..88b5b55 100644
|
||||
--- a/handy.h
|
||||
+++ b/handy.h
|
||||
@@ -2409,17 +2409,17 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe
|
||||
#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d)))
|
||||
#endif
|
||||
|
||||
-#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
-#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
-#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||
+#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
+#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
+#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||
|
||||
-#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
-#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
+#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
+#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
#ifdef HAS_MEMSET
|
||||
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)))
|
||||
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)))
|
||||
#else
|
||||
/* Using bzero(), which returns void. */
|
||||
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)),d)
|
||||
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)),d)
|
||||
#endif
|
||||
|
||||
#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)))
|
||||
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||
index 15c193b..f1c57bc 100644
|
||||
--- a/pp_ctl.c
|
||||
+++ b/pp_ctl.c
|
||||
@@ -1971,7 +1971,8 @@ PP(pp_caller)
|
||||
|
||||
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
|
||||
av_extend(PL_dbargs, AvFILLp(ary) + off);
|
||||
- Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
|
||||
+ if (AvFILLp(ary) + 1 + off)
|
||||
+ Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
|
||||
AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
|
||||
}
|
||||
mPUSHi(CopHINTS_get(cx->blk_oldcop));
|
||||
diff --git a/pp_hot.c b/pp_hot.c
|
||||
index 5899413..66b79ea 100644
|
||||
--- a/pp_hot.c
|
||||
+++ b/pp_hot.c
|
||||
@@ -4138,7 +4138,8 @@ PP(pp_entersub)
|
||||
AvARRAY(av) = ary;
|
||||
}
|
||||
|
||||
- Copy(MARK+1,AvARRAY(av),items,SV*);
|
||||
+ if (items)
|
||||
+ Copy(MARK+1,AvARRAY(av),items,SV*);
|
||||
AvFILLp(av) = items - 1;
|
||||
}
|
||||
if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
From 2c2da8e7f0f6325fab643997a536072633fa0cf8 Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Thu, 1 Jun 2017 14:51:44 +0200
|
||||
Subject: [PATCH] Fix #131190 - UTF8 code improperly casting negative integer
|
||||
to U8 in comparison
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This reverts commit b4972372a75776de3c9e6bd234a398d103677316,
|
||||
effectively restoring commit ca7eb79a236b41b7722c6800527f95cd76843eed,
|
||||
and commit 85fde2b7c3f5631fd982f5db735b84dc9224bec0.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regexec.c | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/regexec.c b/regexec.c
|
||||
index 82128a7..35b88d7 100644
|
||||
--- a/regexec.c
|
||||
+++ b/regexec.c
|
||||
@@ -5593,6 +5593,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
|
||||
if (scan->flags == EXACTL || scan->flags == EXACTFLU8) {
|
||||
_CHECK_AND_WARN_PROBLEMATIC_LOCALE;
|
||||
if (utf8_target
|
||||
+ && nextchr >= 0 /* guard against negative EOS value in nextchr */
|
||||
&& UTF8_IS_ABOVE_LATIN1(nextchr)
|
||||
&& scan->flags == EXACTL)
|
||||
{
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,135 @@
|
|||
From bab0f8e933b383b6bef406d79c2da340bbcded33 Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Sun, 18 Jun 2017 20:45:30 +0200
|
||||
Subject: [PATCH 1/2] Resolve Perl #131522: Spurious "Assuming NOT a POSIX
|
||||
class" warning
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 30 ++++++++++++++++++------------
|
||||
1 file changed, 18 insertions(+), 12 deletions(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 8921eed..0a4ea78 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -13991,6 +13991,13 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
|
||||
REPORT_LOCATION_ARGS(p))); \
|
||||
} \
|
||||
} STMT_END
|
||||
+#define CLEAR_POSIX_WARNINGS() \
|
||||
+ if (posix_warnings && RExC_warn_text) \
|
||||
+ av_clear(RExC_warn_text)
|
||||
+
|
||||
+#define CLEAR_POSIX_WARNINGS_AND_RETURN(ret) \
|
||||
+ CLEAR_POSIX_WARNINGS(); \
|
||||
+ return ret
|
||||
|
||||
STATIC int
|
||||
S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
@@ -14063,7 +14070,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
*
|
||||
* The syntax for a legal posix class is:
|
||||
*
|
||||
- * qr/(?xa: \[ : \^? [:lower:]{4,6} : \] )/
|
||||
+ * qr/(?xa: \[ : \^? [[:lower:]]{4,6} : \] )/
|
||||
*
|
||||
* What this routine considers syntactically to be an intended posix class
|
||||
* is this (the comments indicate some restrictions that the pattern
|
||||
@@ -14088,7 +14095,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
* # for it to be considered to be
|
||||
* # an intended posix class.
|
||||
* \h*
|
||||
- * [:punct:]? # The closing class character,
|
||||
+ * [[:punct:]]? # The closing class character,
|
||||
* # possibly omitted. If not a colon
|
||||
* # nor semi colon, the class name
|
||||
* # must be even closer to a valid
|
||||
@@ -14131,8 +14138,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
|
||||
PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
|
||||
|
||||
- if (posix_warnings && RExC_warn_text)
|
||||
- av_clear(RExC_warn_text);
|
||||
+ CLEAR_POSIX_WARNINGS();
|
||||
|
||||
if (p >= e) {
|
||||
return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||
@@ -14224,7 +14230,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
*updated_parse_ptr = (char *) temp_ptr;
|
||||
}
|
||||
|
||||
- return OOB_NAMEDCLASS;
|
||||
+ CLEAR_POSIX_WARNINGS_AND_RETURN(OOB_NAMEDCLASS);
|
||||
}
|
||||
}
|
||||
|
||||
@@ -14294,7 +14300,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
/* We consider something like [^:^alnum:]] to not have been intended to
|
||||
* be a posix class, but XXX maybe we should */
|
||||
if (complement) {
|
||||
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||
}
|
||||
|
||||
complement = 1;
|
||||
@@ -14321,7 +14327,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
* this leaves this construct looking like [:] or [:^], which almost
|
||||
* certainly weren't intended to be posix classes */
|
||||
if (has_opening_bracket) {
|
||||
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||
}
|
||||
|
||||
/* But this function can be called when we parse the colon for
|
||||
@@ -14338,7 +14344,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
/* XXX We are currently very restrictive here, so this code doesn't
|
||||
* consider the possibility that, say, /[alpha.]]/ was intended to
|
||||
* be a posix class. */
|
||||
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||
}
|
||||
|
||||
/* Here we have something like 'foo:]'. There was no initial colon,
|
||||
@@ -14508,7 +14514,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
}
|
||||
|
||||
/* Otherwise, it can't have meant to have been a class */
|
||||
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||
}
|
||||
|
||||
/* If we ran off the end, and the final character was a punctuation
|
||||
@@ -14558,7 +14564,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
* class name. (We can do this on the first pass, as any second pass
|
||||
* will yield an even shorter name) */
|
||||
if (name_len < 3) {
|
||||
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||
}
|
||||
|
||||
/* Find which class it is. Initially switch on the length of the name.
|
||||
@@ -14717,7 +14723,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
}
|
||||
|
||||
/* Here neither pass found a close-enough class name */
|
||||
- return NOT_MEANT_TO_BE_A_POSIX_CLASS;
|
||||
+ CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
|
||||
}
|
||||
|
||||
probably_meant_to_be:
|
||||
@@ -14759,7 +14765,7 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
|
||||
/* If it is a known class, return the class. The class number
|
||||
* #defines are structured so each complement is +1 to the normal
|
||||
* one */
|
||||
- return class_number + complement;
|
||||
+ CLEAR_POSIX_WARNINGS_AND_RETURN(class_number + complement);
|
||||
}
|
||||
else if (! check_only) {
|
||||
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
From d730a80128abafff1e47e2506c23a8c1a06cfef4 Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Sun, 18 Jun 2017 23:44:07 +0200
|
||||
Subject: [PATCH 2/2] add test for [perl #131522] and fix test for (related)
|
||||
[perl #127581]
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/re/reg_mesg.t | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t
|
||||
index 090eccb..a0b78c4 100644
|
||||
--- a/t/re/reg_mesg.t
|
||||
+++ b/t/re/reg_mesg.t
|
||||
@@ -221,7 +221,6 @@ my @death =
|
||||
'/(?[[[::]]])/' => "Syntax error in (?[...]) in regex m/(?[[[::]]])/",
|
||||
'/(?[[[:w:]]])/' => "Syntax error in (?[...]) in regex m/(?[[[:w:]]])/",
|
||||
'/(?[[:w:]])/' => "",
|
||||
- '/[][[:alpha:]]' => "", # [perl #127581]
|
||||
'/([.].*)[.]/' => "", # [perl #127582]
|
||||
'/[.].*[.]/' => "", # [perl #127604]
|
||||
'/(?[a])/' => 'Unexpected character {#} m/(?[a{#}])/',
|
||||
@@ -587,7 +586,8 @@ my @warning = (
|
||||
'Assuming NOT a POSIX class since a semi-colon was found instead of a colon {#} m/[foo;{#}punct;]]\x{100}/',
|
||||
'Assuming NOT a POSIX class since a semi-colon was found instead of a colon {#} m/[foo;punct;]{#}]\x{100}/',
|
||||
],
|
||||
-
|
||||
+ '/[][[:alpha:]]/' => "", # [perl #127581]
|
||||
+ '/[][[:alpha:]\\@\\\\^_?]/' => "", # [perl #131522]
|
||||
); # See comments before this for why '\x{100}' is generally needed
|
||||
|
||||
# These need the character 'ネ' as a marker for mark_as_utf8()
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
From e80af1fd276d83858d27742ea887415e3263960b Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 12 Oct 2016 10:42:47 +1100
|
||||
Subject: [PATCH] (perl 129183) don't treat \ as an escape in PATH for -S
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
util.c | 5 ++---
|
||||
1 file changed, 2 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/util.c b/util.c
|
||||
index 5bb0dfc..6bc2fe5 100644
|
||||
--- a/util.c
|
||||
+++ b/util.c
|
||||
@@ -3352,9 +3352,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
|
||||
if (len < sizeof tmpbuf)
|
||||
tmpbuf[len] = '\0';
|
||||
# else
|
||||
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
|
||||
- ':',
|
||||
- &len);
|
||||
+ s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
|
||||
+ ':', &len);
|
||||
# endif
|
||||
if (s < bufend)
|
||||
s++;
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,299 @@
|
|||
From 99b847695211f825df6299aa9da91f9494f741e2 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 1 Jun 2017 15:11:27 +1000
|
||||
Subject: [PATCH] [perl #131221] improve duplication of :via handles
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Previously duplication (as with open ... ">&...") would fail
|
||||
unless the user supplied a GETARG, which wasn't documented, and
|
||||
resulted in an attempt to free and unreferened scalar if supplied.
|
||||
|
||||
Cloning on thread creation was simply broken.
|
||||
|
||||
We now handle GETARG correctly, and provide a useful default if it
|
||||
returns nothing.
|
||||
|
||||
Cloning on thread creation now duplicates the appropriate parts of the
|
||||
parent thread's handle.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 1 +
|
||||
ext/PerlIO-via/t/thread.t | 73 +++++++++++++++++++++++++++++++++++++++++++++++
|
||||
ext/PerlIO-via/t/via.t | 56 +++++++++++++++++++++++++++++++++++-
|
||||
ext/PerlIO-via/via.pm | 2 +-
|
||||
ext/PerlIO-via/via.xs | 55 +++++++++++++++++++++++++++++++----
|
||||
5 files changed, 179 insertions(+), 8 deletions(-)
|
||||
create mode 100644 ext/PerlIO-via/t/thread.t
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 8c4950e..d39f992 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -4056,6 +4056,7 @@ ext/PerlIO-scalar/scalar.xs PerlIO layer for scalars
|
||||
ext/PerlIO-scalar/t/scalar.t See if PerlIO::scalar works
|
||||
ext/PerlIO-scalar/t/scalar_ungetc.t Tests for PerlIO layer for scalars
|
||||
ext/PerlIO-via/hints/aix.pl Hint for PerlIO::via for named architecture
|
||||
+ext/PerlIO-via/t/thread.t See if PerlIO::via works with threads
|
||||
ext/PerlIO-via/t/via.t See if PerlIO::via works
|
||||
ext/PerlIO-via/via.pm PerlIO layer for layers in perl
|
||||
ext/PerlIO-via/via.xs PerlIO layer for layers in perl
|
||||
diff --git a/ext/PerlIO-via/t/thread.t b/ext/PerlIO-via/t/thread.t
|
||||
new file mode 100644
|
||||
index 0000000..e4358f9
|
||||
--- /dev/null
|
||||
+++ b/ext/PerlIO-via/t/thread.t
|
||||
@@ -0,0 +1,73 @@
|
||||
+#!perl
|
||||
+BEGIN {
|
||||
+ unless (find PerlIO::Layer 'perlio') {
|
||||
+ print "1..0 # Skip: not perlio\n";
|
||||
+ exit 0;
|
||||
+ }
|
||||
+ require Config;
|
||||
+ unless ($Config::Config{'usethreads'}) {
|
||||
+ print "1..0 # Skip -- need threads for this test\n";
|
||||
+ exit 0;
|
||||
+ }
|
||||
+ if (($Config::Config{'extensions'} !~ m!\bPerlIO/via\b!) ){
|
||||
+ print "1..0 # Skip -- Perl configured without PerlIO::via module\n";
|
||||
+ exit 0;
|
||||
+ }
|
||||
+}
|
||||
+
|
||||
+use strict;
|
||||
+use warnings;
|
||||
+use threads;
|
||||
+
|
||||
+my $tmp = "via$$";
|
||||
+
|
||||
+END {
|
||||
+ 1 while unlink $tmp;
|
||||
+}
|
||||
+
|
||||
+use Test::More tests => 2;
|
||||
+
|
||||
+our $push_count = 0;
|
||||
+
|
||||
+{
|
||||
+ open my $fh, ">:via(Test1)", $tmp
|
||||
+ or die "Cannot open $tmp: $!";
|
||||
+ $fh->autoflush;
|
||||
+
|
||||
+ print $fh "AXAX";
|
||||
+
|
||||
+ # previously this would crash
|
||||
+ threads->create(
|
||||
+ sub {
|
||||
+ print $fh "XZXZ";
|
||||
+ })->join;
|
||||
+
|
||||
+ print $fh "BXBX";
|
||||
+ close $fh;
|
||||
+
|
||||
+ open my $in, "<", $tmp;
|
||||
+ my $line = <$in>;
|
||||
+ close $in;
|
||||
+
|
||||
+ is($line, "AYAYYZYZBYBY", "check thread data delivered");
|
||||
+
|
||||
+ is($push_count, 1, "PUSHED not called for dup on thread creation");
|
||||
+}
|
||||
+
|
||||
+package PerlIO::via::Test1;
|
||||
+
|
||||
+sub PUSHED {
|
||||
+ my ($class) = @_;
|
||||
+ ++$main::push_count;
|
||||
+ bless {}, $class;
|
||||
+}
|
||||
+
|
||||
+sub WRITE {
|
||||
+ my ($self, $data, $fh) = @_;
|
||||
+ $data =~ tr/X/Y/;
|
||||
+ $fh->autoflush;
|
||||
+ print $fh $data;
|
||||
+ return length $data;
|
||||
+}
|
||||
+
|
||||
+
|
||||
diff --git a/ext/PerlIO-via/t/via.t b/ext/PerlIO-via/t/via.t
|
||||
index 6787e11..80577df 100644
|
||||
--- a/ext/PerlIO-via/t/via.t
|
||||
+++ b/ext/PerlIO-via/t/via.t
|
||||
@@ -17,7 +17,7 @@ use warnings;
|
||||
|
||||
my $tmp = "via$$";
|
||||
|
||||
-use Test::More tests => 18;
|
||||
+use Test::More tests => 26;
|
||||
|
||||
my $fh;
|
||||
my $a = join("", map { chr } 0..255) x 10;
|
||||
@@ -84,6 +84,60 @@ is( $obj, 'Foo', 'search for package Foo' );
|
||||
open $fh, '<:via(Bar)', "bar";
|
||||
is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' );
|
||||
|
||||
+{
|
||||
+ # [perl #131221]
|
||||
+ ok(open(my $fh1, ">", $tmp), "open $tmp");
|
||||
+ ok(binmode($fh1, ":via(XXX)"), "binmode :via(XXX) onto it");
|
||||
+ ok(open(my $fh2, ">&", $fh1), "dup it");
|
||||
+ close $fh1;
|
||||
+ close $fh2;
|
||||
+
|
||||
+ # make sure the old workaround still works
|
||||
+ ok(open($fh1, ">", $tmp), "open $tmp");
|
||||
+ ok(binmode($fh1, ":via(YYY)"), "binmode :via(YYY) onto it");
|
||||
+ ok(open($fh2, ">&", $fh1), "dup it");
|
||||
+ print $fh2 "XZXZ";
|
||||
+ close $fh1;
|
||||
+ close $fh2;
|
||||
+
|
||||
+ ok(open($fh1, "<", $tmp), "open $tmp for check");
|
||||
+ { local $/; $b = <$fh1> }
|
||||
+ close $fh1;
|
||||
+ is($b, "XZXZ", "check result is from non-filtering class");
|
||||
+
|
||||
+ package PerlIO::via::XXX;
|
||||
+
|
||||
+ sub PUSHED {
|
||||
+ my $class = shift;
|
||||
+ bless {}, $class;
|
||||
+ }
|
||||
+
|
||||
+ sub WRITE {
|
||||
+ my ($self, $buffer, $handle) = @_;
|
||||
+
|
||||
+ print $handle $buffer;
|
||||
+ return length($buffer);
|
||||
+ }
|
||||
+ package PerlIO::via::YYY;
|
||||
+
|
||||
+ sub PUSHED {
|
||||
+ my $class = shift;
|
||||
+ bless {}, $class;
|
||||
+ }
|
||||
+
|
||||
+ sub WRITE {
|
||||
+ my ($self, $buffer, $handle) = @_;
|
||||
+
|
||||
+ $buffer =~ tr/X/Y/;
|
||||
+ print $handle $buffer;
|
||||
+ return length($buffer);
|
||||
+ }
|
||||
+
|
||||
+ sub GETARG {
|
||||
+ "XXX";
|
||||
+ }
|
||||
+}
|
||||
+
|
||||
END {
|
||||
1 while unlink $tmp;
|
||||
}
|
||||
diff --git a/ext/PerlIO-via/via.pm b/ext/PerlIO-via/via.pm
|
||||
index e477dcc..30083fe 100644
|
||||
--- a/ext/PerlIO-via/via.pm
|
||||
+++ b/ext/PerlIO-via/via.pm
|
||||
@@ -1,5 +1,5 @@
|
||||
package PerlIO::via;
|
||||
-our $VERSION = '0.16';
|
||||
+our $VERSION = '0.17';
|
||||
require XSLoader;
|
||||
XSLoader::load();
|
||||
1;
|
||||
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
|
||||
index 8a7f1fc..61953c8 100644
|
||||
--- a/ext/PerlIO-via/via.xs
|
||||
+++ b/ext/PerlIO-via/via.xs
|
||||
@@ -38,6 +38,8 @@ typedef struct
|
||||
CV *UTF8;
|
||||
} PerlIOVia;
|
||||
|
||||
+static const MGVTBL PerlIOVia_tag = { 0, 0, 0, 0, 0, 0, 0, 0 };
|
||||
+
|
||||
#define MYMethod(x) #x,&s->x
|
||||
|
||||
static CV *
|
||||
@@ -131,8 +133,14 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
|
||||
PerlIO_funcs * tab)
|
||||
{
|
||||
IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
|
||||
+
|
||||
+ if (SvTYPE(arg) >= SVt_PVMG
|
||||
+ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
|
||||
+ return code;
|
||||
+ }
|
||||
+
|
||||
if (code == 0) {
|
||||
- PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
|
||||
+ PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
|
||||
if (!arg) {
|
||||
if (ckWARN(WARN_LAYER))
|
||||
Perl_warner(aTHX_ packWARN(WARN_LAYER),
|
||||
@@ -583,20 +591,55 @@ static SV *
|
||||
PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
|
||||
{
|
||||
PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
|
||||
- PERL_UNUSED_ARG(param);
|
||||
+ SV *arg;
|
||||
PERL_UNUSED_ARG(flags);
|
||||
- return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
|
||||
+
|
||||
+ /* During cloning, return an undef token object so that _pushed() knows
|
||||
+ * that it should not call methods and wait for _dup() to actually dup the
|
||||
+ * object. */
|
||||
+ if (param) {
|
||||
+ SV *sv = newSV(0);
|
||||
+ sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOVia_tag, 0, 0);
|
||||
+ return sv;
|
||||
+ }
|
||||
+
|
||||
+ arg = PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
|
||||
+ if (arg) {
|
||||
+ /* arg is a temp, and PerlIOBase_dup() will explicitly free it */
|
||||
+ SvREFCNT_inc(arg);
|
||||
+ }
|
||||
+ else {
|
||||
+ arg = newSVpvn(HvNAME(s->stash), HvNAMELEN(s->stash));
|
||||
+ }
|
||||
+
|
||||
+ return arg;
|
||||
}
|
||||
|
||||
static PerlIO *
|
||||
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
|
||||
int flags)
|
||||
{
|
||||
- if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
|
||||
- /* Most of the fields will lazily set themselves up as needed
|
||||
- stash and obj have been set up by the implied push
|
||||
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)) && param) {
|
||||
+ /* For a non-interpreter dup stash and obj have been set up
|
||||
+ by the implied push.
|
||||
+
|
||||
+ But if this is a clone for a new interpreter we need to
|
||||
+ translate the objects to their dups.
|
||||
*/
|
||||
+
|
||||
+ PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
|
||||
+ PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
|
||||
+
|
||||
+ fs->obj = sv_dup_inc(os->obj, param);
|
||||
+ fs->stash = (HV*)sv_dup((SV*)os->stash, param);
|
||||
+ fs->var = sv_dup_inc(os->var, param);
|
||||
+ fs->cnt = os->cnt;
|
||||
+
|
||||
+ /* fh, io, cached CVs left as NULL, PerlIOVia_method()
|
||||
+ will reinitialize them if needed */
|
||||
}
|
||||
+ /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
|
||||
+
|
||||
return f;
|
||||
}
|
||||
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
From 7b3443d31f11c15859593e5b710c301795a6de01 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 8 Jun 2017 11:06:39 +1000
|
||||
Subject: [PATCH] [perl #131221] sv_dup/sv_dup_inc are only available under
|
||||
threads
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/PerlIO-via/via.xs | 42 +++++++++++++++++++++++-------------------
|
||||
1 file changed, 23 insertions(+), 19 deletions(-)
|
||||
|
||||
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
|
||||
index 61953c8..d91c685 100644
|
||||
--- a/ext/PerlIO-via/via.xs
|
||||
+++ b/ext/PerlIO-via/via.xs
|
||||
@@ -619,26 +619,30 @@ static PerlIO *
|
||||
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
|
||||
int flags)
|
||||
{
|
||||
- if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)) && param) {
|
||||
- /* For a non-interpreter dup stash and obj have been set up
|
||||
- by the implied push.
|
||||
-
|
||||
- But if this is a clone for a new interpreter we need to
|
||||
- translate the objects to their dups.
|
||||
- */
|
||||
-
|
||||
- PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
|
||||
- PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
|
||||
-
|
||||
- fs->obj = sv_dup_inc(os->obj, param);
|
||||
- fs->stash = (HV*)sv_dup((SV*)os->stash, param);
|
||||
- fs->var = sv_dup_inc(os->var, param);
|
||||
- fs->cnt = os->cnt;
|
||||
-
|
||||
- /* fh, io, cached CVs left as NULL, PerlIOVia_method()
|
||||
- will reinitialize them if needed */
|
||||
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
|
||||
+#ifdef USE_ITHREADS
|
||||
+ if (param) {
|
||||
+ /* For a non-interpreter dup stash and obj have been set up
|
||||
+ by the implied push.
|
||||
+
|
||||
+ But if this is a clone for a new interpreter we need to
|
||||
+ translate the objects to their dups.
|
||||
+ */
|
||||
+
|
||||
+ PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
|
||||
+ PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
|
||||
+
|
||||
+ fs->obj = sv_dup_inc(os->obj, param);
|
||||
+ fs->stash = (HV*)sv_dup((SV*)os->stash, param);
|
||||
+ fs->var = sv_dup_inc(os->var, param);
|
||||
+ fs->cnt = os->cnt;
|
||||
+
|
||||
+ /* fh, io, cached CVs left as NULL, PerlIOVia_method()
|
||||
+ will reinitialize them if needed */
|
||||
+ }
|
||||
+#endif
|
||||
+ /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
|
||||
}
|
||||
- /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
|
||||
|
||||
return f;
|
||||
}
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
From 9604fbf0722bd97ca6031a263c50ad52b6633db7 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 14 Jun 2017 09:42:31 +1000
|
||||
Subject: [PATCH] (perl #131526) don't go beyond the end of the NUL in my_atof2
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Perl_my_atof2() calls GROK_NUMERIC_RADIX() to detect and skip past
|
||||
a decimal point and then can increment the parse pointer (s) before
|
||||
checking what it points at, so skipping the terminating NUL if the
|
||||
decimal point is immediately before the NUL.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
numeric.c | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/numeric.c b/numeric.c
|
||||
index 6ea6968..5771907 100644
|
||||
--- a/numeric.c
|
||||
+++ b/numeric.c
|
||||
@@ -1485,9 +1485,9 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
|
||||
else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
|
||||
seen_dp = 1;
|
||||
if (sig_digits > MAX_SIG_DIGITS) {
|
||||
- do {
|
||||
+ while (isDIGIT(*s)) {
|
||||
++s;
|
||||
- } while (isDIGIT(*s));
|
||||
+ }
|
||||
break;
|
||||
}
|
||||
}
|
||||
--
|
||||
2.9.4
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
From 45908e4d120d33a558a8b052036c56cd0c90b898 Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Wed, 13 Sep 2017 13:30:25 +0200
|
||||
Subject: [PATCH] avoid 'the address of ... will always evaluate as ...' warns
|
||||
in mem macros
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
In f14cf363205 we added asserts to our memory macros (Copy(), Zero() etc)
|
||||
to ensure that the target is non-null. These asserts throw warnings like
|
||||
|
||||
perl.c: In function ‘Perl_eval_sv’:
|
||||
perl.c:2976:264: warning: the address of ‘myop’ will always evaluate
|
||||
as ‘true’ [-Waddress]
|
||||
Zero(&myop, 1, UNOP);
|
||||
|
||||
which is annoying. This patch changes how these asserts are coded so
|
||||
we avoid the warning. Thanks to Zefram for the fix.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
handy.h | 17 ++++++++++-------
|
||||
1 file changed, 10 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/handy.h b/handy.h
|
||||
index 31afaae65e..85e8f70721 100644
|
||||
--- a/handy.h
|
||||
+++ b/handy.h
|
||||
@@ -2409,17 +2409,20 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe
|
||||
#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d)))
|
||||
#endif
|
||||
|
||||
-#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
-#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
-#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||
+#define perl_assert_ptr(p) assert( ((void*)(p)) != 0 )
|
||||
|
||||
-#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
-#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
+
|
||||
+#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
+#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
+#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||
+
|
||||
+#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
+#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||
#ifdef HAS_MEMSET
|
||||
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)))
|
||||
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), memzero((char*)(d), (n) * sizeof(t)))
|
||||
#else
|
||||
/* Using bzero(), which returns void. */
|
||||
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)),d)
|
||||
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), memzero((char*)(d), (n) * sizeof(t)),d)
|
||||
#endif
|
||||
|
||||
#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)))
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
From e7e69c85c7e8e0cb75b831e606ad4f26f18b11ff Mon Sep 17 00:00:00 2001
|
||||
From: Nicolas R <atoomic@cpan.org>
|
||||
Date: Mon, 31 Oct 2016 11:53:17 -0600
|
||||
Subject: [PATCH] Avoid a segfault when untying an object
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Check if the tied object has a stash set
|
||||
before calling UNTIE method.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp_sys.c | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/pp_sys.c b/pp_sys.c
|
||||
index 672e7de08e..6d4dd86b7f 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -1017,7 +1017,7 @@ PP(pp_untie)
|
||||
|
||||
if ((mg = SvTIED_mg(sv, how))) {
|
||||
SV * const obj = SvRV(SvTIED_obj(sv, mg));
|
||||
- if (obj) {
|
||||
+ if (obj && SvSTASH(obj)) {
|
||||
GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
|
||||
CV *cv;
|
||||
if (gv && isGV(gv) && (cv = GvCV(gv))) {
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
From 8e7c2faafb74d3b07e8a5818608dfe065e361604 Mon Sep 17 00:00:00 2001
|
||||
From: "Craig A. Berry" <craigberry@mac.com>
|
||||
Date: Mon, 1 Jan 2018 10:10:33 -0600
|
||||
Subject: [PATCH] Reenable numeric first argument of system() on VMS.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This was broken in 64def2aeaeb63f92dadc6dfa334, and fixed for Win32
|
||||
only in 8fe3452cc6ac7af8c08. But VMS also uses a numeric first
|
||||
argument to system() as a flag indicating spawn without waiting for
|
||||
completion.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp_sys.c | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/pp_sys.c b/pp_sys.c
|
||||
index 0c9147bc4e..5154b9baa8 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -4375,7 +4375,7 @@ PP(pp_system)
|
||||
STRLEN len;
|
||||
char *pv;
|
||||
SvGETMAGIC(origsv);
|
||||
-#ifdef WIN32
|
||||
+#if defined(WIN32) || defined(__VMS)
|
||||
/*
|
||||
* Because of a nasty platform-specific variation on the meaning
|
||||
* of arguments to this op, we must preserve numeric arguments
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
From 8fe3452cc6ac7af8c08c2044cd3757018a9c8887 Mon Sep 17 00:00:00 2001
|
||||
From: Zefram <zefram@fysh.org>
|
||||
Date: Fri, 22 Dec 2017 05:32:41 +0000
|
||||
Subject: [PATCH] preserve numericness of system() args on Win32
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
On Windows there's a nasty variation in the meaning of arguments
|
||||
to Perl's system(), in which a numeric first argument isn't used as
|
||||
part of the command to run, but instead selects between two different
|
||||
operations to perform with the command (whether to wait for the command
|
||||
to complete or not). Therefore the reduction of argument scalars to
|
||||
their operative values in the parent process, which was added in commit
|
||||
64def2aeaeb63f92dadc6dfa33486c1d7b311963, needs to preserve numericness
|
||||
of arguments on Windows. Fixes [perl #132633].
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp_sys.c | 35 +++++++++++++++++++++++++++++++----
|
||||
1 file changed, 31 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/pp_sys.c b/pp_sys.c
|
||||
index beb60da4c6..0649794104 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -4393,12 +4393,39 @@ PP(pp_system)
|
||||
# endif
|
||||
|
||||
while (++MARK <= SP) {
|
||||
- SV *origsv = *MARK;
|
||||
+ SV *origsv = *MARK, *copysv;
|
||||
STRLEN len;
|
||||
char *pv;
|
||||
- pv = SvPV(origsv, len);
|
||||
- *MARK = newSVpvn_flags(pv, len,
|
||||
- (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
|
||||
+ SvGETMAGIC(origsv);
|
||||
+#ifdef WIN32
|
||||
+ /*
|
||||
+ * Because of a nasty platform-specific variation on the meaning
|
||||
+ * of arguments to this op, we must preserve numeric arguments
|
||||
+ * as numeric, not just retain the string value.
|
||||
+ */
|
||||
+ if (SvNIOK(origsv) || SvNIOKp(origsv)) {
|
||||
+ copysv = newSV_type(SVt_PVNV);
|
||||
+ sv_2mortal(copysv);
|
||||
+ if (SvPOK(origsv) || SvPOKp(origsv)) {
|
||||
+ pv = SvPV_nomg(origsv, len);
|
||||
+ sv_setpvn(copysv, pv, len);
|
||||
+ SvPOK_off(copysv);
|
||||
+ }
|
||||
+ if (SvIOK(origsv) || SvIOKp(origsv))
|
||||
+ SvIV_set(copysv, SvIVX(origsv));
|
||||
+ if (SvNOK(origsv) || SvNOKp(origsv))
|
||||
+ SvNV_set(copysv, SvNVX(origsv));
|
||||
+ SvFLAGS(copysv) |= SvFLAGS(origsv) &
|
||||
+ (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK|
|
||||
+ SVf_UTF8|SVf_IVisUV);
|
||||
+ } else
|
||||
+#endif
|
||||
+ {
|
||||
+ pv = SvPV_nomg(origsv, len);
|
||||
+ copysv = newSVpvn_flags(pv, len,
|
||||
+ (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
|
||||
+ }
|
||||
+ *MARK = copysv;
|
||||
}
|
||||
MARK = ORIGMARK;
|
||||
|
||||
--
|
||||
2.13.6
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
From f6bc8fb3d26892ba1a84ba2df76beedd51998dd2 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Mon, 29 Jan 2018 16:34:17 +0100
|
||||
Subject: [PATCH] hints/linux: Add -lphtread to lddlflags
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Passing -z defs to linker flags causes perl to fail to build if threads are
|
||||
enabled:
|
||||
|
||||
gcc -shared -Wl,-z,relro -Wl,-z,defs -specs=/usr/lib/rpm/redhat/redhat-hardened-ld -L/usr/local/lib -fstack-protector-strong Bzip2.o -o ../../lib/auto/Compress/Raw/Bzip2/Bzip2.so \
|
||||
-L/usr/lib64 -lbz2 "-L../.." -lperl \
|
||||
|
||||
Bzip2.o: In function `deRef':
|
||||
/builddir/build/BUILD/perl-5.26.1/cpan/Compress-Raw-Bzip2/Bzip2.xs:256: undefined reference to `pthread_getspecific'
|
||||
|
||||
The reason is Bzip2.xs calls dTHX macro included from thread.h via perl.h that
|
||||
expands to pthread_getspecific() function call that is defined in pthread
|
||||
library. But the pthread library is not explicitly linked to Bzip.so (see the
|
||||
gcc command). This is exactly what -z defs linker flag enforces.
|
||||
|
||||
Underlinking ELFs can be dangerous because in case of versioned
|
||||
symbols it can cause run-time binding to an improper version symbol or
|
||||
even to an symbold from different library.
|
||||
|
||||
This patch fixes hints for Linux by adding -lpthreads to lddlflags. It
|
||||
also adds -shared there because Configure.sh adds it only hints return
|
||||
lddlflags empty.
|
||||
|
||||
<https://lists.fedoraproject.org/archives/list/devel@lists.fedoraproject.org/message/3RHZEHLRUHJFF2XGHI5RB6YPDNLDR4HG/>
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
hints/linux.sh | 4 ++++
|
||||
1 file changed, 4 insertions(+)
|
||||
|
||||
diff --git a/hints/linux.sh b/hints/linux.sh
|
||||
index 3f38ea07f1..9ec3bc02ef 100644
|
||||
--- a/hints/linux.sh
|
||||
+++ b/hints/linux.sh
|
||||
@@ -353,12 +353,16 @@ if [ -f /etc/synoinfo.conf -a -d /usr/syno ]; then
|
||||
echo "$libswanted" >&4
|
||||
fi
|
||||
|
||||
+# Flags needed to produce shared libraries.
|
||||
+lddlflags='-shared'
|
||||
+
|
||||
# This script UU/usethreads.cbu will get 'called-back' by Configure
|
||||
# after it has prompted the user for whether to use threads.
|
||||
cat > UU/usethreads.cbu <<'EOCBU'
|
||||
case "$usethreads" in
|
||||
$define|true|[yY]*)
|
||||
ccflags="-D_REENTRANT -D_GNU_SOURCE $ccflags"
|
||||
+ lddlflags="-lpthread $lddlflags"
|
||||
if echo $libswanted | grep -v pthread >/dev/null
|
||||
then
|
||||
set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
|
||||
--
|
||||
2.13.6
|
||||
|
2
sources
2
sources
|
@ -1 +1 @@
|
|||
SHA512 (perl-5.24.1.tar.bz2) = 5a6e5f5fcd65e7add7ba2126d530a8e2a912cb076cfe61bbf7e49b28e4e63aa0d474183a6f8a388c67d03ea6a44f367efb3b3a768e971ef52b769e737eeb048b
|
||||
SHA512 (perl-5.24.4.tar.bz2) = 3bae714aaa3ac81f4be09c24cf708f339253b2cd3f6195cf60bf91e0e8a025a226ba527c11dfabdba33a642ce885c4c1979b9602367a6915a32a2b4c2c64bb38
|
||||
|
|
Loading…
Reference in New Issue