Compare commits
No commits in common. "c8" and "stream-perl-5.30-rhel-8.10.0" have entirely different histories.
c8
...
stream-per
|
|
@ -1 +1,34 @@
|
|||
SOURCES/perl-5.26.3.tar.bz2
|
||||
perl-5.12.1.tar.gz
|
||||
/perl-5.12.2.tar.gz
|
||||
/perl-5.12.3.tar.gz
|
||||
/perl-5.14.0-RC2.tar.bz2
|
||||
/perl-5.14.0.tar.bz2
|
||||
/perl-5.14.0.tar.gz
|
||||
/perl-5.14.1.tar.gz
|
||||
/perl-5.14.2.tar.bz2
|
||||
/perl-5.16.0-RC2.tar.gz
|
||||
/perl-5.16.0.tar.gz
|
||||
/perl-5.16.1-228.fc19.src.rpm
|
||||
/perl-5.16.1.tar.gz
|
||||
/perl-5.16.2.tar.gz
|
||||
/perl-5.16.3.tar.bz2
|
||||
/perl-5.18.0.tar.bz2
|
||||
/perl-5.18.1.tar.bz2
|
||||
/perl-5.18.2.tar.bz2
|
||||
/perl-5.20.0.tar.bz2
|
||||
/perl-5.20.1.tar.bz2
|
||||
/perl-5.20.2.tar.bz2
|
||||
/perl-5.22.0.tar.bz2
|
||||
/perl-5.22.1.tar.bz2
|
||||
/perl-5.22.2.tar.bz2
|
||||
/perl-5.24.0.tar.bz2
|
||||
/perl-5.24.1.tar.bz2
|
||||
/perl-5.26.0.tar.bz2
|
||||
/perl-5.26.1.tar.bz2
|
||||
/perl-5.26.2-RC1.tar.bz2
|
||||
/perl-5.26.2.tar.bz2
|
||||
/perl-5.28.0.tar.xz
|
||||
/perl-5.28.1.tar.xz
|
||||
/perl-5.28.2.tar.xz
|
||||
/perl-5.30.0.tar.xz
|
||||
/perl-5.30.1.tar.xz
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
4c61872bab631427cbb5b519ef8809d3a4c7f921 SOURCES/perl-5.26.3.tar.bz2
|
||||
4bc190b6ac368f573e6a028f91430f831d40d30a perl-5.30.1.tar.xz
|
||||
|
|
|
|||
|
|
@ -1,30 +0,0 @@
|
|||
From 862c89c81d26dae0dcef138e19df8b45615e69c9 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Mon, 2 Dec 2013 10:10:56 +0100
|
||||
Subject: [PATCH] Document Math::BigInt::CalcEmu requires Math::BigInt
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
<https://rt.cpan.org/Public/Bug/Display.html?id=85015>
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm b/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||
index c82e153..0c0b496 100644
|
||||
--- a/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||
+++ b/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||
@@ -290,6 +290,7 @@ Math::BigInt::CalcEmu - Emulate low-level math with BigInt code
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
+ use Math::BigInt;
|
||||
use Math::BigInt::CalcEmu;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
--
|
||||
1.8.3.1
|
||||
|
||||
|
|
@ -1,73 +0,0 @@
|
|||
From 8985b12868f07d9ef501580d600e49fe8f230eb4 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Tue, 22 Aug 2017 09:49:42 +0200
|
||||
Subject: [PATCH] Time-HiRes: Fix unreliable t/usleep.t and t/utime.t
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Ported from Time-HiRes-1.9746.
|
||||
|
||||
The tests randomly failed on loaded machines because a CPU scheduler
|
||||
could add unpredictable delays.
|
||||
|
||||
CPAN RT#122819
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/Time-HiRes/t/usleep.t | 4 ++--
|
||||
dist/Time-HiRes/t/utime.t | 9 +++++----
|
||||
2 files changed, 7 insertions(+), 6 deletions(-)
|
||||
|
||||
diff --git a/dist/Time-HiRes/t/usleep.t b/dist/Time-HiRes/t/usleep.t
|
||||
index 9322458..bb66cbe 100644
|
||||
--- a/dist/Time-HiRes/t/usleep.t
|
||||
+++ b/dist/Time-HiRes/t/usleep.t
|
||||
@@ -32,7 +32,7 @@ SKIP: {
|
||||
Time::HiRes::usleep(500_000);
|
||||
my $f2 = Time::HiRes::time();
|
||||
my $d = $f2 - $f;
|
||||
- ok $d > 0.4 && $d < 0.9 or print("# slept $d secs $f to $f2\n");
|
||||
+ ok $d > 0.49 or print("# slept $d secs $f to $f2\n");
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
@@ -40,7 +40,7 @@ SKIP: {
|
||||
my $r = [ Time::HiRes::gettimeofday() ];
|
||||
Time::HiRes::sleep( 0.5 );
|
||||
my $f = Time::HiRes::tv_interval $r;
|
||||
- ok $f > 0.4 && $f < 0.9 or print("# slept $f instead of 0.5 secs.\n");
|
||||
+ ok $f > 0.49 or print("# slept $f instead of 0.5 secs.\n");
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
diff --git a/dist/Time-HiRes/t/utime.t b/dist/Time-HiRes/t/utime.t
|
||||
index 22fd48e..c5c7e55 100644
|
||||
--- a/dist/Time-HiRes/t/utime.t
|
||||
+++ b/dist/Time-HiRes/t/utime.t
|
||||
@@ -106,17 +106,18 @@ print "# utime undef sets time to now\n";
|
||||
my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
|
||||
|
||||
my $now = Time::HiRes::time;
|
||||
+ sleep(1);
|
||||
is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed";
|
||||
|
||||
{
|
||||
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
|
||||
- cmp_ok abs( $got_atime - $now), '<', 0.1, "File 1 atime set correctly";
|
||||
- cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 1 mtime set correctly";
|
||||
+ cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly";
|
||||
+ cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly";
|
||||
}
|
||||
{
|
||||
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
|
||||
- cmp_ok abs( $got_atime - $now), '<', 0.1, "File 2 atime set correctly";
|
||||
- cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 2 mtime set correctly";
|
||||
+ cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly";
|
||||
+ cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly";
|
||||
}
|
||||
};
|
||||
|
||||
--
|
||||
2.9.5
|
||||
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
From 7b3e03bd309fcc48a135123a60678ae2596b1c38 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.26.0:
|
||||
|
||||
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 9f3e28e..ae3dc95 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -3179,6 +3179,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 4fe6b00..670ccf6 100644
|
||||
--- a/t/op/gv.t
|
||||
+++ b/t/op/gv.t
|
||||
@@ -12,7 +12,7 @@ BEGIN {
|
||||
|
||||
use warnings;
|
||||
|
||||
-plan(tests => 280);
|
||||
+plan(tests => 282);
|
||||
|
||||
# type coercion on assignment
|
||||
$foo = 'foo';
|
||||
@@ -1170,6 +1170,14 @@ SKIP: {
|
||||
is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
|
||||
}
|
||||
|
||||
+{
|
||||
+ # [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");
|
||||
+}
|
||||
+
|
||||
# test gv_try_downgrade()
|
||||
# If a GV can be stored in a stash in a compact, non-GV form, then
|
||||
# whenever ops are freed which reference the GV, an attempt is made to
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
From cb2fda94b02c5b7e8d16582410034f5a3dae526f Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 25 Jul 2017 16:21:22 +1000
|
||||
Subject: [PATCH] (perl #131588) be a little more careful in arybase::_tie_it()
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Original patch by John Leitch <john@autosectools.com>
|
||||
Petr Pisar: Ported to 5.26.0.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/arybase/arybase.xs | 10 ++++++----
|
||||
ext/arybase/t/arybase.t | 4 +++-
|
||||
2 files changed, 9 insertions(+), 5 deletions(-)
|
||||
|
||||
diff --git a/ext/arybase/arybase.xs b/ext/arybase/arybase.xs
|
||||
index 880bbe3..216442a 100644
|
||||
--- a/ext/arybase/arybase.xs
|
||||
+++ b/ext/arybase/arybase.xs
|
||||
@@ -438,10 +438,12 @@ _tie_it(SV *sv)
|
||||
INIT:
|
||||
GV * const gv = (GV *)sv;
|
||||
CODE:
|
||||
- if (GvSV(gv))
|
||||
- /* This is *our* scalar now! */
|
||||
- sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
|
||||
- tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
|
||||
+ if (isGV(gv)) {
|
||||
+ if (GvSV(gv))
|
||||
+ /* This is *our* scalar now! */
|
||||
+ sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
|
||||
+ tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
|
||||
+ }
|
||||
|
||||
void
|
||||
FETCH(...)
|
||||
diff --git a/ext/arybase/t/arybase.t b/ext/arybase/t/arybase.t
|
||||
index f3d3287..41e90df 100644
|
||||
--- a/ext/arybase/t/arybase.t
|
||||
+++ b/ext/arybase/t/arybase.t
|
||||
@@ -4,7 +4,7 @@
|
||||
# plus miscellaneous bug fix tests
|
||||
|
||||
no warnings 'deprecated';
|
||||
-use Test::More tests => 7;
|
||||
+use Test::More tests => 8;
|
||||
|
||||
sub outside_base_scope { return "${'['}" }
|
||||
|
||||
@@ -34,4 +34,6 @@ is $@, "That use of \$[ is unsupported at $f line $l.\n",
|
||||
|
||||
sub foo { my $x; $x = wait } # compilation of this routine used to crash
|
||||
|
||||
+ok eval { arybase::_tie_it(1); 1 }, "don't crash on bad call to _tie_it()";
|
||||
+
|
||||
1;
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
From 37268580c0cfbf190ff9aa7859a604713cb366ee Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Tue, 27 Jun 2017 16:36:57 +0200
|
||||
Subject: [PATCH] t/op/hash.t: fixup intermittently failing test
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Port to 5.26.0:
|
||||
|
||||
commit b2ac59d1d0fda74d6612701d8316fe8dfb6a1b90
|
||||
Author: Yves Orton <demerphq@gmail.com>
|
||||
Date: Tue Jun 27 16:36:57 2017 +0200
|
||||
|
||||
t/op/hash.t: fixup intermittently failing test
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/hash.t | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/op/hash.t b/t/op/hash.t
|
||||
index a0e79c7..b941c57 100644
|
||||
--- a/t/op/hash.t
|
||||
+++ b/t/op/hash.t
|
||||
@@ -206,7 +206,7 @@ sub torture_hash {
|
||||
my $keys = pop @groups;
|
||||
++$h->{$_} foreach @$keys;
|
||||
my (undef, $total) = validate_hash("$desc " . keys %$h, $h);
|
||||
- is($total, $total0, "bucket count is constant when rebuilding");
|
||||
+ ok($total == $total0 || $total == ($total0*2), "bucket count is expected size when rebuilding");
|
||||
is(scalar %$h, pop @groups, "scalar keys is identical when rebuilding");
|
||||
++$h1->{$_} foreach @$keys;
|
||||
validate_hash("$desc copy " . keys %$h1, $h1);
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
From abd17348111a99642da217c45d836f2df5713594 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.26.1.
|
||||
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 3166415..cc74552 100644
|
||||
--- a/lib/B/Deparse.pm
|
||||
+++ b/lib/B/Deparse.pm
|
||||
@@ -5200,7 +5200,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 7eeb4f8..eae9c49 100644
|
||||
--- a/lib/B/Deparse.t
|
||||
+++ b/lib/B/Deparse.t
|
||||
@@ -2610,3 +2610,8 @@ sub ($a, $=) {
|
||||
$a;
|
||||
}
|
||||
;
|
||||
+####
|
||||
+# tr with unprintable characters
|
||||
+my $str;
|
||||
+$str = 'foo';
|
||||
+$str =~ tr/\cA//;
|
||||
--
|
||||
2.13.6
|
||||
|
||||
|
|
@ -1,111 +0,0 @@
|
|||
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
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,24 +0,0 @@
|
|||
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
|
||||
}
|
||||
|
|
@ -1,107 +0,0 @@
|
|||
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
|
||||
|
||||
|
|
@ -1,223 +0,0 @@
|
|||
From 4ac7295514f35016a79dbcc07500f6c9ca4729b7 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.26.1.
|
||||
|
||||
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 becb19b..70d7747 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -1466,7 +1466,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;
|
||||
@@ -1480,9 +1480,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");
|
||||
@@ -1499,6 +1504,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
|
||||
static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
|
||||
dSP;
|
||||
const char *file;
|
||||
+ STRLEN len;
|
||||
SV* const sv = TOPs;
|
||||
bool isio = FALSE;
|
||||
if (PL_op->op_flags & OPf_REF) {
|
||||
@@ -1542,9 +1548,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 0b60584..1b81fda 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -2963,19 +2963,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);
|
||||
@@ -3211,8 +3216,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
|
||||
@@ -3537,10 +3546,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 9c544e0..c599aa3 100644
|
||||
--- a/t/lib/warnings/pp_sys
|
||||
+++ b/t/lib/warnings/pp_sys
|
||||
@@ -972,3 +972,17 @@ close $fh;
|
||||
unlink $file;
|
||||
EXPECT
|
||||
syswrite() is deprecated on :utf8 handles. This will be a fatal error in Perl 5.30 at - line 5.
|
||||
+########
|
||||
+# NAME stat on name with \0
|
||||
+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 323c498..dbbe6ec 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();
|
||||
|
||||
@@ -653,6 +653,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
|
||||
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
From dc5c68130b7c8b727e9e792506183c255fc2bc70 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.26.1.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/lib/warnings/toke | 5 +++++
|
||||
toke.c | 6 +++---
|
||||
2 files changed, 8 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
|
||||
index fc51d9f..398ee22 100644
|
||||
--- a/t/lib/warnings/toke
|
||||
+++ b/t/lib/warnings/toke
|
||||
@@ -1651,3 +1651,8 @@ Execution of - aborted due to compilation errors.
|
||||
use utf8;
|
||||
qw∘foo ∞ ♥ bar∘
|
||||
EXPECT
|
||||
+########
|
||||
+# NAME tr/// range with empty \N{} at the start
|
||||
+tr//\N{}-0/;
|
||||
+EXPECT
|
||||
+Unknown charname '' is deprecated. Its use will be fatal in Perl 5.28 at - line 1.
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 6f84d2d..6ee7a68 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -2958,9 +2958,9 @@ S_scan_const(pTHX_ char *start)
|
||||
|
||||
/* Here, we don't think we're in a range. If the new character
|
||||
* is not a hyphen; or if it is a hyphen, but it's too close to
|
||||
- * either edge to indicate a range, then it's a regular
|
||||
- * character. */
|
||||
- if (*s != '-' || s >= send - 1 || s == start) {
|
||||
+ * either edge to indicate a range, or if we haven't output any
|
||||
+ * characters yet then it's a regular character. */
|
||||
+ if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
|
||||
|
||||
/* A regular character. Process like any other, but first
|
||||
* clear any flags */
|
||||
--
|
||||
2.13.6
|
||||
|
||||
|
|
@ -1,211 +0,0 @@
|
|||
From 8c7182b26a43f14cd8afbfbe4448cbbd691c3609 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.26.1.
|
||||
|
||||
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 fcbf5cc..996759e 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -5670,6 +5670,7 @@ t/op/srand.t See if srand works
|
||||
t/op/sselect.t See if 4 argument select works
|
||||
t/op/stash.t See if %:: stashes work
|
||||
t/op/stat.t See if stat works
|
||||
+t/op/stat_errors.t See if stat and file tests handle threshold errors
|
||||
t/op/state.t See if state variables work
|
||||
t/op/study.t See if study works
|
||||
t/op/studytied.t See if study works with tied scalars
|
||||
diff --git a/doio.c b/doio.c
|
||||
index 70d7747..71dc6e4 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -1437,8 +1437,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;
|
||||
@@ -1449,6 +1452,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));
|
||||
@@ -1459,6 +1463,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))
|
||||
@@ -1511,6 +1516,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;
|
||||
@@ -1520,6 +1527,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 fefbea3..87961f1 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -2925,10 +2925,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;
|
||||
SvPVCLEAR(PL_statname);
|
||||
@@ -2939,22 +2940,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) {
|
||||
@@ -3451,7 +3455,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
|
||||
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
From dc1f8f6b581a8e4efbb782398ab3e7c3a52b062f Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue, 8 May 2018 12:13:18 -0600
|
||||
Subject: [PATCH] PATCH: [perl #133185] Infinite loop in qr//
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This loop was inadvertently introduced as part of patches to fix
|
||||
(perl #132227 CVE-2018-6797] heap-buffer-overflow". The commit in 5.27
|
||||
responsible was f8fb8615ddc5a80e3bbd4386a8914497f921b62d.
|
||||
|
||||
To be vulnerable, the pattern must start out as /d (hence no use 5.012
|
||||
or higher), and then there must be something that implicitly forces /u
|
||||
(which the \pp does in the test case added by this patch), and then
|
||||
(?aa), and then the code point \xDF. (German Sharp S). The /i must be
|
||||
in effect by the time the DF is encountered, but it needn't come in the
|
||||
(?aa) which the test does.
|
||||
|
||||
The problem is that the conditional that is testing that we switched
|
||||
away from /d rules is assuming that this happened during the
|
||||
construction of the current EXACTFish node. The comments I wrote
|
||||
indicate this assumption. But this example shows that the switch can
|
||||
come before this node started getting constructed, and so it loops.
|
||||
|
||||
The patch explicitly saves the state at the beginning of this node's
|
||||
construction, and only retries if it changed during that construction.
|
||||
Therefore the next time through, it will see that it hasn't changed
|
||||
since the previous time, and won't loop.
|
||||
|
||||
Petr Písař: Ported to 5.26.2 from:
|
||||
|
||||
commit 0b9cb33b146b3eb55634853f883a880771dd1413
|
||||
Author: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue May 8 12:13:18 2018 -0600
|
||||
|
||||
PATCH: [perl #133185] Infinite loop in qr//
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 10 +++++++++-
|
||||
t/re/speed.t | 5 ++++-
|
||||
2 files changed, 13 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 845e660..18fa465 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -13100,6 +13100,10 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
bool maybe_exactfu = PASS2
|
||||
&& (node_type == EXACTF || node_type == EXACTFL);
|
||||
|
||||
+ /* To see if RExC_uni_semantics changes during parsing of the node.
|
||||
+ * */
|
||||
+ bool uni_semantics_at_node_start;
|
||||
+
|
||||
/* If a folding node contains only code points that don't
|
||||
* participate in folds, it can be changed into an EXACT node,
|
||||
* which allows the optimizer more things to look for */
|
||||
@@ -13147,6 +13151,8 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
|| UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
|
||||
|| UTF8_IS_START(UCHARAT(RExC_parse)));
|
||||
|
||||
+ uni_semantics_at_node_start = RExC_uni_semantics;
|
||||
+
|
||||
/* Here, we have a literal character. Find the maximal string of
|
||||
* them in the input that we can fit into a single EXACTish node.
|
||||
* We quit at the first non-literal or when the node gets full */
|
||||
@@ -13550,7 +13556,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
* didn't think it needed to reparse. But this
|
||||
* sharp s now does indicate the need for
|
||||
* reparsing. */
|
||||
- if (RExC_uni_semantics) {
|
||||
+ if ( uni_semantics_at_node_start
|
||||
+ != RExC_uni_semantics)
|
||||
+ {
|
||||
p = oldp;
|
||||
goto loopdone;
|
||||
}
|
||||
diff --git a/t/re/speed.t b/t/re/speed.t
|
||||
index 4a4830f..9a57de1 100644
|
||||
--- a/t/re/speed.t
|
||||
+++ b/t/re/speed.t
|
||||
@@ -24,7 +24,7 @@ BEGIN {
|
||||
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
|
||||
skip_all_without_unicode_tables();
|
||||
|
||||
-plan tests => 58; #** update watchdog timeouts proportionally when adding tests
|
||||
+plan tests => 59; #** update watchdog timeouts proportionally when adding tests
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
@@ -156,6 +156,9 @@ PROG
|
||||
ok( $elapsed <= 1, "should not COW on long string with substr and m//g");
|
||||
}
|
||||
|
||||
+ # [perl #133185] Infinite loop
|
||||
+ like("!\xdf", eval 'qr/\pp(?aai)\xdf/',
|
||||
+ 'Compiling qr/\pp(?aai)\xdf/ doesn\'t loop');
|
||||
|
||||
} # End of sub run_tests
|
||||
|
||||
--
|
||||
2.14.3
|
||||
|
||||
|
|
@ -1,143 +0,0 @@
|
|||
From 07ebe9c4fb1028d17e61caabe8c15abd0cd48983 Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Thu, 29 Jun 2017 11:31:14 +0200
|
||||
Subject: [PATCH] Parse caret vars with subscripts the same as normal vars
|
||||
inside of ${..} escaping
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This behavior is discussed in perl #131664, which complains that
|
||||
"${^CAPTURE}[0]" does not work as expected. Abigail explains the
|
||||
behavior is by design and Eirik Berg Hanssen expands on that explanation
|
||||
pointing out that what /should/ work, "${^CAPTURE[0]}" does not,
|
||||
which Sawyer then ruled was a bug.
|
||||
|
||||
So this patch makes "${^CAPTURE[0]}" (and "${^CAPTURE [0]}" [hi
|
||||
abigial]) work the same as they would if the var was called @foo.
|
||||
|
||||
Petr Písař: Ported to 5.26.2-RC1.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/base/lex.t | 28 +++++++++++++++++++++++++++-
|
||||
toke.c | 46 +++++++++++++++++++++++++---------------------
|
||||
2 files changed, 52 insertions(+), 22 deletions(-)
|
||||
|
||||
diff --git a/t/base/lex.t b/t/base/lex.t
|
||||
index 99fd3bb..ae17bbd 100644
|
||||
--- a/t/base/lex.t
|
||||
+++ b/t/base/lex.t
|
||||
@@ -1,6 +1,6 @@
|
||||
#!./perl
|
||||
|
||||
-print "1..112\n";
|
||||
+print "1..119\n";
|
||||
|
||||
$x = 'x';
|
||||
|
||||
@@ -154,6 +154,32 @@ my $test = 31;
|
||||
print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1;
|
||||
print "ok $test\n"; $test++;
|
||||
# print "($@)\n" if $@;
|
||||
+#
|
||||
+ ${^TEST}= "splat";
|
||||
+ @{^TEST}= ("foo", "bar");
|
||||
+ %{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
|
||||
+
|
||||
+ print "not " if "${^TEST}" ne "splat";
|
||||
+ print "ok $test\n"; $test++;
|
||||
+
|
||||
+ print "not " if "${^TEST}[0]" ne "splat[0]";
|
||||
+ print "ok $test\n"; $test++;
|
||||
+
|
||||
+ print "not " if "${^TEST[0]}" ne "foo";
|
||||
+ print "ok $test\n"; $test++;
|
||||
+
|
||||
+ print "not " if "${ ^TEST [1] }" ne "bar";
|
||||
+ print "ok $test\n"; $test++;
|
||||
+
|
||||
+ print "not " if "${^TEST}{foo}" ne "splat{foo}";
|
||||
+ print "ok $test\n"; $test++;
|
||||
+
|
||||
+ print "not " if "${^TEST{foo}}" ne "FOO";
|
||||
+ print "ok $test\n"; $test++;
|
||||
+
|
||||
+ print "not " if "${ ^TEST {bar} }" ne "BAR";
|
||||
+ print "ok $test\n"; $test++;
|
||||
+
|
||||
|
||||
# Now let's make sure that caret variables are all forced into the main package.
|
||||
package Someother;
|
||||
diff --git a/toke.c b/toke.c
|
||||
index ee9c464..aff785b 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -9416,19 +9416,36 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
|
||||
bool skip;
|
||||
char *s2;
|
||||
/* If we were processing {...} notation then... */
|
||||
- if (isIDFIRST_lazy_if_safe(d, e, is_utf8)) {
|
||||
- /* if it starts as a valid identifier, assume that it is one.
|
||||
- (the later check for } being at the expected point will trap
|
||||
- cases where this doesn't pan out.) */
|
||||
- d += is_utf8 ? UTF8SKIP(d) : 1;
|
||||
- parse_ident(&s, &d, e, 1, is_utf8, TRUE);
|
||||
- *d = '\0';
|
||||
+ if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
|
||||
+ || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
|
||||
+ && isWORDCHAR(*s))
|
||||
+ ) {
|
||||
+ /* note we have to check for a normal identifier first,
|
||||
+ * as it handles utf8 symbols, and only after that has
|
||||
+ * been ruled out can we look at the caret words */
|
||||
+ if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
|
||||
+ /* if it starts as a valid identifier, assume that it is one.
|
||||
+ (the later check for } being at the expected point will trap
|
||||
+ cases where this doesn't pan out.) */
|
||||
+ d += is_utf8 ? UTF8SKIP(d) : 1;
|
||||
+ parse_ident(&s, &d, e, 1, is_utf8, TRUE);
|
||||
+ *d = '\0';
|
||||
+ }
|
||||
+ else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
|
||||
+ d++;
|
||||
+ while (isWORDCHAR(*s) && d < e) {
|
||||
+ *d++ = *s++;
|
||||
+ }
|
||||
+ if (d >= e)
|
||||
+ Perl_croak(aTHX_ "%s", ident_too_long);
|
||||
+ *d = '\0';
|
||||
+ }
|
||||
tmp_copline = CopLINE(PL_curcop);
|
||||
if (s < PL_bufend && isSPACE(*s)) {
|
||||
s = skipspace(s);
|
||||
}
|
||||
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
|
||||
- /* ${foo[0]} and ${foo{bar}} notation. */
|
||||
+ /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
|
||||
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
|
||||
const char * const brack =
|
||||
(const char *)
|
||||
@@ -9447,19 +9464,6 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
|
||||
return s;
|
||||
}
|
||||
}
|
||||
- /* Handle extended ${^Foo} variables
|
||||
- * 1999-02-27 mjd-perl-patch@plover.com */
|
||||
- else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
|
||||
- && isWORDCHAR(*s))
|
||||
- {
|
||||
- d++;
|
||||
- while (isWORDCHAR(*s) && d < e) {
|
||||
- *d++ = *s++;
|
||||
- }
|
||||
- if (d >= e)
|
||||
- Perl_croak(aTHX_ "%s", ident_too_long);
|
||||
- *d = '\0';
|
||||
- }
|
||||
|
||||
if ( !tmp_copline )
|
||||
tmp_copline = CopLINE(PL_curcop);
|
||||
--
|
||||
2.14.3
|
||||
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
From edea384e57453b0a62de58445eed1fded18c1cca Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Thu, 29 Jun 2017 13:20:49 +0200
|
||||
Subject: [PATCH] add an additional test for whitespace tolerance in caret
|
||||
word-vars
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Petr Písař: Ported to 5.26.2-RC1.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/base/lex.t | 7 +++++--
|
||||
1 file changed, 5 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/t/base/lex.t b/t/base/lex.t
|
||||
index ae17bbd..414aa1f 100644
|
||||
--- a/t/base/lex.t
|
||||
+++ b/t/base/lex.t
|
||||
@@ -1,6 +1,6 @@
|
||||
#!./perl
|
||||
|
||||
-print "1..119\n";
|
||||
+print "1..120\n";
|
||||
|
||||
$x = 'x';
|
||||
|
||||
@@ -158,9 +158,12 @@ my $test = 31;
|
||||
${^TEST}= "splat";
|
||||
@{^TEST}= ("foo", "bar");
|
||||
%{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
|
||||
-
|
||||
+
|
||||
print "not " if "${^TEST}" ne "splat";
|
||||
print "ok $test\n"; $test++;
|
||||
+
|
||||
+ print "not " if "${ ^TEST }" ne "splat";
|
||||
+ print "ok $test\n"; $test++;
|
||||
|
||||
print "not " if "${^TEST}[0]" ne "splat[0]";
|
||||
print "ok $test\n"; $test++;
|
||||
--
|
||||
2.14.3
|
||||
|
||||
|
|
@ -1,90 +0,0 @@
|
|||
From 3e6e57e89f298f450cbe14c61609f08fc01bf233 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.26.2-RC1 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 87961f1..07e552a 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -4375,14 +4375,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 237388b..e29de82 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 => 34);
|
||||
+plan(tests => 37);
|
||||
|
||||
my $Perl = which_perl();
|
||||
|
||||
@@ -177,6 +177,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,35 +0,0 @@
|
|||
From 7714b11d11da2bfd0dc11638e9dd6836b6a32e90 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 11 Jun 2018 13:26:24 -0600
|
||||
Subject: [PATCH] perl.h: Add parens around macro arguments
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Arguments used within macros need to be parenthesized in case they are
|
||||
called with an expression. This commit changes
|
||||
_CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG() to do that.
|
||||
|
||||
Petr Písař: Ported to 5.26.2 from upstream ff58ca57f844 commit.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perl.h | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/perl.h b/perl.h
|
||||
index 1c613bc..d278c2a 100644
|
||||
--- a/perl.h
|
||||
+++ b/perl.h
|
||||
@@ -5980,7 +5980,7 @@ typedef struct am_table_short AMTS;
|
||||
# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \
|
||||
STMT_START { /* Check if to warn before doing the conversion work */\
|
||||
if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \
|
||||
- UV cp = utf8_to_uvchr_buf((U8 *) s, (U8 *) send, NULL); \
|
||||
+ UV cp = utf8_to_uvchr_buf((U8 *) (s), (U8 *) (send), NULL); \
|
||||
Perl_warner(aTHX_ packWARN(WARN_LOCALE), \
|
||||
"Wide character (U+%" UVXf ") in %s", \
|
||||
(cp == 0) \
|
||||
--
|
||||
2.14.4
|
||||
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
From 47d2c70bde8c0bdc67e85578133338fc63c33f13 Mon Sep 17 00:00:00 2001
|
||||
From: Jitka Plesnikova <jplesnik@redhat.com>
|
||||
Date: Thu, 17 Jun 2021 11:41:48 +0200
|
||||
Subject: [PATCH 2/2] Fix _resolv return value
|
||||
|
||||
in case of the new warnings.
|
||||
Thanks to @nlv02636
|
||||
|
||||
Backported fromn Net-Ping 2.68
|
||||
---
|
||||
dist/Net-Ping/lib/Net/Ping.pm | 8 +++++++-
|
||||
1 file changed, 7 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm
|
||||
index 9e2497c..87087fc 100644
|
||||
--- a/dist/Net-Ping/lib/Net/Ping.pm
|
||||
+++ b/dist/Net-Ping/lib/Net/Ping.pm
|
||||
@@ -1794,6 +1794,7 @@ sub _resolv {
|
||||
# Clean up port
|
||||
if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) {
|
||||
croak("Invalid port `$h{port}' in `$name'");
|
||||
+ return undef;
|
||||
}
|
||||
# END - host:port
|
||||
|
||||
@@ -1850,18 +1851,21 @@ sub _resolv {
|
||||
} else {
|
||||
(undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
|
||||
}
|
||||
- return \%h
|
||||
+ return \%h;
|
||||
} else {
|
||||
carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
|
||||
+ return undef;
|
||||
}
|
||||
} else {
|
||||
warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
|
||||
$family == AF_INET ? "AF_INET" : "AF_INET6"));
|
||||
+ return undef;
|
||||
}
|
||||
# old way
|
||||
} else {
|
||||
if ($family == $AF_INET6) {
|
||||
croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION");
|
||||
+ return undef;
|
||||
}
|
||||
|
||||
my @gethost = gethostbyname($h{host});
|
||||
@@ -1872,8 +1876,10 @@ sub _resolv {
|
||||
return \%h
|
||||
} else {
|
||||
carp("gethostbyname($h{host}) failed - $^E");
|
||||
+ return undef;
|
||||
}
|
||||
}
|
||||
+ return undef;
|
||||
}
|
||||
|
||||
sub _pack_sockaddr_in($$) {
|
||||
--
|
||||
2.31.1
|
||||
|
||||
|
|
@ -1,99 +0,0 @@
|
|||
From 5a3f94a3f0e21d8e685ede4e851a318578a2151f Mon Sep 17 00:00:00 2001
|
||||
From: Jitka Plesnikova <jplesnik@redhat.com>
|
||||
Date: Thu, 17 Jun 2021 11:12:30 +0200
|
||||
Subject: [PATCH 1/2] carp, not croak on most name lookup failures
|
||||
|
||||
See RT #124830, a regression.
|
||||
Return undef instead.
|
||||
|
||||
Backported from Net-Ping 2.67
|
||||
---
|
||||
dist/Net-Ping/lib/Net/Ping.pm | 24 ++++++++++++------------
|
||||
1 file changed, 12 insertions(+), 12 deletions(-)
|
||||
|
||||
diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm
|
||||
index 13cbe81..9e2497c 100644
|
||||
--- a/dist/Net-Ping/lib/Net/Ping.pm
|
||||
+++ b/dist/Net-Ping/lib/Net/Ping.pm
|
||||
@@ -144,7 +144,7 @@ sub new
|
||||
if ($self->{'host'}) {
|
||||
my $host = $self->{'host'};
|
||||
my $ip = _resolv($host)
|
||||
- or croak("could not resolve host $host");
|
||||
+ or carp("could not resolve host $host");
|
||||
$self->{host} = $ip;
|
||||
$self->{family} = $ip->{family};
|
||||
}
|
||||
@@ -152,7 +152,7 @@ sub new
|
||||
if ($self->{bind}) {
|
||||
my $addr = $self->{bind};
|
||||
my $ip = _resolv($addr)
|
||||
- or croak("could not resolve local addr $addr");
|
||||
+ or carp("could not resolve local addr $addr");
|
||||
$self->{local_addr} = $ip;
|
||||
} else {
|
||||
$self->{local_addr} = undef; # Don't bind by default
|
||||
@@ -323,7 +323,7 @@ sub bind
|
||||
($self->{proto} eq "udp" || $self->{proto} eq "icmp");
|
||||
|
||||
$ip = $self->_resolv($local_addr);
|
||||
- croak("nonexistent local address $local_addr") unless defined($ip);
|
||||
+ carp("nonexistent local address $local_addr") unless defined($ip);
|
||||
$self->{local_addr} = $ip;
|
||||
|
||||
if (($self->{proto} ne "udp") &&
|
||||
@@ -1129,13 +1129,14 @@ sub open
|
||||
$self->{family_local} = $self->{family};
|
||||
}
|
||||
|
||||
- $ip = $self->_resolv($host);
|
||||
$timeout = $self->{timeout} unless $timeout;
|
||||
+ $ip = $self->_resolv($host);
|
||||
|
||||
- if($self->{proto} eq "stream") {
|
||||
- if(defined($self->{fh}->fileno())) {
|
||||
+ if ($self->{proto} eq "stream") {
|
||||
+ if (defined($self->{fh}->fileno())) {
|
||||
croak("socket is already open");
|
||||
} else {
|
||||
+ return () unless $ip;
|
||||
$self->tcp_connect($ip, $timeout);
|
||||
}
|
||||
}
|
||||
@@ -1851,12 +1852,11 @@ sub _resolv {
|
||||
}
|
||||
return \%h
|
||||
} else {
|
||||
- croak("getnameinfo($getaddr[0]->{addr}) failed - $err");
|
||||
+ carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
|
||||
}
|
||||
} else {
|
||||
- my $error = sprintf "getaddrinfo($h{host},,%s) failed - $err",
|
||||
- ($family == AF_INET) ? "AF_INET" : "AF_INET6";
|
||||
- croak("$error");
|
||||
+ warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
|
||||
+ $family == AF_INET ? "AF_INET" : "AF_INET6"));
|
||||
}
|
||||
# old way
|
||||
} else {
|
||||
@@ -1871,7 +1871,7 @@ sub _resolv {
|
||||
$h{family} = AF_INET;
|
||||
return \%h
|
||||
} else {
|
||||
- croak("gethostbyname($h{host}) failed - $^E");
|
||||
+ carp("gethostbyname($h{host}) failed - $^E");
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -1913,7 +1913,7 @@ sub _inet_ntoa {
|
||||
if (defined($address)) {
|
||||
$ret = $address;
|
||||
} else {
|
||||
- croak("getnameinfo($addr) failed - $err");
|
||||
+ carp("getnameinfo($addr) failed - $err");
|
||||
}
|
||||
} else {
|
||||
$ret = inet_ntoa($addr)
|
||||
--
|
||||
2.31.1
|
||||
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
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
|
||||
|
||||
|
|
@ -1,258 +0,0 @@
|
|||
From 0db967b2e6a4093a6a5f649190159767e5d005e0 Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Tue, 25 Apr 2017 15:17:06 +0200
|
||||
Subject: [PATCH] [perl #131211] fixup File::Glob degenerate matching
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
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 b7b6e74..af0da6c 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -3948,6 +3948,7 @@ ext/File-Glob/t/basic.t See if File::Glob works
|
||||
ext/File-Glob/t/case.t See if File::Glob works
|
||||
ext/File-Glob/t/global.t See if File::Glob works
|
||||
ext/File-Glob/t/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/File-Glob/TODO File::Glob extension todo list
|
||||
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
|
||||
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
From b4d257e2d408f0f1c6686dcdc112f3ebfec68f44 Mon Sep 17 00:00:00 2001
|
||||
From: Yves Orton <demerphq@gmail.com>
|
||||
Date: Tue, 27 Jun 2017 10:22:23 +0200
|
||||
Subject: [PATCH] File::Glob - tweak rt131211.t to be less sensitive on wonky
|
||||
boxes
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
make the test less senstive and avoid divide by zero errors,
|
||||
also we skip the test if either elapsed_match or elapsed_fail is
|
||||
true, as we can not rely on the timings then. For the operations
|
||||
we are doing we should get a non-zero timing from Time::HiRes.
|
||||
|
||||
This should mean that running this test on boxes with heavy
|
||||
load, etc, will no longer result in false positives.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/File-Glob/t/rt131211.t | 9 +++++++--
|
||||
1 file changed, 7 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/ext/File-Glob/t/rt131211.t b/ext/File-Glob/t/rt131211.t
|
||||
index c1bcbe0..b29cd04 100644
|
||||
--- a/ext/File-Glob/t/rt131211.t
|
||||
+++ b/ext/File-Glob/t/rt131211.t
|
||||
@@ -49,8 +49,13 @@ while (++$count < 10) {
|
||||
is $count,10,
|
||||
"tried all the patterns without bailing out";
|
||||
|
||||
-cmp_ok $elapsed_fail/$elapsed_match,"<",2,
|
||||
- "time to fail less than twice the time to match";
|
||||
+SKIP: {
|
||||
+ skip "unstable timing", 1 unless $elapsed_match && $elapsed_fail;
|
||||
+ ok $elapsed_fail <= 10 * $elapsed_match,
|
||||
+ "time to fail less than 10x the time to match"
|
||||
+ or diag("elapsed_match=$elapsed_match elapsed_fail=$elapsed_fail");
|
||||
+}
|
||||
+
|
||||
is "@got_files", catfile($path, $files[0]),
|
||||
"only got the expected file for xa*..b";
|
||||
is "@no_files", "", "shouldnt have files for xa*..c";
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,226 +0,0 @@
|
|||
From 5aca16e032861ea3dfcc96ad417ea87e2b1552e5 Mon Sep 17 00:00:00 2001
|
||||
From: Aaron Crane <arc@cpan.org>
|
||||
Date: Sat, 4 Mar 2017 12:50:58 +0000
|
||||
Subject: [PATCH] RT #130907: Fix the Unicode Bug in split " "
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Ported to 5.26.0:
|
||||
|
||||
commit 20ae58f7a9bbf84d043d6e90f5988b6e3ca4ee3d
|
||||
Author: Aaron Crane <arc@cpan.org>
|
||||
Date: Sat Mar 4 12:50:58 2017 +0000
|
||||
|
||||
RT #130907: Fix the Unicode Bug in split " "
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
lib/feature.pm | 5 +++--
|
||||
pod/perldelta.pod | 9 +++++++++
|
||||
pod/perlfunc.pod | 8 ++++++++
|
||||
pod/perlunicode.pod | 11 +++++++++++
|
||||
pod/perluniintro.pod | 5 +++--
|
||||
pp.c | 13 +++++++++++++
|
||||
regen/feature.pl | 5 +++--
|
||||
t/op/split.t | 20 +++++++++++++++++++-
|
||||
8 files changed, 69 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/lib/feature.pm b/lib/feature.pm
|
||||
index ed13273..93e020b 100644
|
||||
--- a/lib/feature.pm
|
||||
+++ b/lib/feature.pm
|
||||
@@ -175,8 +175,9 @@ C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
|
||||
|
||||
This feature is available starting with Perl 5.12; was almost fully
|
||||
implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>;
|
||||
-and extended further in Perl 5.26 to cover L<the range
|
||||
-operator|perlop/Range Operators>.
|
||||
+was extended further in Perl 5.26 to cover L<the range
|
||||
+operator|perlop/Range Operators>; and was extended again in Perl 5.28 to
|
||||
+cover L<special-cased whitespace splitting|perlfunc/split>.
|
||||
|
||||
=head2 The 'unicode_eval' and 'evalbytes' features
|
||||
|
||||
#diff --git a/pod/perldelta.pod b/pod/perldelta.pod
|
||||
#index 06dcd1d..d31335f 100644
|
||||
#--- a/pod/perldelta.pod
|
||||
#+++ b/pod/perldelta.pod
|
||||
#@@ -3206,6 +3206,15 @@ calls.
|
||||
# Parsing bad POSIX charclasses no longer leaks memory.
|
||||
# L<[perl #128313]|https://rt.perl.org/Public/Bug/Display.html?id=128313>
|
||||
#
|
||||
#+=item *
|
||||
#+
|
||||
#+C<split ' '> now correctly handles the argument being split when in the
|
||||
#+scope of the L<< C<unicode_strings>|feature/"The 'unicode_strings' feature"
|
||||
#+>> feature. Previously, when a string using the single-byte internal
|
||||
#+representation contained characters that are whitespace by Unicode rules but
|
||||
#+not by ASCII rules, it treated those characters as part of fields rather
|
||||
#+than as field separators. [perl #130907]
|
||||
#+
|
||||
# =back
|
||||
#
|
||||
# =head1 Known Problems
|
||||
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
|
||||
index b8dca6e..9abadf4 100644
|
||||
--- a/pod/perlfunc.pod
|
||||
+++ b/pod/perlfunc.pod
|
||||
@@ -7616,6 +7616,14 @@ special case was restricted to the use of a plain S<C<" ">> as the
|
||||
pattern argument to split; in Perl 5.18.0 and later this special case is
|
||||
triggered by any expression which evaluates to the simple string S<C<" ">>.
|
||||
|
||||
+As of Perl 5.28, this special-cased whitespace splitting works as expected in
|
||||
+the scope of L<< S<C<"use feature 'unicode_strings">>|feature/The
|
||||
+'unicode_strings' feature >>. In previous versions, and outside the scope of
|
||||
+that feature, it exhibits L<perlunicode/The "Unicode Bug">: characters that are
|
||||
+whitespace according to Unicode rules but not according to ASCII rules can be
|
||||
+treated as part of fields rather than as field separators, depending on the
|
||||
+string's internal encoding.
|
||||
+
|
||||
If omitted, PATTERN defaults to a single space, S<C<" ">>, triggering
|
||||
the previously described I<awk> emulation.
|
||||
|
||||
diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod
|
||||
index 9c13c35..2e84e95 100644
|
||||
--- a/pod/perlunicode.pod
|
||||
+++ b/pod/perlunicode.pod
|
||||
@@ -1835,6 +1835,17 @@ outside its scope, it could produce strings whose length in characters
|
||||
exceeded that of the right-hand side, where the right-hand side took up more
|
||||
bytes than the correct range endpoint.
|
||||
|
||||
+=item *
|
||||
+
|
||||
+In L<< C<split>'s special-case whitespace splitting|perlfunc/split >>.
|
||||
+
|
||||
+Starting in Perl 5.28.0, the C<split> function with a pattern specified as
|
||||
+a string containing a single space handles whitespace characters consistently
|
||||
+within the scope of of C<unicode_strings>. Prior to that, or outside its scope,
|
||||
+characters that are whitespace according to Unicode rules but not according to
|
||||
+ASCII rules were treated as field contents rather than field separators when
|
||||
+they appear in byte-encoded strings.
|
||||
+
|
||||
=back
|
||||
|
||||
You can see from the above that the effect of C<unicode_strings>
|
||||
diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod
|
||||
index d35de34..595ec46 100644
|
||||
--- a/pod/perluniintro.pod
|
||||
+++ b/pod/perluniintro.pod
|
||||
@@ -151,11 +151,12 @@ serious Unicode work. The maintenance release 5.6.1 fixed many of the
|
||||
problems of the initial Unicode implementation, but for example
|
||||
regular expressions still do not work with Unicode in 5.6.1.
|
||||
Perl v5.14.0 is the first release where Unicode support is
|
||||
-(almost) seamlessly integrable without some gotchas. (There are two
|
||||
+(almost) seamlessly integrable without some gotchas. (There are a few
|
||||
exceptions. Firstly, some differences in L<quotemeta|perlfunc/quotemeta>
|
||||
were fixed starting in Perl 5.16.0. Secondly, some differences in
|
||||
L<the range operator|perlop/Range Operators> were fixed starting in
|
||||
-Perl 5.26.0.)
|
||||
+Perl 5.26.0. Thirdly, some differences in L<split|perlfunc/split> were fixed
|
||||
+started in Perl 5.28.0.)
|
||||
|
||||
To enable this
|
||||
seamless support, you should C<use feature 'unicode_strings'> (which is
|
||||
diff --git a/pp.c b/pp.c
|
||||
index cc4cb59..d9dd005 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -5740,6 +5740,7 @@ PP(pp_split)
|
||||
STRLEN len;
|
||||
const char *s = SvPV_const(sv, len);
|
||||
const bool do_utf8 = DO_UTF8(sv);
|
||||
+ const bool in_uni_8_bit = IN_UNI_8_BIT;
|
||||
const char *strend = s + len;
|
||||
PMOP *pm = cPMOPx(PL_op);
|
||||
REGEXP *rx;
|
||||
@@ -5826,6 +5827,10 @@ PP(pp_split)
|
||||
while (s < strend && isSPACE_LC(*s))
|
||||
s++;
|
||||
}
|
||||
+ else if (in_uni_8_bit) {
|
||||
+ while (s < strend && isSPACE_L1(*s))
|
||||
+ s++;
|
||||
+ }
|
||||
else {
|
||||
while (s < strend && isSPACE(*s))
|
||||
s++;
|
||||
@@ -5857,6 +5862,10 @@ PP(pp_split)
|
||||
{
|
||||
while (m < strend && !isSPACE_LC(*m))
|
||||
++m;
|
||||
+ }
|
||||
+ else if (in_uni_8_bit) {
|
||||
+ while (m < strend && !isSPACE_L1(*m))
|
||||
+ ++m;
|
||||
} else {
|
||||
while (m < strend && !isSPACE(*m))
|
||||
++m;
|
||||
@@ -5891,6 +5900,10 @@ PP(pp_split)
|
||||
{
|
||||
while (s < strend && isSPACE_LC(*s))
|
||||
++s;
|
||||
+ }
|
||||
+ else if (in_uni_8_bit) {
|
||||
+ while (s < strend && isSPACE_L1(*s))
|
||||
+ ++s;
|
||||
} else {
|
||||
while (s < strend && isSPACE(*s))
|
||||
++s;
|
||||
diff --git a/regen/feature.pl b/regen/feature.pl
|
||||
index 579120e..8a4ce63 100755
|
||||
--- a/regen/feature.pl
|
||||
+++ b/regen/feature.pl
|
||||
@@ -485,8 +485,9 @@ C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
|
||||
|
||||
This feature is available starting with Perl 5.12; was almost fully
|
||||
implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>;
|
||||
-and extended further in Perl 5.26 to cover L<the range
|
||||
-operator|perlop/Range Operators>.
|
||||
+was extended further in Perl 5.26 to cover L<the range
|
||||
+operator|perlop/Range Operators>; and was extended again in Perl 5.28 to
|
||||
+cover L<special-cased whitespace splitting|perlfunc/split>.
|
||||
|
||||
=head2 The 'unicode_eval' and 'evalbytes' features
|
||||
|
||||
diff --git a/t/op/split.t b/t/op/split.t
|
||||
index d60bcaf..038c5d7 100644
|
||||
--- a/t/op/split.t
|
||||
+++ b/t/op/split.t
|
||||
@@ -7,7 +7,7 @@ BEGIN {
|
||||
set_up_inc('../lib');
|
||||
}
|
||||
|
||||
-plan tests => 163;
|
||||
+plan tests => 172;
|
||||
|
||||
$FS = ':';
|
||||
|
||||
@@ -480,6 +480,24 @@ is($cnt, scalar(@ary));
|
||||
qq{split(\$cond ? qr/ / : " ", "$exp") behaves as expected over repeated similar patterns};
|
||||
}
|
||||
|
||||
+SKIP: {
|
||||
+ # RT #130907: unicode_strings feature doesn't work with split ' '
|
||||
+
|
||||
+ my ($sp) = grep /\s/u, map chr, reverse 128 .. 255 # prefer \xA0 over \x85
|
||||
+ or skip 'no unicode whitespace found in high-8-bit range', 9;
|
||||
+
|
||||
+ for (["$sp$sp. /", "leading unicode whitespace"],
|
||||
+ [".$sp$sp/", "unicode whitespace separator"],
|
||||
+ [". /$sp$sp", "trailing unicode whitespace"]) {
|
||||
+ my ($str, $desc) = @$_;
|
||||
+ use feature "unicode_strings";
|
||||
+ my @got = split " ", $str;
|
||||
+ is @got, 2, "whitespace split: $desc: field count";
|
||||
+ is $got[0], '.', "whitespace split: $desc: field 0";
|
||||
+ is $got[1], '/', "whitespace split: $desc: field 1";
|
||||
+ }
|
||||
+}
|
||||
+
|
||||
{
|
||||
# 'RT #116086: split "\x20" does not work as documented';
|
||||
my @results;
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,51 +0,0 @@
|
|||
From b9a58d500dd75ba783abac92a56e57d41227f62b Mon Sep 17 00:00:00 2001
|
||||
From: Father Chrysostomos <sprout@cpan.org>
|
||||
Date: Sun, 2 Jul 2017 11:35:20 -0700
|
||||
Subject: [PATCH] =?UTF-8?q?[perl=20#131679]=20Fix=20=E2=80=98our=20sub=20f?=
|
||||
=?UTF-8?q?oo::bar=E2=80=99=20message?=
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
It should say subroutine, not variable.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/lib/croak/toke | 6 ++++++
|
||||
toke.c | 3 ++-
|
||||
2 files changed, 8 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/lib/croak/toke b/t/lib/croak/toke
|
||||
index 7aa15ef..2603224 100644
|
||||
--- a/t/lib/croak/toke
|
||||
+++ b/t/lib/croak/toke
|
||||
@@ -133,6 +133,12 @@ state sub;
|
||||
EXPECT
|
||||
Missing name in "state sub" at - line 2.
|
||||
########
|
||||
+# NAME our sub pack::foo
|
||||
+our sub foo::bar;
|
||||
+EXPECT
|
||||
+No package name allowed for subroutine &foo::bar in "our" at - line 1, near "our sub foo::bar"
|
||||
+Execution of - aborted due to compilation errors.
|
||||
+########
|
||||
# NAME my sub pack::foo
|
||||
use feature 'lexical_subs', 'state';
|
||||
my sub foo::bar;
|
||||
diff --git a/toke.c b/toke.c
|
||||
index ace92e3..6aa5f26 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -8848,7 +8848,8 @@ S_pending_ident(pTHX)
|
||||
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
|
||||
if (has_colon)
|
||||
yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
|
||||
- "variable %s in \"our\"",
|
||||
+ "%se %s in \"our\"",
|
||||
+ *PL_tokenbuf=='&' ?"subroutin":"variabl",
|
||||
PL_tokenbuf), UTF ? SVf_UTF8 : 0);
|
||||
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
|
||||
}
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
From 97e57bec1f0ba4f0c3b1dc18ee146632010e3373 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 15 Jul 2017 19:36:25 -0600
|
||||
Subject: [PATCH] t/lib/warnings/utf8: Fix test
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
There is some randomness to this test added to fix [perl #131646].
|
||||
Change what passes to be a pattern that matches the correct template
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/lib/warnings/utf8 | 3 ++-
|
||||
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8
|
||||
index 9066308..dfc58c1 100644
|
||||
--- a/t/lib/warnings/utf8
|
||||
+++ b/t/lib/warnings/utf8
|
||||
@@ -781,4 +781,5 @@ no warnings;
|
||||
use warnings 'utf8';
|
||||
for(uc 0..t){0~~pack"UXc",exp}
|
||||
EXPECT
|
||||
-Malformed UTF-8 character: \xc2\x00 (unexpected non-continuation byte 0x00, immediately after start byte 0xc2; need 2 bytes, got 1) in smart match at - line 9.
|
||||
+OPTIONS regex
|
||||
+Malformed UTF-8 character: \\x([[:xdigit:]]{2})\\x([[:xdigit:]]{2}) \(unexpected non-continuation byte 0x\2, immediately after start byte 0x\1; need 2 bytes, got 1\) in smart match at - line 9.
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
From 05b9033b464ce8dd2c9b33238f9aa14755d7a91a Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 17 Jun 2017 17:56:10 -0600
|
||||
Subject: [PATCH] utf8n_to_uvchr(): Don't display too many bytes in msg
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
When raising a message about malformed UTF-8, we shouldn't display bytes
|
||||
from the next character, unless those bytes were expected to have been
|
||||
part of the current one. Tests for this will be added in future commits
|
||||
in ext/XS-APItest/t/utf8_warn_base.pl
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
utf8.c | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/utf8.c b/utf8.c
|
||||
index ee5405f..e55a6f1 100644
|
||||
--- a/utf8.c
|
||||
+++ b/utf8.c
|
||||
@@ -1428,7 +1428,7 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
|
||||
if (pack_warn) {
|
||||
message = Perl_form(aTHX_ "%s: %s (overflows)",
|
||||
malformed_text,
|
||||
- _byte_dump_string(s0, send - s0, 0));
|
||||
+ _byte_dump_string(s0, curlen, 0));
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -1554,7 +1554,7 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
|
||||
"%s: %s (overlong; instead use %s to represent"
|
||||
" U+%0*" UVXf ")",
|
||||
malformed_text,
|
||||
- _byte_dump_string(s0, send - s0, 0),
|
||||
+ _byte_dump_string(s0, curlen, 0),
|
||||
_byte_dump_string(tmpbuf, e - tmpbuf, 0),
|
||||
((uv < 256) ? 2 : 4), /* Field width of 2 for
|
||||
small code points */
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
From 8121278aa8fe72e9e8aca8651c7f1d4fa204ac1d Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 2 Apr 2018 21:54:59 -0600
|
||||
Subject: [PATCH] PATCH: [perl #132167] Parse error in regex_sets
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
When popping the stack, the code inappropriately also subtracted one
|
||||
from the result. This is probably left over from an earlier change in
|
||||
the implementation. The top of the stack contained the correct value;
|
||||
subtracting was a mistake.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 2 +-
|
||||
t/re/regex_sets.t | 11 +++++++++++
|
||||
2 files changed, 12 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 018d5646fc..39ab260efa 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -15689,7 +15689,7 @@ redo_curchar:
|
||||
* fence. Get rid of it */
|
||||
fence_ptr = av_pop(fence_stack);
|
||||
assert(fence_ptr);
|
||||
- fence = SvIV(fence_ptr) - 1;
|
||||
+ fence = SvIV(fence_ptr);
|
||||
SvREFCNT_dec_NN(fence_ptr);
|
||||
fence_ptr = NULL;
|
||||
|
||||
diff --git a/t/re/regex_sets.t b/t/re/regex_sets.t
|
||||
index e9644bd4e6..e70df81254 100644
|
||||
--- a/t/re/regex_sets.t
|
||||
+++ b/t/re/regex_sets.t
|
||||
@@ -204,6 +204,17 @@ for my $char ("٠", "٥", "٩") {
|
||||
like("a", qr/$pat/, "/$pat/ compiles and matches 'a'");
|
||||
}
|
||||
|
||||
+{ # [perl #132167]
|
||||
+ fresh_perl_is('no warnings "experimental::regex_sets";
|
||||
+ print "c" =~ qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ])/;',
|
||||
+ 1, {},
|
||||
+ 'qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ]) compiles and properly matches');
|
||||
+ fresh_perl_is('no warnings "experimental::regex_sets";
|
||||
+ print "b" =~ qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ])/;',
|
||||
+ "", {},
|
||||
+ 'qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ]) compiles and properly matches');
|
||||
+}
|
||||
+
|
||||
done_testing();
|
||||
|
||||
1;
|
||||
--
|
||||
2.14.3
|
||||
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
From 62e6b70574842d7f2c547d33c85c50228522f685 Mon Sep 17 00:00:00 2001
|
||||
From: Marc-Philip <marc-philip.werner@sap.com>
|
||||
Date: Sun, 8 Apr 2018 12:15:29 -0600
|
||||
Subject: [PATCH] PATCH: [perl #133074] 5.26.1: some coverity fixes
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
we have some coverity code scans here. They have found this
|
||||
uninilialized variable in pp.c and the integer overrun in toke.c.
|
||||
Though it might be possible that these are false positives (no
|
||||
reasonable control path gets there), it's good to mute the scan here to
|
||||
see the real problems easier.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp.c | 1 +
|
||||
toke.c | 8 ++++----
|
||||
2 files changed, 5 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index 5524131658..d777ae4309 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -3727,6 +3727,7 @@ PP(pp_ucfirst)
|
||||
if (! slen) { /* If empty */
|
||||
need = 1; /* still need a trailing NUL */
|
||||
ulen = 0;
|
||||
+ *tmpbuf = '\0';
|
||||
}
|
||||
else if (DO_UTF8(source)) { /* Is the source utf8? */
|
||||
doing_utf8 = TRUE;
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 3405dc6c89..fc87252bb1 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -9052,7 +9052,7 @@ S_pending_ident(pTHX)
|
||||
HEK * const stashname = HvNAME_HEK(stash);
|
||||
SV * const sym = newSVhek(stashname);
|
||||
sv_catpvs(sym, "::");
|
||||
- sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
|
||||
+ sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
|
||||
pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
|
||||
pl_yylval.opval->op_private = OPpCONST_ENTERED;
|
||||
if (pit != '&')
|
||||
@@ -9080,7 +9080,7 @@ S_pending_ident(pTHX)
|
||||
&& PL_lex_state != LEX_NORMAL
|
||||
&& !PL_lex_brackets)
|
||||
{
|
||||
- GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
|
||||
+ GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||
( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
|
||||
SVt_PVAV);
|
||||
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
|
||||
@@ -9097,11 +9097,11 @@ S_pending_ident(pTHX)
|
||||
/* build ops for a bareword */
|
||||
pl_yylval.opval = newSVOP(OP_CONST, 0,
|
||||
newSVpvn_flags(PL_tokenbuf + 1,
|
||||
- tokenbuf_len - 1,
|
||||
+ tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||
UTF ? SVf_UTF8 : 0 ));
|
||||
pl_yylval.opval->op_private = OPpCONST_ENTERED;
|
||||
if (pit != '&')
|
||||
- gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
|
||||
+ gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||
(PL_in_eval ? GV_ADDMULTI : GV_ADD)
|
||||
| ( UTF ? SVf_UTF8 : 0 ),
|
||||
((PL_tokenbuf[0] == '$') ? SVt_PV
|
||||
--
|
||||
2.14.3
|
||||
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
From 357c35e6f18e65f372e7a1b22ee39a3c7c9e5810 Mon Sep 17 00:00:00 2001
|
||||
From: Robin Barker <RMBarker@cpan.org>
|
||||
Date: Mon, 17 Dec 2012 18:20:14 +0100
|
||||
Subject: [PATCH] Avoid compiler warnings due to mismatched types in *printf
|
||||
format strings.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
gcc (and probably others) was warning about a mismatch for between `int`
|
||||
(implied by the format %d) and the actual type passed, `line_t`. Avoid this
|
||||
by explicitly casting to UV, and using UVuf.
|
||||
|
||||
CPAN #63832
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm | 7 ++++---
|
||||
1 file changed, 4 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||
index 545d322..c7e6d05 100644
|
||||
--- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||
+++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||
@@ -629,13 +629,14 @@ EOA
|
||||
if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
|
||||
? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
|
||||
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
|
||||
- ", used at %" COP_FILE_F " line %d\\n", sv,
|
||||
- COP_FILE(cop), CopLINE(cop));
|
||||
+ ", used at %" COP_FILE_F " line %" UVuf "\\n",
|
||||
+ sv, COP_FILE(cop), (UV)CopLINE(cop));
|
||||
} else
|
||||
#endif
|
||||
{
|
||||
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro at %"
|
||||
- COP_FILE_F " line %d\\n", sv, COP_FILE(cop), CopLINE(cop));
|
||||
+ COP_FILE_F " line %" UVuf "\\n",
|
||||
+ sv, COP_FILE(cop), (UV)CopLINE(cop));
|
||||
}
|
||||
croak_sv(sv_2mortal(sv));
|
||||
EOC
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,69 +0,0 @@
|
|||
From 389f3ef2fdfbba2c2816e7334a69a5f540c0a33d Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Mon, 15 Dec 2014 16:14:13 +0000
|
||||
Subject: [PATCH] EU::Constant: avoid 'uninit' warning
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The code generated by ExtUtils::Constant can look something like:
|
||||
|
||||
static int
|
||||
constant (..., IV *iv_return) {
|
||||
switch (...) {
|
||||
case ...:
|
||||
*iv_return = ...;
|
||||
return PERL_constant_ISIV;
|
||||
...
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
int type;
|
||||
IV iv;
|
||||
type = constant(..., &iv);
|
||||
switch (type) {
|
||||
case PERL_constant_ISIV:
|
||||
PUSHi(iv);
|
||||
...
|
||||
}
|
||||
}
|
||||
|
||||
and the compiler isn't clever enough to realise that the value of iv
|
||||
is only used in the code path where its been set.
|
||||
|
||||
So initialise it to zero to shut gcc up. Ditto nv and pv.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm | 6 +++---
|
||||
1 file changed, 3 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||
index 0dc9258..cf0e1ca 100644
|
||||
--- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||
+++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||
@@ -198,17 +198,17 @@ $XS_subname(sv)
|
||||
EOT
|
||||
|
||||
if ($params->{IV}) {
|
||||
- $xs .= " IV iv;\n";
|
||||
+ $xs .= " IV iv = 0; /* avoid uninit var warning */\n";
|
||||
} else {
|
||||
$xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
|
||||
}
|
||||
if ($params->{NV}) {
|
||||
- $xs .= " NV nv;\n";
|
||||
+ $xs .= " NV nv = 0.0; /* avoid uninit var warning */\n";
|
||||
} else {
|
||||
$xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
|
||||
}
|
||||
if ($params->{PV}) {
|
||||
- $xs .= " const char *pv;\n";
|
||||
+ $xs .= " const char *pv = NULL; /* avoid uninit var warning */\n";
|
||||
} else {
|
||||
$xs .=
|
||||
" /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
|
||||
--
|
||||
2.9.4
|
||||
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
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
|
||||
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
From 4369267db9ca4982c1a9bd1ef680bc4350decc3a Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 18 Sep 2017 15:07:21 +1000
|
||||
Subject: [PATCH] (perl #132008) try to prevent the similar mistakes in the
|
||||
future
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/Term-ReadLine/lib/Term/ReadLine.pm | 2 ++
|
||||
1 file changed, 2 insertions(+)
|
||||
|
||||
diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||
index e00fb376cd..78c1ebf5b6 100644
|
||||
--- a/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||
+++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||
@@ -75,6 +75,8 @@ history. Returns the old value.
|
||||
returns an array with two strings that give most appropriate names for
|
||||
files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
|
||||
|
||||
+The strings returned may not be useful for 3-argument open().
|
||||
+
|
||||
=item Attribs
|
||||
|
||||
returns a reference to a hash which describes internal configuration
|
||||
--
|
||||
2.13.6
|
||||
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
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
|
||||
|
||||
|
|
@ -1,73 +0,0 @@
|
|||
From b3937e202aaf10c2f8996e2993c880bb38a7a268 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.
|
||||
|
||||
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 6127b26f54..ef11a0c046 100644
|
||||
--- a/dist/Carp/lib/Carp.pm
|
||||
+++ b/dist/Carp/lib/Carp.pm
|
||||
@@ -593,7 +593,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 65daed7c6c..b1e399d143 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 => 67;
|
||||
+use Test::More tests => 68;
|
||||
|
||||
sub runperl {
|
||||
my(%args) = @_;
|
||||
@@ -488,6 +488,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
|
||||
|
||||
|
|
@ -1,593 +0,0 @@
|
|||
From 3f8a98327dfdb171bd6e447fec23721b0e74c7a6 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.26.1.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp_ctl.c | 4 +-
|
||||
pp_hot.c | 4 +-
|
||||
t/op/taint.t | 428 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
|
||||
3 files changed, 422 insertions(+), 14 deletions(-)
|
||||
|
||||
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||
index f136f91..15c193b 100644
|
||||
--- a/pp_ctl.c
|
||||
+++ b/pp_ctl.c
|
||||
@@ -219,9 +219,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 f445fd9..5899413 100644
|
||||
--- a/pp_hot.c
|
||||
+++ b/pp_hot.c
|
||||
@@ -3250,7 +3250,7 @@ PP(pp_subst)
|
||||
doutf8 = DO_UTF8(dstr);
|
||||
}
|
||||
|
||||
- if (SvTAINTED(dstr))
|
||||
+ if (UNLIKELY(TAINT_get))
|
||||
rxtainted |= SUBST_TAINT_REPL;
|
||||
}
|
||||
else {
|
||||
@@ -3421,8 +3421,6 @@ PP(pp_subst)
|
||||
}
|
||||
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 c13eaf6..be5eaa8 100644
|
||||
--- a/t/op/taint.t
|
||||
+++ b/t/op/taint.t
|
||||
@@ -17,7 +17,7 @@ BEGIN {
|
||||
use strict;
|
||||
use Config;
|
||||
|
||||
-plan tests => 828;
|
||||
+plan tests => 1040;
|
||||
|
||||
$| = 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
|
||||
@@ -2448,6 +2580,284 @@ is eval { eval $::x.1 }, 1, 'reset does not taint undef';
|
||||
isnt_tainted $b, "list assign post tainted expression b";
|
||||
}
|
||||
|
||||
+# taint passing through overloading
|
||||
+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: {
|
||||
--
|
||||
2.13.6
|
||||
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
From 695d6585affc8f13711f013329fb4810ab89d833 Mon Sep 17 00:00:00 2001
|
||||
From: Father Chrysostomos <sprout@cpan.org>
|
||||
Date: Tue, 14 Nov 2017 18:55:55 -0800
|
||||
Subject: [PATCH] [perl #132442] 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.
|
||||
|
||||
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 8fa5aad876..c617ad2a00 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -9243,6 +9243,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 3fa17acdda..f085cd97e8 100644
|
||||
--- a/t/op/lexsub.t
|
||||
+++ b/t/op/lexsub.t
|
||||
@@ -7,7 +7,7 @@ BEGIN {
|
||||
*bar::is = *is;
|
||||
*bar::like = *like;
|
||||
}
|
||||
-plan 149;
|
||||
+plan 150;
|
||||
|
||||
# -------------------- our -------------------- #
|
||||
|
||||
@@ -957,3 +957,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
|
||||
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
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
|
||||
|
||||
|
|
@ -1,73 +0,0 @@
|
|||
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
|
||||
|
||||
|
|
@ -1,127 +0,0 @@
|
|||
From fed9fe5b48ccdffef9065a03c12c237cc7418de6 Mon Sep 17 00:00:00 2001
|
||||
From: Zefram <zefram@fysh.org>
|
||||
Date: Fri, 16 Feb 2018 17:20:34 +0000
|
||||
Subject: [PATCH] don't clobber file bytes in :encoding layer
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The PerlIO::encoding layer, when used on input, was creating an SvLEN==0
|
||||
scalar pointing into the byte buffer, to pass to the ->decode method
|
||||
of the encoding object. Since the method mutates this scalar, for some
|
||||
encodings this led to mutating the byte buffer, and depending on where
|
||||
it came from that might be something visible elsewhere that should not
|
||||
be mutated. Remove the code for the SvLEN==0 scalar, instead always
|
||||
using the alternate code that would copy the bytes into a separate buffer
|
||||
owned by the scalar. Fixes [perl #132833].
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/PerlIO-encoding/encoding.pm | 2 +-
|
||||
ext/PerlIO-encoding/encoding.xs | 43 ++++++++++------------------------------
|
||||
ext/PerlIO-encoding/t/encoding.t | 12 ++++++++++-
|
||||
3 files changed, 22 insertions(+), 35 deletions(-)
|
||||
|
||||
diff --git a/ext/PerlIO-encoding/encoding.pm b/ext/PerlIO-encoding/encoding.pm
|
||||
index 08d2df4713..3d740b181a 100644
|
||||
--- a/ext/PerlIO-encoding/encoding.pm
|
||||
+++ b/ext/PerlIO-encoding/encoding.pm
|
||||
@@ -1,7 +1,7 @@
|
||||
package PerlIO::encoding;
|
||||
|
||||
use strict;
|
||||
-our $VERSION = '0.25';
|
||||
+our $VERSION = '0.26';
|
||||
our $DEBUG = 0;
|
||||
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
|
||||
|
||||
diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs
|
||||
index bb4754f3d9..941d786266 100644
|
||||
--- a/ext/PerlIO-encoding/encoding.xs
|
||||
+++ b/ext/PerlIO-encoding/encoding.xs
|
||||
@@ -307,42 +307,19 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
|
||||
goto end_of_file;
|
||||
}
|
||||
}
|
||||
- if (SvCUR(e->dataSV)) {
|
||||
- /* something left over from last time - create a normal
|
||||
- SV with new data appended
|
||||
- */
|
||||
- if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
|
||||
- if (e->flags & NEEDS_LINES) {
|
||||
- /* Have to grow buffer */
|
||||
- e->base.bufsiz = use + SvCUR(e->dataSV);
|
||||
- PerlIOEncode_get_base(aTHX_ f);
|
||||
- }
|
||||
- else {
|
||||
- use = e->base.bufsiz - SvCUR(e->dataSV);
|
||||
- }
|
||||
- }
|
||||
- sv_catpvn(e->dataSV,(char*)ptr,use);
|
||||
- }
|
||||
- else {
|
||||
- /* Create a "dummy" SV to represent the available data from layer below */
|
||||
- if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
|
||||
- Safefree(SvPVX_mutable(e->dataSV));
|
||||
- }
|
||||
- if (use > (SSize_t)e->base.bufsiz) {
|
||||
- if (e->flags & NEEDS_LINES) {
|
||||
- /* Have to grow buffer */
|
||||
- e->base.bufsiz = use;
|
||||
- PerlIOEncode_get_base(aTHX_ f);
|
||||
- }
|
||||
- else {
|
||||
- use = e->base.bufsiz;
|
||||
+ if (!SvCUR(e->dataSV))
|
||||
+ SvPVCLEAR(e->dataSV);
|
||||
+ if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
|
||||
+ if (e->flags & NEEDS_LINES) {
|
||||
+ /* Have to grow buffer */
|
||||
+ e->base.bufsiz = use + SvCUR(e->dataSV);
|
||||
+ PerlIOEncode_get_base(aTHX_ f);
|
||||
}
|
||||
+ else {
|
||||
+ use = e->base.bufsiz - SvCUR(e->dataSV);
|
||||
}
|
||||
- SvPV_set(e->dataSV, (char *) ptr);
|
||||
- SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
|
||||
- SvCUR_set(e->dataSV,use);
|
||||
- SvPOK_only(e->dataSV);
|
||||
}
|
||||
+ sv_catpvn(e->dataSV,(char*)ptr,use);
|
||||
SvUTF8_off(e->dataSV);
|
||||
PUSHMARK(sp);
|
||||
XPUSHs(e->enc);
|
||||
diff --git a/ext/PerlIO-encoding/t/encoding.t b/ext/PerlIO-encoding/t/encoding.t
|
||||
index 088f89ee20..41cefcb137 100644
|
||||
--- a/ext/PerlIO-encoding/t/encoding.t
|
||||
+++ b/ext/PerlIO-encoding/t/encoding.t
|
||||
@@ -16,7 +16,7 @@ BEGIN {
|
||||
require "../../t/charset_tools.pl";
|
||||
}
|
||||
|
||||
-use Test::More tests => 24;
|
||||
+use Test::More tests => 27;
|
||||
|
||||
my $grk = "grk$$";
|
||||
my $utf = "utf$$";
|
||||
@@ -231,6 +231,16 @@ is $x, "To hymn him who heard her herd herd\n",
|
||||
|
||||
} # SKIP
|
||||
|
||||
+# decoding shouldn't mutate the original bytes [perl #132833]
|
||||
+{
|
||||
+ my $b = "a\0b\0\n\0";
|
||||
+ open my $fh, "<:encoding(UTF16-LE)", \$b or die;
|
||||
+ is scalar(<$fh>), "ab\n";
|
||||
+ is $b, "a\0b\0\n\0";
|
||||
+ close $fh or die;
|
||||
+ is $b, "a\0b\0\n\0";
|
||||
+}
|
||||
+
|
||||
END {
|
||||
1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
|
||||
}
|
||||
--
|
||||
2.14.3
|
||||
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
From 823ba440369100de3f2693420a3887a645a57d28 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Wed, 7 Mar 2018 09:27:26 +0000
|
||||
Subject: [PATCH] fix line numbers in multi-line s///
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
my commit v5.25.6-230-g6432a58, "Eliminate SVrepl_EVAL and SvEVALED()",
|
||||
introduced a regression: __LINE__ no longer took account of multiple
|
||||
lines in the s///.
|
||||
|
||||
Now fixed.
|
||||
|
||||
Spotted by Abigail.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/re/subst.t | 12 +++++++++++-
|
||||
toke.c | 2 +-
|
||||
2 files changed, 12 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/t/re/subst.t b/t/re/subst.t
|
||||
index b9b9939b11..dd62e95ee6 100644
|
||||
--- a/t/re/subst.t
|
||||
+++ b/t/re/subst.t
|
||||
@@ -11,7 +11,7 @@ BEGIN {
|
||||
require './loc_tools.pl';
|
||||
}
|
||||
|
||||
-plan(tests => 275);
|
||||
+plan(tests => 276);
|
||||
|
||||
$_ = 'david';
|
||||
$a = s/david/rules/r;
|
||||
@@ -1163,6 +1163,16 @@ __EOF__
|
||||
pass("RT #130188");
|
||||
}
|
||||
|
||||
+# RT #131930
|
||||
+# a multi-line s/// wasn't resetting the cop_line correctly
|
||||
+{
|
||||
+ my $l0 = __LINE__;
|
||||
+ my $s = "a";
|
||||
+ $s =~ s[a]
|
||||
+ [b];
|
||||
+ my $lines = __LINE__ - $l0;
|
||||
+ is $lines, 4, "RT #131930";
|
||||
+}
|
||||
|
||||
|
||||
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 9dbad98408..0ef33415c0 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -9884,7 +9884,7 @@ S_scan_subst(pTHX_ char *start)
|
||||
* the NVX field indicates how many src code lines the replacement
|
||||
* spreads over */
|
||||
sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
|
||||
- ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
|
||||
+ ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
|
||||
((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
|
||||
cBOOL(es);
|
||||
}
|
||||
--
|
||||
2.14.3
|
||||
|
||||
|
|
@ -1,113 +0,0 @@
|
|||
From 381d51822fccaa333cbd0ab9fca8b69f650c05f9 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Fri, 14 Feb 2020 14:10:10 +0100
|
||||
Subject: [PATCH] Only pass 2-digit years to tests when testing 2-digit year
|
||||
handling
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This will start breaking in 2020 if done without working around the whole
|
||||
breakpoint thing. See https://rt.cpan.org/Ticket/Display.html?id=124787.
|
||||
|
||||
Ported from Time-Local 63265fd81c7f6177bf28dfe0d1ada9cb897de566 commit
|
||||
by Dave Rolsky <autarch@urth.org> to perl 5.28.2.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
cpan/Time-Local/t/Local.t | 40 +++++++++++++++++++++++++++++----------
|
||||
1 file changed, 30 insertions(+), 10 deletions(-)
|
||||
|
||||
diff --git a/cpan/Time-Local/t/Local.t b/cpan/Time-Local/t/Local.t
|
||||
index 6341396..701d22d 100644
|
||||
--- a/cpan/Time-Local/t/Local.t
|
||||
+++ b/cpan/Time-Local/t/Local.t
|
||||
@@ -85,19 +85,17 @@ my $epoch_is_64
|
||||
|
||||
for ( @time, @neg_time ) {
|
||||
my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
|
||||
- $year -= 1900;
|
||||
$mon--;
|
||||
|
||||
SKIP: {
|
||||
skip '1970 test on VOS fails.', 12
|
||||
- if $^O eq 'vos' && $year == 70;
|
||||
+ if $^O eq 'vos' && $year == 1970;
|
||||
skip 'this platform does not support negative epochs.', 12
|
||||
- if $year < 70 && !$neg_epoch_ok;
|
||||
+ if $year < 1970 && !$neg_epoch_ok;
|
||||
|
||||
# Test timelocal()
|
||||
{
|
||||
- my $year_in = $year < 70 ? $year + 1900 : $year;
|
||||
- my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year_in );
|
||||
+ my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year );
|
||||
|
||||
my ( $s, $m, $h, $D, $M, $Y ) = localtime($time);
|
||||
|
||||
@@ -106,13 +104,12 @@ SKIP: {
|
||||
is( $h, $hour, "timelocal hour for @$_" );
|
||||
is( $D, $mday, "timelocal day for @$_" );
|
||||
is( $M, $mon, "timelocal month for @$_" );
|
||||
- is( $Y, $year, "timelocal year for @$_" );
|
||||
+ is( $Y, $year - 1900, "timelocal year for @$_" );
|
||||
}
|
||||
|
||||
# Test timegm()
|
||||
{
|
||||
- my $year_in = $year < 70 ? $year + 1900 : $year;
|
||||
- my $time = timegm( $sec, $min, $hour, $mday, $mon, $year_in );
|
||||
+ my $time = timegm( $sec, $min, $hour, $mday, $mon, $year );
|
||||
|
||||
my ( $s, $m, $h, $D, $M, $Y ) = gmtime($time);
|
||||
|
||||
@@ -121,14 +118,13 @@ SKIP: {
|
||||
is( $h, $hour, "timegm hour for @$_" );
|
||||
is( $D, $mday, "timegm day for @$_" );
|
||||
is( $M, $mon, "timegm month for @$_" );
|
||||
- is( $Y, $year, "timegm year for @$_" );
|
||||
+ is( $Y, $year - 1900, "timegm year for @$_" );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
for (@bad_time) {
|
||||
my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
|
||||
- $year -= 1900;
|
||||
$mon--;
|
||||
|
||||
eval { timegm( $sec, $min, $hour, $mday, $mon, $year ) };
|
||||
@@ -229,6 +225,30 @@ SKIP:
|
||||
);
|
||||
}
|
||||
|
||||
+# 2-digit years
|
||||
+{
|
||||
+ my $current_year = ( localtime() )[5];
|
||||
+ my $pre_break = ( $current_year + 49 ) - 100;
|
||||
+ my $break = ( $current_year + 50 ) - 100;
|
||||
+ my $post_break = ( $current_year + 51 ) - 100;
|
||||
+
|
||||
+ is(
|
||||
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $pre_break ) ) )[5] ),
|
||||
+ $pre_break + 100,
|
||||
+ "year $pre_break is treated as next century",
|
||||
+ );
|
||||
+ is(
|
||||
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $break ) ) )[5] ),
|
||||
+ $break + 100,
|
||||
+ "year $break is treated as next century",
|
||||
+ );
|
||||
+ is(
|
||||
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $post_break ) ) )[5] ),
|
||||
+ $post_break,
|
||||
+ "year $post_break is treated as current century",
|
||||
+ );
|
||||
+}
|
||||
+
|
||||
SKIP:
|
||||
{
|
||||
skip 'These tests only run for the package maintainer.', 8
|
||||
--
|
||||
2.21.1
|
||||
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
From 892e8b006aa99ac2c880cdc2a81fd16f06c1a0f3 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Mon, 9 Jul 2018 16:18:36 +0200
|
||||
Subject: [PATCH] Remove ext/GDBM_File/t/fatal.t
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
gdbm-1.15 defaults to a memory-mapped I/O and does not report any I/O
|
||||
errors on store and close operations. Thus ext/GDBM_File/t/fatal.t
|
||||
test that expects these fatal error reports fails. Because there is
|
||||
no other way to provoke a fatal error in gdbm-1.15 this patch
|
||||
removes the test. Future gdbm version promisses reporting a regular
|
||||
error on closing a database.
|
||||
|
||||
RT#133295
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 1 -
|
||||
ext/GDBM_File/t/fatal.t | 49 -------------------------------------------------
|
||||
2 files changed, 50 deletions(-)
|
||||
delete mode 100644 ext/GDBM_File/t/fatal.t
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 95fa539095..b07fed1f54 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -4100,7 +4100,6 @@ ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
|
||||
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
|
||||
ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
|
||||
ext/GDBM_File/Makefile.PL GDBM extension makefile writer
|
||||
-ext/GDBM_File/t/fatal.t Test the fatal_func argument to gdbm_open
|
||||
ext/GDBM_File/t/gdbm.t See if GDBM_File works
|
||||
ext/GDBM_File/typemap GDBM extension interface types
|
||||
ext/Hash-Util/Changes Change history of Hash::Util
|
||||
diff --git a/ext/GDBM_File/t/fatal.t b/ext/GDBM_File/t/fatal.t
|
||||
deleted file mode 100644
|
||||
index 0e426d4dbc..0000000000
|
||||
--- a/ext/GDBM_File/t/fatal.t
|
||||
+++ /dev/null
|
||||
@@ -1,49 +0,0 @@
|
||||
-#!./perl -w
|
||||
-use strict;
|
||||
-
|
||||
-use Test::More;
|
||||
-use Config;
|
||||
-
|
||||
-BEGIN {
|
||||
- plan(skip_all => "GDBM_File was not built")
|
||||
- unless $Config{extensions} =~ /\bGDBM_File\b/;
|
||||
-
|
||||
- # https://rt.perl.org/Public/Bug/Display.html?id=117967
|
||||
- plan(skip_all => "GDBM_File is flaky in $^O")
|
||||
- if $^O =~ /darwin/;
|
||||
-
|
||||
- plan(tests => 8);
|
||||
- use_ok('GDBM_File');
|
||||
-}
|
||||
-
|
||||
-unlink <Op_dbmx*>;
|
||||
-
|
||||
-open my $fh, '<', $^X or die "Can't open $^X: $!";
|
||||
-my $fileno = fileno $fh;
|
||||
-isnt($fileno, undef, "Can find next available file descriptor");
|
||||
-close $fh or die $!;
|
||||
-
|
||||
-is((open $fh, "<&=$fileno"), undef,
|
||||
- "Check that we cannot open fileno $fileno. \$! is $!");
|
||||
-
|
||||
-umask(0);
|
||||
-my %h;
|
||||
-isa_ok(tie(%h, 'GDBM_File', 'Op_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
|
||||
-
|
||||
-isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno")
|
||||
- or diag("\$! = $!");
|
||||
-isnt(close $fh, undef,
|
||||
- "close fileno $fileno, out from underneath the GDBM_File");
|
||||
-is(eval {
|
||||
- $h{Perl} = 'Rules';
|
||||
- untie %h;
|
||||
- 1;
|
||||
-}, undef, 'Trapped error when attempting to write to knobbled GDBM_File');
|
||||
-
|
||||
-# Observed "File write error" and "lseek error" from two different systems.
|
||||
-# So there might be more variants. Important part was that we trapped the error
|
||||
-# via croak.
|
||||
-like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/,
|
||||
- 'expected error message from GDBM_File');
|
||||
-
|
||||
-unlink <Op_dbmx*>;
|
||||
--
|
||||
2.14.4
|
||||
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
From e1a2878a55b1a7f11f19b384c4ea5235c29866b2 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 11 Jun 2018 13:28:53 -0600
|
||||
Subject: [PATCH] regexec.c: Call macro with correct args.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The second argument to this macro is a pointer to the end, as opposed to
|
||||
a length.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regexec.c | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regexec.c b/regexec.c
|
||||
index 7ed8f4fabc..ba52ae97c7 100644
|
||||
--- a/regexec.c
|
||||
+++ b/regexec.c
|
||||
@@ -1808,7 +1808,7 @@ STMT_START {
|
||||
case trie_flu8: \
|
||||
_CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
|
||||
if (UTF8_IS_ABOVE_LATIN1(*uc)) { \
|
||||
- _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end - uc); \
|
||||
+ _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end); \
|
||||
} \
|
||||
goto do_trie_utf8_fold; \
|
||||
case trie_utf8_exactfa_fold: \
|
||||
--
|
||||
2.14.4
|
||||
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
From 6d9d949fb4962e32636aee48a948081d8936d318 Mon Sep 17 00:00:00 2001
|
||||
From: Jitka Plesnikova <jplesnik@redhat.com>
|
||||
Date: Wed, 11 Jan 2023 09:12:18 +0100
|
||||
Subject: [PATCH] Add definition of OPTIMIZE to .ph files
|
||||
|
||||
The fortify.h header includes a test to ensure that -O is used when
|
||||
compiling with _FORTIFY_SOURCE, and the header looks for OPTIMIZE, which
|
||||
is set by the compiler whenever -O is used. Perl translates this test
|
||||
to the .ph file, but nothing ever sets OPTIMIZE. This causes a warning
|
||||
for anything that uses features.ph.
|
||||
|
||||
_FORTIFY_SOURCE is defined in /usr/lib64/perl5/_h2ph_pre.ph which is
|
||||
generated by h2ph. It uses value of @Config{'ccsymbols', 'cppsymbols',
|
||||
'cppccsymbols'} which does not contain definition for OPTIMIZE.
|
||||
|
||||
The patch updated h2ph to add OPTIMIZE if -O is used.
|
||||
---
|
||||
utils/h2ph.PL | 5 +++++
|
||||
1 file changed, 5 insertions(+)
|
||||
|
||||
diff --git a/utils/h2ph.PL b/utils/h2ph.PL
|
||||
index afa53c2..3950d11 100644
|
||||
--- a/utils/h2ph.PL
|
||||
+++ b/utils/h2ph.PL
|
||||
@@ -865,6 +865,11 @@ sub _extract_cc_defines
|
||||
my $allsymbols = join " ",
|
||||
@Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
|
||||
|
||||
+ # If optimizing -O2 is used, add the definition
|
||||
+ if ($Config{'ccflags'} =~ /(?:\s+|^)-O([\d]+)(?:\s+|$)/) {
|
||||
+ $allsymbols .= " __OPTIMIZE__=$1";
|
||||
+ }
|
||||
+
|
||||
# Split compiler pre-definitions into 'key=value' pairs:
|
||||
while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
|
||||
$define{$1} = $2;
|
||||
--
|
||||
2.39.0
|
||||
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
#requires gdbm
|
||||
|
||||
mcd $BUILDDIR/perl
|
||||
|
||||
GV=$(cd $SRC; echo perl-*)
|
||||
SONAME_VER=`echo $GV | cut -f2- -d'-' | sed 's/^\\([^.]*\\.[^.]*\\).*/\\1/'`
|
||||
PERL_VER=`echo $GV | cut -f2- -d'-'`
|
||||
|
||||
cd $SRC/$GV
|
||||
|
||||
sh $SRC/$GV/Configure -des -Dprefix=/usr -Dlibpth="/usr/local/lib$SUFFIX /lib$SUFFIX /usr/lib$SUFFIX" -Darchlib="/usr/lib$SUFFIX/perl5" -Dsitelib="/usr/local/share/perl5" -DDEBUGGING=-g -Dcc=gcc -Dmyhostname=localhost -Dperladmin=root@localhost -Duseshrplib -Dusethreads -Duseithreads -Uusedtrace -Duselargefiles -Dd_semctl_semun -Di_db -Ui_ndbm -Di_gdbm -Di_shadow -Di_syslog -Dman3ext=3pm -Duseperlio -Dinstallusrbinperl=n -Ubincompat5005 -Uversiononly -Dd_gethostent_r_proto -Ud_endhostent_r_proto -Ud_sethostent_r_proto -Ud_endprotoent_r_proto -Ud_setprotoent_r_proto -Ud_endservent_r_proto -Ud_setservent_r_proto
|
||||
|
||||
BUILD_BZIP2=0
|
||||
BZIP2_LIB=%{_libdir}
|
||||
export BUILD_BZIP2 BZIP2_LIB
|
||||
|
||||
ln -sf libperl.so libperl.so.${SONAME_VER}
|
||||
|
||||
make
|
||||
|
||||
rm -f /usr/lib${SUFFIX}/perl5/CORE/libperl.so
|
||||
|
||||
make install
|
||||
|
||||
rm -f /usr/lib${SUFFIX}/libperl.so.${PERL_VER}
|
||||
mv /usr/lib${SUFFIX}/perl5/CORE/libperl.so /usr/lib${SUFFIX}/libperl.so.${PERL_VER}
|
||||
ln -sf libperl.so.${PERL_VER} /usr/lib${SUFFIX}/libperl.so.${SONAME_VER}
|
||||
ln -sf libperl.so.${PERL_VER} /usr/lib${SUFFIX}/libperl.so
|
||||
ln -sf libperl.so.${PERL_VER} /usr/lib${SUFFIX}/perl5/CORE/libperl.so
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
#!/bin/bash
|
||||
for P in "$@"; do
|
||||
echo "Empty directories in RPM package $P:"
|
||||
|
||||
for D in $(rpm -qlvp "$P" | \
|
||||
perl -ne \
|
||||
'if (/\Adrwx/) {$n=${[split /\s+/]}[8]; print qq{$n\n}}' | \
|
||||
sort -f); do
|
||||
test $(rpm -qlp "$P" | grep -c -F "$D/") == 0 && echo "$D";
|
||||
done
|
||||
done
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
#!/usr/bin/perl
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
use RPM2;
|
||||
|
||||
for my $rpm_file (@ARGV) {
|
||||
my $package = RPM2->open_package($rpm_file)
|
||||
or die q{Could not open `} . $rpm_file . q{'.};
|
||||
|
||||
my $package_name = $package->tag('NAME');
|
||||
my $package_version = $package->tag('VERSION');
|
||||
|
||||
my $module_name = $package_name;
|
||||
$module_name =~ s/^([^-]+)-(.*)/$1($2)/;
|
||||
$module_name =~ s/-/::/g;
|
||||
|
||||
my @names = $package->tag('PROVIDENAME');
|
||||
my @flags = $package->tag('PROVIDEFLAGS');
|
||||
my @versions = $package->tag('PROVIDEVERSION');
|
||||
if (!($#names == $#flags) && ($#names == $#versions)) {
|
||||
die (q{Inconsistent number of provides names, flags, and versions in `}
|
||||
. $rpm_file . q{'.});
|
||||
}
|
||||
|
||||
my $found = 0;
|
||||
for my $name (@names) {
|
||||
my $flag = shift @flags;
|
||||
my $version = shift @versions;
|
||||
if ($name eq $module_name) {
|
||||
$found = 1;
|
||||
|
||||
if (($flag & 0x8) && (($flag & (0x2+0x4)) == 0)) {
|
||||
if (!($package_version eq $version)) {
|
||||
print $rpm_file . q{: Package version `} .
|
||||
$package_version . q{' differs from `} .
|
||||
$module_name . q{' module version `} .
|
||||
$version . q{'.} . "\n";
|
||||
}
|
||||
last;
|
||||
} else {
|
||||
print $rpm_file . q{: `} . $module_name .
|
||||
q{' in list of provides is not qualified (};
|
||||
printf '0x%x', $flag;
|
||||
print q{) as equaled.} . "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($found == 0) {
|
||||
print $rpm_file . q{: missing `} . $module_name .
|
||||
q{' in list of provides.} . "\n";
|
||||
}
|
||||
}
|
||||
|
||||
__END__
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
checkpackageversion - Check a RPM package version matches main Perl module
|
||||
version
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
checkpackageversion RPM_PACKAGE...
|
||||
|
||||
It opens each RPM_PACKAGE, guesses a main Perl module from package name, finds
|
||||
it in list of provides (e.g. perl-Foo-Bar → perl(Foo::Bar) and compares
|
||||
versions. It reports any irregularities to standard output.
|
||||
|
||||
Petr Písař <ppisar@redhat.com>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
Copyright (C) 2011 Petr Písař <ppisar@redhat.com>
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
|
||||
my ($arch, $patfile, $infile, $outfile, $libdir, $thread_arch) = @ARGV;
|
||||
|
||||
if (not $arch or not $patfile or not $infile or not $outfile or not $libdir) {
|
||||
die "Usage: $0 arch thread_arch pattern-file in-file out-file libdir [ threadarch ]";
|
||||
}
|
||||
|
||||
$thread_arch ||= '';
|
||||
|
||||
open IN, "<$infile"
|
||||
or die "Can't open $infile: $!";
|
||||
open OUT, ">$outfile"
|
||||
or die "Can't open $outfile: $!";
|
||||
open PATTERN, "<$patfile"
|
||||
or die "Can't open $patfile: $!";
|
||||
|
||||
my @patterns = <PATTERN>;
|
||||
chomp @patterns;
|
||||
for my $p (@patterns) {
|
||||
$p =~ s/%{_libdir}/$libdir/g;
|
||||
$p =~ s/%{_arch}/$arch/g;
|
||||
$p =~ s/%{thread_arch}/$thread_arch/g;
|
||||
}
|
||||
|
||||
my %exclude = map { $_ => 1 } @patterns;
|
||||
|
||||
close PATTERN;
|
||||
|
||||
while(<IN>) {
|
||||
chomp;
|
||||
|
||||
print OUT "$_\n"
|
||||
unless exists $exclude{$_}
|
||||
}
|
||||
|
||||
close IN;
|
||||
close OUT;
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
#!/bin/bash
|
||||
|
||||
if [ "$#" != 2 ]; then
|
||||
cat<<EOM
|
||||
Usage: $(basename $0) OLD_RELEASE NEW_RELEASE
|
||||
|
||||
Compares corresponding RPM packages produced in OLD_RELASE and NEW_RELEASE.
|
||||
The same version strings are assumed.
|
||||
EOM
|
||||
exit 1;
|
||||
fi
|
||||
|
||||
OLD_RELEASE="$1"
|
||||
NEW_RELEASE="$2"
|
||||
|
||||
function process_dir() {
|
||||
for F in $(ls $1/* | sed -r 's/-[0-9].*//' | sort | uniq ); do
|
||||
OLD_RPM=$(echo ${F}-[0-9]*-${OLD_RELEASE}.*)
|
||||
NEW_RPM=$(echo ${F}-[0-9]*-${NEW_RELEASE}.*)
|
||||
|
||||
test \( ! -e "$OLD_RPM" \) -a \( ! -e "$NEW_RPM" \) && continue
|
||||
if [ ! -e "$OLD_RPM" ]; then echo "+ Package ${F}"; continue; fi
|
||||
if [ ! -e "$NEW_RPM" ]; then echo "- Package ${F}"; continue; fi
|
||||
|
||||
DIFF=$(rpmdiff -i S -i 5 -i T "$OLD_RPM" "$NEW_RPM" | \
|
||||
grep -vE 'REQUIRES perl = | REQUIRES rpmlib\(' )
|
||||
|
||||
test -n "$DIFF" && printf '* %s:\n%s\n' "$F" "$DIFF"
|
||||
done
|
||||
}
|
||||
|
||||
process_dir 'x86_64'
|
||||
process_dir 'noarch'
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,163 @@
|
|||
#!/usr/bin/perl
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Split "A B >= 1" dependencies string into ("A", "B >= 1") list.
|
||||
sub appendsymbols {
|
||||
my ($array, $line) = @_;
|
||||
my $qualified;
|
||||
my $dependency;
|
||||
for my $token (split(/\s/, $line)) {
|
||||
if ($token =~ /\A[<>]?=\z/) {
|
||||
$qualified = 1;
|
||||
$dependency .= ' ' . $token;
|
||||
next;
|
||||
}
|
||||
if (!$qualified) {
|
||||
if (defined $dependency) {
|
||||
push @$array, $dependency;
|
||||
}
|
||||
$dependency = $token;
|
||||
next;
|
||||
}
|
||||
if ($qualified) {
|
||||
$qualified = 0;
|
||||
$dependency .= ' ' . $token;
|
||||
push @$array, $dependency;
|
||||
$dependency = undef;
|
||||
next;
|
||||
}
|
||||
}
|
||||
if (defined $dependency) {
|
||||
push @$array, $dependency;
|
||||
}
|
||||
}
|
||||
|
||||
# Return true if the argument is a Perl dependency. Otherwise return false.
|
||||
sub is_perl_dependency {
|
||||
my $dependency = shift;
|
||||
return ($dependency =~ /\Aperl\(/);
|
||||
}
|
||||
|
||||
my $file = shift @ARGV;
|
||||
if (!defined $file) {
|
||||
die "Missing an argument with an RPM build log!\n"
|
||||
}
|
||||
|
||||
# Parse build log
|
||||
open(my $log, '<', $file) or die "Could not open `$file': $!\n";
|
||||
my ($package, %packages);
|
||||
while (!eof($log)) {
|
||||
defined($_ = <$log>) or die "Error while reading from `$file': $!\n";
|
||||
chomp;
|
||||
|
||||
if (/\AProcessing files: ([\S]+)-[^-]+-[^-]+$/) {
|
||||
$package = $1;
|
||||
$packages{$package}{requires} = [];
|
||||
$packages{$package}{provides} = [];
|
||||
} elsif ($package && /\AProvides: (.*)\z/) {
|
||||
appendsymbols($packages{$package}{provides}, $1);
|
||||
} elsif ($package && /\ARequires: (.*)\z/) {
|
||||
appendsymbols($packages{$package}{requires}, $1);
|
||||
}
|
||||
}
|
||||
close($log);
|
||||
|
||||
# Save dependencies into file
|
||||
my $filename = 'gendep.macros';
|
||||
open (my $gendep, '>', $filename) or
|
||||
die "Could not open `$filename' for writing: $!\n";
|
||||
for my $package (sort keys %packages) {
|
||||
# Macro name
|
||||
my $macro = 'gendep_' . $package;
|
||||
$macro =~ s/[+-]/_/g;
|
||||
$gendep->print("%global $macro \\\n");
|
||||
# Macro value
|
||||
for my $dependency (@{$packages{$package}{requires}}) {
|
||||
if (is_perl_dependency($dependency)) {
|
||||
$gendep->print("Requires: $dependency \\\n");
|
||||
}
|
||||
}
|
||||
for my $dependency (@{$packages{$package}{provides}}) {
|
||||
if (is_perl_dependency($dependency)) {
|
||||
$gendep->print("Provides: $dependency \\\n");
|
||||
}
|
||||
}
|
||||
# Macro trailer
|
||||
$gendep->print("%{nil}\n");
|
||||
}
|
||||
close($gendep) or die "Could not close `$filename': $!\n";
|
||||
|
||||
|
||||
__END__
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
generatedependencies - Distil generated Perl dependencies from a build log
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<generatedependencies> I<BUILD_LOG>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
It opens specified RPM build log I<BUILD_LOG>. It locates a protocol about
|
||||
autogenerated dependencies. It stores the reported dependencies into F<./gendep.macros> file.
|
||||
|
||||
The output file will define macros C<gendep_I<BINARY_PACKAGE_NAME>>. A macro
|
||||
for each binary package. The macro name will use underscores instead of
|
||||
hyphens or other SPEC language special characters.
|
||||
|
||||
It will ignore non-Perl dependencies (not C<perl(*)>) as they do not come from
|
||||
Perl dependency generator.
|
||||
|
||||
=head1 EXIT CODE
|
||||
|
||||
Returns zero, if no error occurred. Otherwise non-zero code is returned.
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
The invocation is:
|
||||
|
||||
$ generatedependencies .build-5.24.0-364.fc25.log
|
||||
|
||||
The output is:
|
||||
|
||||
$ grep -A5 perl_Devel_Peek gendep.macros
|
||||
%global gendep_perl_Devel_Peek \
|
||||
Requires: perl(Exporter) \
|
||||
Requires: perl(XSLoader) \
|
||||
Provides: perl(Devel::Peek) = 1.23 \
|
||||
%nil{}
|
||||
%global gendep_perl_Devel_SelfStubber \
|
||||
|
||||
|
||||
The output can be used in a spec file like:
|
||||
|
||||
Name: perl
|
||||
Source0: gendep.macros
|
||||
%include %{SOURCE0}
|
||||
%package Devel-Peek
|
||||
%gendep_Devel_Peek
|
||||
%package Devel-SelfStubber
|
||||
%gendep_Devel_SelfStubber
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
Copyright (C) 2016 Petr Písař <ppisar@redhat.com>
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
=cut
|
||||
|
|
@ -22,6 +22,13 @@ export PERL_AUTOINSTALL="--defaultdeps"
|
|||
export PERL_MM_USE_DEFAULT=1
|
||||
}
|
||||
|
||||
#############################################################################
|
||||
# Perl specific macros, no longer part of rpm >= 4.15
|
||||
%perl_vendorarch %(eval "`%{__perl} -V:installvendorarch`"; echo $installvendorarch)
|
||||
%perl_vendorlib %(eval "`%{__perl} -V:installvendorlib`"; echo $installvendorlib)
|
||||
%perl_archlib %(eval "`%{__perl} -V:installarchlib`"; echo $installarchlib)
|
||||
%perl_privlib %(eval "`%{__perl} -V:installprivlib`"; echo $installprivlib)
|
||||
|
||||
#############################################################################
|
||||
# Filtering macro incantations
|
||||
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
diff -up perl-5.10.0/Configure.didi perl-5.10.0/Configure
|
||||
--- perl-5.10.0/Configure.didi 2007-12-18 11:47:07.000000000 +0100
|
||||
+++ perl-5.10.0/Configure 2008-07-21 10:51:16.000000000 +0200
|
||||
@@ -1479,7 +1479,7 @@ archname=''
|
||||
@@ -1483,7 +1483,7 @@ archname=''
|
||||
usereentrant='undef'
|
||||
: List of libraries we want.
|
||||
: If anyone needs extra -lxxx, put those in a hint file.
|
||||
|
|
@ -1,12 +1,12 @@
|
|||
diff -up perl-5.10.0/t/io/fs.t.BAD perl-5.10.0/t/io/fs.t
|
||||
--- perl-5.10.0/t/io/fs.t.BAD 2008-01-30 13:36:43.000000000 -0500
|
||||
+++ perl-5.10.0/t/io/fs.t 2008-01-30 13:41:27.000000000 -0500
|
||||
@@ -227,7 +227,7 @@ isnt($atime, 500000000, 'atime');
|
||||
isnt($mtime, 500000000 + $delta, 'mtime');
|
||||
@@ -257,7 +257,7 @@ isnt($atime, 500000000, 'atime');
|
||||
isnt($mtime, $ut + $delta, 'mtime: utime called with two undefs');
|
||||
|
||||
SKIP: {
|
||||
- skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define";
|
||||
+ skip "no futimes", 6;
|
||||
note("check futimes");
|
||||
open(my $fh, "<", 'b');
|
||||
$foo = (utime 500000000,500000000 + $delta, $fh);
|
||||
is($foo, 1, "futime");
|
||||
$foo = (utime $ut,$ut + $delta, $fh);
|
||||
|
|
@ -20,7 +20,7 @@ diff --git a/MANIFEST b/MANIFEST
|
|||
index 397252a..d7c519b 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -3093,6 +3093,7 @@ dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm CBuilder methods fo
|
||||
@@ -3424,6 +3424,7 @@ dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm CBuilder methods fo
|
||||
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm CBuilder methods for cygwin
|
||||
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm CBuilder methods for darwin
|
||||
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm CBuilder methods for OSF
|
||||
|
|
@ -18,7 +18,7 @@ diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm b/cpan/ExtUtils-Mak
|
|||
index a8b172f..a3fbce2 100644
|
||||
--- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
|
||||
+++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
|
||||
@@ -31,6 +31,7 @@ BEGIN {
|
||||
@@ -30,6 +30,7 @@ BEGIN {
|
||||
$Is{IRIX} = $^O eq 'irix';
|
||||
$Is{NetBSD} = $^O eq 'netbsd';
|
||||
$Is{Interix} = $^O eq 'interix';
|
||||
|
|
@ -26,7 +26,7 @@ index a8b172f..a3fbce2 100644
|
|||
$Is{SunOS4} = $^O eq 'sunos';
|
||||
$Is{Solaris} = $^O eq 'solaris';
|
||||
$Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
|
||||
@@ -932,7 +933,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
|
||||
@@ -1028,7 +1029,7 @@ sub xs_make_dynamic_lib {
|
||||
push(@m," \$(RM_F) \$\@\n");
|
||||
|
||||
my $libs = '$(LDLOADLIBS)';
|
||||
|
|
@ -35,7 +35,7 @@ index a8b172f..a3fbce2 100644
|
|||
# Use nothing on static perl platforms, and to the flags needed
|
||||
# to link against the shared libperl library on shared perl
|
||||
# platforms. We peek at lddlflags to see if we need -Wl,-R
|
||||
@@ -941,6 +942,11 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
|
||||
@@ -1041,6 +1042,11 @@ sub xs_make_dynamic_lib {
|
||||
# The Android linker will not recognize symbols from
|
||||
# libperl unless the module explicitly depends on it.
|
||||
$libs .= ' "-L$(PERL_INC)" -lperl';
|
||||
|
|
@ -14,16 +14,21 @@ diff --git a/Makefile.SH b/Makefile.SH
|
|||
index d1da0a0..7733a32 100755
|
||||
--- a/Makefile.SH
|
||||
+++ b/Makefile.SH
|
||||
@@ -58,7 +58,7 @@ true)
|
||||
${api_revision}.${api_version}.${api_subversion} \
|
||||
-current_version \
|
||||
${revision}.${patchlevel}.${subversion} \
|
||||
- -install_name \$(shrpdir)/\$@"
|
||||
+ -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
|
||||
@@ -70,11 +70,11 @@ true)
|
||||
${revision}.${patchlevel}.${subversion}"
|
||||
case "$osvers" in
|
||||
1[5-9]*|[2-9]*)
|
||||
- shrpldflags="$shrpldflags -install_name `pwd`/\$@ -Xlinker -headerpad_max_install_names"
|
||||
+ shrpldflags="$shrpldflags -install_name `pwd`/libperl.${revision}.${patchlevel}.dylib -Xlinker -headerpad_max_install_names"
|
||||
exeldflags="-Xlinker -headerpad_max_install_names"
|
||||
;;
|
||||
*)
|
||||
- shrpldflags="$shrpldflags -install_name \$(shrpdir)/\$@"
|
||||
+ shrpldflags="$shrpldflags -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
|
||||
;;
|
||||
esac
|
||||
;;
|
||||
cygwin*)
|
||||
shrpldflags="$shrpldflags -Wl,--out-implib=libperl.dll.a -Wl,--image-base,0x52000000"
|
||||
@@ -66,13 +66,15 @@ true)
|
||||
@@ -76,13 +76,15 @@ true)
|
||||
;;
|
||||
sunos*)
|
||||
linklibperl="-lperl"
|
||||
|
|
@ -40,7 +45,7 @@ index d1da0a0..7733a32 100755
|
|||
;;
|
||||
aix*)
|
||||
case "$cc" in
|
||||
@@ -110,6 +112,9 @@ true)
|
||||
@@ -120,6 +122,9 @@ true)
|
||||
linklibperl='libperl.x'
|
||||
DPERL_EXTERNAL_GLOB=''
|
||||
;;
|
||||
|
|
@ -41,15 +41,15 @@ index 33e08e2..7160f54 100644
|
|||
GDBM_FILE dbp ;
|
||||
SV * filter[4];
|
||||
int filtering ;
|
||||
@@ -89,6 +90,7 @@ gdbm_TIEHASH(dbtype, name, read_write, mode)
|
||||
if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode,
|
||||
(FATALFUNC) croak_string))) {
|
||||
RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type)) ;
|
||||
+ RETVAL->owner = aTHX;
|
||||
RETVAL->dbp = dbp ;
|
||||
}
|
||||
|
||||
@@ -109,12 +111,14 @@ gdbm_DESTROY(db)
|
||||
@@ -98,6 +99,7 @@ gdbm_TIEHASH(dbtype, name, read_write, m
|
||||
}
|
||||
if (dbp) {
|
||||
RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type));
|
||||
+ RETVAL->owner = aTHX;
|
||||
RETVAL->dbp = dbp;
|
||||
} else {
|
||||
RETVAL = NULL;
|
||||
@@ -118,12 +120,14 @@ gdbm_DESTROY(db)
|
||||
PREINIT:
|
||||
int i = store_value;
|
||||
CODE:
|
||||
|
|
@ -115,7 +115,7 @@ diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
|
|||
index d1ece7f..f7e00a0 100644
|
||||
--- a/ext/ODBM_File/ODBM_File.xs
|
||||
+++ b/ext/ODBM_File/ODBM_File.xs
|
||||
@@ -45,6 +45,7 @@ datum nextkey(datum key);
|
||||
@@ -49,6 +49,7 @@ datum nextkey(datum key);
|
||||
#define store_value 3
|
||||
|
||||
typedef struct {
|
||||
|
|
@ -123,7 +123,7 @@ index d1ece7f..f7e00a0 100644
|
|||
void * dbp ;
|
||||
SV * filter[4];
|
||||
int filtering ;
|
||||
@@ -112,6 +113,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
|
||||
@@ -137,6 +138,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
|
||||
}
|
||||
dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
|
||||
RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
|
||||
|
|
@ -131,7 +131,7 @@ index d1ece7f..f7e00a0 100644
|
|||
RETVAL->dbp = dbp ;
|
||||
}
|
||||
OUTPUT:
|
||||
@@ -124,13 +126,15 @@ DESTROY(db)
|
||||
@@ -149,13 +151,15 @@ DESTROY(db)
|
||||
dMY_CXT;
|
||||
int i = store_value;
|
||||
CODE:
|
||||
|
|
@ -166,7 +166,7 @@ index 291e41b..0bdae9a 100644
|
|||
DBM * dbp ;
|
||||
SV * filter[4];
|
||||
int filtering ;
|
||||
@@ -49,6 +50,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
|
||||
@@ -51,6 +52,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
|
||||
}
|
||||
if (dbp) {
|
||||
RETVAL = (SDBM_File)safecalloc(1, sizeof(SDBM_File_type));
|
||||
|
|
@ -174,7 +174,7 @@ index 291e41b..0bdae9a 100644
|
|||
RETVAL->dbp = dbp ;
|
||||
}
|
||||
|
||||
@@ -60,7 +62,7 @@ void
|
||||
@@ -62,7 +64,7 @@ void
|
||||
sdbm_DESTROY(db)
|
||||
SDBM_File db
|
||||
CODE:
|
||||
|
|
@ -187,7 +187,7 @@ diff --git a/t/lib/dbmt_common.pl b/t/lib/dbmt_common.pl
|
|||
index 5d4098c..a0a4d52 100644
|
||||
--- a/t/lib/dbmt_common.pl
|
||||
+++ b/t/lib/dbmt_common.pl
|
||||
@@ -511,5 +511,40 @@ unlink <Op_dbmx*>, $Dfile;
|
||||
@@ -510,5 +510,40 @@ unlink <Op_dbmx*>, $Dfile;
|
||||
unlink <Op1_dbmx*>;
|
||||
}
|
||||
|
||||
|
|
@ -16,7 +16,7 @@ diff --git a/Configure b/Configure
|
|||
index 2f30261..825496e 100755
|
||||
--- a/Configure
|
||||
+++ b/Configure
|
||||
@@ -8249,7 +8249,9 @@ esac
|
||||
@@ -8762,7 +8762,9 @@ esac
|
||||
|
||||
# Detect old use of shrpdir via undocumented Configure -Dshrpdir
|
||||
case "$shrpdir" in
|
||||
|
|
@ -27,7 +27,7 @@ index 2f30261..825496e 100755
|
|||
*) $cat >&4 <<EOM
|
||||
WARNING: Use of the shrpdir variable for the installation location of
|
||||
the shared $libperl is not supported. It was never documented and
|
||||
@@ -8279,7 +8281,6 @@ esac
|
||||
@@ -8792,7 +8794,6 @@ esac
|
||||
# Add $xxx to ccdlflags.
|
||||
# If we can't figure out a command-line option, use $shrpenv to
|
||||
# set env LD_RUN_PATH. The main perl makefile uses this.
|
||||
|
|
@ -35,7 +35,7 @@ index 2f30261..825496e 100755
|
|||
xxx=''
|
||||
tmp_shrpenv=''
|
||||
if "$useshrplib"; then
|
||||
@@ -8294,7 +8295,7 @@ if "$useshrplib"; then
|
||||
@@ -8807,7 +8808,7 @@ if "$useshrplib"; then
|
||||
xxx="-Wl,-R$shrpdir"
|
||||
;;
|
||||
bsdos|linux|irix*|dec_osf|gnu*|haiku)
|
||||
|
|
@ -48,7 +48,7 @@ diff --git a/Makefile.SH b/Makefile.SH
|
|||
index 7733a32..a481183 100755
|
||||
--- a/Makefile.SH
|
||||
+++ b/Makefile.SH
|
||||
@@ -266,7 +266,7 @@ ranlib = $ranlib
|
||||
@@ -288,7 +288,7 @@ ranlib = $ranlib
|
||||
# installman commandline.
|
||||
bin = $installbin
|
||||
scriptdir = $scriptdir
|
||||
|
|
@ -23,7 +23,7 @@ diff --git a/MANIFEST b/MANIFEST
|
|||
index 6af238c..d4f0c56 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -1045,6 +1045,7 @@ cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
|
||||
@@ -784,6 +784,7 @@ cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
|
||||
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
|
||||
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm MakeMaker methods for QNX
|
||||
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm MakeMaker methods for Unix
|
||||
|
|
@ -20,7 +20,7 @@ diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
|
|||
index 6a82bdf..b6cd7ef 100644
|
||||
--- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm
|
||||
+++ b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
|
||||
@@ -230,7 +230,7 @@ sub can_run {
|
||||
@@ -232,7 +232,7 @@ sub can_run {
|
||||
}
|
||||
|
||||
require File::Spec;
|
||||
|
|
@ -10,7 +10,7 @@ diff --git a/Makefile.SH b/Makefile.SH
|
|||
index 5fc6d1c..e89ad70 100755
|
||||
--- a/Makefile.SH
|
||||
+++ b/Makefile.SH
|
||||
@@ -457,6 +457,8 @@ CCCMD = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@
|
||||
@@ -462,6 +462,8 @@ CCCMD = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@
|
||||
|
||||
CCCMDSRC = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $<
|
||||
|
||||
|
|
@ -19,7 +19,7 @@ index 5fc6d1c..e89ad70 100755
|
|||
CONFIGPM_FROM_CONFIG_SH = lib/Config.pm lib/Config_heavy.pl
|
||||
CONFIGPM = $(CONFIGPM_FROM_CONFIG_SH) lib/Config_git.pl
|
||||
|
||||
@@ -890,19 +892,19 @@ $(DTRACE_MINI_O): perldtrace.d $(miniperl_objs_nodt)
|
||||
@@ -895,19 +897,19 @@ $(DTRACE_MINI_O): perldtrace.d $(miniperl_objs_nodt)
|
||||
-rm -rf mpdtrace
|
||||
mkdir mpdtrace
|
||||
cp $(miniperl_objs_nodt) mpdtrace/
|
||||
|
|
@ -46,10 +46,10 @@ diff --git a/cflags.SH b/cflags.SH
|
|||
index 3af1e97..b845127 100755
|
||||
--- a/cflags.SH
|
||||
+++ b/cflags.SH
|
||||
@@ -516,7 +516,10 @@ for file do
|
||||
@@ -519,7 +519,10 @@ for file do
|
||||
toke) optimize=-O0 ;;
|
||||
esac
|
||||
|
||||
# Can we perhaps use $ansi2knr here
|
||||
- echo "$cc -c -DPERL_CORE $ccflags $stdflags $optimize $warn $extra"
|
||||
+ case "$file" in
|
||||
+ dtrace_*) echo "$ccflags $stdflags $optimize $warn $extra";;
|
||||
|
|
@ -0,0 +1,389 @@
|
|||
From fd30a7c49a661aecfb361045646da264cdadea8f Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Fri, 23 Aug 2019 12:40:24 -0600
|
||||
Subject: [PATCH] PATCH: [perl #134329] Use after free in regcomp.c
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
A compiled regex is composed of nodes, forming a linked list, with
|
||||
normally a maximum of 16 bits used to specify the offset of the next
|
||||
link. For patterns that require more space than this, the nodes that
|
||||
jump around are replaced with ones that have wider offsets. Most nodes
|
||||
are unaffected, as they just contain the offset of the next node, and
|
||||
that number is always small. The jump nodes are the ones affected.
|
||||
|
||||
When compiling a pattern, the 16 bit mechanism is used, until it
|
||||
overflows, at which point the pattern is recompiled with the long jumps
|
||||
instead.
|
||||
|
||||
When I rewrote the compiler last year to make it generally one pass, I
|
||||
noticed a lot of the cases where a node was added didn't check if the
|
||||
result overflowed (the function that does this returns FALSE in that
|
||||
case). I presumed the prior authors knew better, and did not change
|
||||
things, except to put in a bogus value in the link (offset) field that
|
||||
should cause a crash if it were used. That's what's happening in this
|
||||
ticket.
|
||||
|
||||
But seeing this example, it's clear that the return value should be
|
||||
checked every time, because you can reach the limit at any time. This
|
||||
commit changes to do that, and to require the function's return value to
|
||||
not be ignored, to guard against future changes.
|
||||
|
||||
My guess is that the reason it generally worked when there were multiple
|
||||
passes is that the first pass didn't do anything except count space, and
|
||||
that at some point before the end of the pass the return value did get
|
||||
checked, so by the time the nodes were allocated for real, it knew
|
||||
enough to use the long jumps.
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
3b2e5620ed4a6b341f97ffd1d4b6466cc2c4bc5b.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 1 +
|
||||
embed.fnc | 4 +-
|
||||
proto.h | 8 ++-
|
||||
regcomp.c | 109 ++++++++++++++++++++++++++++-----------
|
||||
t/re/bigfuzzy_not_utf8.t | Bin 0 -> 36399 bytes
|
||||
5 files changed, 88 insertions(+), 34 deletions(-)
|
||||
create mode 100644 t/re/bigfuzzy_not_utf8.t
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 10e2cc0..cc24cd7 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -5839,6 +5839,7 @@ t/porting/test_bootstrap.t Test that the instructions for test bootstrapping are
|
||||
t/porting/utils.t Check that utility scripts still compile
|
||||
t/re/alpha_assertions.t See if things like '(*postive_lookahed:...) work properly
|
||||
t/re/anyof.t See if bracketed char classes [...] compile properly
|
||||
+t/re/bigfuzzy_not_utf8.t Big and ugly tests not storable as UTF-8
|
||||
t/re/charset.t See if regex modifiers like /d, /u work properly
|
||||
t/re/fold_grind.pl Core file to see if regex case folding works properly
|
||||
t/re/fold_grind_8.t Wrapper for fold_grind.pl for /l testing with a UTF-8 locale
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index c977d39..c2c5f16 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -2427,7 +2427,7 @@ Es |void |reginsert |NN RExC_state_t *pRExC_state \
|
||||
|const U8 op \
|
||||
|const regnode_offset operand \
|
||||
|const U32 depth
|
||||
-Es |bool |regtail |NN RExC_state_t * pRExC_state \
|
||||
+EsR |bool |regtail |NN RExC_state_t * pRExC_state \
|
||||
|NN const regnode_offset p \
|
||||
|NN const regnode_offset val \
|
||||
|const U32 depth
|
||||
@@ -2561,7 +2561,7 @@ Es |void |dump_trie_interim_list|NN const struct _reg_trie_data *trie\
|
||||
Es |void |dump_trie_interim_table|NN const struct _reg_trie_data *trie\
|
||||
|NULLOK HV* widecharmap|NN AV *revcharmap\
|
||||
|U32 next_alloc|U32 depth
|
||||
-Es |bool |regtail_study |NN RExC_state_t *pRExC_state \
|
||||
+EsR |bool |regtail_study |NN RExC_state_t *pRExC_state \
|
||||
|NN regnode_offset p|NN const regnode_offset val|U32 depth
|
||||
# endif
|
||||
#endif
|
||||
diff --git a/proto.h b/proto.h
|
||||
index e0ea55b..2ef7ce2 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -4457,9 +4457,11 @@ PERL_CALLCONV int Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...);
|
||||
assert(fmt)
|
||||
STATIC void S_regdump_extflags(pTHX_ const char *lead, const U32 flags);
|
||||
STATIC void S_regdump_intflags(pTHX_ const char *lead, const U32 flags);
|
||||
-STATIC bool S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, const regnode_offset val, U32 depth);
|
||||
+STATIC bool S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, const regnode_offset val, U32 depth)
|
||||
+ __attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_REGTAIL_STUDY \
|
||||
assert(pRExC_state); assert(p); assert(val)
|
||||
+
|
||||
# endif
|
||||
# if defined(PERL_IN_REGEXEC_C)
|
||||
STATIC void S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8, const char *start, const char *end, const char *blurb);
|
||||
@@ -5599,9 +5601,11 @@ STATIC regnode_offset S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 o
|
||||
STATIC regnode_offset S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth);
|
||||
#define PERL_ARGS_ASSERT_REGPIECE \
|
||||
assert(pRExC_state); assert(flagp)
|
||||
-STATIC bool S_regtail(pTHX_ RExC_state_t * pRExC_state, const regnode_offset p, const regnode_offset val, const U32 depth);
|
||||
+STATIC bool S_regtail(pTHX_ RExC_state_t * pRExC_state, const regnode_offset p, const regnode_offset val, const U32 depth)
|
||||
+ __attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_REGTAIL \
|
||||
assert(pRExC_state); assert(p); assert(val)
|
||||
+
|
||||
STATIC void S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, struct scan_data_t *data, SSize_t *minlenp, int is_inf);
|
||||
#define PERL_ARGS_ASSERT_SCAN_COMMIT \
|
||||
assert(pRExC_state); assert(data); assert(minlenp)
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index dfc22bc..b93fbe7 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -11307,10 +11307,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
return 0;
|
||||
}
|
||||
|
||||
- REGTAIL(pRExC_state, ret, atomic);
|
||||
+ if (! REGTAIL(pRExC_state, ret, atomic)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
|
||||
- REGTAIL(pRExC_state, atomic,
|
||||
- reg_node(pRExC_state, SRCLOSE));
|
||||
+ if (! REGTAIL(pRExC_state, atomic, reg_node(pRExC_state,
|
||||
+ SRCLOSE)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
|
||||
RExC_in_script_run = 0;
|
||||
return ret;
|
||||
@@ -11769,7 +11774,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
RExC_flags & RXf_PMf_COMPILETIME
|
||||
);
|
||||
FLAGS(REGNODE_p(ret)) = 2;
|
||||
- REGTAIL(pRExC_state, ret, eval);
|
||||
+ if (! REGTAIL(pRExC_state, ret, eval)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
/* deal with the length of this later - MJD */
|
||||
return ret;
|
||||
}
|
||||
@@ -11822,7 +11829,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
|
||||
tail = reg(pRExC_state, 1, &flag, depth+1);
|
||||
RETURN_FAIL_ON_RESTART(flag, flagp);
|
||||
- REGTAIL(pRExC_state, ret, tail);
|
||||
+ if (! REGTAIL(pRExC_state, ret, tail)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
goto insert_if;
|
||||
}
|
||||
else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
|
||||
@@ -11914,15 +11923,22 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
}
|
||||
nextchar(pRExC_state);
|
||||
insert_if:
|
||||
- REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
|
||||
+ if (! REGTAIL(pRExC_state, ret, reganode(pRExC_state,
|
||||
+ IFTHEN, 0)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
br = regbranch(pRExC_state, &flags, 1, depth+1);
|
||||
if (br == 0) {
|
||||
RETURN_FAIL_ON_RESTART(flags,flagp);
|
||||
FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
|
||||
(UV) flags);
|
||||
} else
|
||||
- REGTAIL(pRExC_state, br, reganode(pRExC_state,
|
||||
- LONGJMP, 0));
|
||||
+ if (! REGTAIL(pRExC_state, br, reganode(pRExC_state,
|
||||
+ LONGJMP, 0)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
c = UCHARAT(RExC_parse);
|
||||
nextchar(pRExC_state);
|
||||
if (flags&HASWIDTH)
|
||||
@@ -11939,7 +11955,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
|
||||
(UV) flags);
|
||||
}
|
||||
- REGTAIL(pRExC_state, ret, lastbr);
|
||||
+ if (! REGTAIL(pRExC_state, ret, lastbr)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (flags&HASWIDTH)
|
||||
*flagp |= HASWIDTH;
|
||||
c = UCHARAT(RExC_parse);
|
||||
@@ -11954,16 +11972,26 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
vFAIL("Switch (?(condition)... contains too many branches");
|
||||
}
|
||||
ender = reg_node(pRExC_state, TAIL);
|
||||
- REGTAIL(pRExC_state, br, ender);
|
||||
+ if (! REGTAIL(pRExC_state, br, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (lastbr) {
|
||||
- REGTAIL(pRExC_state, lastbr, ender);
|
||||
- REGTAIL(pRExC_state, REGNODE_OFFSET(
|
||||
- NEXTOPER(
|
||||
- NEXTOPER(REGNODE_p(lastbr)))),
|
||||
- ender);
|
||||
+ if (! REGTAIL(pRExC_state, lastbr, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
+ if (! REGTAIL(pRExC_state,
|
||||
+ REGNODE_OFFSET(
|
||||
+ NEXTOPER(
|
||||
+ NEXTOPER(REGNODE_p(lastbr)))),
|
||||
+ ender))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
#if 0 /* Removing this doesn't cause failures in the test suite -- khw */
|
||||
RExC_size++; /* XXX WHY do we need this?!!
|
||||
For large programs it seems to be required
|
||||
@@ -12113,7 +12141,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
*flagp |= flags&SIMPLE;
|
||||
}
|
||||
if (is_open) { /* Starts with OPEN. */
|
||||
- REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
|
||||
+ if (! REGTAIL(pRExC_state, ret, br)) { /* OPEN -> first. */
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else if (paren != '?') /* Not Conditional */
|
||||
ret = br;
|
||||
@@ -12121,12 +12151,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
lastbr = br;
|
||||
while (*RExC_parse == '|') {
|
||||
if (RExC_use_BRANCHJ) {
|
||||
+ bool shut_gcc_up;
|
||||
+
|
||||
ender = reganode(pRExC_state, LONGJMP, 0);
|
||||
|
||||
/* Append to the previous. */
|
||||
- REGTAIL(pRExC_state,
|
||||
- REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
|
||||
- ender);
|
||||
+ shut_gcc_up = REGTAIL(pRExC_state,
|
||||
+ REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
|
||||
+ ender);
|
||||
+ PERL_UNUSED_VAR(shut_gcc_up);
|
||||
}
|
||||
nextchar(pRExC_state);
|
||||
if (freeze_paren) {
|
||||
@@ -12237,9 +12270,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
is_nothing= 0;
|
||||
}
|
||||
else if (op == BRANCHJ) {
|
||||
- REGTAIL_STUDY(pRExC_state,
|
||||
- REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
|
||||
- ender);
|
||||
+ bool shut_gcc_up = REGTAIL_STUDY(pRExC_state,
|
||||
+ REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
|
||||
+ ender);
|
||||
+ PERL_UNUSED_VAR(shut_gcc_up);
|
||||
/* for now we always disable this optimisation * /
|
||||
if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
|
||||
|| regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender))
|
||||
@@ -12551,7 +12585,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
const regnode_offset w = reg_node(pRExC_state, WHILEM);
|
||||
|
||||
FLAGS(REGNODE_p(w)) = 0;
|
||||
- REGTAIL(pRExC_state, ret, w);
|
||||
+ if (! REGTAIL(pRExC_state, ret, w)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (RExC_use_BRANCHJ) {
|
||||
reginsert(pRExC_state, LONGJMP, ret, depth+1);
|
||||
reginsert(pRExC_state, NOTHING, ret, depth+1);
|
||||
@@ -12566,7 +12602,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
if (RExC_use_BRANCHJ)
|
||||
NEXT_OFF(REGNODE_p(ret)) = 3; /* Go over NOTHING to
|
||||
LONGJMP. */
|
||||
- REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
|
||||
+ if (! REGTAIL(pRExC_state, ret, reg_node(pRExC_state,
|
||||
+ NOTHING)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
RExC_whilem_seen++;
|
||||
MARK_NAUGHTY_EXP(1, 4); /* compound interest */
|
||||
}
|
||||
@@ -12638,16 +12678,22 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
if (*RExC_parse == '?') {
|
||||
nextchar(pRExC_state);
|
||||
reginsert(pRExC_state, MINMOD, ret, depth+1);
|
||||
- REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else if (*RExC_parse == '+') {
|
||||
regnode_offset ender;
|
||||
nextchar(pRExC_state);
|
||||
ender = reg_node(pRExC_state, SUCCEED);
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
reginsert(pRExC_state, SUSPEND, ret, depth+1);
|
||||
ender = reg_node(pRExC_state, TAIL);
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
|
||||
if (ISMULT2(RExC_parse)) {
|
||||
@@ -19815,8 +19861,8 @@ S_regtail(pTHX_ RExC_state_t * pRExC_state,
|
||||
}
|
||||
else {
|
||||
if (val - scan > U16_MAX) {
|
||||
- /* Since not all callers check the return value, populate this with
|
||||
- * something that won't loop and will likely lead to a crash if
|
||||
+ /* Populate this with something that won't loop and will likely
|
||||
+ * lead to a crash if the caller ignores the failure return, and
|
||||
* execution continues */
|
||||
NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
|
||||
return FALSE;
|
||||
@@ -19927,6 +19973,9 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p,
|
||||
}
|
||||
else {
|
||||
if (val - scan > U16_MAX) {
|
||||
+ /* Populate this with something that won't loop and will likely
|
||||
+ * lead to a crash if the caller ignores the failure return, and
|
||||
+ * execution continues */
|
||||
NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
|
||||
return FALSE;
|
||||
}
|
||||
diff --git a/t/re/bigfuzzy_not_utf8.t b/t/re/bigfuzzy_not_utf8.t
|
||||
new file mode 100644
|
||||
index 0000000000000000000000000000000000000000..b4dfd150a9297172af5d8e7811357fd68931f8d7
|
||||
GIT binary patch
|
||||
literal 36399
|
||||
zcmeI5y>Ht_6u>V)vj`|)bnw`ot)P-@MMCTpNTQ@6nzlsHpvaKGfa6%8#FNC9CKZxu
|
||||
z;)Jf$YRJ%zoeHDqo_|0?hWr89EXQ;I1&?0XN7}J$MN%l4pVm7V_T9aA@8fqzil1_F
|
||||
zE|;$}O->{eN&28B=@fnhT2nU|t*9E+ShXPw8fDMw8q;-2Rj9#qL#IYfFlbp&QU)zC
|
||||
zsvD}tL@Ma?;e+olU(13qL4mf$Xi2KlMpfR-(n>>?sal~`K`RMWM$0up6UqkD^enA1
|
||||
zg=vB;ZywbQuvXdxGnK~k=b({GBpSNyN0Z7%!KptLG(}RXdLfa}8zrhWl%f+Fv@e<T
|
||||
z7QF(MZ@%O2{zzXWD3o$dlr)+$QdFwY%c5N?I0B75X-E+19aX7F)dH0^>Z)eEZ=O;~
|
||||
z<?^<VTwP8TfX(4J=(JPOnNc)URn{G8|1eoC_e<>oje1d1%IQ=tmzSkdDoay2=T|Pz
|
||||
zo*8+Kr80%Y79{wyR4)RabV^adFWpeZh73a5P-K`EDzb{C0J1N?-Bg5osvt7$#*LDy
|
||||
z8pU1*;Hb;O`}w=|H2|VCNgvil!C)|-F!4`oOre4(0@l39WM)9+aK3^6G2ryE+cJd2
|
||||
zG%)O}9%o(Xh5+npOk+9dJvA{f4-S<VFd0eu$X<3dd1d+P^3wIkj=-L!jZMnkKb#l4
|
||||
zS%FnoE840>Nl&MqX!&&dnrWK5-2KkXUdJ@kJhZYzBs1%)nFU8yw#)YRc86bC;+Jl5
|
||||
zgy&7Z`^Fw(?OiZUet&)S)$APMGYhtb_713ZrNwu<++Ih39!HYq+wJzw?PH0VT{$4+
|
||||
zz%lmLw7_MJYpy#@2q4sQ7fUP%j9esxG8j3)cOk6*w(m~R0TQqY5H30#e)2t(Pe1U0
|
||||
zo7x9RuwyuZKZc9WF8Sr`COoz9_eZT+t&ggp!nq?r$P9^7Qf{`Z-{X`J#)<@xfTsj3
|
||||
zt7*Z}u%|ZB*f}Q9ILEnRY6A%n(u&6pLLV6Zhn*Je^046bHe3TpU@8gBV?hE)AbtcU
|
||||
z+*`#j(Lf`1Pqq2ly)J6Thrs2aLgj*Tgns-Zu;!m>A1&i8UmxMd)HGfL@L=Np^}xmu
|
||||
z6KnnbWTw9d+eiQj_)Fjmf6b$HBoG*ZvmFNFos+;OYFZqXdWnYd{P*jg`)Jij({(%|
|
||||
z`6Q@2v~b4IiYzkMz+$L)vsWgF{`mxB#u(y$sg7Y3RpU)yZB+QhQ9`d|Ekc6YFM1X7
|
||||
zv7KL!Yu;A|z5IoJ9um0Yp{;0|@_teFTYTByaiWdaEl<FRQ}wer1&gsF0VEJ%0z*Cq
|
||||
zPFzulaPT39=F90?E5wAR)%Dpf=7vno3fVuppO8RoQO7l$E%7!gQ^8*6kwlia=^
|
||||
z7B0VddLMEq9(*#931rOF{~Aj_u33(iBr5k4z;mpAB2(G^Zz{9Kq>+G^1Vp#S{&b=E
|
||||
zj|&}JWy0IK6Ap73lq)qn<QR$RqGeqiso;SyjOXJ#2pdfx0VLp>z?y5#A&T&w<H48c
|
||||
zUiJx|1$vwg0zrO}lpkL`u+~3K_<CVK5ue+x_nNLxR(uXP3g#_eo?nPUW*EaL0(kl}
|
||||
zicZin*SoHPf#Jg+1F=k5r(avNUv|&?^aT4NA<j}5>#6r1;mt7IkM<dnBRjm-J$jnL
|
||||
zl=}L=Xoe&f=@$t@+-3rNH|>W2eFfxdF(5w^x}jvkffEfIvgHNTjXV5+K%<*L3ET_R
|
||||
z+c|c&wLM;PQ@lgr#v_H=NB{{Sfw2f&z<1F4c?Err>gK7){ur^11cD`i`-xzApY~Qf
|
||||
z-Soco%zKmLS;Xfudc5$tj2??=s^NXSD9!fSp38_*Cb5m>t!bHAQk&zN(xREQTJ4>c
|
||||
zC4OI8w7BN_>Y<Q`P|Yl)JEqC+?<=onyWQ@36FPXvI!i<{<A|?8t9(>=zWZjEyWg?)
|
||||
z-~n%be|`1U>>S}U3wvP0@z9kP-|cdH9RYeANt%btP&>Dm_#=s#T{$4+fFnF_9>oX|
|
||||
zooo&c`N+|sIY^}|4akg;3*^W-WYBK!OJAAU-%N9Mt_49ZzRWCquG}WPRkz@uPUllu
|
||||
jIzOMKFSg+CqdL=Mn!K`nb$RLf<M~V>L7{9Vwi5pX0LDXb
|
||||
|
||||
literal 0
|
||||
HcmV?d00001
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
From 7e5b390a008ccad094a39c350f385d58e8a5102a Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Fri, 3 May 2019 13:57:47 -0600
|
||||
Subject: [PATCH] Remove undefined behavior from IV shifting
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
It is undefined behavior to shift a negative integer to the left. This
|
||||
commit avoids that by treating the value as unsigned, then casting back
|
||||
to integer for return.
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
814735a391b874af8f00eaf89469e5ec7f38cd4aa.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
asan_ignore | 5 -----
|
||||
pp.c | 21 ++++++++++++++++++++-
|
||||
2 files changed, 20 insertions(+), 6 deletions(-)
|
||||
|
||||
diff --git a/asan_ignore b/asan_ignore
|
||||
index e0f5685..f520546 100644
|
||||
--- a/asan_ignore
|
||||
+++ b/asan_ignore
|
||||
@@ -18,11 +18,6 @@
|
||||
|
||||
fun:Perl_pp_i_*
|
||||
|
||||
-# Perl's << is defined as using the underlying C's << operator, with the
|
||||
-# same undefined behaviour for shifts greater than the word size.
|
||||
-# (UVs normally, IVs with 'use integer')
|
||||
-
|
||||
-fun:Perl_pp_left_shift
|
||||
|
||||
# this function numifies the field width in eg printf "%10f".
|
||||
# It has its own overflow detection, so don't warn about it
|
||||
diff --git a/pp.c b/pp.c
|
||||
index 7afb090..3ca04e1 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1991,10 +1991,29 @@ static IV S_iv_shift(IV iv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
+
|
||||
if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return iv < 0 && !left ? -1 : 0;
|
||||
}
|
||||
- return left ? iv << shift : iv >> shift;
|
||||
+ /* For left shifts, perl 5 has chosen to treat the value as unsigned for
|
||||
+ * the * purposes of shifting, then cast back to signed. This is very
|
||||
+ * different from perl 6:
|
||||
+ *
|
||||
+ * $ perl6 -e 'say -2 +< 5'
|
||||
+ * -64
|
||||
+ *
|
||||
+ * $ ./perl -le 'print -2 << 5'
|
||||
+ * 18446744073709551552
|
||||
+ * */
|
||||
+ if (left) {
|
||||
+ if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
|
||||
+ return 0;
|
||||
+ }
|
||||
+ return (IV) (((UV) iv) << shift);
|
||||
+ }
|
||||
+
|
||||
+ /* Here is right shift */
|
||||
+ return iv >> shift;
|
||||
}
|
||||
|
||||
#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,191 @@
|
|||
From 8e9cf86aa69cb79c91edf5ff0586f87bfe4c91bd Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 2 Jul 2019 14:16:35 +1000
|
||||
Subject: [PATCH] (perl #134221) support append mode for open .. undef
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
45b29440d38be155c5177c8d6f9a5d4e7c2c098c.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
doio.c | 15 +++++++++++++++
|
||||
embed.fnc | 1 +
|
||||
perlio.c | 26 +++++++++++++++++++++-----
|
||||
perlio.h | 3 +++
|
||||
proto.h | 5 +++++
|
||||
t/io/perlio_open.t | 14 ++++++++++++--
|
||||
6 files changed, 57 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/doio.c b/doio.c
|
||||
index 05a0696..424e0e3 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -265,6 +265,21 @@ Perl_my_mkstemp_cloexec(char *templte)
|
||||
#endif
|
||||
}
|
||||
|
||||
+int
|
||||
+Perl_my_mkostemp_cloexec(char *templte, int flags)
|
||||
+{
|
||||
+ dVAR;
|
||||
+ PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC;
|
||||
+#if defined(O_CLOEXEC)
|
||||
+ DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
|
||||
+ PL_strategy_mkstemp,
|
||||
+ Perl_my_mkostemp(templte, flags | O_CLOEXEC),
|
||||
+ Perl_my_mkostemp(templte, flags));
|
||||
+#else
|
||||
+ DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags));
|
||||
+#endif
|
||||
+}
|
||||
+
|
||||
#ifdef HAS_PIPE
|
||||
int
|
||||
Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index 259affd..c977d39 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -476,6 +476,7 @@ p |int |PerlLIO_dup2_cloexec|int oldfd|int newfd
|
||||
pR |int |PerlLIO_open_cloexec|NN const char *file|int flag
|
||||
pR |int |PerlLIO_open3_cloexec|NN const char *file|int flag|int perm
|
||||
pnoR |int |my_mkstemp_cloexec|NN char *templte
|
||||
+pnoR |int |my_mkostemp_cloexec|NN char *templte|int flags
|
||||
#ifdef HAS_PIPE
|
||||
pR |int |PerlProc_pipe_cloexec|NN int *pipefd
|
||||
#endif
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index 904d47a..5a0cd36 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -1490,7 +1490,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
|
||||
int imode, int perm, PerlIO *f, int narg, SV **args)
|
||||
{
|
||||
if (!f && narg == 1 && *args == &PL_sv_undef) {
|
||||
- if ((f = PerlIO_tmpfile())) {
|
||||
+ int imode = PerlIOUnix_oflags(mode);
|
||||
+
|
||||
+ if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
|
||||
if (!layers || !*layers)
|
||||
layers = Perl_PerlIO_context_layers(aTHX_ mode);
|
||||
if (layers && *layers)
|
||||
@@ -5048,6 +5050,15 @@ PerlIO_stdoutf(const char *fmt, ...)
|
||||
#undef PerlIO_tmpfile
|
||||
PerlIO *
|
||||
PerlIO_tmpfile(void)
|
||||
+{
|
||||
+ return PerlIO_tmpfile_flags(0);
|
||||
+}
|
||||
+
|
||||
+#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
|
||||
+#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
|
||||
+
|
||||
+PerlIO *
|
||||
+PerlIO_tmpfile_flags(int imode)
|
||||
{
|
||||
#ifndef WIN32
|
||||
dTHX;
|
||||
@@ -5063,27 +5074,32 @@ PerlIO_tmpfile(void)
|
||||
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
|
||||
SV * sv = NULL;
|
||||
int old_umask = umask(0177);
|
||||
+ imode &= ~MKOSTEMP_MODE_MASK;
|
||||
if (tmpdir && *tmpdir) {
|
||||
/* if TMPDIR is set and not empty, we try that first */
|
||||
sv = newSVpv(tmpdir, 0);
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
}
|
||||
if (fd < 0) {
|
||||
SvREFCNT_dec(sv);
|
||||
sv = NULL;
|
||||
/* else we try /tmp */
|
||||
- fd = Perl_my_mkstemp_cloexec(tempname);
|
||||
+ fd = Perl_my_mkostemp_cloexec(tempname, imode);
|
||||
}
|
||||
if (fd < 0) {
|
||||
/* Try cwd */
|
||||
sv = newSVpvs(".");
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
}
|
||||
umask(old_umask);
|
||||
if (fd >= 0) {
|
||||
- f = PerlIO_fdopen(fd, "w+");
|
||||
+ /* fdopen() with a numeric mode */
|
||||
+ char mode[8];
|
||||
+ int writing = 1;
|
||||
+ (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
|
||||
+ f = PerlIO_fdopen(fd, mode);
|
||||
if (f)
|
||||
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
|
||||
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
|
||||
diff --git a/perlio.h b/perlio.h
|
||||
index d515020..ee16ab8 100644
|
||||
--- a/perlio.h
|
||||
+++ b/perlio.h
|
||||
@@ -286,6 +286,9 @@ PERL_CALLCONV SSize_t PerlIO_get_bufsiz(PerlIO *);
|
||||
#ifndef PerlIO_tmpfile
|
||||
PERL_CALLCONV PerlIO *PerlIO_tmpfile(void);
|
||||
#endif
|
||||
+#ifndef PerlIO_tmpfile_flags
|
||||
+PERL_CALLCONV PerlIO *PerlIO_tmpfile_flags(int flags);
|
||||
+#endif
|
||||
#ifndef PerlIO_stdin
|
||||
PERL_CALLCONV PerlIO *PerlIO_stdin(void);
|
||||
#endif
|
||||
diff --git a/proto.h b/proto.h
|
||||
index 74a8e46..e0ea55b 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -2270,6 +2270,11 @@ PERL_CALLCONV Pid_t Perl_my_fork(void);
|
||||
PERL_CALLCONV I32 Perl_my_lstat(pTHX);
|
||||
#endif
|
||||
PERL_CALLCONV I32 Perl_my_lstat_flags(pTHX_ const U32 flags);
|
||||
+PERL_CALLCONV int Perl_my_mkostemp_cloexec(char *templte, int flags)
|
||||
+ __attribute__warn_unused_result__;
|
||||
+#define PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC \
|
||||
+ assert(templte)
|
||||
+
|
||||
PERL_CALLCONV int Perl_my_mkstemp_cloexec(char *templte)
|
||||
__attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC \
|
||||
diff --git a/t/io/perlio_open.t b/t/io/perlio_open.t
|
||||
index 99d7e51..56c354b 100644
|
||||
--- a/t/io/perlio_open.t
|
||||
+++ b/t/io/perlio_open.t
|
||||
@@ -11,7 +11,7 @@ BEGIN {
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
-plan tests => 6;
|
||||
+plan tests => 10;
|
||||
|
||||
use Fcntl qw(:seek);
|
||||
|
||||
@@ -31,6 +31,16 @@ use Fcntl qw(:seek);
|
||||
is($data, "the right read stuff", "found the right stuff");
|
||||
}
|
||||
|
||||
-
|
||||
+SKIP:
|
||||
+{
|
||||
+ ok((open my $fh, "+>>", undef), "open my \$fh, '+>>', undef")
|
||||
+ or skip "can't open temp for append: $!", 3;
|
||||
+ print $fh "abc";
|
||||
+ ok(seek($fh, 0, SEEK_SET), "seek to zero");
|
||||
+ print $fh "xyz";
|
||||
+ ok(seek($fh, 0, SEEK_SET), "seek to zero again");
|
||||
+ my $data = <$fh>;
|
||||
+ is($data, "abcxyz", "check the second write appended");
|
||||
+}
|
||||
|
||||
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,102 @@
|
|||
From 3f8dbf40138bd2bcb569b23c88888a41ede9c355 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 5 Aug 2019 15:23:45 +1000
|
||||
Subject: [PATCH] (perl #134266) make sure $@ is writable when we write to it
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
when unwinding.
|
||||
|
||||
Since except_sv might be ERRSV we try to preserve it's value,
|
||||
if not the actual SV (which we have an extra refcount on if it is
|
||||
except_sv).
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
933e3e630076d4fdbe32a101eeb5f12e37ec4ac2.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perl.h | 17 +++++++++++++++++
|
||||
pp_ctl.c | 10 ++++++++--
|
||||
t/lib/croak/pp_ctl | 8 ++++++++
|
||||
3 files changed, 33 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/perl.h b/perl.h
|
||||
index e5a5585..383487c 100644
|
||||
--- a/perl.h
|
||||
+++ b/perl.h
|
||||
@@ -1357,6 +1357,23 @@ EXTERN_C char *crypt(const char *, const char *);
|
||||
} \
|
||||
} STMT_END
|
||||
|
||||
+/* contains inlined gv_add_by_type */
|
||||
+#define SANE_ERRSV() STMT_START { \
|
||||
+ SV ** const svp = &GvSV(PL_errgv); \
|
||||
+ if (!*svp) { \
|
||||
+ *svp = newSVpvs(""); \
|
||||
+ } else if (SvREADONLY(*svp)) { \
|
||||
+ SV *dupsv = newSVsv(*svp); \
|
||||
+ SvREFCNT_dec_NN(*svp); \
|
||||
+ *svp = dupsv; \
|
||||
+ } else { \
|
||||
+ SV *const errsv = *svp; \
|
||||
+ if (SvMAGICAL(errsv)) { \
|
||||
+ mg_free(errsv); \
|
||||
+ } \
|
||||
+ } \
|
||||
+ } STMT_END
|
||||
+
|
||||
|
||||
#ifdef PERL_CORE
|
||||
# define DEFSV (0 + GvSVn(PL_defgv))
|
||||
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||
index a38b9c1..1f2d812 100644
|
||||
--- a/pp_ctl.c
|
||||
+++ b/pp_ctl.c
|
||||
@@ -1720,9 +1720,13 @@ Perl_die_unwind(pTHX_ SV *msv)
|
||||
* perls 5.13.{1..7} which had late setting of $@ without this
|
||||
* early-setting hack.
|
||||
*/
|
||||
- if (!(in_eval & EVAL_KEEPERR))
|
||||
+ if (!(in_eval & EVAL_KEEPERR)) {
|
||||
+ /* remove any read-only/magic from the SV, so we don't
|
||||
+ get infinite recursion when setting ERRSV */
|
||||
+ SANE_ERRSV();
|
||||
sv_setsv_flags(ERRSV, exceptsv,
|
||||
(SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
|
||||
+ }
|
||||
|
||||
if (in_eval & EVAL_KEEPERR) {
|
||||
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
|
||||
@@ -1784,8 +1788,10 @@ Perl_die_unwind(pTHX_ SV *msv)
|
||||
*/
|
||||
S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
|
||||
|
||||
- if (!(in_eval & EVAL_KEEPERR))
|
||||
+ if (!(in_eval & EVAL_KEEPERR)) {
|
||||
+ SANE_ERRSV();
|
||||
sv_setsv(ERRSV, exceptsv);
|
||||
+ }
|
||||
PL_restartjmpenv = restartjmpenv;
|
||||
PL_restartop = restartop;
|
||||
JMPENV_JUMP(3);
|
||||
diff --git a/t/lib/croak/pp_ctl b/t/lib/croak/pp_ctl
|
||||
index b1e754c..de0221b 100644
|
||||
--- a/t/lib/croak/pp_ctl
|
||||
+++ b/t/lib/croak/pp_ctl
|
||||
@@ -51,3 +51,11 @@ use 5.01;
|
||||
default{}
|
||||
EXPECT
|
||||
Can't "default" outside a topicalizer at - line 2.
|
||||
+########
|
||||
+# NAME croak with read only $@
|
||||
+eval '"a" =~ /${*@=\_})/';
|
||||
+die;
|
||||
+# this would previously recurse infinitely in the eval
|
||||
+EXPECT
|
||||
+Unmatched ) in regex; marked by <-- HERE in m/_) <-- HERE / at (eval 1) line 1.
|
||||
+ ...propagated at - line 2.
|
||||
--
|
||||
2.21.0
|
||||
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
From 4f0ded009bf6de2da6a2a2022bec03576dcb80ca Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Wed, 1 May 2019 10:41:38 -0600
|
||||
Subject: [PATCH] pp.c: Add two UNLIKELY()s
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
It should be uncommon to shift beyond a full word
|
||||
|
||||
Signed-off-by: Ported to 5.30.0 from
|
||||
bae047b68c92622bb4bb04499e36cdaa48138909.
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp.c | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index 90db3a0..7afb090 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1979,7 +1979,7 @@ static UV S_uv_shift(UV uv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
- if (shift >= IV_BITS) {
|
||||
+ if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return 0;
|
||||
}
|
||||
return left ? uv << shift : uv >> shift;
|
||||
@@ -1991,7 +1991,7 @@ static IV S_iv_shift(IV iv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
- if (shift >= IV_BITS) {
|
||||
+ if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return iv < 0 && !left ? -1 : 0;
|
||||
}
|
||||
return left ? iv << shift : iv >> shift;
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
From a0148bb8496444302b087bc0ffcf8dad42f8e475 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 11 Nov 2019 14:43:42 +1100
|
||||
Subject: [PATCH] handle s being updated without len being updated
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
fix #17279
|
||||
|
||||
Petr Písař: Ported to 5.30.1 from
|
||||
e56dfd967ce460481a9922d14e931b438548093d.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
numeric.c | 2 +-
|
||||
t/lib/croak/regcomp | 4 ++++
|
||||
2 files changed, 5 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/numeric.c b/numeric.c
|
||||
index d6ce53e..35adebe 100644
|
||||
--- a/numeric.c
|
||||
+++ b/numeric.c
|
||||
@@ -1552,7 +1552,7 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
|
||||
/* strtold() accepts 0x-prefixed hex and in POSIX implementations,
|
||||
0b-prefixed binary numbers, which is backward incompatible
|
||||
*/
|
||||
- if ((len == 0 || len >= 2) && *s == '0' &&
|
||||
+ if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
|
||||
(isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
|
||||
*value = 0;
|
||||
return (char *)s+1;
|
||||
diff --git a/t/lib/croak/regcomp b/t/lib/croak/regcomp
|
||||
index 0ba705e..c0c2710 100644
|
||||
--- a/t/lib/croak/regcomp
|
||||
+++ b/t/lib/croak/regcomp
|
||||
@@ -70,3 +70,7 @@ qr/((a))/;
|
||||
EXPECT
|
||||
Too many nested open parens in regex; marked by <-- HERE in m/(( <-- HERE a))/ at - line 3.
|
||||
########
|
||||
+# NAME numeric parsing buffer overflow in numeric.c
|
||||
+0=~/\p{nV:-0}/
|
||||
+EXPECT
|
||||
+Can't find Unicode property definition "nV:-0" in regex; marked by <-- HERE in m/\p{nV:-0} <-- HERE / at - line 1.
|
||||
--
|
||||
2.21.0
|
||||
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
From b061e315b4eac4d82edb3ca14581805417a68936 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 11 Sep 2019 11:50:23 +1000
|
||||
Subject: [PATCH] (perl #125557) correctly handle overload for bin/oct floats
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The hexfp code doesn't check that the shift is 4, and so also
|
||||
accepts binary and octal fp numbers.
|
||||
|
||||
Unfortunately the call to S_new_constant() always passed a prefix
|
||||
of 0x, so overloading would be trying to parse the wrong number.
|
||||
|
||||
Another option is to simply allow only hex floats, though some work
|
||||
was done in 131894 to improve oct/bin float support.
|
||||
|
||||
Petr Písař: Ported to 5.30.1 from
|
||||
2cb5a7e8af11acb0eca22421ec5a4df7ef18e2a9.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/hexfp.t | 16 +++++++++++++++-
|
||||
toke.c | 21 ++++++++++++++++-----
|
||||
2 files changed, 31 insertions(+), 6 deletions(-)
|
||||
|
||||
diff --git a/t/op/hexfp.t b/t/op/hexfp.t
|
||||
index 64f8136..0f239d4 100644
|
||||
--- a/t/op/hexfp.t
|
||||
+++ b/t/op/hexfp.t
|
||||
@@ -10,7 +10,7 @@ use strict;
|
||||
|
||||
use Config;
|
||||
|
||||
-plan(tests => 123);
|
||||
+plan(tests => 125);
|
||||
|
||||
# Test hexfloat literals.
|
||||
|
||||
@@ -277,6 +277,20 @@ is(0b1p0, 1);
|
||||
is(0b10p0, 2);
|
||||
is(0b1.1p0, 1.5);
|
||||
|
||||
+# previously these would pass "0x..." to the overload instead of the appropriate
|
||||
+# "0b" or "0" prefix.
|
||||
+fresh_perl_is(<<'CODE', "1", {}, "overload binary fp");
|
||||
+use overload;
|
||||
+BEGIN { overload::constant float => sub { return eval $_[0]; }; }
|
||||
+print 0b0.1p1;
|
||||
+CODE
|
||||
+
|
||||
+fresh_perl_is(<<'CODE', "1", {}, "overload octal fp");
|
||||
+use overload;
|
||||
+BEGIN { overload::constant float => sub { return eval $_[0]; }; }
|
||||
+print 00.1p3;
|
||||
+CODE
|
||||
+
|
||||
# sprintf %a/%A testing is done in sprintf2.t,
|
||||
# trickier than necessary because of long doubles,
|
||||
# and because looseness of the spec.
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 03c4f2b..3fa20dc 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -10966,6 +10966,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
const char *lastub = NULL; /* position of last underbar */
|
||||
static const char* const number_too_long = "Number too long";
|
||||
bool warned_about_underscore = 0;
|
||||
+ I32 shift; /* shift per digit for hex/oct/bin, hoisted here for fp */
|
||||
#define WARN_ABOUT_UNDERSCORE() \
|
||||
do { \
|
||||
if (!warned_about_underscore) { \
|
||||
@@ -11012,8 +11013,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
{
|
||||
/* variables:
|
||||
u holds the "number so far"
|
||||
- shift the power of 2 of the base
|
||||
- (hex == 4, octal == 3, binary == 1)
|
||||
overflowed was the number more than we can hold?
|
||||
|
||||
Shift is used when we add a digit. It also serves as an "are
|
||||
@@ -11022,7 +11021,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
*/
|
||||
NV n = 0.0;
|
||||
UV u = 0;
|
||||
- I32 shift;
|
||||
bool overflowed = FALSE;
|
||||
bool just_zero = TRUE; /* just plain 0 or binary number? */
|
||||
static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
|
||||
@@ -11369,8 +11367,21 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
if (hexfp) {
|
||||
floatit = TRUE;
|
||||
*d++ = '0';
|
||||
- *d++ = 'x';
|
||||
- s = start + 2;
|
||||
+ switch (shift) {
|
||||
+ case 4:
|
||||
+ *d++ = 'x';
|
||||
+ s = start + 2;
|
||||
+ break;
|
||||
+ case 3:
|
||||
+ s = start + 1;
|
||||
+ break;
|
||||
+ case 1:
|
||||
+ *d++ = 'b';
|
||||
+ s = start + 2;
|
||||
+ break;
|
||||
+ default:
|
||||
+ NOT_REACHED; /* NOTREACHED */
|
||||
+ }
|
||||
}
|
||||
|
||||
/* read next group of digits and _ and copy into d */
|
||||
--
|
||||
2.21.0
|
||||
|
||||
|
|
@ -1,40 +1,47 @@
|
|||
From c031e3ec7c713077659f5f7dc6638d926c69d7b2 Mon Sep 17 00:00:00 2001
|
||||
From 783ddef8fc74b00cde72898c2c3228853dc82d91 Mon Sep 17 00:00:00 2001
|
||||
From: Hugo van der Sanden <hv@crypt.org>
|
||||
Date: Sat, 11 Apr 2020 14:10:24 +0100
|
||||
Subject: [PATCH v528 3/3] study_chunk: avoid mutating regexp program within
|
||||
GOSUB
|
||||
Subject: [PATCH] study_chunk: avoid mutating regexp program within GOSUB
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
gh16947 and gh17743: studying GOSUB may restudy in an inner call
|
||||
(via a mix of recursion and enframing) something that an outer call
|
||||
is in the middle of looking at. Let the outer frame deal with it.
|
||||
|
||||
(CVE-2020-12723)
|
||||
|
||||
(cherry picked from commit c4033e740bd18d9fbe3456a9db2ec2053cdc5271)
|
||||
Petr Písař: Ported to 5.30.1 from
|
||||
66bbb51b93253a3f87d11c2695cfb7bdb782184a.
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
embed.fnc | 2 +-
|
||||
embed.h | 2 +-
|
||||
proto.h | 2 +-
|
||||
regcomp.c | 48 ++++++++++++++++++++++++++++++++----------------
|
||||
regcomp.c | 54 +++++++++++++++++++++++++++++++++++-------------------
|
||||
t/re/pat.t | 26 +++++++++++++++++++++++++-
|
||||
5 files changed, 60 insertions(+), 20 deletions(-)
|
||||
5 files changed, 63 insertions(+), 23 deletions(-)
|
||||
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index cf89277163..4b1ba28277 100644
|
||||
index 1b9cf54..d0463e4 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -2397,7 +2397,7 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|
||||
@@ -2482,7 +2482,7 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|
||||
|NULLOK struct scan_data_t *data \
|
||||
|I32 stopparen|U32 recursed_depth \
|
||||
|NULLOK regnode_ssc *and_withp \
|
||||
- |U32 flags|U32 depth
|
||||
+ |U32 flags|U32 depth|bool was_mutate_ok
|
||||
Es |void |rck_elide_nothing|NN regnode *node
|
||||
EsR |SV * |get_ANYOFM_contents|NN const regnode * n
|
||||
EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
|
||||
|NN const char* const s|const U32 n
|
||||
rs |void |re_croak2 |bool utf8|NN const char* pat1|NN const char* pat2|...
|
||||
diff --git a/embed.h b/embed.h
|
||||
index 886551ce5c..50fcabc140 100644
|
||||
index cf44011..72c2a8e 100644
|
||||
--- a/embed.h
|
||||
+++ b/embed.h
|
||||
@@ -1075,7 +1075,7 @@
|
||||
@@ -1239,7 +1239,7 @@
|
||||
#define ssc_is_cp_posixl_init S_ssc_is_cp_posixl_init
|
||||
#define ssc_or(a,b,c) S_ssc_or(aTHX_ a,b,c)
|
||||
#define ssc_union(a,b,c) S_ssc_union(aTHX_ a,b,c)
|
||||
|
|
@ -44,10 +51,10 @@ index 886551ce5c..50fcabc140 100644
|
|||
# if defined(PERL_IN_REGCOMP_C) || defined (PERL_IN_DUMP_C)
|
||||
#define _invlist_dump(a,b,c,d) Perl__invlist_dump(aTHX_ a,b,c,d)
|
||||
diff --git a/proto.h b/proto.h
|
||||
index d3f8802c1d..e276f69bd1 100644
|
||||
index ee74153..9a3ce27 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -5258,7 +5258,7 @@ PERL_STATIC_INLINE void S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, c
|
||||
@@ -5671,7 +5671,7 @@ PERL_STATIC_INLINE void S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, c
|
||||
#define PERL_ARGS_ASSERT_SSC_UNION \
|
||||
assert(ssc); assert(invlist)
|
||||
#endif
|
||||
|
|
@ -57,18 +64,18 @@ index d3f8802c1d..e276f69bd1 100644
|
|||
assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last)
|
||||
#endif
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 0a9c6a8085..e66032a16a 100644
|
||||
index b101752..b9ea2a0 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -110,6 +110,7 @@ typedef struct scan_frame {
|
||||
@@ -106,6 +106,7 @@ typedef struct scan_frame {
|
||||
regnode *next_regnode; /* next node to process when last is reached */
|
||||
U32 prev_recursed_depth;
|
||||
I32 stopparen; /* what stopparen do we use */
|
||||
+ bool in_gosub; /* this or an outer frame is for GOSUB */
|
||||
U32 is_top_frame; /* what flags do we use? */
|
||||
|
||||
struct scan_frame *this_prev_frame; /* this previous frame */
|
||||
@@ -4102,7 +4103,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
struct scan_frame *prev_frame; /* previous frame */
|
||||
@@ -4475,7 +4476,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
I32 stopparen,
|
||||
U32 recursed_depth,
|
||||
regnode_ssc *and_withp,
|
||||
|
|
@ -77,7 +84,7 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
/* scanp: Start here (read-write). */
|
||||
/* deltap: Write maxlen-minlen here. */
|
||||
/* last: Stop before this one. */
|
||||
@@ -4179,6 +4180,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
@@ -4554,6 +4555,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
node length to get a real minimum (because
|
||||
the folded version may be shorter) */
|
||||
bool unfolded_multi_char = FALSE;
|
||||
|
|
@ -86,9 +93,9 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
+ */
|
||||
+ bool mutate_ok = was_mutate_ok && !(frame && frame->in_gosub);
|
||||
/* Peephole optimizer: */
|
||||
DEBUG_STUDYDATA("Peep:", data, depth);
|
||||
DEBUG_PEEP("Peep", scan, depth);
|
||||
@@ -4189,7 +4194,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
DEBUG_STUDYDATA("Peep", data, depth, is_inf);
|
||||
DEBUG_PEEP("Peep", scan, depth, flags);
|
||||
@@ -4564,7 +4569,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
* parsing code, as each (?:..) is handled by a different invocation of
|
||||
* reg() -- Yves
|
||||
*/
|
||||
|
|
@ -96,10 +103,10 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
+ if (mutate_ok)
|
||||
+ JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
|
||||
|
||||
/* Follow the next-chain of the current node and optimize
|
||||
away all the NOTHINGs from it. */
|
||||
@@ -4238,7 +4244,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
* NOTE we dont use the return here! */
|
||||
/* Follow the next-chain of the current node and optimize
|
||||
away all the NOTHINGs from it.
|
||||
@@ -4596,7 +4602,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
/* DEFINEP study_chunk() recursion */
|
||||
(void)study_chunk(pRExC_state, &scan, &minlen,
|
||||
&deltanext, next, &data_fake, stopparen,
|
||||
- recursed_depth, NULL, f, depth+1);
|
||||
|
|
@ -107,17 +114,17 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
|
||||
scan = next;
|
||||
} else
|
||||
@@ -4305,7 +4311,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
/* we suppose the run is continuous, last=next...*/
|
||||
@@ -4664,7 +4670,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
/* recurse study_chunk() for each BRANCH in an alternation */
|
||||
minnext = study_chunk(pRExC_state, &scan, minlenp,
|
||||
&deltanext, next, &data_fake, stopparen,
|
||||
- recursed_depth, NULL, f,depth+1);
|
||||
- recursed_depth, NULL, f, depth+1);
|
||||
+ recursed_depth, NULL, f, depth+1,
|
||||
+ mutate_ok);
|
||||
|
||||
if (min1 > minnext)
|
||||
min1 = minnext;
|
||||
@@ -4372,9 +4379,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
@@ -4731,9 +4738,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -131,7 +138,7 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
/* demq.
|
||||
|
||||
Assuming this was/is a branch we are dealing with: 'scan'
|
||||
@@ -4825,6 +4833,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
@@ -5188,6 +5196,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
newframe->stopparen = stopparen;
|
||||
newframe->prev_recursed_depth = recursed_depth;
|
||||
newframe->this_prev_frame= frame;
|
||||
|
|
@ -139,9 +146,30 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
+ (frame && frame->in_gosub) || OP(scan) == GOSUB
|
||||
+ );
|
||||
|
||||
DEBUG_STUDYDATA("frame-new:",data,depth);
|
||||
DEBUG_PEEP("fnew", scan, depth);
|
||||
@@ -5043,7 +5054,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
|
||||
DEBUG_PEEP("fnew", scan, depth, flags);
|
||||
@@ -5345,7 +5356,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
|
||||
/* This temporary node can now be turned into EXACTFU, and
|
||||
* must, as regexec.c doesn't handle it */
|
||||
- if (OP(next) == EXACTFU_S_EDGE) {
|
||||
+ if (OP(next) == EXACTFU_S_EDGE && mutate_ok) {
|
||||
OP(next) = EXACTFU;
|
||||
}
|
||||
|
||||
@@ -5353,8 +5364,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
&& isALPHA_A(* STRING(next))
|
||||
&& ( OP(next) == EXACTFAA
|
||||
|| ( OP(next) == EXACTFU
|
||||
- && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(next)))))
|
||||
- {
|
||||
+ && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(next))))
|
||||
+ && mutate_ok
|
||||
+ ) {
|
||||
/* These differ in just one bit */
|
||||
U8 mask = ~ ('A' ^ 'a');
|
||||
|
||||
@@ -5441,7 +5453,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
(mincount == 0
|
||||
? (f & ~SCF_DO_SUBSTR)
|
||||
: f)
|
||||
|
|
@ -150,7 +178,7 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
|
||||
if (flags & SCF_DO_STCLASS)
|
||||
data->start_class = oclass;
|
||||
@@ -5105,7 +5116,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
@@ -5507,7 +5519,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
if ( OP(oscan) == CURLYX && data
|
||||
&& data->flags & SF_IN_PAR
|
||||
&& !(data->flags & SF_HAS_EVAL)
|
||||
|
|
@ -161,7 +189,7 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
/* Try to optimize to CURLYN. */
|
||||
regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
|
||||
regnode * const nxt1 = nxt;
|
||||
@@ -5151,10 +5164,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
@@ -5557,10 +5571,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
&& !(data->flags & SF_HAS_EVAL)
|
||||
&& !deltanext /* atom is fixed width */
|
||||
&& minnext != 0 /* CURLYM can't handle zero width */
|
||||
|
|
@ -173,46 +201,45 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
) {
|
||||
/* XXXX How to optimize if data == 0? */
|
||||
/* Optimize to a simpler form. */
|
||||
@@ -5201,7 +5214,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
#endif
|
||||
/* Optimize again: */
|
||||
@@ -5613,7 +5627,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
/* recurse study_chunk() on optimised CURLYX => CURLYM */
|
||||
study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
|
||||
- NULL, stopparen, recursed_depth, NULL, 0,depth+1);
|
||||
+ NULL, stopparen, recursed_depth, NULL, 0,
|
||||
NULL, stopparen, recursed_depth, NULL, 0,
|
||||
- depth+1);
|
||||
+ depth+1, mutate_ok);
|
||||
}
|
||||
else
|
||||
oscan->flags = 0;
|
||||
@@ -5592,7 +5606,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||
nscan = NEXTOPER(NEXTOPER(scan));
|
||||
@@ -6018,7 +6032,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||
/* recurse study_chunk() for lookahead body */
|
||||
minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
|
||||
last, &data_fake, stopparen,
|
||||
- recursed_depth, NULL, f, depth+1);
|
||||
+ recursed_depth, NULL, f, depth+1,
|
||||
+ mutate_ok);
|
||||
if (scan->flags) {
|
||||
if (deltanext) {
|
||||
FAIL("Variable length lookbehind not implemented");
|
||||
@@ -5681,7 +5696,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||
if ( deltanext < 0
|
||||
|| deltanext > (I32) U8_MAX
|
||||
@@ -6123,7 +6138,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||
*minnextp = study_chunk(pRExC_state, &nscan, minnextp,
|
||||
&deltanext, last, &data_fake,
|
||||
stopparen, recursed_depth, NULL,
|
||||
- f,depth+1);
|
||||
- f, depth+1);
|
||||
+ f, depth+1, mutate_ok);
|
||||
if (scan->flags) {
|
||||
if (deltanext) {
|
||||
FAIL("Variable length lookbehind not implemented");
|
||||
@@ -5841,7 +5856,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||
branches even though they arent otherwise used. */
|
||||
assert(0); /* This code has never been tested since this
|
||||
is normally not compiled */
|
||||
@@ -6291,7 +6306,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||
/* optimise study_chunk() for TRIE */
|
||||
minnext = study_chunk(pRExC_state, &scan, minlenp,
|
||||
&deltanext, (regnode *)nextbranch, &data_fake,
|
||||
- stopparen, recursed_depth, NULL, f,depth+1);
|
||||
- stopparen, recursed_depth, NULL, f, depth+1);
|
||||
+ stopparen, recursed_depth, NULL, f, depth+1,
|
||||
+ mutate_ok);
|
||||
}
|
||||
if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
|
||||
nextbranch= regnext((regnode*)nextbranch);
|
||||
@@ -7524,7 +7540,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
|
||||
@@ -8084,7 +8100,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
|
||||
&data, -1, 0, NULL,
|
||||
SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
|
||||
| (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
|
||||
|
|
@ -221,7 +248,7 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
|
||||
|
||||
CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
|
||||
@@ -7670,7 +7686,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
|
||||
@@ -8213,7 +8229,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
|
||||
SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
|
||||
? SCF_TRIE_DOING_RESTUDY
|
||||
: 0),
|
||||
|
|
@ -231,21 +258,21 @@ index 0a9c6a8085..e66032a16a 100644
|
|||
CHECK_RESTUDY_GOTO_butfirst(NOOP);
|
||||
|
||||
diff --git a/t/re/pat.t b/t/re/pat.t
|
||||
index 1d98fe77d7..1488259b02 100644
|
||||
index 6a868f4..ba89a58 100644
|
||||
--- a/t/re/pat.t
|
||||
+++ b/t/re/pat.t
|
||||
@@ -23,7 +23,7 @@ BEGIN {
|
||||
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
|
||||
skip_all_without_unicode_tables();
|
||||
@@ -25,7 +25,7 @@ BEGIN {
|
||||
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
|
||||
skip_all_without_unicode_tables();
|
||||
|
||||
-plan tests => 840; # Update this when adding/deleting tests.
|
||||
+plan tests => 844; # Update this when adding/deleting tests.
|
||||
-plan tests => 864; # Update this when adding/deleting tests.
|
||||
+plan tests => 868; # Update this when adding/deleting tests.
|
||||
|
||||
run_tests() unless caller;
|
||||
|
||||
@@ -1929,6 +1929,30 @@ EOP
|
||||
fresh_perl_is('"AA" =~ m/AA{1,0}/','',{},"handle OPFAIL insert properly");
|
||||
}
|
||||
@@ -2115,6 +2115,30 @@ x{0c!}\;\;îçÿ /0f/! F /;îçÿù\Q xÿÿÿÿ ù `x{0c!}; ù\Q
|
||||
like(runperl(prog => "$s", stderr => 1), qr/Unmatched \(/);
|
||||
}
|
||||
|
||||
+ # gh16947: test regexp corruption (GOSUB)
|
||||
+ {
|
||||
|
|
@ -275,5 +302,5 @@ index 1d98fe77d7..1488259b02 100644
|
|||
|
||||
1;
|
||||
--
|
||||
2.20.1
|
||||
2.25.4
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
From 3295b48defa0f8570114877b063fe546dd348b3c Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Thu, 20 Feb 2020 17:49:36 +0000
|
||||
Subject: [PATCH 2/2] regcomp: use long jumps if there is any possibility of
|
||||
overflow
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
(CVE-2020-10878) Be conservative for backporting, we'll aim to do
|
||||
something more aggressive for bleadperl.
|
||||
|
||||
(cherry picked from commit 9d7759db46f3b31b1d3f79c44266b6ba42a47fc6)
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 7 +++++++
|
||||
1 file changed, 7 insertions(+)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 4ba2980db6..73c35a6702 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -7762,6 +7762,13 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
|
||||
|
||||
/* We have that number in RExC_npar */
|
||||
RExC_total_parens = RExC_npar;
|
||||
+
|
||||
+ /* XXX For backporting, use long jumps if there is any possibility of
|
||||
+ * overflow */
|
||||
+ if (RExC_size > U16_MAX && ! RExC_use_BRANCHJ) {
|
||||
+ RExC_use_BRANCHJ = TRUE;
|
||||
+ flags |= RESTART_PARSE;
|
||||
+ }
|
||||
}
|
||||
else if (! MUST_RESTART(flags)) {
|
||||
ReREFCNT_dec(Rx);
|
||||
--
|
||||
2.25.4
|
||||
|
||||
|
|
@ -1,24 +1,29 @@
|
|||
From 208dea486fa24081cbc0cf05fa5a15c802e2bc68 Mon Sep 17 00:00:00 2001
|
||||
From 897d1f7fd515b828e4b198d8b8bef76c6faf03ed Mon Sep 17 00:00:00 2001
|
||||
From: John Lightsey <jd@cpanel.net>
|
||||
Date: Wed, 20 Nov 2019 20:02:45 -0600
|
||||
Subject: [PATCH v528 1/3] regcomp.c: Prevent integer overflow from nested
|
||||
regex quantifiers.
|
||||
Subject: [PATCH] regcomp.c: Prevent integer overflow from nested regex
|
||||
quantifiers.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
(CVE-2020-10543) On 32bit systems the size calculations for nested regular
|
||||
expression quantifiers could overflow causing heap memory corruption.
|
||||
|
||||
Fixes: Perl/perl5-security#125
|
||||
(cherry picked from commit bfd31397db5dc1a5c5d3e0a1f753a4f89a736e71)
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 6 ++++++
|
||||
1 file changed, 6 insertions(+)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index e1da15a77c..dd18add1db 100644
|
||||
index 93c8d98fbb..5f86be8086 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -5102,6 +5139,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
(void)ReREFCNT_inc(RExC_rx_sv);
|
||||
}
|
||||
@@ -5489,6 +5489,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
RExC_precomp)));
|
||||
}
|
||||
|
||||
+ if ( ( minnext > 0 && mincount >= SSize_t_MAX / minnext )
|
||||
+ || min >= SSize_t_MAX - minnext * mincount )
|
||||
|
|
@ -30,5 +35,5 @@ index e1da15a77c..dd18add1db 100644
|
|||
is_inf_internal |= deltanext == SSize_t_MAX
|
||||
|| (maxcount == REG_INFTY && minnext + deltanext > 0);
|
||||
--
|
||||
2.20.1
|
||||
2.25.4
|
||||
|
||||
|
|
@ -1,9 +1,15 @@
|
|||
From a3a7598c8ec6efb0eb9c0b786d80c4d2a3751b70 Mon Sep 17 00:00:00 2001
|
||||
From 0a320d753fe7fca03df259a4dfd8e641e51edaa8 Mon Sep 17 00:00:00 2001
|
||||
From: Hugo van der Sanden <hv@crypt.org>
|
||||
Date: Tue, 18 Feb 2020 13:51:16 +0000
|
||||
Subject: [PATCH v528 2/3] study_chunk: extract rck_elide_nothing
|
||||
Subject: [PATCH 1/2] study_chunk: extract rck_elide_nothing
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
(CVE-2020-10878)
|
||||
|
||||
(cherry picked from commit 93dee06613d4e1428fb10905ce1c3c96f53113dc)
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
embed.fnc | 1 +
|
||||
embed.h | 1 +
|
||||
|
|
@ -12,34 +18,34 @@ Subject: [PATCH v528 2/3] study_chunk: extract rck_elide_nothing
|
|||
4 files changed, 48 insertions(+), 27 deletions(-)
|
||||
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index e762fe1eec..cf89277163 100644
|
||||
index aedb4baef1..d7cd04d3fc 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -2398,6 +2398,7 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|
||||
@@ -2481,6 +2481,7 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|
||||
|I32 stopparen|U32 recursed_depth \
|
||||
|NULLOK regnode_ssc *and_withp \
|
||||
|U32 flags|U32 depth|bool was_mutate_ok
|
||||
|U32 flags|U32 depth
|
||||
+Es |void |rck_elide_nothing|NN regnode *node
|
||||
EsR |SV * |get_ANYOFM_contents|NN const regnode * n
|
||||
EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
|
||||
|NN const char* const s|const U32 n
|
||||
rs |void |re_croak2 |bool utf8|NN const char* pat1|NN const char* pat2|...
|
||||
diff --git a/embed.h b/embed.h
|
||||
index a5416a1148..886551ce5c 100644
|
||||
index 75c91f77f4..356a8b98d9 100644
|
||||
--- a/embed.h
|
||||
+++ b/embed.h
|
||||
@@ -1046,6 +1046,7 @@
|
||||
#define output_or_return_posix_warnings(a,b,c) S_output_or_return_posix_warnings(aTHX_ a,b,c)
|
||||
@@ -1208,6 +1208,7 @@
|
||||
#define parse_lparen_question_flags(a) S_parse_lparen_question_flags(aTHX_ a)
|
||||
#define parse_uniprop_string(a,b,c,d,e,f,g,h,i) Perl_parse_uniprop_string(aTHX_ a,b,c,d,e,f,g,h,i)
|
||||
#define populate_ANYOF_from_invlist(a,b) S_populate_ANYOF_from_invlist(aTHX_ a,b)
|
||||
+#define rck_elide_nothing(a) S_rck_elide_nothing(aTHX_ a)
|
||||
#define reg(a,b,c,d) S_reg(aTHX_ a,b,c,d)
|
||||
#define reg2Lanode(a,b,c,d) S_reg2Lanode(aTHX_ a,b,c,d)
|
||||
#define reg_node(a,b) S_reg_node(aTHX_ a,b)
|
||||
diff --git a/proto.h b/proto.h
|
||||
index 66bb29b132..d3f8802c1d 100644
|
||||
index 141ddbaee6..f316fe134e 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -5150,6 +5150,9 @@ STATIC void S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state);
|
||||
@@ -5543,6 +5543,9 @@ PERL_CALLCONV SV * Perl_parse_uniprop_string(pTHX_ const char * const name, cons
|
||||
STATIC void S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr);
|
||||
#define PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST \
|
||||
assert(node); assert(invlist_ptr)
|
||||
|
|
@ -50,10 +56,10 @@ index 66bb29b132..d3f8802c1d 100644
|
|||
__attribute__noreturn__;
|
||||
#define PERL_ARGS_ASSERT_RE_CROAK2 \
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index dd18add1db..0a9c6a8085 100644
|
||||
index 5f86be8086..4ba2980db6 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -4094,6 +4094,43 @@ S_unwind_scan_frames(pTHX_ const void *p)
|
||||
@@ -4450,6 +4450,44 @@ S_unwind_scan_frames(pTHX_ const void *p)
|
||||
} while (f);
|
||||
}
|
||||
|
||||
|
|
@ -94,12 +100,13 @@ index dd18add1db..0a9c6a8085 100644
|
|||
+ }
|
||||
+ return;
|
||||
+}
|
||||
|
||||
+
|
||||
/* the return from this sub is the minimum length that could possibly match */
|
||||
STATIC SSize_t
|
||||
S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
@@ -4197,28 +4234,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
if (mutate_ok)
|
||||
JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
|
||||
@@ -4550,28 +4588,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
|
||||
*/
|
||||
JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
|
||||
|
||||
- /* Follow the next-chain of the current node and optimize
|
||||
- away all the NOTHINGs from it. */
|
||||
|
|
@ -130,7 +137,7 @@ index dd18add1db..0a9c6a8085 100644
|
|||
|
||||
/* The principal pseudo-switch. Cannot be a switch, since we
|
||||
look into several different things. */
|
||||
@@ -5348,11 +5367,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||
@@ -5745,11 +5765,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
|
||||
if (data && (fl & SF_HAS_EVAL))
|
||||
data->flags |= SF_HAS_EVAL;
|
||||
optimize_curly_tail:
|
||||
|
|
@ -144,5 +151,5 @@ index dd18add1db..0a9c6a8085 100644
|
|||
|
||||
default:
|
||||
--
|
||||
2.20.1
|
||||
2.25.4
|
||||
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
From 1a1d29aaa2e0c668f9a8c960d52b516415f28983 Mon Sep 17 00:00:00 2001
|
||||
From: Vickenty Fesunov <kent@setattr.net>
|
||||
Date: Fri, 22 Sep 2017 19:00:46 -0400
|
||||
Subject: [PATCH] %{^CAPTURE_ALL} was intended to be an alias for %-; make it
|
||||
so.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
For: RT #131867
|
||||
|
||||
Add Vickenty Fesunov to AUTHORS.
|
||||
|
||||
Signed-off-by: Ported to 5.30 from 1a1d29aaa2e0c668f9a8c960d52b516415f28983.
|
||||
|
||||
---
|
||||
AUTHORS | 1 +
|
||||
ext/Tie-Hash-NamedCapture/NamedCapture.xs | 5 ++++-
|
||||
ext/Tie-Hash-NamedCapture/t/tiehash.t | 11 ++++++++---
|
||||
|
||||
diff --git a/AUTHORS b/AUTHORS
|
||||
index 0091100600..c920d52e96 100644
|
||||
--- a/AUTHORS
|
||||
+++ b/AUTHORS
|
||||
@@ -1265,6 +1265,7 @@ Unicode Consortium <unicode.org>
|
||||
Vadim Konovalov <vkonovalov@lucent.com>
|
||||
Valeriy E. Ushakov <uwe@ptc.spbu.ru>
|
||||
Vernon Lyon <vlyon@cpan.org>
|
||||
+Vickenty Fesunov <kent@setattr.net>
|
||||
Victor Adam <victor@drawall.cc>
|
||||
Victor Efimov <victor@vsespb.ru>
|
||||
Viktor Turskyi <koorchik@gmail.com>
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/NamedCapture.xs b/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
index 7eaae5614d..a607c10090 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
+++ b/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
@@ -25,8 +25,11 @@ _tie_it(SV *sv)
|
||||
GV * const gv = (GV *)sv;
|
||||
HV * const hv = GvHVn(gv);
|
||||
SV *rv = newSV_type(SVt_RV);
|
||||
+ const char *gv_name = GvNAME(gv);
|
||||
CODE:
|
||||
- SvRV_set(rv, newSVuv(*GvNAME(gv) == '-' ? RXapif_ALL : RXapif_ONE));
|
||||
+ SvRV_set(rv, newSVuv(
|
||||
+ strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
|
||||
+ ? RXapif_ALL : RXapif_ONE));
|
||||
SvROK_on(rv);
|
||||
sv_bless(rv, GvSTASH(CvGV(cv)));
|
||||
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/t/tiehash.t b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
index 3ebc81ad68..962754085f 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
+++ b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
@@ -3,7 +3,12 @@ use strict;
|
||||
|
||||
use Test::More;
|
||||
|
||||
-my %hashes = ('+' => \%+, '-' => \%-);
|
||||
+my %hashes = (
|
||||
+ '+' => \%+,
|
||||
+ '-' => \%-,
|
||||
+ '{^CAPTURE}' => \%{^CAPTURE},
|
||||
+ '{^CAPTURE_ALL}' => \%{^CAPTURE_ALL},
|
||||
+);
|
||||
|
||||
foreach (['plus1'],
|
||||
['minus1', all => 1],
|
||||
@@ -20,12 +25,12 @@ foreach (['plus1'],
|
||||
is("abcdef" =~ /(?<foo>[ab])*(?<bar>c)(?<foo>d)(?<bar>[ef]*)/, 1,
|
||||
"We matched");
|
||||
|
||||
-foreach my $name (qw(+ plus1 plus2 plus3)) {
|
||||
+foreach my $name (qw(+ {^CAPTURE} plus1 plus2 plus3)) {
|
||||
my $hash = $hashes{$name};
|
||||
is_deeply($hash, { foo => 'b', bar => 'c' }, "%$name is as expected");
|
||||
}
|
||||
|
||||
-foreach my $name (qw(- minus1 minus2)) {
|
||||
+foreach my $name (qw(- {^CAPTURE_ALL} minus1 minus2)) {
|
||||
my $hash = $hashes{$name};
|
||||
is_deeply($hash, { foo => [qw(b d)], bar => [qw(c ef)] },
|
||||
"%$name is as expected");
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,181 @@
|
|||
From 3a019afd6f6291c3249c254b5c01e244e4ec83ab Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sun, 28 Apr 2019 17:42:44 -0600
|
||||
Subject: [PATCH 1/3] Create fcn for lossless conversion of NV to IV
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Essentially the same code was being used in three places, and had
|
||||
undefined C behavior for some inputs.
|
||||
|
||||
This consolidates the code into one inline function, and rewrites it to
|
||||
avoid undefined behavior.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
embed.fnc | 1 +
|
||||
embed.h | 3 +++
|
||||
inline.h | 34 ++++++++++++++++++++++++++++++++++
|
||||
pp.c | 20 ++++----------------
|
||||
pp_hot.c | 10 ++--------
|
||||
proto.h | 7 +++++++
|
||||
6 files changed, 51 insertions(+), 24 deletions(-)
|
||||
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index 45597f67b6..259affded0 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -2272,6 +2272,7 @@ sR |SV* |refto |NN SV* sv
|
||||
: Used in pp_hot.c
|
||||
pRxo |GV* |softref2xv |NN SV *const sv|NN const char *const what \
|
||||
|const svtype type|NN SV ***spp
|
||||
+inR |bool |lossless_NV_to_IV|const NV nv|NN IV * ivp
|
||||
#endif
|
||||
|
||||
#if defined(PERL_IN_PP_PACK_C)
|
||||
diff --git a/embed.h b/embed.h
|
||||
index 75c91f77f4..9178c51e92 100644
|
||||
--- a/embed.h
|
||||
+++ b/embed.h
|
||||
@@ -1924,6 +1924,9 @@
|
||||
#define do_delete_local() S_do_delete_local(aTHX)
|
||||
#define refto(a) S_refto(aTHX_ a)
|
||||
# endif
|
||||
+# if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+#define lossless_NV_to_IV S_lossless_NV_to_IV
|
||||
+# endif
|
||||
# if defined(PERL_IN_PP_CTL_C)
|
||||
#define check_type_and_open(a) S_check_type_and_open(aTHX_ a)
|
||||
#define destroy_matcher(a) S_destroy_matcher(aTHX_ a)
|
||||
diff --git a/inline.h b/inline.h
|
||||
index 654f801b75..de1e33e8ce 100644
|
||||
--- a/inline.h
|
||||
+++ b/inline.h
|
||||
@@ -1913,6 +1913,40 @@ S_should_warn_nl(const char *pv) {
|
||||
|
||||
#endif
|
||||
|
||||
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+
|
||||
+PERL_STATIC_INLINE bool
|
||||
+S_lossless_NV_to_IV(const NV nv, IV *ivp)
|
||||
+{
|
||||
+ /* This function determines if the input NV 'nv' may be converted without
|
||||
+ * loss of data to an IV. If not, it returns FALSE taking no other action.
|
||||
+ * But if it is possible, it does the conversion, returning TRUE, and
|
||||
+ * storing the converted result in '*ivp' */
|
||||
+
|
||||
+ PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
|
||||
+
|
||||
+# if defined(Perl_isnan)
|
||||
+
|
||||
+ if (UNLIKELY(Perl_isnan(nv))) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+# endif
|
||||
+
|
||||
+ if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+ if ((IV) nv != nv) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+ *ivp = (IV) nv;
|
||||
+ return TRUE;
|
||||
+}
|
||||
+
|
||||
+#endif
|
||||
+
|
||||
/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
|
||||
|
||||
#define MAX_CHARSET_NAME_LENGTH 2
|
||||
diff --git a/pp.c b/pp.c
|
||||
index c89cb7198c..0956121b27 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1268,16 +1268,10 @@ PP(pp_multiply)
|
||||
NV nr = SvNVX(svr);
|
||||
NV result;
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
result = nl * nr;
|
||||
# if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
|
||||
@@ -1849,16 +1843,10 @@ PP(pp_subtract)
|
||||
NV nl = SvNVX(svl);
|
||||
NV nr = SvNVX(svr);
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
|
||||
SETs(TARG);
|
||||
diff --git a/pp_hot.c b/pp_hot.c
|
||||
index 7d5ffc02fd..2df5df8303 100644
|
||||
--- a/pp_hot.c
|
||||
+++ b/pp_hot.c
|
||||
@@ -1435,16 +1435,10 @@ PP(pp_add)
|
||||
NV nl = SvNVX(svl);
|
||||
NV nr = SvNVX(svr);
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
|
||||
SETs(TARG);
|
||||
diff --git a/proto.h b/proto.h
|
||||
index 0f8feed187..74a8e46ab7 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -5224,6 +5224,13 @@ STATIC SV* S_refto(pTHX_ SV* sv)
|
||||
|
||||
#endif
|
||||
#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+#ifndef PERL_NO_INLINE_FUNCTIONS
|
||||
+PERL_STATIC_INLINE bool S_lossless_NV_to_IV(const NV nv, IV * ivp)
|
||||
+ __attribute__warn_unused_result__;
|
||||
+#define PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV \
|
||||
+ assert(ivp)
|
||||
+#endif
|
||||
+
|
||||
PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const svtype type, SV ***spp)
|
||||
__attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_SOFTREF2XV \
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
From 1d31efef7dd4388fd606972e67bda3318e8838fe Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= <ilmari@ilmari.org>
|
||||
Date: Tue, 21 May 2019 17:34:49 +0100
|
||||
Subject: [PATCH] Don't use PL_check[op_type] to check for filetets ops to
|
||||
stack
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This breaks hooking the filetest ops' check function by modules like
|
||||
bareword::filehandles. Instead use the OP_IS_FILETEST() macro to decide
|
||||
check for filetest ops. Also add an OP_IS_STAT() macro for when we want
|
||||
to check for (l)stat as well as the filetest ops.
|
||||
|
||||
c.f. https://rt.cpan.org/Ticket/Display.html?id=127073
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 11 ++++-------
|
||||
op.h | 2 ++
|
||||
regen/opcodes | 1 +
|
||||
3 files changed, 7 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index 29181ba731..dba7ac7fea 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -991,8 +991,7 @@ Perl_op_clear(pTHX_ OP *o)
|
||||
o->op_targ = 0;
|
||||
break;
|
||||
default:
|
||||
- if (!(o->op_flags & OPf_REF)
|
||||
- || (PL_check[o->op_type] != Perl_ck_ftst))
|
||||
+ if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
|
||||
break;
|
||||
/* FALLTHROUGH */
|
||||
case OP_GVSV:
|
||||
@@ -4413,8 +4412,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
|
||||
/* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
|
||||
their argument is a filehandle; thus \stat(".") should not set
|
||||
it. AMS 20011102 */
|
||||
- if (type == OP_REFGEN &&
|
||||
- PL_check[o->op_type] == Perl_ck_ftst)
|
||||
+ if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
|
||||
return o;
|
||||
|
||||
if (type != OP_LEAVESUBLV)
|
||||
@@ -11696,9 +11694,8 @@ Perl_ck_ftst(pTHX_ OP *o)
|
||||
scalar((OP *) kid);
|
||||
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
|
||||
o->op_private |= OPpFT_ACCESS;
|
||||
- if (type != OP_STAT && type != OP_LSTAT
|
||||
- && PL_check[kidtype] == Perl_ck_ftst
|
||||
- && kidtype != OP_STAT && kidtype != OP_LSTAT
|
||||
+ if (OP_IS_FILETEST(type)
|
||||
+ && OP_IS_FILETEST(kidtype)
|
||||
) {
|
||||
o->op_private |= OPpFT_STACKED;
|
||||
kid->op_private |= OPpFT_STACKING;
|
||||
diff --git a/op.h b/op.h
|
||||
index c9f05b2271..ad6cf7fe49 100644
|
||||
--- a/op.h
|
||||
+++ b/op.h
|
||||
@@ -1021,6 +1021,8 @@ C<sib> is non-null. For a higher-level interface, see C<L</op_sibling_splice>>.
|
||||
#define OP_TYPE_ISNT_AND_WASNT(o, type) \
|
||||
( (o) && OP_TYPE_ISNT_AND_WASNT_NN(o, type) )
|
||||
|
||||
+/* should match anything that uses ck_ftst in regen/opcodes */
|
||||
+#define OP_IS_STAT(op) (OP_IS_FILETEST(op) || (op) == OP_LSTAT || (op) == OP_STAT)
|
||||
|
||||
# define OpHAS_SIBLING(o) (cBOOL((o)->op_moresib))
|
||||
# define OpSIBLING(o) (0 + (o)->op_moresib ? (o)->op_sibparent : NULL)
|
||||
diff --git a/regen/opcodes b/regen/opcodes
|
||||
index b4bf904fdc..4e8236947a 100644
|
||||
--- a/regen/opcodes
|
||||
+++ b/regen/opcodes
|
||||
@@ -397,6 +397,7 @@ getsockname getsockname ck_fun is% Fs
|
||||
getpeername getpeername ck_fun is% Fs
|
||||
|
||||
# Stat calls. OP_IS_FILETEST wants them consecutive.
|
||||
+# Also needs to match OP_IS_STAT() in op.h
|
||||
|
||||
lstat lstat ck_ftst u- F?
|
||||
stat stat ck_ftst u- F?
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
From cc16d262eb72677cdda2aa9395e943818b85ba38 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 29 Apr 2019 15:24:18 -0600
|
||||
Subject: [PATCH] PATCH: [perl #134059] panic outputting a warning
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This was due to a logic error on my part. We need to save and restore a
|
||||
value. Instead, it was getting restored to the wrong value.
|
||||
|
||||
This particular instance of the bug was outputting a fatal error
|
||||
message, so that the only harm is not giving the user the correct info,
|
||||
and creating unnecessary work for them and us when it gets reported.
|
||||
But this bug could manifest itself when trying to output just a warning
|
||||
that the program otherwise would carry on from.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 12 ++++++++++--
|
||||
t/re/reg_mesg.t | 1 +
|
||||
2 files changed, 11 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 3ad09c52b2..1c54fe3f38 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -131,6 +131,8 @@ struct RExC_state_t {
|
||||
char *parse; /* Input-scan pointer. */
|
||||
char *copy_start; /* start of copy of input within
|
||||
constructed parse string */
|
||||
+ char *save_copy_start; /* Provides one level of saving
|
||||
+ and restoring 'copy_start' */
|
||||
char *copy_start_in_input; /* Position in input string
|
||||
corresponding to copy_start */
|
||||
SSize_t whilem_seen; /* number of WHILEM in this expr */
|
||||
@@ -229,6 +231,7 @@ struct RExC_state_t {
|
||||
#define RExC_precomp (pRExC_state->precomp)
|
||||
#define RExC_copy_start_in_input (pRExC_state->copy_start_in_input)
|
||||
#define RExC_copy_start_in_constructed (pRExC_state->copy_start)
|
||||
+#define RExC_save_copy_start_in_constructed (pRExC_state->save_copy_start)
|
||||
#define RExC_precomp_end (pRExC_state->precomp_end)
|
||||
#define RExC_rx_sv (pRExC_state->rx_sv)
|
||||
#define RExC_rx (pRExC_state->rx)
|
||||
@@ -821,8 +824,13 @@ static const scan_data_t zero_scan_data = {
|
||||
} STMT_END
|
||||
|
||||
/* Setting this to NULL is a signal to not output warnings */
|
||||
-#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE RExC_copy_start_in_constructed = NULL
|
||||
-#define RESTORE_WARNINGS RExC_copy_start_in_constructed = RExC_precomp
|
||||
+#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE \
|
||||
+ STMT_START { \
|
||||
+ RExC_save_copy_start_in_constructed = RExC_copy_start_in_constructed;\
|
||||
+ RExC_copy_start_in_constructed = NULL; \
|
||||
+ } STMT_END
|
||||
+#define RESTORE_WARNINGS \
|
||||
+ RExC_copy_start_in_constructed = RExC_save_copy_start_in_constructed
|
||||
|
||||
/* Since a warning can be generated multiple times as the input is reparsed, we
|
||||
* output it the first time we come to that point in the parse, but suppress it
|
||||
diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t
|
||||
index c5c79f0323..d10fa2c09a 100644
|
||||
--- a/t/re/reg_mesg.t
|
||||
+++ b/t/re/reg_mesg.t
|
||||
@@ -318,6 +318,7 @@ my @death =
|
||||
'/\p{Is_Other_Alphabetic=F}/ ' => 'Can\'t find Unicode property definition "Is_Other_Alphabetic=F" {#} m/\p{Is_Other_Alphabetic=F}{#}/',
|
||||
'/\x{100}(?(/' => 'Unknown switch condition (?(...)) {#} m/\\x{100}(?({#}/', # [perl #133896]
|
||||
'/(?[\N{KEYCAP DIGIT NINE}/' => '\N{} in inverted character class or as a range end-point is restricted to one character {#} m/(?[\\N{U+39.FE0F.20E3{#}}/', # [perl #133988]
|
||||
+ '/0000000000000000[\N{U+0.00}0000/' => 'Unmatched [ {#} m/0000000000000000[{#}\N{U+0.00}0000/', # [perl #134059]
|
||||
);
|
||||
|
||||
# These are messages that are death under 'use re "strict"', and may or may
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
From 89f69032d6a71f41b96ae6becbf3df4e2f9509a5 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 27 Apr 2019 13:56:39 -0600
|
||||
Subject: [PATCH] S_scan_const() Properly test if need to grow
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
As we parse the input, creating a string constant, we may have to grow
|
||||
the destination if it fills up as we go along. It allocates space in an
|
||||
SV and populates the string, but it doesn' update the SvCUR until the
|
||||
end, so in single stepping the debugger through the code, the SV looks
|
||||
empty until the end. It turns out that as a result SvEND also doesn't
|
||||
get updated and still points to the beginning of the string until SvCUR
|
||||
is finally set. That means that the test changed by this commit was
|
||||
always succeeding, because it was using SvEND that didn't get updated,
|
||||
so it would attempt to grow each time through the loop. By moving a
|
||||
couple of statements earlier, and using SvLEN instead, which does always
|
||||
have the correct value, those extra growth attempts are avoided.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
toke.c | 10 ++++++----
|
||||
1 file changed, 6 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 68eea0cae6..03c4f2ba26 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -4097,10 +4097,12 @@ S_scan_const(pTHX_ char *start)
|
||||
goto default_action; /* Redo, having upgraded so both are UTF-8 */
|
||||
}
|
||||
else { /* UTF8ness matters: convert this non-UTF8 source char to
|
||||
- UTF-8 for output. It will occupy 2 bytes */
|
||||
- if (d + 2 >= SvEND(sv)) {
|
||||
- const STRLEN extra = 2 + (send - s - 1) + 1;
|
||||
- const STRLEN off = d - SvPVX_const(sv);
|
||||
+ UTF-8 for output. It will occupy 2 bytes, but don't include
|
||||
+ the input byte since we haven't incremented 's' yet. See
|
||||
+ Note on sizing above. */
|
||||
+ const STRLEN off = d - SvPVX(sv);
|
||||
+ const STRLEN extra = 2 + (send - s - 1) + 1;
|
||||
+ if (off + extra > SvLEN(sv)) {
|
||||
d = off + SvGROW(sv, off + extra);
|
||||
}
|
||||
*d++ = UTF8_EIGHT_BIT_HI(*s);
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
From 35608a1658fe75c79ca53d96aea6cf7cb2a98615 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 9 May 2019 09:52:30 +1000
|
||||
Subject: [PATCH] (perl #122112) a simpler fix for pclose() aborted by a signal
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This change results in a zombie child process for the lifetime of
|
||||
the process, but I think that's the responsibility of the signal
|
||||
handler that aborted pclose().
|
||||
|
||||
We could add some magic to retry (and retry and retry) waiting on
|
||||
child process as we rewind (since there's no other way to remove
|
||||
the zombie), but the program has chosen implicitly to abort the
|
||||
wait() done by pclose() and it's best to honor that.
|
||||
|
||||
If we do choose to retry the wait() we might be blocking an attempt
|
||||
by the process to terminate, whether by exit() or die().
|
||||
|
||||
If a program does need more flexible handling there's always
|
||||
pipe()/fork()/exec() and/or the various event-driven frameworks on
|
||||
CPAN.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
doio.c | 12 +++++++++++-
|
||||
t/io/pipe.t | 2 --
|
||||
2 files changed, 11 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/doio.c b/doio.c
|
||||
index 0cc4e55404..05a06968dc 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -1779,7 +1779,17 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
|
||||
|
||||
if (IoIFP(io)) {
|
||||
if (IoTYPE(io) == IoTYPE_PIPE) {
|
||||
- const int status = PerlProc_pclose(IoIFP(io));
|
||||
+ PerlIO *fh = IoIFP(io);
|
||||
+ int status;
|
||||
+
|
||||
+ /* my_pclose() can propagate signals which might bypass any code
|
||||
+ after the call here if the signal handler throws an exception.
|
||||
+ This would leave the handle in the IO object and try to close it again
|
||||
+ when the SV is destroyed on unwind or global destruction.
|
||||
+ So NULL it early.
|
||||
+ */
|
||||
+ IoOFP(io) = IoIFP(io) = NULL;
|
||||
+ status = PerlProc_pclose(fh);
|
||||
if (not_implicit) {
|
||||
STATUS_NATIVE_CHILD_SET(status);
|
||||
retval = (STATUS_UNIX == 0);
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index 1d01db6af6..fc3071300d 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -255,9 +255,7 @@ close \$fh;
|
||||
PROG
|
||||
print $prog;
|
||||
my $out = fresh_perl($prog, {});
|
||||
- $::TODO = "not fixed yet";
|
||||
cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
- undef $::TODO;
|
||||
# checks that that program did something rather than failing to
|
||||
# compile
|
||||
cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
From 2fe0d7f40a94163d6c242c3e695fdcd19e387422 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 11 Jun 2019 14:59:23 +1000
|
||||
Subject: [PATCH] (perl #122112) remove some interfering debug output
|
||||
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/io/pipe.t | 1 -
|
||||
1 file changed, 1 deletion(-)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index fc3071300d..9f5bb3bcf8 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -253,7 +253,6 @@ my \$cmd = qq(\$Perl -e "sleep 3");
|
||||
my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
|
||||
close \$fh;
|
||||
PROG
|
||||
- print $prog;
|
||||
my $out = fresh_perl($prog, {});
|
||||
cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
# checks that that program did something rather than failing to
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
From fb5e77103dd443cc2112ba14dc665aa5ec072ce6 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 30 May 2018 14:03:04 +1000
|
||||
Subject: [PATCH] (perl #122112) test for signal handler death in pclose
|
||||
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/io/pipe.t | 23 ++++++++++++++++++++++-
|
||||
1 file changed, 22 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index f9ee65afe8..1d01db6af6 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -10,7 +10,7 @@ if (!$Config{'d_fork'}) {
|
||||
skip_all("fork required to pipe");
|
||||
}
|
||||
else {
|
||||
- plan(tests => 25);
|
||||
+ plan(tests => 27);
|
||||
}
|
||||
|
||||
my $Perl = which_perl();
|
||||
@@ -241,3 +241,24 @@ SKIP: {
|
||||
|
||||
is($child, -1, 'child reaped if piped program cannot be executed');
|
||||
}
|
||||
+
|
||||
+{
|
||||
+ # [perl #122112] refcnt: fd -1 < 0 when a signal handler dies
|
||||
+ # while a pipe close is waiting on a child process
|
||||
+ my $prog = <<PROG;
|
||||
+\$SIG{ALRM}=sub{die};
|
||||
+alarm 1;
|
||||
+\$Perl = "$Perl";
|
||||
+my \$cmd = qq(\$Perl -e "sleep 3");
|
||||
+my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
|
||||
+close \$fh;
|
||||
+PROG
|
||||
+ print $prog;
|
||||
+ my $out = fresh_perl($prog, {});
|
||||
+ $::TODO = "not fixed yet";
|
||||
+ cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
+ undef $::TODO;
|
||||
+ # checks that that program did something rather than failing to
|
||||
+ # compile
|
||||
+ cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
|
||||
+}
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
From 027471cf1095f75f273df40310e4647fe1e8a9df Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 20 Mar 2019 16:47:49 +1100
|
||||
Subject: [PATCH] (perl #133913) limit numeric format results to INT_MAX
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The return value of v?snprintf() is int, and we pay attention to that
|
||||
return value, so limit the expected size of numeric formats to
|
||||
INT_MAX.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perldiag.pod | 6 ++++++
|
||||
sv.c | 7 +++++++
|
||||
t/op/sprintf2.t | 7 +++++++
|
||||
3 files changed, 20 insertions(+)
|
||||
|
||||
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
|
||||
index 1037215d44..166d29b4bb 100644
|
||||
--- a/pod/perldiag.pod
|
||||
+++ b/pod/perldiag.pod
|
||||
@@ -4354,6 +4354,12 @@ the meantime, try using scientific notation (e.g. "1e6" instead of
|
||||
a number. This happens, for example with C<\o{}>, with no number between
|
||||
the braces.
|
||||
|
||||
+=item Numeric format result too large
|
||||
+
|
||||
+(F) The length of the result of a numeric format supplied to sprintf()
|
||||
+or printf() would have been too large for the underlying C function to
|
||||
+report. This limit is typically 2GB.
|
||||
+
|
||||
=item Octal number > 037777777777 non-portable
|
||||
|
||||
(W portable) The octal number you specified is larger than 2**32-1
|
||||
diff --git a/sv.c b/sv.c
|
||||
index 8fbca52eb2..8bc0af0c16 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -13085,6 +13085,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
|
||||
if (float_need < width)
|
||||
float_need = width;
|
||||
|
||||
+ if (float_need > INT_MAX) {
|
||||
+ /* snprintf() returns an int, and we use that return value,
|
||||
+ so die horribly if the expected size is too large for int
|
||||
+ */
|
||||
+ Perl_croak(aTHX_ "Numeric format result too large");
|
||||
+ }
|
||||
+
|
||||
if (PL_efloatsize <= float_need) {
|
||||
/* PL_efloatbuf should be at least 1 greater than
|
||||
* float_need to allow a trailing \0 to be returned by
|
||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
||||
index 84259a4afd..5fee8efede 100644
|
||||
--- a/t/op/sprintf2.t
|
||||
+++ b/t/op/sprintf2.t
|
||||
@@ -1153,4 +1153,11 @@ foreach(
|
||||
is sprintf("%.0f", $_), sprintf("%-.0f", $_), "special-case %.0f on $_";
|
||||
}
|
||||
|
||||
+# large uvsize needed so the large width is parsed properly
|
||||
+# large sizesize needed so the STRLEN check doesn't
|
||||
+if ($Config{intsize} == 4 && $Config{uvsize} > 4 && $Config{sizesize} > 4) {
|
||||
+ eval { my $x = sprintf("%7000000000E", 0) };
|
||||
+ like($@, qr/^Numeric format result too large at /,
|
||||
+ "croak for very large numeric format results");
|
||||
+}
|
||||
done_testing();
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
From 1d9630e7857d6fbae6fddd261fbb80c9c9a8cfd6 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 18 Mar 2019 16:02:33 +1100
|
||||
Subject: [PATCH] (perl #133936) document differences between IO::Socket::* and
|
||||
builtin
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 43 +++++++++++++++++++++++++++++++++++++---
|
||||
1 file changed, 40 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index da9e8c94d0..345ffd475d 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -434,9 +434,6 @@ corresponding built-in functions:
|
||||
bind
|
||||
listen
|
||||
accept
|
||||
- send
|
||||
- recv
|
||||
- peername (getpeername)
|
||||
sockname (getsockname)
|
||||
shutdown
|
||||
|
||||
@@ -517,6 +514,46 @@ SO_LINGER enabled with a zero timeout, then the peer's close() will generate
|
||||
a RST segment, upon receipt of which the local TCP transitions immediately to
|
||||
B<CLOSED>, and in that state, connected() I<will> return undef.
|
||||
|
||||
+=item send(MSG, [, FLAGS [, TO ] ])
|
||||
+
|
||||
+Like the built-in L<send()|perlfunc/send>, except that:
|
||||
+
|
||||
+=over
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+C<FLAGS> is optional and defaults to C<0>, and
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+after a successful send with C<TO>, further calls to send() without
|
||||
+C<TO> will send to the same address, and C<TO> will be used as the
|
||||
+result of peername().
|
||||
+
|
||||
+=back
|
||||
+
|
||||
+=item recv(BUF, LEN, [,FLAGS])
|
||||
+
|
||||
+Like the built-in L<recv()|perlfunc/recv>, except that:
|
||||
+
|
||||
+=over
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+C<FLAGS> is optional and defaults to C<0>, and
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+the cached value returned by peername() is updated with the result of
|
||||
+recv().
|
||||
+
|
||||
+=back
|
||||
+
|
||||
+=item peername
|
||||
+
|
||||
+Returns the cached peername, possibly set by recv() or send() above.
|
||||
+If not otherwise set returns (and caches) the result of getpeername().
|
||||
+
|
||||
=item protocol
|
||||
|
||||
Returns the numerical number for the protocol being used on the socket, if
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
From f1000aa2d58fbed2741dbb2887b668f872ef0cb8 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 18 Mar 2019 15:05:32 +1100
|
||||
Subject: [PATCH] (perl #133936) ensure TO is honoured for UDP $sock->send()
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 7 ++++---
|
||||
dist/IO/t/io_udp.t | 31 +++++++++++++++++++++++++++----
|
||||
2 files changed, 31 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index 1bf57ab826..a34a10b232 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -282,9 +282,10 @@ sub send {
|
||||
croak 'send: Cannot determine peer address'
|
||||
unless(defined $peer);
|
||||
|
||||
- my $r = defined(getpeername($sock))
|
||||
- ? send($sock, $_[1], $flags)
|
||||
- : send($sock, $_[1], $flags, $peer);
|
||||
+ my $type = $sock->socktype;
|
||||
+ my $r = $type == SOCK_DGRAM || $type == SOCK_RAW
|
||||
+ ? send($sock, $_[1], $flags, $peer)
|
||||
+ : send($sock, $_[1], $flags);
|
||||
|
||||
# remember who we send to, if it was successful
|
||||
${*$sock}{'io_socket_peername'} = $peer
|
||||
diff --git a/dist/IO/t/io_udp.t b/dist/IO/t/io_udp.t
|
||||
index d7e95a8829..571e4303bb 100644
|
||||
--- a/dist/IO/t/io_udp.t
|
||||
+++ b/dist/IO/t/io_udp.t
|
||||
@@ -15,6 +15,8 @@ BEGIN {
|
||||
skip_all($reason) if $reason;
|
||||
}
|
||||
|
||||
+use strict;
|
||||
+
|
||||
sub compare_addr {
|
||||
no utf8;
|
||||
my $a = shift;
|
||||
@@ -36,18 +38,18 @@ sub compare_addr {
|
||||
"$a[0]$a[1]" eq "$b[0]$b[1]";
|
||||
}
|
||||
|
||||
-plan(7);
|
||||
+plan(15);
|
||||
watchdog(15);
|
||||
|
||||
use Socket;
|
||||
use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
|
||||
|
||||
-$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+my $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
|| IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
ok(1);
|
||||
|
||||
-$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+my $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
|| IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
ok(1);
|
||||
@@ -56,6 +58,7 @@ $udpa->send('BORK', 0, $udpb->sockname);
|
||||
|
||||
ok(compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname'));
|
||||
|
||||
+my $buf;
|
||||
my $where = $udpb->recv($buf="", 4);
|
||||
is($buf, 'BORK');
|
||||
|
||||
@@ -69,7 +72,27 @@ $udpb->send('FOObar', @xtra);
|
||||
$udpa->recv($buf="", 6);
|
||||
is($buf, 'FOObar');
|
||||
|
||||
-ok(! $udpa->connected);
|
||||
+{
|
||||
+ # check the TO parameter passed to $sock->send() is honoured for UDP sockets
|
||||
+ # [perl #133936]
|
||||
+ my $udpc = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+ || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
+ or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
+ pass("created C socket");
|
||||
+
|
||||
+ ok($udpc->connect($udpa->sockname), "connect C to A");
|
||||
+
|
||||
+ ok($udpc->connected, "connected a UDP socket");
|
||||
+
|
||||
+ ok($udpc->send("fromctoa"), "send to a");
|
||||
+
|
||||
+ ok($udpa->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctoa", "check value received");
|
||||
+
|
||||
+ ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
+ ok($udpb->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctob", "check value received");
|
||||
+}
|
||||
|
||||
exit(0);
|
||||
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
From bc26d2e6b287cc6693f41e1a2d48b0dd77d2e427 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 18 Jun 2019 14:59:00 +1000
|
||||
Subject: [PATCH] (perl #133936) make send() a bit saner
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This undoes some of the effect of f1000aa2d in that TO will always
|
||||
be supplied to CORE::send() if it's supplied, otherwise whether
|
||||
TO is supplied to CORE::send() is based on whether the socket is
|
||||
connected.
|
||||
|
||||
On Linux you appear to be able to sendto() to a different address on
|
||||
a connected UDP socket, but this doesn't appear to be portable,
|
||||
failing on darwin, and presumably on other BSDs.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 25 +++++++++++++++++--------
|
||||
dist/IO/t/io_udp.t | 11 ++++++++---
|
||||
2 files changed, 25 insertions(+), 11 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index 345ffd475d..28fa1ec149 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -277,13 +277,22 @@ sub send {
|
||||
@_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
|
||||
my $sock = $_[0];
|
||||
my $flags = $_[2] || 0;
|
||||
- my $peer = $_[3] || $sock->peername;
|
||||
+ my $peer;
|
||||
|
||||
- croak 'send: Cannot determine peer address'
|
||||
- unless(defined $peer);
|
||||
+ if ($_[3]) {
|
||||
+ # the caller explicitly requested a TO, so use it
|
||||
+ # this is non-portable for "connected" UDP sockets
|
||||
+ $peer = $_[3];
|
||||
+ }
|
||||
+ elsif (!defined getpeername($sock)) {
|
||||
+ # we're not connected, so we require a peer from somewhere
|
||||
+ $peer = $sock->peername;
|
||||
+
|
||||
+ croak 'send: Cannot determine peer address'
|
||||
+ unless(defined $peer);
|
||||
+ }
|
||||
|
||||
- my $type = $sock->socktype;
|
||||
- my $r = $type == SOCK_DGRAM || $type == SOCK_RAW
|
||||
+ my $r = $peer
|
||||
? send($sock, $_[1], $flags, $peer)
|
||||
: send($sock, $_[1], $flags);
|
||||
|
||||
@@ -526,9 +535,9 @@ C<FLAGS> is optional and defaults to C<0>, and
|
||||
|
||||
=item *
|
||||
|
||||
-after a successful send with C<TO>, further calls to send() without
|
||||
-C<TO> will send to the same address, and C<TO> will be used as the
|
||||
-result of peername().
|
||||
+after a successful send with C<TO>, further calls to send() on an
|
||||
+unconnected socket without C<TO> will send to the same address, and
|
||||
+C<TO> will be used as the result of peername().
|
||||
|
||||
=back
|
||||
|
||||
diff --git a/dist/IO/t/io_udp.t b/dist/IO/t/io_udp.t
|
||||
index 571e4303bb..2adc6a4a69 100644
|
||||
--- a/dist/IO/t/io_udp.t
|
||||
+++ b/dist/IO/t/io_udp.t
|
||||
@@ -89,9 +89,14 @@ is($buf, 'FOObar');
|
||||
ok($udpa->recv($buf = "", 8), "recv it");
|
||||
is($buf, "fromctoa", "check value received");
|
||||
|
||||
- ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
- ok($udpb->recv($buf = "", 8), "recv it");
|
||||
- is($buf, "fromctob", "check value received");
|
||||
+ SKIP:
|
||||
+ {
|
||||
+ $^O eq "linux"
|
||||
+ or skip "This is non-portable, known to 'work' on Linux", 3;
|
||||
+ ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
+ ok($udpb->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctob", "check value received");
|
||||
+ }
|
||||
}
|
||||
|
||||
exit(0);
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
From 9dfe0a3438ae69872b71b98e4fb4f4bef084983d Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 3 Jun 2019 14:34:17 +1000
|
||||
Subject: [PATCH 2/2] (perl #134008) an alternative test
|
||||
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/sprintf2.t | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
||||
index 569bd8053d..84259a4afd 100644
|
||||
--- a/t/op/sprintf2.t
|
||||
+++ b/t/op/sprintf2.t
|
||||
@@ -840,6 +840,7 @@ SKIP: {
|
||||
|
||||
# [rt.perl.org #134008]
|
||||
is(sprintf("%.*a", -99999, 1.03125), "0x1.08p+0", "[rt.perl.org #134008]");
|
||||
+ is(sprintf("%.*a", -100000,0), "0x0p+0", "negative precision ignored by format_hexfp");
|
||||
|
||||
# [rt.perl.org #128890]
|
||||
is(sprintf("%a", 0x1.18p+0), "0x1.18p+0");
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
From 40258daf9899686d934c460ba3630431312d7694 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 15 May 2019 15:59:49 +1000
|
||||
Subject: [PATCH] (perl #134072) allow \&foo = \&bar to work in main::
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
subs in main:: are stored as a RV referring to a CV as a space
|
||||
optimization, but the pp_refassign code expected to find a glob,
|
||||
which made the assignment a no-op.
|
||||
|
||||
Fix this by upgrading the reference to a glob in the refassign check
|
||||
function.
|
||||
|
||||
Note that this would be an issue in other packages if 1e2cfe157ca
|
||||
was reverted (allowing the space savings in other packages too.)
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 9 +++++++++
|
||||
t/op/lvref.t | 15 ++++++++++++++-
|
||||
2 files changed, 23 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index f63eeadc36..6ad192307f 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -12462,7 +12462,16 @@ Perl_ck_refassign(pTHX_ OP *o)
|
||||
OP * const kid = cUNOPx(kidparent)->op_first;
|
||||
o->op_private |= OPpLVREF_CV;
|
||||
if (kid->op_type == OP_GV) {
|
||||
+ SV *sv = (SV*)cGVOPx_gv(kid);
|
||||
varop = kidparent;
|
||||
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
|
||||
+ /* a CVREF here confuses pp_refassign, so make sure
|
||||
+ it gets a GV */
|
||||
+ CV *const cv = (CV*)SvRV(sv);
|
||||
+ SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
|
||||
+ (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
|
||||
+ assert(SvTYPE(sv) == SVt_PVGV);
|
||||
+ }
|
||||
goto detach_and_stack;
|
||||
}
|
||||
if (kid->op_type != OP_PADCV) goto bad;
|
||||
diff --git a/t/op/lvref.t b/t/op/lvref.t
|
||||
index 3d5e952fb0..3991a53780 100644
|
||||
--- a/t/op/lvref.t
|
||||
+++ b/t/op/lvref.t
|
||||
@@ -1,10 +1,11 @@
|
||||
+#!perl
|
||||
BEGIN {
|
||||
chdir 't';
|
||||
require './test.pl';
|
||||
set_up_inc("../lib");
|
||||
}
|
||||
|
||||
-plan 164;
|
||||
+plan 167;
|
||||
|
||||
eval '\$x = \$y';
|
||||
like $@, qr/^Experimental aliasing via reference not enabled/,
|
||||
@@ -291,6 +292,18 @@ package CodeTest {
|
||||
my sub bs;
|
||||
\(&cs) = expect_list_cx;
|
||||
is \&cs, \&ThatSub, '\(&statesub)';
|
||||
+
|
||||
+ package main {
|
||||
+ # this is only a problem in main:: due to 1e2cfe157ca
|
||||
+ sub sx { "x" }
|
||||
+ sub sy { "y" }
|
||||
+ is sx(), "x", "check original";
|
||||
+ my $temp = \&sx;
|
||||
+ \&sx = \&sy;
|
||||
+ is sx(), "y", "aliased";
|
||||
+ \&sx = $temp;
|
||||
+ is sx(), "x", "and restored";
|
||||
+ }
|
||||
}
|
||||
|
||||
# Mixed List Assignments
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
From 22f05786af0b7f963440e47908cd5f35cf074c12 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 13 Jun 2019 10:05:15 +1000
|
||||
Subject: [PATCH] (perl #134193) allow %{^CAPTURE} to work when @{^CAPTURE}
|
||||
comes first
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
gv_magicalize() is called when the GV is created, so when the array
|
||||
was mentioned first, the hash wouldn't reach this code and the magic
|
||||
wouldn't be added to the hash.
|
||||
|
||||
This also fixes a similar problem with (%|@){^CAPTURE_ALL}, though
|
||||
@{^CAPTURE_ALL} is unused at this point.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/Tie-Hash-NamedCapture/t/tiehash.t | 3 +++
|
||||
gv.c | 6 ++----
|
||||
2 files changed, 5 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/t/tiehash.t b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
index 962754085f..cca05278f4 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
+++ b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
@@ -3,6 +3,9 @@ use strict;
|
||||
|
||||
use Test::More;
|
||||
|
||||
+# this would break the hash magic setup [perl #134193]
|
||||
+my ($ca, $c) = ( \@{^CAPTURE_ALL}, \@{^CAPTURE} );
|
||||
+
|
||||
my %hashes = (
|
||||
'+' => \%+,
|
||||
'-' => \%-,
|
||||
diff --git a/gv.c b/gv.c
|
||||
index 46a32dcc20..2b83680898 100644
|
||||
--- a/gv.c
|
||||
+++ b/gv.c
|
||||
@@ -2032,13 +2032,11 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
|
||||
sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
|
||||
SvREADONLY_on(av);
|
||||
|
||||
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
|
||||
- require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
|
||||
} else /* %{^CAPTURE_ALL} */
|
||||
if (memEQs(name, len, "\003APTURE_ALL")) {
|
||||
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
|
||||
- require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
}
|
||||
break;
|
||||
case '\005': /* $^ENCODING */
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
From d8422270033e0728e6a9cecb24cdbd123656e367 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 17 Jun 2019 11:46:00 +1000
|
||||
Subject: [PATCH] (perl #134193) make the varname match the %[+-] names
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
when loading Tie/Hash/NamedCapture.pm for the long name variants
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
gv.c | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/gv.c b/gv.c
|
||||
index 2b83680898..652f5e737d 100644
|
||||
--- a/gv.c
|
||||
+++ b/gv.c
|
||||
@@ -2032,11 +2032,11 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
|
||||
sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
|
||||
SvREADONLY_on(av);
|
||||
|
||||
- require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
|
||||
} else /* %{^CAPTURE_ALL} */
|
||||
if (memEQs(name, len, "\003APTURE_ALL")) {
|
||||
- require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
}
|
||||
break;
|
||||
case '\005': /* $^ENCODING */
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
From 28eabf1185634216ca335b3a24e1131b0f392ca1 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Wed, 10 Jul 2019 12:59:06 +0100
|
||||
Subject: [PATCH] avoid SEGV with uninit warning with multideref
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
RT #134275
|
||||
|
||||
When the 'uninitialized warning' code in S_find_uninit_var() comes
|
||||
across an OP_MULTIDEREF node, it scans it to see if any part of that op
|
||||
(e.g. the indices or the returned value) could have been the source of
|
||||
the uninitialized value which triggered the warning. Unfortunately when
|
||||
getting an AV or HV from a GV, it wasn't checking whether gp_av/gp_hv
|
||||
contained a NULL value. If so, it would SEGV.
|
||||
|
||||
The test code is a bit contrived; you have to "pull the rug" from under
|
||||
the GV at just the right moment with *foo = *bar, then trigger an uninit
|
||||
warning on an op whose subtree includes an OP_MULTIDEREF.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
sv.c | 5 ++++-
|
||||
t/lib/warnings/9uninit | 10 ++++++++++
|
||||
2 files changed, 14 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/sv.c b/sv.c
|
||||
index 83de536ad7..4315fe9b64 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -16662,8 +16662,11 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
|
||||
|
||||
if (agg_targ)
|
||||
sv = PAD_SV(agg_targ);
|
||||
- else if (agg_gv)
|
||||
+ else if (agg_gv) {
|
||||
sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
|
||||
+ if (!sv)
|
||||
+ break;
|
||||
+ }
|
||||
else
|
||||
break;
|
||||
|
||||
diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
|
||||
index 774c6ee432..5c173fdb2a 100644
|
||||
--- a/t/lib/warnings/9uninit
|
||||
+++ b/t/lib/warnings/9uninit
|
||||
@@ -2206,3 +2206,13 @@ use warnings 'uninitialized';
|
||||
undef $0;
|
||||
EXPECT
|
||||
Use of uninitialized value in undef operator at - line 5.
|
||||
+########
|
||||
+# RT #134275
|
||||
+# This was SEGVing due to the multideref code in S_find_uninit_var not
|
||||
+# handling a GV with a null gp_hv slot.
|
||||
+use warnings 'uninitialized';
|
||||
+"" =~ /$foo{a}${*foo=*bar}$x/;
|
||||
+EXPECT
|
||||
+Use of uninitialized value in regexp compilation at - line 5.
|
||||
+Use of uninitialized value in regexp compilation at - line 5.
|
||||
+Use of uninitialized value $x in regexp compilation at - line 5.
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
From 293a533c53d9c0fe939e23c439f4dfc47a5736dc Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 25 Jun 2019 15:47:57 +1000
|
||||
Subject: [PATCH] (perl #122112) make sure SIGPIPE is delivered if we test it
|
||||
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/io/pipe.t | 12 ++++++++++++
|
||||
1 file changed, 12 insertions(+)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index 9f5bb3bcf8..bdf743c26c 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -125,6 +125,18 @@ wait; # Collect from $pid
|
||||
pipe(READER,WRITER) || die "Can't open pipe";
|
||||
close READER;
|
||||
|
||||
+eval {
|
||||
+ # one platform at least appears to block SIGPIPE by default (see #122112)
|
||||
+ # so make sure it's unblocked.
|
||||
+ # The eval wrapper should ensure this does nothing if these aren't
|
||||
+ # implemented.
|
||||
+ require POSIX;
|
||||
+ my $mask = POSIX::SigSet->new(POSIX::SIGPIPE());
|
||||
+ my $old = POSIX::SigSet->new();
|
||||
+ POSIX::sigprocmask(POSIX::SIG_UNBLOCK(), $mask, $old);
|
||||
+ note "Yes, SIGPIPE was blocked" if $old->ismember(POSIX::SIGPIPE());
|
||||
+};
|
||||
+
|
||||
$SIG{'PIPE'} = 'broken_pipe';
|
||||
|
||||
sub broken_pipe {
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,128 @@
|
|||
From 74b421cc877e412c4eda06757396a1e19fc756ba Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 15 Jul 2019 11:53:23 +1000
|
||||
Subject: [PATCH 3/3] (perl #134221) support O_APPEND for open ..., undef on
|
||||
VMS
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
VMS doesn't allow you to delete an open file like POSIXish systems
|
||||
do, but you can mark a file to be deleted once it's closed, but
|
||||
only when you open it.
|
||||
|
||||
Since VMS doesn't (yet) have mkostemp() we can add our own flag to
|
||||
our mkostemp() emulation to pass the necessary magic to open() call
|
||||
to delete the file on close.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perlio.c | 10 ++++++----
|
||||
util.c | 15 ++++++++++++++-
|
||||
util.h | 11 +++++++++++
|
||||
3 files changed, 31 insertions(+), 5 deletions(-)
|
||||
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index 81ebc156ad..805959f840 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -5062,7 +5062,7 @@ PerlIO_tmpfile_flags(int imode)
|
||||
const int fd = win32_tmpfd_mode(imode);
|
||||
if (fd >= 0)
|
||||
f = PerlIO_fdopen(fd, "w+b");
|
||||
-#elif ! defined(VMS) && ! defined(OS2)
|
||||
+#elif ! defined(OS2)
|
||||
int fd = -1;
|
||||
char tempname[] = "/tmp/PerlIO_XXXXXX";
|
||||
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
|
||||
@@ -5073,19 +5073,19 @@ PerlIO_tmpfile_flags(int imode)
|
||||
/* if TMPDIR is set and not empty, we try that first */
|
||||
sv = newSVpv(tmpdir, 0);
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
if (fd < 0) {
|
||||
SvREFCNT_dec(sv);
|
||||
sv = NULL;
|
||||
/* else we try /tmp */
|
||||
- fd = Perl_my_mkostemp_cloexec(tempname, imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
if (fd < 0) {
|
||||
/* Try cwd */
|
||||
sv = newSVpvs(".");
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
umask(old_umask);
|
||||
if (fd >= 0) {
|
||||
@@ -5096,7 +5096,9 @@ PerlIO_tmpfile_flags(int imode)
|
||||
f = PerlIO_fdopen(fd, mode);
|
||||
if (f)
|
||||
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
|
||||
+# ifndef VMS
|
||||
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
|
||||
+# endif
|
||||
}
|
||||
SvREFCNT_dec(sv);
|
||||
#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
|
||||
diff --git a/util.c b/util.c
|
||||
index e6863f6dfe..165d13a39e 100644
|
||||
--- a/util.c
|
||||
+++ b/util.c
|
||||
@@ -5712,6 +5712,11 @@ S_my_mkostemp(char *templte, int flags) {
|
||||
STRLEN len = strlen(templte);
|
||||
int fd;
|
||||
int attempts = 0;
|
||||
+#ifdef VMS
|
||||
+ int delete_on_close = flags & O_VMS_DELETEONCLOSE;
|
||||
+
|
||||
+ flags &= ~O_VMS_DELETEONCLOSE;
|
||||
+#endif
|
||||
|
||||
if (len < 6 ||
|
||||
templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
|
||||
@@ -5725,7 +5730,15 @@ S_my_mkostemp(char *templte, int flags) {
|
||||
for (i = 1; i <= 6; ++i) {
|
||||
templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
|
||||
}
|
||||
- fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
|
||||
+#ifdef VMS
|
||||
+ if (delete_on_close) {
|
||||
+ fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt");
|
||||
+ }
|
||||
+ else
|
||||
+#endif
|
||||
+ {
|
||||
+ fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
|
||||
+ }
|
||||
} while (fd == -1 && errno == EEXIST && ++attempts <= 100);
|
||||
|
||||
return fd;
|
||||
diff --git a/util.h b/util.h
|
||||
index d8fa3e8396..d9df7b39c6 100644
|
||||
--- a/util.h
|
||||
+++ b/util.h
|
||||
@@ -248,6 +248,17 @@ means arg not present, 1 is empty string/null byte */
|
||||
int mkstemp(char*);
|
||||
#endif
|
||||
|
||||
+#ifdef PERL_CORE
|
||||
+# if defined(VMS)
|
||||
+/* only useful for calls to our mkostemp() emulation */
|
||||
+# define O_VMS_DELETEONCLOSE 0x40000000
|
||||
+# ifdef HAS_MKOSTEMP
|
||||
+# error 134221 will need a new solution for VMS
|
||||
+# endif
|
||||
+# else
|
||||
+# define O_VMS_DELETEONCLOSE 0
|
||||
+# endif
|
||||
+#endif
|
||||
#if defined(HAS_MKOSTEMP) && defined(PERL_CORE)
|
||||
# define Perl_my_mkostemp(templte, flags) mkostemp(templte, flags)
|
||||
#endif
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
From 0424723402ef153af8ee44222315d9b6a818d1ba Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 2 Jul 2019 15:22:26 +1000
|
||||
Subject: [PATCH 2/3] (perl #134221) support append mode temp files on Win32
|
||||
too
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perlio.c | 2 +-
|
||||
win32/win32.c | 10 +++++++++-
|
||||
win32/win32iop.h | 1 +
|
||||
3 files changed, 11 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index a737e79e02..81ebc156ad 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -5059,7 +5059,7 @@ PerlIO_tmpfile_flags(int imode)
|
||||
#endif
|
||||
PerlIO *f = NULL;
|
||||
#ifdef WIN32
|
||||
- const int fd = win32_tmpfd();
|
||||
+ const int fd = win32_tmpfd_mode(imode);
|
||||
if (fd >= 0)
|
||||
f = PerlIO_fdopen(fd, "w+b");
|
||||
#elif ! defined(VMS) && ! defined(OS2)
|
||||
diff --git a/win32/win32.c b/win32/win32.c
|
||||
index 8104d864c2..91fdffe09b 100644
|
||||
--- a/win32/win32.c
|
||||
+++ b/win32/win32.c
|
||||
@@ -2907,10 +2907,18 @@ win32_rewind(FILE *pf)
|
||||
|
||||
DllExport int
|
||||
win32_tmpfd(void)
|
||||
+{
|
||||
+ return win32_tmpfd_mode(0);
|
||||
+}
|
||||
+
|
||||
+DllExport int
|
||||
+win32_tmpfd_mode(int mode)
|
||||
{
|
||||
char prefix[MAX_PATH+1];
|
||||
char filename[MAX_PATH+1];
|
||||
DWORD len = GetTempPath(MAX_PATH, prefix);
|
||||
+ mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
|
||||
+ mode |= O_RDWR;
|
||||
if (len && len < MAX_PATH) {
|
||||
if (GetTempFileName(prefix, "plx", 0, filename)) {
|
||||
HANDLE fh = CreateFile(filename,
|
||||
@@ -2922,7 +2930,7 @@ win32_tmpfd(void)
|
||||
| FILE_FLAG_DELETE_ON_CLOSE,
|
||||
NULL);
|
||||
if (fh != INVALID_HANDLE_VALUE) {
|
||||
- int fd = win32_open_osfhandle((intptr_t)fh, 0);
|
||||
+ int fd = win32_open_osfhandle((intptr_t)fh, mode);
|
||||
if (fd >= 0) {
|
||||
PERL_DEB(dTHX;)
|
||||
DEBUG_p(PerlIO_printf(Perl_debug_log,
|
||||
diff --git a/win32/win32iop.h b/win32/win32iop.h
|
||||
index 53330e5951..559e1f9cd2 100644
|
||||
--- a/win32/win32iop.h
|
||||
+++ b/win32/win32iop.h
|
||||
@@ -64,6 +64,7 @@ DllExport int win32_fgetpos(FILE *pf,fpos_t *p);
|
||||
DllExport int win32_fsetpos(FILE *pf,const fpos_t *p);
|
||||
DllExport void win32_rewind(FILE *pf);
|
||||
DllExport int win32_tmpfd(void);
|
||||
+DllExport int win32_tmpfd_mode(int mode);
|
||||
DllExport FILE* win32_tmpfile(void);
|
||||
DllExport void win32_abort(void);
|
||||
DllExport int win32_fstat(int fd,Stat_t *sbufptr);
|
||||
--
|
||||
2.20.1
|
||||
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
From 12e1284a67e5e3404c704c3f864749fd9f04c7c4 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 7 Aug 2019 14:58:14 +1000
|
||||
Subject: [PATCH] PerlIO::Via: check arg is non-NULL before using it.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
I can't find any code in core that ends up calling the _pushed handler
|
||||
with arg == NULL, but PerlIO_push() is API, and there might be
|
||||
CPAN or DarkPAN code out there that does, escpecially since there's
|
||||
a check for arg being non-NULL further down.
|
||||
|
||||
CID 169261.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/PerlIO-via/via.xs | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
|
||||
index d91c6855fc..8456242bc0 100644
|
||||
--- a/ext/PerlIO-via/via.xs
|
||||
+++ b/ext/PerlIO-via/via.xs
|
||||
@@ -134,8 +134,8 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
|
||||
{
|
||||
IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
|
||||
|
||||
- if (SvTYPE(arg) >= SVt_PVMG
|
||||
- && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
|
||||
+ if (arg && SvTYPE(arg) >= SVt_PVMG
|
||||
+ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
|
||||
return code;
|
||||
}
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue