Compare commits
No commits in common. 'c9' and 'c8-stream-5.26' have entirely different histories.
c9
...
c8-stream-
@ -1 +1 @@
|
|||||||
SOURCES/perl-5.32.1.tar.xz
|
SOURCES/perl-5.26.2.tar.bz2
|
||||||
|
|||||||
@ -1 +1 @@
|
|||||||
1fb4f710d139da1e1a3e1fa4eaba201fcaa8e18e SOURCES/perl-5.32.1.tar.xz
|
2057b65e3a6ac71287c973402cd01084a1edc35b SOURCES/perl-5.26.2.tar.bz2
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -1,12 +1,12 @@
|
|||||||
diff -up perl-5.10.0/t/io/fs.t.BAD perl-5.10.0/t/io/fs.t
|
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.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
|
+++ perl-5.10.0/t/io/fs.t 2008-01-30 13:41:27.000000000 -0500
|
||||||
@@ -257,7 +257,7 @@ isnt($atime, 500000000, 'atime');
|
@@ -227,7 +227,7 @@ isnt($atime, 500000000, 'atime');
|
||||||
isnt($mtime, $ut + $delta, 'mtime: utime called with two undefs');
|
isnt($mtime, 500000000 + $delta, 'mtime');
|
||||||
|
|
||||||
SKIP: {
|
SKIP: {
|
||||||
- skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define";
|
- skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define";
|
||||||
+ skip "no futimes", 6;
|
+ skip "no futimes", 6;
|
||||||
note("check futimes");
|
|
||||||
open(my $fh, "<", 'b');
|
open(my $fh, "<", 'b');
|
||||||
$foo = (utime $ut,$ut + $delta, $fh);
|
$foo = (utime 500000000,500000000 + $delta, $fh);
|
||||||
|
is($foo, 1, "futime");
|
||||||
|
|||||||
@ -0,0 +1,30 @@
|
|||||||
|
From 862c89c81d26dae0dcef138e19df8b45615e69c9 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Mon, 2 Dec 2013 10:10:56 +0100
|
||||||
|
Subject: [PATCH] Document Math::BigInt::CalcEmu requires Math::BigInt
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
<https://rt.cpan.org/Public/Bug/Display.html?id=85015>
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm | 1 +
|
||||||
|
1 file changed, 1 insertion(+)
|
||||||
|
|
||||||
|
diff --git a/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm b/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||||
|
index c82e153..0c0b496 100644
|
||||||
|
--- a/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||||
|
+++ b/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
|
||||||
|
@@ -290,6 +290,7 @@ Math::BigInt::CalcEmu - Emulate low-level math with BigInt code
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
+ use Math::BigInt;
|
||||||
|
use Math::BigInt::CalcEmu;
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
--
|
||||||
|
1.8.3.1
|
||||||
|
|
||||||
@ -0,0 +1,73 @@
|
|||||||
|
From 8985b12868f07d9ef501580d600e49fe8f230eb4 Mon Sep 17 00:00:00 2001
|
||||||
|
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||||
|
Date: Tue, 22 Aug 2017 09:49:42 +0200
|
||||||
|
Subject: [PATCH] Time-HiRes: Fix unreliable t/usleep.t and t/utime.t
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported from Time-HiRes-1.9746.
|
||||||
|
|
||||||
|
The tests randomly failed on loaded machines because a CPU scheduler
|
||||||
|
could add unpredictable delays.
|
||||||
|
|
||||||
|
CPAN RT#122819
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Time-HiRes/t/usleep.t | 4 ++--
|
||||||
|
dist/Time-HiRes/t/utime.t | 9 +++++----
|
||||||
|
2 files changed, 7 insertions(+), 6 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/dist/Time-HiRes/t/usleep.t b/dist/Time-HiRes/t/usleep.t
|
||||||
|
index 9322458..bb66cbe 100644
|
||||||
|
--- a/dist/Time-HiRes/t/usleep.t
|
||||||
|
+++ b/dist/Time-HiRes/t/usleep.t
|
||||||
|
@@ -32,7 +32,7 @@ SKIP: {
|
||||||
|
Time::HiRes::usleep(500_000);
|
||||||
|
my $f2 = Time::HiRes::time();
|
||||||
|
my $d = $f2 - $f;
|
||||||
|
- ok $d > 0.4 && $d < 0.9 or print("# slept $d secs $f to $f2\n");
|
||||||
|
+ ok $d > 0.49 or print("# slept $d secs $f to $f2\n");
|
||||||
|
}
|
||||||
|
|
||||||
|
SKIP: {
|
||||||
|
@@ -40,7 +40,7 @@ SKIP: {
|
||||||
|
my $r = [ Time::HiRes::gettimeofday() ];
|
||||||
|
Time::HiRes::sleep( 0.5 );
|
||||||
|
my $f = Time::HiRes::tv_interval $r;
|
||||||
|
- ok $f > 0.4 && $f < 0.9 or print("# slept $f instead of 0.5 secs.\n");
|
||||||
|
+ ok $f > 0.49 or print("# slept $f instead of 0.5 secs.\n");
|
||||||
|
}
|
||||||
|
|
||||||
|
SKIP: {
|
||||||
|
diff --git a/dist/Time-HiRes/t/utime.t b/dist/Time-HiRes/t/utime.t
|
||||||
|
index 22fd48e..c5c7e55 100644
|
||||||
|
--- a/dist/Time-HiRes/t/utime.t
|
||||||
|
+++ b/dist/Time-HiRes/t/utime.t
|
||||||
|
@@ -106,17 +106,18 @@ print "# utime undef sets time to now\n";
|
||||||
|
my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
|
||||||
|
|
||||||
|
my $now = Time::HiRes::time;
|
||||||
|
+ sleep(1);
|
||||||
|
is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed";
|
||||||
|
|
||||||
|
{
|
||||||
|
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
|
||||||
|
- cmp_ok abs( $got_atime - $now), '<', 0.1, "File 1 atime set correctly";
|
||||||
|
- cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 1 mtime set correctly";
|
||||||
|
+ cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly";
|
||||||
|
+ cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly";
|
||||||
|
}
|
||||||
|
{
|
||||||
|
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
|
||||||
|
- cmp_ok abs( $got_atime - $now), '<', 0.1, "File 2 atime set correctly";
|
||||||
|
- cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 2 mtime set correctly";
|
||||||
|
+ cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly";
|
||||||
|
+ cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly";
|
||||||
|
}
|
||||||
|
};
|
||||||
|
|
||||||
|
--
|
||||||
|
2.9.5
|
||||||
|
|
||||||
@ -0,0 +1,72 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,61 @@
|
|||||||
|
From cb2fda94b02c5b7e8d16582410034f5a3dae526f Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Tue, 25 Jul 2017 16:21:22 +1000
|
||||||
|
Subject: [PATCH] (perl #131588) be a little more careful in arybase::_tie_it()
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Original patch by John Leitch <john@autosectools.com>
|
||||||
|
Petr Pisar: Ported to 5.26.0.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/arybase/arybase.xs | 10 ++++++----
|
||||||
|
ext/arybase/t/arybase.t | 4 +++-
|
||||||
|
2 files changed, 9 insertions(+), 5 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/arybase/arybase.xs b/ext/arybase/arybase.xs
|
||||||
|
index 880bbe3..216442a 100644
|
||||||
|
--- a/ext/arybase/arybase.xs
|
||||||
|
+++ b/ext/arybase/arybase.xs
|
||||||
|
@@ -438,10 +438,12 @@ _tie_it(SV *sv)
|
||||||
|
INIT:
|
||||||
|
GV * const gv = (GV *)sv;
|
||||||
|
CODE:
|
||||||
|
- if (GvSV(gv))
|
||||||
|
- /* This is *our* scalar now! */
|
||||||
|
- sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
|
||||||
|
- tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
|
||||||
|
+ if (isGV(gv)) {
|
||||||
|
+ if (GvSV(gv))
|
||||||
|
+ /* This is *our* scalar now! */
|
||||||
|
+ sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
|
||||||
|
+ tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
|
||||||
|
+ }
|
||||||
|
|
||||||
|
void
|
||||||
|
FETCH(...)
|
||||||
|
diff --git a/ext/arybase/t/arybase.t b/ext/arybase/t/arybase.t
|
||||||
|
index f3d3287..41e90df 100644
|
||||||
|
--- a/ext/arybase/t/arybase.t
|
||||||
|
+++ b/ext/arybase/t/arybase.t
|
||||||
|
@@ -4,7 +4,7 @@
|
||||||
|
# plus miscellaneous bug fix tests
|
||||||
|
|
||||||
|
no warnings 'deprecated';
|
||||||
|
-use Test::More tests => 7;
|
||||||
|
+use Test::More tests => 8;
|
||||||
|
|
||||||
|
sub outside_base_scope { return "${'['}" }
|
||||||
|
|
||||||
|
@@ -34,4 +34,6 @@ is $@, "That use of \$[ is unsupported at $f line $l.\n",
|
||||||
|
|
||||||
|
sub foo { my $x; $x = wait } # compilation of this routine used to crash
|
||||||
|
|
||||||
|
+ok eval { arybase::_tie_it(1); 1 }, "don't crash on bad call to _tie_it()";
|
||||||
|
+
|
||||||
|
1;
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,37 @@
|
|||||||
|
From 37268580c0cfbf190ff9aa7859a604713cb366ee Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 27 Jun 2017 16:36:57 +0200
|
||||||
|
Subject: [PATCH] t/op/hash.t: fixup intermittently failing test
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Port to 5.26.0:
|
||||||
|
|
||||||
|
commit b2ac59d1d0fda74d6612701d8316fe8dfb6a1b90
|
||||||
|
Author: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue Jun 27 16:36:57 2017 +0200
|
||||||
|
|
||||||
|
t/op/hash.t: fixup intermittently failing test
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/op/hash.t | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/op/hash.t b/t/op/hash.t
|
||||||
|
index a0e79c7..b941c57 100644
|
||||||
|
--- a/t/op/hash.t
|
||||||
|
+++ b/t/op/hash.t
|
||||||
|
@@ -206,7 +206,7 @@ sub torture_hash {
|
||||||
|
my $keys = pop @groups;
|
||||||
|
++$h->{$_} foreach @$keys;
|
||||||
|
my (undef, $total) = validate_hash("$desc " . keys %$h, $h);
|
||||||
|
- is($total, $total0, "bucket count is constant when rebuilding");
|
||||||
|
+ ok($total == $total0 || $total == ($total0*2), "bucket count is expected size when rebuilding");
|
||||||
|
is(scalar %$h, pop @groups, "scalar keys is identical when rebuilding");
|
||||||
|
++$h1->{$_} foreach @$keys;
|
||||||
|
validate_hash("$desc copy " . keys %$h1, $h1);
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,48 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,111 @@
|
|||||||
|
From 3dfcac940930a8aa6779f5debea6ea6357372419 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Daniel Dragan <bulk88@hotmail.com>
|
||||||
|
Date: Sun, 16 Aug 2015 04:30:23 -0400
|
||||||
|
Subject: [PATCH] fix do dir returning no $!
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
do()ing a directory was returning false/empty string in $!, which isn't
|
||||||
|
an error, yet documentation says $! should have the error code in it.
|
||||||
|
Fix this by returning EISDIR for dirs, and EINVAL for block devices.
|
||||||
|
[perl #125774]
|
||||||
|
|
||||||
|
Remove "errno = 0" and comment added in b2da7ead68, since now there is no
|
||||||
|
scenario where errno is uninitialized, since the dir and block device
|
||||||
|
failure branches now set errno, where previously they didn't.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.1.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_ctl.c | 25 +++++++++++++++++--------
|
||||||
|
t/op/do.t | 14 +++++++++++++-
|
||||||
|
2 files changed, 30 insertions(+), 9 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
|
index e24d7b6..f136f91 100644
|
||||||
|
--- a/pp_ctl.c
|
||||||
|
+++ b/pp_ctl.c
|
||||||
|
@@ -3534,15 +3534,22 @@ S_check_type_and_open(pTHX_ SV *name)
|
||||||
|
errno EACCES, so only do a stat to separate a dir from a real EACCES
|
||||||
|
caused by user perms */
|
||||||
|
#ifndef WIN32
|
||||||
|
- /* we use the value of errno later to see how stat() or open() failed.
|
||||||
|
- * We don't want it set if the stat succeeded but we still failed,
|
||||||
|
- * such as if the name exists, but is a directory */
|
||||||
|
- errno = 0;
|
||||||
|
-
|
||||||
|
st_rc = PerlLIO_stat(p, &st);
|
||||||
|
|
||||||
|
- if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
|
||||||
|
+ if (st_rc < 0)
|
||||||
|
return NULL;
|
||||||
|
+ else {
|
||||||
|
+ int eno;
|
||||||
|
+ if(S_ISBLK(st.st_mode)) {
|
||||||
|
+ eno = EINVAL;
|
||||||
|
+ goto not_file;
|
||||||
|
+ }
|
||||||
|
+ else if(S_ISDIR(st.st_mode)) {
|
||||||
|
+ eno = EISDIR;
|
||||||
|
+ not_file:
|
||||||
|
+ errno = eno;
|
||||||
|
+ return NULL;
|
||||||
|
+ }
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
@@ -3554,8 +3561,10 @@ S_check_type_and_open(pTHX_ SV *name)
|
||||||
|
int eno;
|
||||||
|
st_rc = PerlLIO_stat(p, &st);
|
||||||
|
if (st_rc >= 0) {
|
||||||
|
- if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
|
||||||
|
- eno = 0;
|
||||||
|
+ if(S_ISDIR(st.st_mode))
|
||||||
|
+ eno = EISDIR;
|
||||||
|
+ else if(S_ISBLK(st.st_mode))
|
||||||
|
+ eno = EINVAL;
|
||||||
|
else
|
||||||
|
eno = EACCES;
|
||||||
|
errno = eno;
|
||||||
|
diff --git a/t/op/do.t b/t/op/do.t
|
||||||
|
index 78d8800..1c54f0b 100644
|
||||||
|
--- a/t/op/do.t
|
||||||
|
+++ b/t/op/do.t
|
||||||
|
@@ -7,6 +7,7 @@ BEGIN {
|
||||||
|
}
|
||||||
|
use strict;
|
||||||
|
no warnings 'void';
|
||||||
|
+use Errno qw(ENOENT EISDIR);
|
||||||
|
|
||||||
|
my $called;
|
||||||
|
my $result = do{ ++$called; 'value';};
|
||||||
|
@@ -247,7 +248,7 @@ SKIP: {
|
||||||
|
my $saved_errno = $!;
|
||||||
|
ok(!$rv, "do returns false on io errror");
|
||||||
|
ok(!$saved_error, "\$\@ not set on io error");
|
||||||
|
- ok($saved_errno, "\$! set on io error");
|
||||||
|
+ ok($saved_errno == ENOENT, "\$! is ENOENT for nonexistent file");
|
||||||
|
}
|
||||||
|
|
||||||
|
# do subname should not be do "subname"
|
||||||
|
@@ -305,4 +306,15 @@ SKIP: {
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
+# do file $!s must be correct
|
||||||
|
+{
|
||||||
|
+ local @INC = ('.'); #want EISDIR not ENOENT
|
||||||
|
+ my $rv = do 'op'; # /t/op dir
|
||||||
|
+ my $saved_error = $@;
|
||||||
|
+ my $saved_errno = $!+0;
|
||||||
|
+ ok(!$rv, "do dir returns false");
|
||||||
|
+ ok(!$saved_error, "\$\@ is false on do dir");
|
||||||
|
+ ok($saved_errno == EISDIR, "\$! is EISDIR on do dir");
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
done_testing();
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,24 @@
|
|||||||
|
commit 13e70b397dcb0d1bf4a869b670f041c1d7b730d0
|
||||||
|
Author: Björn Esser <besser82@fedoraproject.org>
|
||||||
|
Date: Sat Jan 20 20:22:53 2018 +0100
|
||||||
|
|
||||||
|
pp: Guard fix for really old bug in glibc libcrypt
|
||||||
|
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index d50ad7ddbf..6510c7b15c 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -3650,8 +3650,12 @@ PP(pp_crypt)
|
||||||
|
#if defined(__GLIBC__) || defined(__EMX__)
|
||||||
|
if (PL_reentrant_buffer->_crypt_struct_buffer) {
|
||||||
|
PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
|
||||||
|
- /* work around glibc-2.2.5 bug */
|
||||||
|
+#if (defined(__GLIBC__) && __GLIBC__ == 2) && \
|
||||||
|
+ (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
|
||||||
|
+ /* work around glibc-2.2.5 bug, has been fixed at some
|
||||||
|
+ * time in glibc-2.3.X */
|
||||||
|
PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
|
||||||
|
+#endif
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
}
|
||||||
@ -0,0 +1,107 @@
|
|||||||
|
From 7a962424149cc60f3a187d0213a12689dd5e806b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 14 Aug 2017 11:52:39 +1000
|
||||||
|
Subject: [PATCH] (perl #131746) avoid undefined behaviour in Copy() etc
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
These functions depend on C library functions which have undefined
|
||||||
|
behaviour when passed NULL pointers, even when passed a zero 'n' value.
|
||||||
|
|
||||||
|
Some compilers use this information, ie. assume the pointers are
|
||||||
|
non-NULL when optimizing any following code, so we do need to
|
||||||
|
prevent such unguarded calls.
|
||||||
|
|
||||||
|
My initial thought was to add conditionals to each macro to skip the
|
||||||
|
call to the library function when n is zero, but this adds a cost to
|
||||||
|
every use of these macros, even when the n value is always true.
|
||||||
|
|
||||||
|
So instead I added asserts() which will give us a much more visible
|
||||||
|
indicator of such broken code and revealed the pp_caller and Glob.xs
|
||||||
|
issues also patched here.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.1 from
|
||||||
|
f14cf3632059d421de83cf901c7e849adc1fcd03.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/File-Glob/Glob.xs | 2 +-
|
||||||
|
handy.h | 14 +++++++-------
|
||||||
|
pp_ctl.c | 3 ++-
|
||||||
|
pp_hot.c | 3 ++-
|
||||||
|
4 files changed, 12 insertions(+), 10 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
|
||||||
|
index e0a3681..9779d54 100644
|
||||||
|
--- a/ext/File-Glob/Glob.xs
|
||||||
|
+++ b/ext/File-Glob/Glob.xs
|
||||||
|
@@ -121,7 +121,7 @@ iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, boo
|
||||||
|
|
||||||
|
/* chuck it all out, quick or slow */
|
||||||
|
if (gimme == G_ARRAY) {
|
||||||
|
- if (!on_stack) {
|
||||||
|
+ if (!on_stack && AvFILLp(entries) + 1) {
|
||||||
|
EXTEND(SP, AvFILLp(entries)+1);
|
||||||
|
Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
|
||||||
|
SP += AvFILLp(entries)+1;
|
||||||
|
diff --git a/handy.h b/handy.h
|
||||||
|
index 80f9cf4..88b5b55 100644
|
||||||
|
--- a/handy.h
|
||||||
|
+++ b/handy.h
|
||||||
|
@@ -2409,17 +2409,17 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe
|
||||||
|
#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d)))
|
||||||
|
#endif
|
||||||
|
|
||||||
|
-#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
+#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), (void)memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
|
||||||
|
-#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
-#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
+#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
|
||||||
|
#ifdef HAS_MEMSET
|
||||||
|
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)))
|
||||||
|
#else
|
||||||
|
/* Using bzero(), which returns void. */
|
||||||
|
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)),d)
|
||||||
|
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)),d)
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)))
|
||||||
|
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||||
|
index 15c193b..f1c57bc 100644
|
||||||
|
--- a/pp_ctl.c
|
||||||
|
+++ b/pp_ctl.c
|
||||||
|
@@ -1971,7 +1971,8 @@ PP(pp_caller)
|
||||||
|
|
||||||
|
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
|
||||||
|
av_extend(PL_dbargs, AvFILLp(ary) + off);
|
||||||
|
- Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
|
||||||
|
+ if (AvFILLp(ary) + 1 + off)
|
||||||
|
+ Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
|
||||||
|
AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
|
||||||
|
}
|
||||||
|
mPUSHi(CopHINTS_get(cx->blk_oldcop));
|
||||||
|
diff --git a/pp_hot.c b/pp_hot.c
|
||||||
|
index 5899413..66b79ea 100644
|
||||||
|
--- a/pp_hot.c
|
||||||
|
+++ b/pp_hot.c
|
||||||
|
@@ -4138,7 +4138,8 @@ PP(pp_entersub)
|
||||||
|
AvARRAY(av) = ary;
|
||||||
|
}
|
||||||
|
|
||||||
|
- Copy(MARK+1,AvARRAY(av),items,SV*);
|
||||||
|
+ if (items)
|
||||||
|
+ Copy(MARK+1,AvARRAY(av),items,SV*);
|
||||||
|
AvFILLp(av) = items - 1;
|
||||||
|
}
|
||||||
|
if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
||||||
@ -0,0 +1,223 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,54 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,211 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,105 @@
|
|||||||
|
From dc1f8f6b581a8e4efbb782398ab3e7c3a52b062f Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Tue, 8 May 2018 12:13:18 -0600
|
||||||
|
Subject: [PATCH] PATCH: [perl #133185] Infinite loop in qr//
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This loop was inadvertently introduced as part of patches to fix
|
||||||
|
(perl #132227 CVE-2018-6797] heap-buffer-overflow". The commit in 5.27
|
||||||
|
responsible was f8fb8615ddc5a80e3bbd4386a8914497f921b62d.
|
||||||
|
|
||||||
|
To be vulnerable, the pattern must start out as /d (hence no use 5.012
|
||||||
|
or higher), and then there must be something that implicitly forces /u
|
||||||
|
(which the \pp does in the test case added by this patch), and then
|
||||||
|
(?aa), and then the code point \xDF. (German Sharp S). The /i must be
|
||||||
|
in effect by the time the DF is encountered, but it needn't come in the
|
||||||
|
(?aa) which the test does.
|
||||||
|
|
||||||
|
The problem is that the conditional that is testing that we switched
|
||||||
|
away from /d rules is assuming that this happened during the
|
||||||
|
construction of the current EXACTFish node. The comments I wrote
|
||||||
|
indicate this assumption. But this example shows that the switch can
|
||||||
|
come before this node started getting constructed, and so it loops.
|
||||||
|
|
||||||
|
The patch explicitly saves the state at the beginning of this node's
|
||||||
|
construction, and only retries if it changed during that construction.
|
||||||
|
Therefore the next time through, it will see that it hasn't changed
|
||||||
|
since the previous time, and won't loop.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.2 from:
|
||||||
|
|
||||||
|
commit 0b9cb33b146b3eb55634853f883a880771dd1413
|
||||||
|
Author: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Tue May 8 12:13:18 2018 -0600
|
||||||
|
|
||||||
|
PATCH: [perl #133185] Infinite loop in qr//
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
regcomp.c | 10 +++++++++-
|
||||||
|
t/re/speed.t | 5 ++++-
|
||||||
|
2 files changed, 13 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/regcomp.c b/regcomp.c
|
||||||
|
index 845e660..18fa465 100644
|
||||||
|
--- a/regcomp.c
|
||||||
|
+++ b/regcomp.c
|
||||||
|
@@ -13100,6 +13100,10 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
bool maybe_exactfu = PASS2
|
||||||
|
&& (node_type == EXACTF || node_type == EXACTFL);
|
||||||
|
|
||||||
|
+ /* To see if RExC_uni_semantics changes during parsing of the node.
|
||||||
|
+ * */
|
||||||
|
+ bool uni_semantics_at_node_start;
|
||||||
|
+
|
||||||
|
/* If a folding node contains only code points that don't
|
||||||
|
* participate in folds, it can be changed into an EXACT node,
|
||||||
|
* which allows the optimizer more things to look for */
|
||||||
|
@@ -13147,6 +13151,8 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
|| UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
|
||||||
|
|| UTF8_IS_START(UCHARAT(RExC_parse)));
|
||||||
|
|
||||||
|
+ uni_semantics_at_node_start = RExC_uni_semantics;
|
||||||
|
+
|
||||||
|
/* Here, we have a literal character. Find the maximal string of
|
||||||
|
* them in the input that we can fit into a single EXACTish node.
|
||||||
|
* We quit at the first non-literal or when the node gets full */
|
||||||
|
@@ -13550,7 +13556,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||||
|
* didn't think it needed to reparse. But this
|
||||||
|
* sharp s now does indicate the need for
|
||||||
|
* reparsing. */
|
||||||
|
- if (RExC_uni_semantics) {
|
||||||
|
+ if ( uni_semantics_at_node_start
|
||||||
|
+ != RExC_uni_semantics)
|
||||||
|
+ {
|
||||||
|
p = oldp;
|
||||||
|
goto loopdone;
|
||||||
|
}
|
||||||
|
diff --git a/t/re/speed.t b/t/re/speed.t
|
||||||
|
index 4a4830f..9a57de1 100644
|
||||||
|
--- a/t/re/speed.t
|
||||||
|
+++ b/t/re/speed.t
|
||||||
|
@@ -24,7 +24,7 @@ BEGIN {
|
||||||
|
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
|
||||||
|
skip_all_without_unicode_tables();
|
||||||
|
|
||||||
|
-plan tests => 58; #** update watchdog timeouts proportionally when adding tests
|
||||||
|
+plan tests => 59; #** update watchdog timeouts proportionally when adding tests
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
@@ -156,6 +156,9 @@ PROG
|
||||||
|
ok( $elapsed <= 1, "should not COW on long string with substr and m//g");
|
||||||
|
}
|
||||||
|
|
||||||
|
+ # [perl #133185] Infinite loop
|
||||||
|
+ like("!\xdf", eval 'qr/\pp(?aai)\xdf/',
|
||||||
|
+ 'Compiling qr/\pp(?aai)\xdf/ doesn\'t loop');
|
||||||
|
|
||||||
|
} # End of sub run_tests
|
||||||
|
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
||||||
@ -0,0 +1,143 @@
|
|||||||
|
From 07ebe9c4fb1028d17e61caabe8c15abd0cd48983 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Thu, 29 Jun 2017 11:31:14 +0200
|
||||||
|
Subject: [PATCH] Parse caret vars with subscripts the same as normal vars
|
||||||
|
inside of ${..} escaping
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This behavior is discussed in perl #131664, which complains that
|
||||||
|
"${^CAPTURE}[0]" does not work as expected. Abigail explains the
|
||||||
|
behavior is by design and Eirik Berg Hanssen expands on that explanation
|
||||||
|
pointing out that what /should/ work, "${^CAPTURE[0]}" does not,
|
||||||
|
which Sawyer then ruled was a bug.
|
||||||
|
|
||||||
|
So this patch makes "${^CAPTURE[0]}" (and "${^CAPTURE [0]}" [hi
|
||||||
|
abigial]) work the same as they would if the var was called @foo.
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.2-RC1.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/base/lex.t | 28 +++++++++++++++++++++++++++-
|
||||||
|
toke.c | 46 +++++++++++++++++++++++++---------------------
|
||||||
|
2 files changed, 52 insertions(+), 22 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/base/lex.t b/t/base/lex.t
|
||||||
|
index 99fd3bb..ae17bbd 100644
|
||||||
|
--- a/t/base/lex.t
|
||||||
|
+++ b/t/base/lex.t
|
||||||
|
@@ -1,6 +1,6 @@
|
||||||
|
#!./perl
|
||||||
|
|
||||||
|
-print "1..112\n";
|
||||||
|
+print "1..119\n";
|
||||||
|
|
||||||
|
$x = 'x';
|
||||||
|
|
||||||
|
@@ -154,6 +154,32 @@ my $test = 31;
|
||||||
|
print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1;
|
||||||
|
print "ok $test\n"; $test++;
|
||||||
|
# print "($@)\n" if $@;
|
||||||
|
+#
|
||||||
|
+ ${^TEST}= "splat";
|
||||||
|
+ @{^TEST}= ("foo", "bar");
|
||||||
|
+ %{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST}" ne "splat";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST}[0]" ne "splat[0]";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST[0]}" ne "foo";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${ ^TEST [1] }" ne "bar";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST}{foo}" ne "splat{foo}";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${^TEST{foo}}" ne "FOO";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${ ^TEST {bar} }" ne "BAR";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
|
||||||
|
# Now let's make sure that caret variables are all forced into the main package.
|
||||||
|
package Someother;
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index ee9c464..aff785b 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -9416,19 +9416,36 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
|
||||||
|
bool skip;
|
||||||
|
char *s2;
|
||||||
|
/* If we were processing {...} notation then... */
|
||||||
|
- if (isIDFIRST_lazy_if_safe(d, e, is_utf8)) {
|
||||||
|
- /* if it starts as a valid identifier, assume that it is one.
|
||||||
|
- (the later check for } being at the expected point will trap
|
||||||
|
- cases where this doesn't pan out.) */
|
||||||
|
- d += is_utf8 ? UTF8SKIP(d) : 1;
|
||||||
|
- parse_ident(&s, &d, e, 1, is_utf8, TRUE);
|
||||||
|
- *d = '\0';
|
||||||
|
+ if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
|
||||||
|
+ || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
|
||||||
|
+ && isWORDCHAR(*s))
|
||||||
|
+ ) {
|
||||||
|
+ /* note we have to check for a normal identifier first,
|
||||||
|
+ * as it handles utf8 symbols, and only after that has
|
||||||
|
+ * been ruled out can we look at the caret words */
|
||||||
|
+ if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
|
||||||
|
+ /* if it starts as a valid identifier, assume that it is one.
|
||||||
|
+ (the later check for } being at the expected point will trap
|
||||||
|
+ cases where this doesn't pan out.) */
|
||||||
|
+ d += is_utf8 ? UTF8SKIP(d) : 1;
|
||||||
|
+ parse_ident(&s, &d, e, 1, is_utf8, TRUE);
|
||||||
|
+ *d = '\0';
|
||||||
|
+ }
|
||||||
|
+ else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
|
||||||
|
+ d++;
|
||||||
|
+ while (isWORDCHAR(*s) && d < e) {
|
||||||
|
+ *d++ = *s++;
|
||||||
|
+ }
|
||||||
|
+ if (d >= e)
|
||||||
|
+ Perl_croak(aTHX_ "%s", ident_too_long);
|
||||||
|
+ *d = '\0';
|
||||||
|
+ }
|
||||||
|
tmp_copline = CopLINE(PL_curcop);
|
||||||
|
if (s < PL_bufend && isSPACE(*s)) {
|
||||||
|
s = skipspace(s);
|
||||||
|
}
|
||||||
|
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
|
||||||
|
- /* ${foo[0]} and ${foo{bar}} notation. */
|
||||||
|
+ /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
|
||||||
|
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
|
||||||
|
const char * const brack =
|
||||||
|
(const char *)
|
||||||
|
@@ -9447,19 +9464,6 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
|
||||||
|
return s;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
- /* Handle extended ${^Foo} variables
|
||||||
|
- * 1999-02-27 mjd-perl-patch@plover.com */
|
||||||
|
- else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
|
||||||
|
- && isWORDCHAR(*s))
|
||||||
|
- {
|
||||||
|
- d++;
|
||||||
|
- while (isWORDCHAR(*s) && d < e) {
|
||||||
|
- *d++ = *s++;
|
||||||
|
- }
|
||||||
|
- if (d >= e)
|
||||||
|
- Perl_croak(aTHX_ "%s", ident_too_long);
|
||||||
|
- *d = '\0';
|
||||||
|
- }
|
||||||
|
|
||||||
|
if ( !tmp_copline )
|
||||||
|
tmp_copline = CopLINE(PL_curcop);
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
||||||
@ -0,0 +1,45 @@
|
|||||||
|
From edea384e57453b0a62de58445eed1fded18c1cca Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Thu, 29 Jun 2017 13:20:49 +0200
|
||||||
|
Subject: [PATCH] add an additional test for whitespace tolerance in caret
|
||||||
|
word-vars
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Petr Písař: Ported to 5.26.2-RC1.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/base/lex.t | 7 +++++--
|
||||||
|
1 file changed, 5 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/base/lex.t b/t/base/lex.t
|
||||||
|
index ae17bbd..414aa1f 100644
|
||||||
|
--- a/t/base/lex.t
|
||||||
|
+++ b/t/base/lex.t
|
||||||
|
@@ -1,6 +1,6 @@
|
||||||
|
#!./perl
|
||||||
|
|
||||||
|
-print "1..119\n";
|
||||||
|
+print "1..120\n";
|
||||||
|
|
||||||
|
$x = 'x';
|
||||||
|
|
||||||
|
@@ -158,9 +158,12 @@ my $test = 31;
|
||||||
|
${^TEST}= "splat";
|
||||||
|
@{^TEST}= ("foo", "bar");
|
||||||
|
%{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
|
||||||
|
-
|
||||||
|
+
|
||||||
|
print "not " if "${^TEST}" ne "splat";
|
||||||
|
print "ok $test\n"; $test++;
|
||||||
|
+
|
||||||
|
+ print "not " if "${ ^TEST }" ne "splat";
|
||||||
|
+ print "ok $test\n"; $test++;
|
||||||
|
|
||||||
|
print "not " if "${^TEST}[0]" ne "splat[0]";
|
||||||
|
print "ok $test\n"; $test++;
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
||||||
@ -0,0 +1,90 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,32 @@
|
|||||||
|
From e80af1fd276d83858d27742ea887415e3263960b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Wed, 12 Oct 2016 10:42:47 +1100
|
||||||
|
Subject: [PATCH] (perl 129183) don't treat \ as an escape in PATH for -S
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
util.c | 5 ++---
|
||||||
|
1 file changed, 2 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/util.c b/util.c
|
||||||
|
index 5bb0dfc..6bc2fe5 100644
|
||||||
|
--- a/util.c
|
||||||
|
+++ b/util.c
|
||||||
|
@@ -3352,9 +3352,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
|
||||||
|
if (len < sizeof tmpbuf)
|
||||||
|
tmpbuf[len] = '\0';
|
||||||
|
# else
|
||||||
|
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
|
||||||
|
- ':',
|
||||||
|
- &len);
|
||||||
|
+ s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
|
||||||
|
+ ':', &len);
|
||||||
|
# endif
|
||||||
|
if (s < bufend)
|
||||||
|
s++;
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,258 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,45 @@
|
|||||||
|
From b4d257e2d408f0f1c6686dcdc112f3ebfec68f44 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Yves Orton <demerphq@gmail.com>
|
||||||
|
Date: Tue, 27 Jun 2017 10:22:23 +0200
|
||||||
|
Subject: [PATCH] File::Glob - tweak rt131211.t to be less sensitive on wonky
|
||||||
|
boxes
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
make the test less senstive and avoid divide by zero errors,
|
||||||
|
also we skip the test if either elapsed_match or elapsed_fail is
|
||||||
|
true, as we can not rely on the timings then. For the operations
|
||||||
|
we are doing we should get a non-zero timing from Time::HiRes.
|
||||||
|
|
||||||
|
This should mean that running this test on boxes with heavy
|
||||||
|
load, etc, will no longer result in false positives.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/File-Glob/t/rt131211.t | 9 +++++++--
|
||||||
|
1 file changed, 7 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/File-Glob/t/rt131211.t b/ext/File-Glob/t/rt131211.t
|
||||||
|
index c1bcbe0..b29cd04 100644
|
||||||
|
--- a/ext/File-Glob/t/rt131211.t
|
||||||
|
+++ b/ext/File-Glob/t/rt131211.t
|
||||||
|
@@ -49,8 +49,13 @@ while (++$count < 10) {
|
||||||
|
is $count,10,
|
||||||
|
"tried all the patterns without bailing out";
|
||||||
|
|
||||||
|
-cmp_ok $elapsed_fail/$elapsed_match,"<",2,
|
||||||
|
- "time to fail less than twice the time to match";
|
||||||
|
+SKIP: {
|
||||||
|
+ skip "unstable timing", 1 unless $elapsed_match && $elapsed_fail;
|
||||||
|
+ ok $elapsed_fail <= 10 * $elapsed_match,
|
||||||
|
+ "time to fail less than 10x the time to match"
|
||||||
|
+ or diag("elapsed_match=$elapsed_match elapsed_fail=$elapsed_fail");
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
is "@got_files", catfile($path, $files[0]),
|
||||||
|
"only got the expected file for xa*..b";
|
||||||
|
is "@no_files", "", "shouldnt have files for xa*..c";
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,226 @@
|
|||||||
|
From 5aca16e032861ea3dfcc96ad417ea87e2b1552e5 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Aaron Crane <arc@cpan.org>
|
||||||
|
Date: Sat, 4 Mar 2017 12:50:58 +0000
|
||||||
|
Subject: [PATCH] RT #130907: Fix the Unicode Bug in split " "
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Ported to 5.26.0:
|
||||||
|
|
||||||
|
commit 20ae58f7a9bbf84d043d6e90f5988b6e3ca4ee3d
|
||||||
|
Author: Aaron Crane <arc@cpan.org>
|
||||||
|
Date: Sat Mar 4 12:50:58 2017 +0000
|
||||||
|
|
||||||
|
RT #130907: Fix the Unicode Bug in split " "
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
lib/feature.pm | 5 +++--
|
||||||
|
pod/perldelta.pod | 9 +++++++++
|
||||||
|
pod/perlfunc.pod | 8 ++++++++
|
||||||
|
pod/perlunicode.pod | 11 +++++++++++
|
||||||
|
pod/perluniintro.pod | 5 +++--
|
||||||
|
pp.c | 13 +++++++++++++
|
||||||
|
regen/feature.pl | 5 +++--
|
||||||
|
t/op/split.t | 20 +++++++++++++++++++-
|
||||||
|
8 files changed, 69 insertions(+), 7 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/lib/feature.pm b/lib/feature.pm
|
||||||
|
index ed13273..93e020b 100644
|
||||||
|
--- a/lib/feature.pm
|
||||||
|
+++ b/lib/feature.pm
|
||||||
|
@@ -175,8 +175,9 @@ C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
|
||||||
|
|
||||||
|
This feature is available starting with Perl 5.12; was almost fully
|
||||||
|
implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>;
|
||||||
|
-and extended further in Perl 5.26 to cover L<the range
|
||||||
|
-operator|perlop/Range Operators>.
|
||||||
|
+was extended further in Perl 5.26 to cover L<the range
|
||||||
|
+operator|perlop/Range Operators>; and was extended again in Perl 5.28 to
|
||||||
|
+cover L<special-cased whitespace splitting|perlfunc/split>.
|
||||||
|
|
||||||
|
=head2 The 'unicode_eval' and 'evalbytes' features
|
||||||
|
|
||||||
|
#diff --git a/pod/perldelta.pod b/pod/perldelta.pod
|
||||||
|
#index 06dcd1d..d31335f 100644
|
||||||
|
#--- a/pod/perldelta.pod
|
||||||
|
#+++ b/pod/perldelta.pod
|
||||||
|
#@@ -3206,6 +3206,15 @@ calls.
|
||||||
|
# Parsing bad POSIX charclasses no longer leaks memory.
|
||||||
|
# L<[perl #128313]|https://rt.perl.org/Public/Bug/Display.html?id=128313>
|
||||||
|
#
|
||||||
|
#+=item *
|
||||||
|
#+
|
||||||
|
#+C<split ' '> now correctly handles the argument being split when in the
|
||||||
|
#+scope of the L<< C<unicode_strings>|feature/"The 'unicode_strings' feature"
|
||||||
|
#+>> feature. Previously, when a string using the single-byte internal
|
||||||
|
#+representation contained characters that are whitespace by Unicode rules but
|
||||||
|
#+not by ASCII rules, it treated those characters as part of fields rather
|
||||||
|
#+than as field separators. [perl #130907]
|
||||||
|
#+
|
||||||
|
# =back
|
||||||
|
#
|
||||||
|
# =head1 Known Problems
|
||||||
|
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
|
||||||
|
index b8dca6e..9abadf4 100644
|
||||||
|
--- a/pod/perlfunc.pod
|
||||||
|
+++ b/pod/perlfunc.pod
|
||||||
|
@@ -7616,6 +7616,14 @@ special case was restricted to the use of a plain S<C<" ">> as the
|
||||||
|
pattern argument to split; in Perl 5.18.0 and later this special case is
|
||||||
|
triggered by any expression which evaluates to the simple string S<C<" ">>.
|
||||||
|
|
||||||
|
+As of Perl 5.28, this special-cased whitespace splitting works as expected in
|
||||||
|
+the scope of L<< S<C<"use feature 'unicode_strings">>|feature/The
|
||||||
|
+'unicode_strings' feature >>. In previous versions, and outside the scope of
|
||||||
|
+that feature, it exhibits L<perlunicode/The "Unicode Bug">: characters that are
|
||||||
|
+whitespace according to Unicode rules but not according to ASCII rules can be
|
||||||
|
+treated as part of fields rather than as field separators, depending on the
|
||||||
|
+string's internal encoding.
|
||||||
|
+
|
||||||
|
If omitted, PATTERN defaults to a single space, S<C<" ">>, triggering
|
||||||
|
the previously described I<awk> emulation.
|
||||||
|
|
||||||
|
diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod
|
||||||
|
index 9c13c35..2e84e95 100644
|
||||||
|
--- a/pod/perlunicode.pod
|
||||||
|
+++ b/pod/perlunicode.pod
|
||||||
|
@@ -1835,6 +1835,17 @@ outside its scope, it could produce strings whose length in characters
|
||||||
|
exceeded that of the right-hand side, where the right-hand side took up more
|
||||||
|
bytes than the correct range endpoint.
|
||||||
|
|
||||||
|
+=item *
|
||||||
|
+
|
||||||
|
+In L<< C<split>'s special-case whitespace splitting|perlfunc/split >>.
|
||||||
|
+
|
||||||
|
+Starting in Perl 5.28.0, the C<split> function with a pattern specified as
|
||||||
|
+a string containing a single space handles whitespace characters consistently
|
||||||
|
+within the scope of of C<unicode_strings>. Prior to that, or outside its scope,
|
||||||
|
+characters that are whitespace according to Unicode rules but not according to
|
||||||
|
+ASCII rules were treated as field contents rather than field separators when
|
||||||
|
+they appear in byte-encoded strings.
|
||||||
|
+
|
||||||
|
=back
|
||||||
|
|
||||||
|
You can see from the above that the effect of C<unicode_strings>
|
||||||
|
diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod
|
||||||
|
index d35de34..595ec46 100644
|
||||||
|
--- a/pod/perluniintro.pod
|
||||||
|
+++ b/pod/perluniintro.pod
|
||||||
|
@@ -151,11 +151,12 @@ serious Unicode work. The maintenance release 5.6.1 fixed many of the
|
||||||
|
problems of the initial Unicode implementation, but for example
|
||||||
|
regular expressions still do not work with Unicode in 5.6.1.
|
||||||
|
Perl v5.14.0 is the first release where Unicode support is
|
||||||
|
-(almost) seamlessly integrable without some gotchas. (There are two
|
||||||
|
+(almost) seamlessly integrable without some gotchas. (There are a few
|
||||||
|
exceptions. Firstly, some differences in L<quotemeta|perlfunc/quotemeta>
|
||||||
|
were fixed starting in Perl 5.16.0. Secondly, some differences in
|
||||||
|
L<the range operator|perlop/Range Operators> were fixed starting in
|
||||||
|
-Perl 5.26.0.)
|
||||||
|
+Perl 5.26.0. Thirdly, some differences in L<split|perlfunc/split> were fixed
|
||||||
|
+started in Perl 5.28.0.)
|
||||||
|
|
||||||
|
To enable this
|
||||||
|
seamless support, you should C<use feature 'unicode_strings'> (which is
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index cc4cb59..d9dd005 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -5740,6 +5740,7 @@ PP(pp_split)
|
||||||
|
STRLEN len;
|
||||||
|
const char *s = SvPV_const(sv, len);
|
||||||
|
const bool do_utf8 = DO_UTF8(sv);
|
||||||
|
+ const bool in_uni_8_bit = IN_UNI_8_BIT;
|
||||||
|
const char *strend = s + len;
|
||||||
|
PMOP *pm = cPMOPx(PL_op);
|
||||||
|
REGEXP *rx;
|
||||||
|
@@ -5826,6 +5827,10 @@ PP(pp_split)
|
||||||
|
while (s < strend && isSPACE_LC(*s))
|
||||||
|
s++;
|
||||||
|
}
|
||||||
|
+ else if (in_uni_8_bit) {
|
||||||
|
+ while (s < strend && isSPACE_L1(*s))
|
||||||
|
+ s++;
|
||||||
|
+ }
|
||||||
|
else {
|
||||||
|
while (s < strend && isSPACE(*s))
|
||||||
|
s++;
|
||||||
|
@@ -5857,6 +5862,10 @@ PP(pp_split)
|
||||||
|
{
|
||||||
|
while (m < strend && !isSPACE_LC(*m))
|
||||||
|
++m;
|
||||||
|
+ }
|
||||||
|
+ else if (in_uni_8_bit) {
|
||||||
|
+ while (m < strend && !isSPACE_L1(*m))
|
||||||
|
+ ++m;
|
||||||
|
} else {
|
||||||
|
while (m < strend && !isSPACE(*m))
|
||||||
|
++m;
|
||||||
|
@@ -5891,6 +5900,10 @@ PP(pp_split)
|
||||||
|
{
|
||||||
|
while (s < strend && isSPACE_LC(*s))
|
||||||
|
++s;
|
||||||
|
+ }
|
||||||
|
+ else if (in_uni_8_bit) {
|
||||||
|
+ while (s < strend && isSPACE_L1(*s))
|
||||||
|
+ ++s;
|
||||||
|
} else {
|
||||||
|
while (s < strend && isSPACE(*s))
|
||||||
|
++s;
|
||||||
|
diff --git a/regen/feature.pl b/regen/feature.pl
|
||||||
|
index 579120e..8a4ce63 100755
|
||||||
|
--- a/regen/feature.pl
|
||||||
|
+++ b/regen/feature.pl
|
||||||
|
@@ -485,8 +485,9 @@ C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
|
||||||
|
|
||||||
|
This feature is available starting with Perl 5.12; was almost fully
|
||||||
|
implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>;
|
||||||
|
-and extended further in Perl 5.26 to cover L<the range
|
||||||
|
-operator|perlop/Range Operators>.
|
||||||
|
+was extended further in Perl 5.26 to cover L<the range
|
||||||
|
+operator|perlop/Range Operators>; and was extended again in Perl 5.28 to
|
||||||
|
+cover L<special-cased whitespace splitting|perlfunc/split>.
|
||||||
|
|
||||||
|
=head2 The 'unicode_eval' and 'evalbytes' features
|
||||||
|
|
||||||
|
diff --git a/t/op/split.t b/t/op/split.t
|
||||||
|
index d60bcaf..038c5d7 100644
|
||||||
|
--- a/t/op/split.t
|
||||||
|
+++ b/t/op/split.t
|
||||||
|
@@ -7,7 +7,7 @@ BEGIN {
|
||||||
|
set_up_inc('../lib');
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan tests => 163;
|
||||||
|
+plan tests => 172;
|
||||||
|
|
||||||
|
$FS = ':';
|
||||||
|
|
||||||
|
@@ -480,6 +480,24 @@ is($cnt, scalar(@ary));
|
||||||
|
qq{split(\$cond ? qr/ / : " ", "$exp") behaves as expected over repeated similar patterns};
|
||||||
|
}
|
||||||
|
|
||||||
|
+SKIP: {
|
||||||
|
+ # RT #130907: unicode_strings feature doesn't work with split ' '
|
||||||
|
+
|
||||||
|
+ my ($sp) = grep /\s/u, map chr, reverse 128 .. 255 # prefer \xA0 over \x85
|
||||||
|
+ or skip 'no unicode whitespace found in high-8-bit range', 9;
|
||||||
|
+
|
||||||
|
+ for (["$sp$sp. /", "leading unicode whitespace"],
|
||||||
|
+ [".$sp$sp/", "unicode whitespace separator"],
|
||||||
|
+ [". /$sp$sp", "trailing unicode whitespace"]) {
|
||||||
|
+ my ($str, $desc) = @$_;
|
||||||
|
+ use feature "unicode_strings";
|
||||||
|
+ my @got = split " ", $str;
|
||||||
|
+ is @got, 2, "whitespace split: $desc: field count";
|
||||||
|
+ is $got[0], '.', "whitespace split: $desc: field 0";
|
||||||
|
+ is $got[1], '/', "whitespace split: $desc: field 1";
|
||||||
|
+ }
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
{
|
||||||
|
# 'RT #116086: split "\x20" does not work as documented';
|
||||||
|
my @results;
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,51 @@
|
|||||||
|
From b9a58d500dd75ba783abac92a56e57d41227f62b Mon Sep 17 00:00:00 2001
|
||||||
|
From: Father Chrysostomos <sprout@cpan.org>
|
||||||
|
Date: Sun, 2 Jul 2017 11:35:20 -0700
|
||||||
|
Subject: [PATCH] =?UTF-8?q?[perl=20#131679]=20Fix=20=E2=80=98our=20sub=20f?=
|
||||||
|
=?UTF-8?q?oo::bar=E2=80=99=20message?=
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
It should say subroutine, not variable.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/lib/croak/toke | 6 ++++++
|
||||||
|
toke.c | 3 ++-
|
||||||
|
2 files changed, 8 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/lib/croak/toke b/t/lib/croak/toke
|
||||||
|
index 7aa15ef..2603224 100644
|
||||||
|
--- a/t/lib/croak/toke
|
||||||
|
+++ b/t/lib/croak/toke
|
||||||
|
@@ -133,6 +133,12 @@ state sub;
|
||||||
|
EXPECT
|
||||||
|
Missing name in "state sub" at - line 2.
|
||||||
|
########
|
||||||
|
+# NAME our sub pack::foo
|
||||||
|
+our sub foo::bar;
|
||||||
|
+EXPECT
|
||||||
|
+No package name allowed for subroutine &foo::bar in "our" at - line 1, near "our sub foo::bar"
|
||||||
|
+Execution of - aborted due to compilation errors.
|
||||||
|
+########
|
||||||
|
# NAME my sub pack::foo
|
||||||
|
use feature 'lexical_subs', 'state';
|
||||||
|
my sub foo::bar;
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index ace92e3..6aa5f26 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -8848,7 +8848,8 @@ S_pending_ident(pTHX)
|
||||||
|
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
|
||||||
|
if (has_colon)
|
||||||
|
yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
|
||||||
|
- "variable %s in \"our\"",
|
||||||
|
+ "%se %s in \"our\"",
|
||||||
|
+ *PL_tokenbuf=='&' ?"subroutin":"variabl",
|
||||||
|
PL_tokenbuf), UTF ? SVf_UTF8 : 0);
|
||||||
|
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,30 @@
|
|||||||
|
From 97e57bec1f0ba4f0c3b1dc18ee146632010e3373 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Sat, 15 Jul 2017 19:36:25 -0600
|
||||||
|
Subject: [PATCH] t/lib/warnings/utf8: Fix test
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
There is some randomness to this test added to fix [perl #131646].
|
||||||
|
Change what passes to be a pattern that matches the correct template
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/lib/warnings/utf8 | 3 ++-
|
||||||
|
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8
|
||||||
|
index 9066308..dfc58c1 100644
|
||||||
|
--- a/t/lib/warnings/utf8
|
||||||
|
+++ b/t/lib/warnings/utf8
|
||||||
|
@@ -781,4 +781,5 @@ no warnings;
|
||||||
|
use warnings 'utf8';
|
||||||
|
for(uc 0..t){0~~pack"UXc",exp}
|
||||||
|
EXPECT
|
||||||
|
-Malformed UTF-8 character: \xc2\x00 (unexpected non-continuation byte 0x00, immediately after start byte 0xc2; need 2 bytes, got 1) in smart match at - line 9.
|
||||||
|
+OPTIONS regex
|
||||||
|
+Malformed UTF-8 character: \\x([[:xdigit:]]{2})\\x([[:xdigit:]]{2}) \(unexpected non-continuation byte 0x\2, immediately after start byte 0x\1; need 2 bytes, got 1\) in smart match at - line 9.
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,43 @@
|
|||||||
|
From 05b9033b464ce8dd2c9b33238f9aa14755d7a91a Mon Sep 17 00:00:00 2001
|
||||||
|
From: Karl Williamson <khw@cpan.org>
|
||||||
|
Date: Sat, 17 Jun 2017 17:56:10 -0600
|
||||||
|
Subject: [PATCH] utf8n_to_uvchr(): Don't display too many bytes in msg
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
When raising a message about malformed UTF-8, we shouldn't display bytes
|
||||||
|
from the next character, unless those bytes were expected to have been
|
||||||
|
part of the current one. Tests for this will be added in future commits
|
||||||
|
in ext/XS-APItest/t/utf8_warn_base.pl
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
utf8.c | 4 ++--
|
||||||
|
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/utf8.c b/utf8.c
|
||||||
|
index ee5405f..e55a6f1 100644
|
||||||
|
--- a/utf8.c
|
||||||
|
+++ b/utf8.c
|
||||||
|
@@ -1428,7 +1428,7 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
|
||||||
|
if (pack_warn) {
|
||||||
|
message = Perl_form(aTHX_ "%s: %s (overflows)",
|
||||||
|
malformed_text,
|
||||||
|
- _byte_dump_string(s0, send - s0, 0));
|
||||||
|
+ _byte_dump_string(s0, curlen, 0));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
@@ -1554,7 +1554,7 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
|
||||||
|
"%s: %s (overlong; instead use %s to represent"
|
||||||
|
" U+%0*" UVXf ")",
|
||||||
|
malformed_text,
|
||||||
|
- _byte_dump_string(s0, send - s0, 0),
|
||||||
|
+ _byte_dump_string(s0, curlen, 0),
|
||||||
|
_byte_dump_string(tmpbuf, e - tmpbuf, 0),
|
||||||
|
((uv < 256) ? 2 : 4), /* Field width of 2 for
|
||||||
|
small code points */
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,71 @@
|
|||||||
|
From 62e6b70574842d7f2c547d33c85c50228522f685 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Marc-Philip <marc-philip.werner@sap.com>
|
||||||
|
Date: Sun, 8 Apr 2018 12:15:29 -0600
|
||||||
|
Subject: [PATCH] PATCH: [perl #133074] 5.26.1: some coverity fixes
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
we have some coverity code scans here. They have found this
|
||||||
|
uninilialized variable in pp.c and the integer overrun in toke.c.
|
||||||
|
Though it might be possible that these are false positives (no
|
||||||
|
reasonable control path gets there), it's good to mute the scan here to
|
||||||
|
see the real problems easier.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp.c | 1 +
|
||||||
|
toke.c | 8 ++++----
|
||||||
|
2 files changed, 5 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp.c b/pp.c
|
||||||
|
index 5524131658..d777ae4309 100644
|
||||||
|
--- a/pp.c
|
||||||
|
+++ b/pp.c
|
||||||
|
@@ -3727,6 +3727,7 @@ PP(pp_ucfirst)
|
||||||
|
if (! slen) { /* If empty */
|
||||||
|
need = 1; /* still need a trailing NUL */
|
||||||
|
ulen = 0;
|
||||||
|
+ *tmpbuf = '\0';
|
||||||
|
}
|
||||||
|
else if (DO_UTF8(source)) { /* Is the source utf8? */
|
||||||
|
doing_utf8 = TRUE;
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index 3405dc6c89..fc87252bb1 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -9052,7 +9052,7 @@ S_pending_ident(pTHX)
|
||||||
|
HEK * const stashname = HvNAME_HEK(stash);
|
||||||
|
SV * const sym = newSVhek(stashname);
|
||||||
|
sv_catpvs(sym, "::");
|
||||||
|
- sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
|
||||||
|
+ sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
|
||||||
|
pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
|
||||||
|
pl_yylval.opval->op_private = OPpCONST_ENTERED;
|
||||||
|
if (pit != '&')
|
||||||
|
@@ -9080,7 +9080,7 @@ S_pending_ident(pTHX)
|
||||||
|
&& PL_lex_state != LEX_NORMAL
|
||||||
|
&& !PL_lex_brackets)
|
||||||
|
{
|
||||||
|
- GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
|
||||||
|
+ GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||||
|
( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
|
||||||
|
SVt_PVAV);
|
||||||
|
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
|
||||||
|
@@ -9097,11 +9097,11 @@ S_pending_ident(pTHX)
|
||||||
|
/* build ops for a bareword */
|
||||||
|
pl_yylval.opval = newSVOP(OP_CONST, 0,
|
||||||
|
newSVpvn_flags(PL_tokenbuf + 1,
|
||||||
|
- tokenbuf_len - 1,
|
||||||
|
+ tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||||
|
UTF ? SVf_UTF8 : 0 ));
|
||||||
|
pl_yylval.opval->op_private = OPpCONST_ENTERED;
|
||||||
|
if (pit != '&')
|
||||||
|
- gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
|
||||||
|
+ gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
|
||||||
|
(PL_in_eval ? GV_ADDMULTI : GV_ADD)
|
||||||
|
| ( UTF ? SVf_UTF8 : 0 ),
|
||||||
|
((PL_tokenbuf[0] == '$') ? SVt_PV
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
||||||
@ -0,0 +1,45 @@
|
|||||||
|
From 357c35e6f18e65f372e7a1b22ee39a3c7c9e5810 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Robin Barker <RMBarker@cpan.org>
|
||||||
|
Date: Mon, 17 Dec 2012 18:20:14 +0100
|
||||||
|
Subject: [PATCH] Avoid compiler warnings due to mismatched types in *printf
|
||||||
|
format strings.
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
gcc (and probably others) was warning about a mismatch for between `int`
|
||||||
|
(implied by the format %d) and the actual type passed, `line_t`. Avoid this
|
||||||
|
by explicitly casting to UV, and using UVuf.
|
||||||
|
|
||||||
|
CPAN #63832
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm | 7 ++++---
|
||||||
|
1 file changed, 4 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||||
|
index 545d322..c7e6d05 100644
|
||||||
|
--- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||||
|
+++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
|
||||||
|
@@ -629,13 +629,14 @@ EOA
|
||||||
|
if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
|
||||||
|
? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
|
||||||
|
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
|
||||||
|
- ", used at %" COP_FILE_F " line %d\\n", sv,
|
||||||
|
- COP_FILE(cop), CopLINE(cop));
|
||||||
|
+ ", used at %" COP_FILE_F " line %" UVuf "\\n",
|
||||||
|
+ sv, COP_FILE(cop), (UV)CopLINE(cop));
|
||||||
|
} else
|
||||||
|
#endif
|
||||||
|
{
|
||||||
|
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro at %"
|
||||||
|
- COP_FILE_F " line %d\\n", sv, COP_FILE(cop), CopLINE(cop));
|
||||||
|
+ COP_FILE_F " line %" UVuf "\\n",
|
||||||
|
+ sv, COP_FILE(cop), (UV)CopLINE(cop));
|
||||||
|
}
|
||||||
|
croak_sv(sv_2mortal(sv));
|
||||||
|
EOC
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,69 @@
|
|||||||
|
From 389f3ef2fdfbba2c2816e7334a69a5f540c0a33d Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Mon, 15 Dec 2014 16:14:13 +0000
|
||||||
|
Subject: [PATCH] EU::Constant: avoid 'uninit' warning
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
The code generated by ExtUtils::Constant can look something like:
|
||||||
|
|
||||||
|
static int
|
||||||
|
constant (..., IV *iv_return) {
|
||||||
|
switch (...) {
|
||||||
|
case ...:
|
||||||
|
*iv_return = ...;
|
||||||
|
return PERL_constant_ISIV;
|
||||||
|
...
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
{
|
||||||
|
int type;
|
||||||
|
IV iv;
|
||||||
|
type = constant(..., &iv);
|
||||||
|
switch (type) {
|
||||||
|
case PERL_constant_ISIV:
|
||||||
|
PUSHi(iv);
|
||||||
|
...
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
and the compiler isn't clever enough to realise that the value of iv
|
||||||
|
is only used in the code path where its been set.
|
||||||
|
|
||||||
|
So initialise it to zero to shut gcc up. Ditto nv and pv.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm | 6 +++---
|
||||||
|
1 file changed, 3 insertions(+), 3 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||||
|
index 0dc9258..cf0e1ca 100644
|
||||||
|
--- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||||
|
+++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
|
||||||
|
@@ -198,17 +198,17 @@ $XS_subname(sv)
|
||||||
|
EOT
|
||||||
|
|
||||||
|
if ($params->{IV}) {
|
||||||
|
- $xs .= " IV iv;\n";
|
||||||
|
+ $xs .= " IV iv = 0; /* avoid uninit var warning */\n";
|
||||||
|
} else {
|
||||||
|
$xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
|
||||||
|
}
|
||||||
|
if ($params->{NV}) {
|
||||||
|
- $xs .= " NV nv;\n";
|
||||||
|
+ $xs .= " NV nv = 0.0; /* avoid uninit var warning */\n";
|
||||||
|
} else {
|
||||||
|
$xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
|
||||||
|
}
|
||||||
|
if ($params->{PV}) {
|
||||||
|
- $xs .= " const char *pv;\n";
|
||||||
|
+ $xs .= " const char *pv = NULL; /* avoid uninit var warning */\n";
|
||||||
|
} else {
|
||||||
|
$xs .=
|
||||||
|
" /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
|
||||||
|
--
|
||||||
|
2.9.4
|
||||||
|
|
||||||
@ -0,0 +1,30 @@
|
|||||||
|
From 4369267db9ca4982c1a9bd1ef680bc4350decc3a Mon Sep 17 00:00:00 2001
|
||||||
|
From: Tony Cook <tony@develop-help.com>
|
||||||
|
Date: Mon, 18 Sep 2017 15:07:21 +1000
|
||||||
|
Subject: [PATCH] (perl #132008) try to prevent the similar mistakes in the
|
||||||
|
future
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
dist/Term-ReadLine/lib/Term/ReadLine.pm | 2 ++
|
||||||
|
1 file changed, 2 insertions(+)
|
||||||
|
|
||||||
|
diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||||
|
index e00fb376cd..78c1ebf5b6 100644
|
||||||
|
--- a/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||||
|
+++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm
|
||||||
|
@@ -75,6 +75,8 @@ history. Returns the old value.
|
||||||
|
returns an array with two strings that give most appropriate names for
|
||||||
|
files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
|
||||||
|
|
||||||
|
+The strings returned may not be useful for 3-argument open().
|
||||||
|
+
|
||||||
|
=item Attribs
|
||||||
|
|
||||||
|
returns a reference to a hash which describes internal configuration
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
||||||
@ -0,0 +1,32 @@
|
|||||||
|
From e7e69c85c7e8e0cb75b831e606ad4f26f18b11ff Mon Sep 17 00:00:00 2001
|
||||||
|
From: Nicolas R <atoomic@cpan.org>
|
||||||
|
Date: Mon, 31 Oct 2016 11:53:17 -0600
|
||||||
|
Subject: [PATCH] Avoid a segfault when untying an object
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
Check if the tied object has a stash set
|
||||||
|
before calling UNTIE method.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_sys.c | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index 672e7de08e..6d4dd86b7f 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -1017,7 +1017,7 @@ PP(pp_untie)
|
||||||
|
|
||||||
|
if ((mg = SvTIED_mg(sv, how))) {
|
||||||
|
SV * const obj = SvRV(SvTIED_obj(sv, mg));
|
||||||
|
- if (obj) {
|
||||||
|
+ if (obj && SvSTASH(obj)) {
|
||||||
|
GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
|
||||||
|
CV *cv;
|
||||||
|
if (gv && isGV(gv) && (cv = GvCV(gv))) {
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
||||||
@ -0,0 +1,73 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,593 @@
|
|||||||
|
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
|
||||||
|
|
||||||
@ -0,0 +1,34 @@
|
|||||||
|
From 8e7c2faafb74d3b07e8a5818608dfe065e361604 Mon Sep 17 00:00:00 2001
|
||||||
|
From: "Craig A. Berry" <craigberry@mac.com>
|
||||||
|
Date: Mon, 1 Jan 2018 10:10:33 -0600
|
||||||
|
Subject: [PATCH] Reenable numeric first argument of system() on VMS.
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
This was broken in 64def2aeaeb63f92dadc6dfa334, and fixed for Win32
|
||||||
|
only in 8fe3452cc6ac7af8c08. But VMS also uses a numeric first
|
||||||
|
argument to system() as a flag indicating spawn without waiting for
|
||||||
|
completion.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_sys.c | 2 +-
|
||||||
|
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||||
|
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index 0c9147bc4e..5154b9baa8 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -4375,7 +4375,7 @@ PP(pp_system)
|
||||||
|
STRLEN len;
|
||||||
|
char *pv;
|
||||||
|
SvGETMAGIC(origsv);
|
||||||
|
-#ifdef WIN32
|
||||||
|
+#if defined(WIN32) || defined(__VMS)
|
||||||
|
/*
|
||||||
|
* Because of a nasty platform-specific variation on the meaning
|
||||||
|
* of arguments to this op, we must preserve numeric arguments
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
||||||
@ -0,0 +1,73 @@
|
|||||||
|
From 8fe3452cc6ac7af8c08c2044cd3757018a9c8887 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Zefram <zefram@fysh.org>
|
||||||
|
Date: Fri, 22 Dec 2017 05:32:41 +0000
|
||||||
|
Subject: [PATCH] preserve numericness of system() args on Win32
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
On Windows there's a nasty variation in the meaning of arguments
|
||||||
|
to Perl's system(), in which a numeric first argument isn't used as
|
||||||
|
part of the command to run, but instead selects between two different
|
||||||
|
operations to perform with the command (whether to wait for the command
|
||||||
|
to complete or not). Therefore the reduction of argument scalars to
|
||||||
|
their operative values in the parent process, which was added in commit
|
||||||
|
64def2aeaeb63f92dadc6dfa33486c1d7b311963, needs to preserve numericness
|
||||||
|
of arguments on Windows. Fixes [perl #132633].
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
pp_sys.c | 35 +++++++++++++++++++++++++++++++----
|
||||||
|
1 file changed, 31 insertions(+), 4 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/pp_sys.c b/pp_sys.c
|
||||||
|
index beb60da4c6..0649794104 100644
|
||||||
|
--- a/pp_sys.c
|
||||||
|
+++ b/pp_sys.c
|
||||||
|
@@ -4393,12 +4393,39 @@ PP(pp_system)
|
||||||
|
# endif
|
||||||
|
|
||||||
|
while (++MARK <= SP) {
|
||||||
|
- SV *origsv = *MARK;
|
||||||
|
+ SV *origsv = *MARK, *copysv;
|
||||||
|
STRLEN len;
|
||||||
|
char *pv;
|
||||||
|
- pv = SvPV(origsv, len);
|
||||||
|
- *MARK = newSVpvn_flags(pv, len,
|
||||||
|
- (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
|
||||||
|
+ SvGETMAGIC(origsv);
|
||||||
|
+#ifdef WIN32
|
||||||
|
+ /*
|
||||||
|
+ * Because of a nasty platform-specific variation on the meaning
|
||||||
|
+ * of arguments to this op, we must preserve numeric arguments
|
||||||
|
+ * as numeric, not just retain the string value.
|
||||||
|
+ */
|
||||||
|
+ if (SvNIOK(origsv) || SvNIOKp(origsv)) {
|
||||||
|
+ copysv = newSV_type(SVt_PVNV);
|
||||||
|
+ sv_2mortal(copysv);
|
||||||
|
+ if (SvPOK(origsv) || SvPOKp(origsv)) {
|
||||||
|
+ pv = SvPV_nomg(origsv, len);
|
||||||
|
+ sv_setpvn(copysv, pv, len);
|
||||||
|
+ SvPOK_off(copysv);
|
||||||
|
+ }
|
||||||
|
+ if (SvIOK(origsv) || SvIOKp(origsv))
|
||||||
|
+ SvIV_set(copysv, SvIVX(origsv));
|
||||||
|
+ if (SvNOK(origsv) || SvNOKp(origsv))
|
||||||
|
+ SvNV_set(copysv, SvNVX(origsv));
|
||||||
|
+ SvFLAGS(copysv) |= SvFLAGS(origsv) &
|
||||||
|
+ (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK|
|
||||||
|
+ SVf_UTF8|SVf_IVisUV);
|
||||||
|
+ } else
|
||||||
|
+#endif
|
||||||
|
+ {
|
||||||
|
+ pv = SvPV_nomg(origsv, len);
|
||||||
|
+ copysv = newSVpvn_flags(pv, len,
|
||||||
|
+ (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
|
||||||
|
+ }
|
||||||
|
+ *MARK = copysv;
|
||||||
|
}
|
||||||
|
MARK = ORIGMARK;
|
||||||
|
|
||||||
|
--
|
||||||
|
2.13.6
|
||||||
|
|
||||||
@ -0,0 +1,127 @@
|
|||||||
|
From fed9fe5b48ccdffef9065a03c12c237cc7418de6 Mon Sep 17 00:00:00 2001
|
||||||
|
From: Zefram <zefram@fysh.org>
|
||||||
|
Date: Fri, 16 Feb 2018 17:20:34 +0000
|
||||||
|
Subject: [PATCH] don't clobber file bytes in :encoding layer
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
The PerlIO::encoding layer, when used on input, was creating an SvLEN==0
|
||||||
|
scalar pointing into the byte buffer, to pass to the ->decode method
|
||||||
|
of the encoding object. Since the method mutates this scalar, for some
|
||||||
|
encodings this led to mutating the byte buffer, and depending on where
|
||||||
|
it came from that might be something visible elsewhere that should not
|
||||||
|
be mutated. Remove the code for the SvLEN==0 scalar, instead always
|
||||||
|
using the alternate code that would copy the bytes into a separate buffer
|
||||||
|
owned by the scalar. Fixes [perl #132833].
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
ext/PerlIO-encoding/encoding.pm | 2 +-
|
||||||
|
ext/PerlIO-encoding/encoding.xs | 43 ++++++++++------------------------------
|
||||||
|
ext/PerlIO-encoding/t/encoding.t | 12 ++++++++++-
|
||||||
|
3 files changed, 22 insertions(+), 35 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/ext/PerlIO-encoding/encoding.pm b/ext/PerlIO-encoding/encoding.pm
|
||||||
|
index 08d2df4713..3d740b181a 100644
|
||||||
|
--- a/ext/PerlIO-encoding/encoding.pm
|
||||||
|
+++ b/ext/PerlIO-encoding/encoding.pm
|
||||||
|
@@ -1,7 +1,7 @@
|
||||||
|
package PerlIO::encoding;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
-our $VERSION = '0.25';
|
||||||
|
+our $VERSION = '0.26';
|
||||||
|
our $DEBUG = 0;
|
||||||
|
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
|
||||||
|
|
||||||
|
diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs
|
||||||
|
index bb4754f3d9..941d786266 100644
|
||||||
|
--- a/ext/PerlIO-encoding/encoding.xs
|
||||||
|
+++ b/ext/PerlIO-encoding/encoding.xs
|
||||||
|
@@ -307,42 +307,19 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
|
||||||
|
goto end_of_file;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
- if (SvCUR(e->dataSV)) {
|
||||||
|
- /* something left over from last time - create a normal
|
||||||
|
- SV with new data appended
|
||||||
|
- */
|
||||||
|
- if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
|
||||||
|
- if (e->flags & NEEDS_LINES) {
|
||||||
|
- /* Have to grow buffer */
|
||||||
|
- e->base.bufsiz = use + SvCUR(e->dataSV);
|
||||||
|
- PerlIOEncode_get_base(aTHX_ f);
|
||||||
|
- }
|
||||||
|
- else {
|
||||||
|
- use = e->base.bufsiz - SvCUR(e->dataSV);
|
||||||
|
- }
|
||||||
|
- }
|
||||||
|
- sv_catpvn(e->dataSV,(char*)ptr,use);
|
||||||
|
- }
|
||||||
|
- else {
|
||||||
|
- /* Create a "dummy" SV to represent the available data from layer below */
|
||||||
|
- if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
|
||||||
|
- Safefree(SvPVX_mutable(e->dataSV));
|
||||||
|
- }
|
||||||
|
- if (use > (SSize_t)e->base.bufsiz) {
|
||||||
|
- if (e->flags & NEEDS_LINES) {
|
||||||
|
- /* Have to grow buffer */
|
||||||
|
- e->base.bufsiz = use;
|
||||||
|
- PerlIOEncode_get_base(aTHX_ f);
|
||||||
|
- }
|
||||||
|
- else {
|
||||||
|
- use = e->base.bufsiz;
|
||||||
|
+ if (!SvCUR(e->dataSV))
|
||||||
|
+ SvPVCLEAR(e->dataSV);
|
||||||
|
+ if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
|
||||||
|
+ if (e->flags & NEEDS_LINES) {
|
||||||
|
+ /* Have to grow buffer */
|
||||||
|
+ e->base.bufsiz = use + SvCUR(e->dataSV);
|
||||||
|
+ PerlIOEncode_get_base(aTHX_ f);
|
||||||
|
}
|
||||||
|
+ else {
|
||||||
|
+ use = e->base.bufsiz - SvCUR(e->dataSV);
|
||||||
|
}
|
||||||
|
- SvPV_set(e->dataSV, (char *) ptr);
|
||||||
|
- SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
|
||||||
|
- SvCUR_set(e->dataSV,use);
|
||||||
|
- SvPOK_only(e->dataSV);
|
||||||
|
}
|
||||||
|
+ sv_catpvn(e->dataSV,(char*)ptr,use);
|
||||||
|
SvUTF8_off(e->dataSV);
|
||||||
|
PUSHMARK(sp);
|
||||||
|
XPUSHs(e->enc);
|
||||||
|
diff --git a/ext/PerlIO-encoding/t/encoding.t b/ext/PerlIO-encoding/t/encoding.t
|
||||||
|
index 088f89ee20..41cefcb137 100644
|
||||||
|
--- a/ext/PerlIO-encoding/t/encoding.t
|
||||||
|
+++ b/ext/PerlIO-encoding/t/encoding.t
|
||||||
|
@@ -16,7 +16,7 @@ BEGIN {
|
||||||
|
require "../../t/charset_tools.pl";
|
||||||
|
}
|
||||||
|
|
||||||
|
-use Test::More tests => 24;
|
||||||
|
+use Test::More tests => 27;
|
||||||
|
|
||||||
|
my $grk = "grk$$";
|
||||||
|
my $utf = "utf$$";
|
||||||
|
@@ -231,6 +231,16 @@ is $x, "To hymn him who heard her herd herd\n",
|
||||||
|
|
||||||
|
} # SKIP
|
||||||
|
|
||||||
|
+# decoding shouldn't mutate the original bytes [perl #132833]
|
||||||
|
+{
|
||||||
|
+ my $b = "a\0b\0\n\0";
|
||||||
|
+ open my $fh, "<:encoding(UTF16-LE)", \$b or die;
|
||||||
|
+ is scalar(<$fh>), "ab\n";
|
||||||
|
+ is $b, "a\0b\0\n\0";
|
||||||
|
+ close $fh or die;
|
||||||
|
+ is $b, "a\0b\0\n\0";
|
||||||
|
+}
|
||||||
|
+
|
||||||
|
END {
|
||||||
|
1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
||||||
@ -0,0 +1,68 @@
|
|||||||
|
From 823ba440369100de3f2693420a3887a645a57d28 Mon Sep 17 00:00:00 2001
|
||||||
|
From: David Mitchell <davem@iabyn.com>
|
||||||
|
Date: Wed, 7 Mar 2018 09:27:26 +0000
|
||||||
|
Subject: [PATCH] fix line numbers in multi-line s///
|
||||||
|
MIME-Version: 1.0
|
||||||
|
Content-Type: text/plain; charset=UTF-8
|
||||||
|
Content-Transfer-Encoding: 8bit
|
||||||
|
|
||||||
|
my commit v5.25.6-230-g6432a58, "Eliminate SVrepl_EVAL and SvEVALED()",
|
||||||
|
introduced a regression: __LINE__ no longer took account of multiple
|
||||||
|
lines in the s///.
|
||||||
|
|
||||||
|
Now fixed.
|
||||||
|
|
||||||
|
Spotted by Abigail.
|
||||||
|
|
||||||
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||||
|
---
|
||||||
|
t/re/subst.t | 12 +++++++++++-
|
||||||
|
toke.c | 2 +-
|
||||||
|
2 files changed, 12 insertions(+), 2 deletions(-)
|
||||||
|
|
||||||
|
diff --git a/t/re/subst.t b/t/re/subst.t
|
||||||
|
index b9b9939b11..dd62e95ee6 100644
|
||||||
|
--- a/t/re/subst.t
|
||||||
|
+++ b/t/re/subst.t
|
||||||
|
@@ -11,7 +11,7 @@ BEGIN {
|
||||||
|
require './loc_tools.pl';
|
||||||
|
}
|
||||||
|
|
||||||
|
-plan(tests => 275);
|
||||||
|
+plan(tests => 276);
|
||||||
|
|
||||||
|
$_ = 'david';
|
||||||
|
$a = s/david/rules/r;
|
||||||
|
@@ -1163,6 +1163,16 @@ __EOF__
|
||||||
|
pass("RT #130188");
|
||||||
|
}
|
||||||
|
|
||||||
|
+# RT #131930
|
||||||
|
+# a multi-line s/// wasn't resetting the cop_line correctly
|
||||||
|
+{
|
||||||
|
+ my $l0 = __LINE__;
|
||||||
|
+ my $s = "a";
|
||||||
|
+ $s =~ s[a]
|
||||||
|
+ [b];
|
||||||
|
+ my $lines = __LINE__ - $l0;
|
||||||
|
+ is $lines, 4, "RT #131930";
|
||||||
|
+}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
diff --git a/toke.c b/toke.c
|
||||||
|
index 9dbad98408..0ef33415c0 100644
|
||||||
|
--- a/toke.c
|
||||||
|
+++ b/toke.c
|
||||||
|
@@ -9884,7 +9884,7 @@ S_scan_subst(pTHX_ char *start)
|
||||||
|
* the NVX field indicates how many src code lines the replacement
|
||||||
|
* spreads over */
|
||||||
|
sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
|
||||||
|
- ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
|
||||||
|
+ ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
|
||||||
|
((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
|
||||||
|
cBOOL(es);
|
||||||
|
}
|
||||||
|
--
|
||||||
|
2.14.3
|
||||||
|
|
||||||
@ -0,0 +1,94 @@
|
|||||||
|
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,175 +0,0 @@
|
|||||||
From bafffe7f2ca587960177ed03216e2d5692fe6143 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Wed, 19 Aug 2020 11:57:17 -0600
|
|
||||||
Subject: [PATCH] Add av_count()
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
This returns the number of elements in an array in a clearly named
|
|
||||||
function.
|
|
||||||
|
|
||||||
av_top_index(), av_tindex() are clearly named, but are less than ideal,
|
|
||||||
and came about because no one back then thought of this one, until now
|
|
||||||
Paul Evans did.
|
|
||||||
|
|
||||||
Petr Písař: Port 87306e0674dfe3af29804b4641347cd5ac9b0521 to 5.32.0.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
av.c | 17 ++++++++++++++---
|
|
||||||
av.h | 3 ++-
|
|
||||||
embed.fnc | 3 ++-
|
|
||||||
embed.h | 2 +-
|
|
||||||
inline.h | 16 ++++++++++++----
|
|
||||||
proto.h | 11 ++++++++---
|
|
||||||
6 files changed, 39 insertions(+), 13 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/av.c b/av.c
|
|
||||||
index 27b2f12..b5ddaca 100644
|
|
||||||
--- a/av.c
|
|
||||||
+++ b/av.c
|
|
||||||
@@ -814,9 +814,10 @@ The Perl equivalent for this is C<$#myarray>.
|
|
||||||
=for apidoc av_len
|
|
||||||
|
|
||||||
Same as L</av_top_index>. Note that, unlike what the name implies, it returns
|
|
||||||
-the highest index in the array, so to get the size of the array you need to use
|
|
||||||
-S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
|
|
||||||
-expect.
|
|
||||||
+the highest index in the array. This is unlike L</sv_len>, which returns what
|
|
||||||
+you would expect.
|
|
||||||
+
|
|
||||||
+B<To get the true number of elements in the array, instead use C<L</av_count>>>.
|
|
||||||
|
|
||||||
=cut
|
|
||||||
*/
|
|
||||||
@@ -1089,6 +1090,16 @@ Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
|
|
||||||
return sv;
|
|
||||||
}
|
|
||||||
|
|
||||||
+SSize_t
|
|
||||||
+Perl_av_top_index(pTHX_ AV *av)
|
|
||||||
+{
|
|
||||||
+ PERL_ARGS_ASSERT_AV_TOP_INDEX;
|
|
||||||
+ assert(SvTYPE(av) == SVt_PVAV);
|
|
||||||
+
|
|
||||||
+ return AvFILL(av);
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
+
|
|
||||||
/*
|
|
||||||
* ex: set ts=8 sts=4 sw=4 et:
|
|
||||||
*/
|
|
||||||
diff --git a/av.h b/av.h
|
|
||||||
index 5e39c42..90ebfff 100644
|
|
||||||
--- a/av.h
|
|
||||||
+++ b/av.h
|
|
||||||
@@ -81,7 +81,8 @@ Same as C<av_top_index()>.
|
|
||||||
|
|
||||||
#define AvFILL(av) ((SvRMAGICAL((const SV *) (av))) \
|
|
||||||
? mg_size(MUTABLE_SV(av)) : AvFILLp(av))
|
|
||||||
-#define av_tindex(av) av_top_index(av)
|
|
||||||
+#define av_top_index(av) AvFILL(av)
|
|
||||||
+#define av_tindex(av) av_top_index(av)
|
|
||||||
|
|
||||||
/* Note that it doesn't make sense to do this:
|
|
||||||
* SvGETMAGIC(av); IV x = av_tindex_nomg(av);
|
|
||||||
diff --git a/embed.fnc b/embed.fnc
|
|
||||||
index 589ab1a..789cd3c 100644
|
|
||||||
--- a/embed.fnc
|
|
||||||
+++ b/embed.fnc
|
|
||||||
@@ -541,7 +541,8 @@ Apd |void |av_push |NN AV *av|NN SV *val
|
|
||||||
EXp |void |av_reify |NN AV *av
|
|
||||||
ApdR |SV* |av_shift |NN AV *av
|
|
||||||
Apd |SV** |av_store |NN AV *av|SSize_t key|NULLOK SV *val
|
|
||||||
-AidRp |SSize_t|av_top_index |NN AV *av
|
|
||||||
+AMdRp |SSize_t|av_top_index |NN AV *av
|
|
||||||
+AidRp |Size_t |av_count |NN AV *av
|
|
||||||
AmdR |SSize_t|av_tindex |NN AV *av
|
|
||||||
Apd |void |av_undef |NN AV *av
|
|
||||||
Apdoex |SV** |av_create_and_unshift_one|NN AV **const avp|NN SV *const val
|
|
||||||
diff --git a/embed.h b/embed.h
|
|
||||||
index 182b12a..329ac40 100644
|
|
||||||
--- a/embed.h
|
|
||||||
+++ b/embed.h
|
|
||||||
@@ -48,6 +48,7 @@
|
|
||||||
#define atfork_lock Perl_atfork_lock
|
|
||||||
#define atfork_unlock Perl_atfork_unlock
|
|
||||||
#define av_clear(a) Perl_av_clear(aTHX_ a)
|
|
||||||
+#define av_count(a) Perl_av_count(aTHX_ a)
|
|
||||||
#define av_delete(a,b,c) Perl_av_delete(aTHX_ a,b,c)
|
|
||||||
#define av_exists(a,b) Perl_av_exists(aTHX_ a,b)
|
|
||||||
#define av_extend(a,b) Perl_av_extend(aTHX_ a,b)
|
|
||||||
@@ -59,7 +60,6 @@
|
|
||||||
#define av_push(a,b) Perl_av_push(aTHX_ a,b)
|
|
||||||
#define av_shift(a) Perl_av_shift(aTHX_ a)
|
|
||||||
#define av_store(a,b,c) Perl_av_store(aTHX_ a,b,c)
|
|
||||||
-#define av_top_index(a) Perl_av_top_index(aTHX_ a)
|
|
||||||
#define av_undef(a) Perl_av_undef(aTHX_ a)
|
|
||||||
#define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b)
|
|
||||||
#define block_end(a,b) Perl_block_end(aTHX_ a,b)
|
|
||||||
diff --git a/inline.h b/inline.h
|
|
||||||
index 27005d2..35af18a 100644
|
|
||||||
--- a/inline.h
|
|
||||||
+++ b/inline.h
|
|
||||||
@@ -39,13 +39,21 @@ SOFTWARE.
|
|
||||||
|
|
||||||
/* ------------------------------- av.h ------------------------------- */
|
|
||||||
|
|
||||||
-PERL_STATIC_INLINE SSize_t
|
|
||||||
-Perl_av_top_index(pTHX_ AV *av)
|
|
||||||
+/*
|
|
||||||
+=for apidoc av_count
|
|
||||||
+Returns the number of elements in the array C<av>. This is the true length of
|
|
||||||
+the array, including any undefined elements. It is always the same as
|
|
||||||
+S<C<av_top_index(av) + 1>>.
|
|
||||||
+
|
|
||||||
+=cut
|
|
||||||
+*/
|
|
||||||
+PERL_STATIC_INLINE Size_t
|
|
||||||
+Perl_av_count(pTHX_ AV *av)
|
|
||||||
{
|
|
||||||
- PERL_ARGS_ASSERT_AV_TOP_INDEX;
|
|
||||||
+ PERL_ARGS_ASSERT_AV_COUNT;
|
|
||||||
assert(SvTYPE(av) == SVt_PVAV);
|
|
||||||
|
|
||||||
- return AvFILL(av);
|
|
||||||
+ return AvFILL(av) + 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* ------------------------------- cv.h ------------------------------- */
|
|
||||||
diff --git a/proto.h b/proto.h
|
|
||||||
index 02ef4ed..83ba098 100644
|
|
||||||
--- a/proto.h
|
|
||||||
+++ b/proto.h
|
|
||||||
@@ -219,6 +219,13 @@ PERL_CALLCONV SV** Perl_av_arylen_p(pTHX_ AV *av);
|
|
||||||
PERL_CALLCONV void Perl_av_clear(pTHX_ AV *av);
|
|
||||||
#define PERL_ARGS_ASSERT_AV_CLEAR \
|
|
||||||
assert(av)
|
|
||||||
+#ifndef PERL_NO_INLINE_FUNCTIONS
|
|
||||||
+PERL_STATIC_INLINE Size_t Perl_av_count(pTHX_ AV *av)
|
|
||||||
+ __attribute__warn_unused_result__;
|
|
||||||
+#define PERL_ARGS_ASSERT_AV_COUNT \
|
|
||||||
+ assert(av)
|
|
||||||
+#endif
|
|
||||||
+
|
|
||||||
PERL_CALLCONV void Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val);
|
|
||||||
#define PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH \
|
|
||||||
assert(avp); assert(val)
|
|
||||||
@@ -284,12 +291,10 @@ PERL_CALLCONV SV** Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val);
|
|
||||||
__attribute__warn_unused_result__; */
|
|
||||||
#define PERL_ARGS_ASSERT_AV_TINDEX
|
|
||||||
|
|
||||||
-#ifndef PERL_NO_INLINE_FUNCTIONS
|
|
||||||
-PERL_STATIC_INLINE SSize_t Perl_av_top_index(pTHX_ AV *av)
|
|
||||||
+PERL_CALLCONV SSize_t Perl_av_top_index(pTHX_ AV *av)
|
|
||||||
__attribute__warn_unused_result__;
|
|
||||||
#define PERL_ARGS_ASSERT_AV_TOP_INDEX \
|
|
||||||
assert(av)
|
|
||||||
-#endif
|
|
||||||
|
|
||||||
PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av);
|
|
||||||
#define PERL_ARGS_ASSERT_AV_UNDEF \
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,196 +0,0 @@
|
|||||||
From d7504df2a5d8985f2a8b04f17acff5e324572c39 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Richard Leach <richardleach@users.noreply.github.com>
|
|
||||||
Date: Sun, 11 Oct 2020 12:26:27 +0100
|
|
||||||
Subject: [PATCH] pp_split: no SWITCHSTACK in @ary = split(...) optimisation
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Petr Písař: 607eaf26a99ff76ab48877e68f1d7b005dc51575 ported to 5.32.0.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
pp.c | 89 +++++++++++++++++++++++++++++-----------------------
|
|
||||||
t/op/split.t | 23 +++++++++++++-
|
|
||||||
2 files changed, 72 insertions(+), 40 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/pp.c b/pp.c
|
|
||||||
index df80830..e4863d3 100644
|
|
||||||
--- a/pp.c
|
|
||||||
+++ b/pp.c
|
|
||||||
@@ -5985,6 +5985,7 @@ PP(pp_split)
|
|
||||||
|
|
||||||
/* handle @ary = split(...) optimisation */
|
|
||||||
if (PL_op->op_private & OPpSPLIT_ASSIGN) {
|
|
||||||
+ realarray = 1;
|
|
||||||
if (!(PL_op->op_flags & OPf_STACKED)) {
|
|
||||||
if (PL_op->op_private & OPpSPLIT_LEX) {
|
|
||||||
if (PL_op->op_private & OPpLVAL_INTRO)
|
|
||||||
@@ -6007,26 +6008,10 @@ PP(pp_split)
|
|
||||||
oldsave = PL_savestack_ix;
|
|
||||||
}
|
|
||||||
|
|
||||||
- realarray = 1;
|
|
||||||
- PUTBACK;
|
|
||||||
- av_extend(ary,0);
|
|
||||||
- (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
|
|
||||||
- av_clear(ary);
|
|
||||||
- SPAGAIN;
|
|
||||||
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
|
|
||||||
PUSHMARK(SP);
|
|
||||||
XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
|
|
||||||
- }
|
|
||||||
- else {
|
|
||||||
- if (!AvREAL(ary)) {
|
|
||||||
- I32 i;
|
|
||||||
- AvREAL_on(ary);
|
|
||||||
- AvREIFY_off(ary);
|
|
||||||
- for (i = AvFILLp(ary); i >= 0; i--)
|
|
||||||
- AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
|
|
||||||
- }
|
|
||||||
- /* temporarily switch stacks */
|
|
||||||
- SAVESWITCHSTACK(PL_curstack, ary);
|
|
||||||
+ } else {
|
|
||||||
make_mortal = 0;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
@@ -6358,29 +6343,56 @@ PP(pp_split)
|
|
||||||
LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
|
|
||||||
SPAGAIN;
|
|
||||||
if (realarray) {
|
|
||||||
- if (!mg) {
|
|
||||||
- if (SvSMAGICAL(ary)) {
|
|
||||||
- PUTBACK;
|
|
||||||
+ if (!mg) {
|
|
||||||
+ PUTBACK;
|
|
||||||
+ if(AvREAL(ary)) {
|
|
||||||
+ if (av_count(ary) > 0)
|
|
||||||
+ av_clear(ary);
|
|
||||||
+ } else {
|
|
||||||
+ AvREAL_on(ary);
|
|
||||||
+ AvREIFY_off(ary);
|
|
||||||
+
|
|
||||||
+ if (AvMAX(ary) > -1) {
|
|
||||||
+ /* don't free mere refs */
|
|
||||||
+ Zero(AvARRAY(ary), AvMAX(ary), SV*);
|
|
||||||
+ }
|
|
||||||
+ }
|
|
||||||
+ if(AvMAX(ary) < iters)
|
|
||||||
+ av_extend(ary,iters);
|
|
||||||
+ SPAGAIN;
|
|
||||||
+
|
|
||||||
+ /* Need to copy the SV*s from the stack into ary */
|
|
||||||
+ Copy(SP + 1 - iters, AvARRAY(ary), iters, SV*);
|
|
||||||
+ AvFILLp(ary) = iters - 1;
|
|
||||||
+
|
|
||||||
+ if (SvSMAGICAL(ary)) {
|
|
||||||
+ PUTBACK;
|
|
||||||
mg_set(MUTABLE_SV(ary));
|
|
||||||
SPAGAIN;
|
|
||||||
- }
|
|
||||||
- if (gimme == G_ARRAY) {
|
|
||||||
- EXTEND(SP, iters);
|
|
||||||
- Copy(AvARRAY(ary), SP + 1, iters, SV*);
|
|
||||||
- SP += iters;
|
|
||||||
- RETURN;
|
|
||||||
- }
|
|
||||||
+ }
|
|
||||||
+
|
|
||||||
+ if (gimme != G_ARRAY) {
|
|
||||||
+ /* SP points to the final SV* pushed to the stack. But the SV* */
|
|
||||||
+ /* are not going to be used from the stack. Point SP to below */
|
|
||||||
+ /* the first of these SV*. */
|
|
||||||
+ SP -= iters;
|
|
||||||
+ PUTBACK;
|
|
||||||
+ }
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
- PUTBACK;
|
|
||||||
- ENTER_with_name("call_PUSH");
|
|
||||||
- call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
|
|
||||||
- LEAVE_with_name("call_PUSH");
|
|
||||||
- SPAGAIN;
|
|
||||||
+ PUTBACK;
|
|
||||||
+ av_extend(ary,iters);
|
|
||||||
+ av_clear(ary);
|
|
||||||
+
|
|
||||||
+ ENTER_with_name("call_PUSH");
|
|
||||||
+ call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
|
|
||||||
+ LEAVE_with_name("call_PUSH");
|
|
||||||
+ SPAGAIN;
|
|
||||||
+
|
|
||||||
if (gimme == G_ARRAY) {
|
|
||||||
SSize_t i;
|
|
||||||
/* EXTEND should not be needed - we just popped them */
|
|
||||||
- EXTEND(SP, iters);
|
|
||||||
+ EXTEND_SKIP(SP, iters);
|
|
||||||
for (i=0; i < iters; i++) {
|
|
||||||
SV **svp = av_fetch(ary, i, FALSE);
|
|
||||||
PUSHs((svp) ? *svp : &PL_sv_undef);
|
|
||||||
@@ -6389,13 +6401,12 @@ PP(pp_split)
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
- else {
|
|
||||||
- if (gimme == G_ARRAY)
|
|
||||||
- RETURN;
|
|
||||||
- }
|
|
||||||
|
|
||||||
- GETTARGET;
|
|
||||||
- XPUSHi(iters);
|
|
||||||
+ if (gimme != G_ARRAY) {
|
|
||||||
+ GETTARGET;
|
|
||||||
+ XPUSHi(iters);
|
|
||||||
+ }
|
|
||||||
+
|
|
||||||
RETURN;
|
|
||||||
}
|
|
||||||
|
|
||||||
diff --git a/t/op/split.t b/t/op/split.t
|
|
||||||
index 14f9158..7f37512 100644
|
|
||||||
--- a/t/op/split.t
|
|
||||||
+++ b/t/op/split.t
|
|
||||||
@@ -7,7 +7,7 @@ BEGIN {
|
|
||||||
set_up_inc('../lib');
|
|
||||||
}
|
|
||||||
|
|
||||||
-plan tests => 176;
|
|
||||||
+plan tests => 182;
|
|
||||||
|
|
||||||
$FS = ':';
|
|
||||||
|
|
||||||
@@ -648,6 +648,19 @@ is "@a", '1 2 3', 'assignment to split-to-array (stacked)';
|
|
||||||
is (+@a, 0, "empty utf8 string");
|
|
||||||
}
|
|
||||||
|
|
||||||
+# correct stack adjustments (gh#18232)
|
|
||||||
+{
|
|
||||||
+ sub foo { return @_ }
|
|
||||||
+ my @a = foo(1, scalar split " ", "a b");
|
|
||||||
+ is(join('', @a), "12", "Scalar split to a sub parameter");
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
+{
|
|
||||||
+ sub foo { return @_ }
|
|
||||||
+ my @a = foo(1, scalar(@x = split " ", "a b"));
|
|
||||||
+ is(join('', @a), "12", "Split to @x then use scalar result as a sub parameter");
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
fresh_perl_is(<<'CODE', '', {}, "scalar split stack overflow");
|
|
||||||
map{int"";split//.0>60for"0000000000000000"}split// for"00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
|
|
||||||
CODE
|
|
||||||
@@ -667,3 +680,11 @@ CODE
|
|
||||||
ok(eq_array(\@result,['a','b']), "Resulting in ('a','b')");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
+
|
|
||||||
+# check that the (@ary = split) optimisation survives @ary being modified
|
|
||||||
+
|
|
||||||
+fresh_perl_is('my @ary; @ary = split(/\w(?{ @ary[1000] = 1 })/, "abc");',
|
|
||||||
+ '',{},'(@ary = split ...) survives @ary being Renew()ed');
|
|
||||||
+fresh_perl_is('my @ary; @ary = split(/\w(?{ undef @ary })/, "abc");',
|
|
||||||
+ '',{},'(@ary = split ...) survives an (undef @ary)');
|
|
||||||
+
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,34 +0,0 @@
|
|||||||
From ab72b7bd043df0f0ad6090a4c95f378624fad9fc Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Sat, 7 Mar 2020 12:54:19 -0700
|
|
||||||
Subject: [PATCH] DynaLoader: use PerlEnv_getenv()
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Doing so invokes thread-safe guards
|
|
||||||
|
|
||||||
Petr Písař: Ported from b0312014d6c1804920d2b687a5fa5645b445ce9f to
|
|
||||||
5.32.1.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
ext/DynaLoader/dlutils.c | 2 +-
|
|
||||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c
|
|
||||||
index 8584f89..1a27fbd 100644
|
|
||||||
--- a/ext/DynaLoader/dlutils.c
|
|
||||||
+++ b/ext/DynaLoader/dlutils.c
|
|
||||||
@@ -115,7 +115,7 @@ dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS)
|
|
||||||
- if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL
|
|
||||||
+ if ( (perl_dl_nonlazy = PerlEnv_getenv("PERL_DL_NONLAZY")) != NULL
|
|
||||||
&& grok_atoUV(perl_dl_nonlazy, &uv, NULL)
|
|
||||||
&& uv <= INT_MAX
|
|
||||||
) {
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,44 +0,0 @@
|
|||||||
From 2ce7bf1ad5fd7aee21975b3dd1c8dceef3aab7e4 Mon Sep 17 00:00:00 2001
|
|
||||||
From: David Mitchell <davem@iabyn.com>
|
|
||||||
Date: Tue, 9 Mar 2021 16:42:11 +0000
|
|
||||||
Subject: [PATCH] Perl_do_sv_dump(): handle PL_strtab
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
When dumping this special hash, the values in the HE entry are refcounts
|
|
||||||
rather than SV pointers. sv_dump() used to crash here.
|
|
||||||
|
|
||||||
Petr Písař: Ported to 5.32.1 from upstream
|
|
||||||
a9bb6a62ae45bb372a5cca98a76d1a79edd89ccb.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
dump.c | 11 +++++++++--
|
|
||||||
1 file changed, 9 insertions(+), 2 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/dump.c b/dump.c
|
|
||||||
index f03c3f6..0f15d77 100644
|
|
||||||
--- a/dump.c
|
|
||||||
+++ b/dump.c
|
|
||||||
@@ -2224,8 +2224,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
|
|
||||||
PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
|
|
||||||
if (HvEITER_get(hv) == he)
|
|
||||||
PerlIO_printf(file, "[CURRENT] ");
|
|
||||||
- PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
|
|
||||||
- do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
|
|
||||||
+ PerlIO_printf(file, "HASH = 0x%" UVxf, (UV) hash);
|
|
||||||
+
|
|
||||||
+ if (sv == (SV*)PL_strtab)
|
|
||||||
+ PerlIO_printf(file, " REFCNT = 0x%" UVxf "\n",
|
|
||||||
+ (UV)he->he_valu.hent_refcount );
|
|
||||||
+ else {
|
|
||||||
+ (void)PerlIO_putc(file, '\n');
|
|
||||||
+ do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
|
|
||||||
+ }
|
|
||||||
}
|
|
||||||
}
|
|
||||||
DONEHV:;
|
|
||||||
--
|
|
||||||
2.26.3
|
|
||||||
|
|
||||||
@ -1,53 +0,0 @@
|
|||||||
From c5eed6e541fe27d9e9dfd31f42c43f4dfa1f486b Mon Sep 17 00:00:00 2001
|
|
||||||
From: Yves Orton <demerphq@gmail.com>
|
|
||||||
Date: Sat, 11 Jul 2020 09:26:21 +0200
|
|
||||||
Subject: [PATCH] hv.c: add a guard clause to prevent the number of buckets in
|
|
||||||
a hash from getting too large
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
This caps it at 1<<28 buckets, eg, ~268M. In theory without a guard clause like
|
|
||||||
this we could grow to the point of possibly wrapping around in terms of size,
|
|
||||||
not to mention being ridiculously wasteful of memory at larger sizes.
|
|
||||||
Even this cap is probably too high. It should probably be something like 1<<24.
|
|
||||||
|
|
||||||
Petr Písař: Ported to 5.32.1 from
|
|
||||||
aae087f7cec022be14a17deb95cb2208e16b7891.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
hv.c | 10 +++++++++-
|
|
||||||
1 file changed, 9 insertions(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/hv.c b/hv.c
|
|
||||||
index eccae62..32dbd19 100644
|
|
||||||
--- a/hv.c
|
|
||||||
+++ b/hv.c
|
|
||||||
@@ -38,7 +38,13 @@ holds the key and hash value.
|
|
||||||
* NOTE if you change this formula so we split earlier than previously
|
|
||||||
* you MUST change the logic in hv_ksplit()
|
|
||||||
*/
|
|
||||||
-#define DO_HSPLIT(xhv) ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1)) > (xhv)->xhv_max )
|
|
||||||
+
|
|
||||||
+/* MAX_BUCKET_MAX is the maximum max bucket index, at which point we stop growing the
|
|
||||||
+ * number of buckets,
|
|
||||||
+ */
|
|
||||||
+#define MAX_BUCKET_MAX ((1<<26)-1)
|
|
||||||
+#define DO_HSPLIT(xhv) ( ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1)) > (xhv)->xhv_max ) && \
|
|
||||||
+ ((xhv)->xhv_max < MAX_BUCKET_MAX) )
|
|
||||||
#define HV_FILL_THRESHOLD 31
|
|
||||||
|
|
||||||
static const char S_strtab_error[]
|
|
||||||
@@ -1426,6 +1432,8 @@ S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
|
|
||||||
);
|
|
||||||
|
|
||||||
PERL_ARGS_ASSERT_HSPLIT;
|
|
||||||
+ if (newsize > MAX_BUCKET_MAX+1)
|
|
||||||
+ return;
|
|
||||||
|
|
||||||
PL_nomemok = TRUE;
|
|
||||||
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,30 +0,0 @@
|
|||||||
From 3c53c6179afbdbef748c110abdb849cb463c2727 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Todd Rinaldo <toddr@cpan.org>
|
|
||||||
Date: Thu, 30 Jul 2020 17:42:47 -0500
|
|
||||||
Subject: [PATCH] Add missing MANIFEST entry from fix for debugger
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Add on fix to #17901
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
MANIFEST | 1 +
|
|
||||||
1 file changed, 1 insertion(+)
|
|
||||||
|
|
||||||
diff --git a/MANIFEST b/MANIFEST
|
|
||||||
index 990a75ad52..12601e46b4 100644
|
|
||||||
--- a/MANIFEST
|
|
||||||
+++ b/MANIFEST
|
|
||||||
@@ -4826,6 +4826,7 @@ lib/perl5db/t/symbol-table-bug Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/taint Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/test-a-statement-1 Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/test-a-statement-2 Tests for the Perl debugger
|
|
||||||
+lib/perl5db/t/test-a-statement-3 Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/test-dieLevel-option-1 Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/test-frame-option-1 Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/test-l-statement-1 Tests for the Perl debugger
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,90 +0,0 @@
|
|||||||
From b248789b64d6bd277c52bfe608ed3192023af1bd Mon Sep 17 00:00:00 2001
|
|
||||||
From: "E. Choroba" <choroba@matfyz.cz>
|
|
||||||
Date: Fri, 26 Jun 2020 21:19:24 +0200
|
|
||||||
Subject: [PATCH] After running an action in the debugger, turn it off
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
When running with "c", there was no problem, but when running with "n"
|
|
||||||
or "s", once the action was executed, it kept executing on the
|
|
||||||
following lines, which wasn't expected. Clearing $action here prevents
|
|
||||||
this unwanted behaviour.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
lib/perl5db.pl | 3 ++-
|
|
||||||
lib/perl5db.t | 22 ++++++++++++++++++++++
|
|
||||||
lib/perl5db/t/test-a-statement-3 | 6 ++++++
|
|
||||||
3 files changed, 30 insertions(+), 1 deletion(-)
|
|
||||||
create mode 100644 lib/perl5db/t/test-a-statement-3
|
|
||||||
|
|
||||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
|
|
||||||
index 69a9bb6e64..e04a0e17fa 100644
|
|
||||||
--- a/lib/perl5db.pl
|
|
||||||
+++ b/lib/perl5db.pl
|
|
||||||
@@ -529,7 +529,7 @@ BEGIN {
|
|
||||||
use vars qw($VERSION $header);
|
|
||||||
|
|
||||||
# bump to X.XX in blead, only use X.XX_XX in maint
|
|
||||||
-$VERSION = '1.57';
|
|
||||||
+$VERSION = '1.58';
|
|
||||||
|
|
||||||
$header = "perl5db.pl version $VERSION";
|
|
||||||
|
|
||||||
@@ -2708,6 +2708,7 @@ If there are any preprompt actions, execute those as well.
|
|
||||||
# The &-call is here to ascertain the mutability of @_.
|
|
||||||
&DB::eval;
|
|
||||||
}
|
|
||||||
+ undef $action;
|
|
||||||
|
|
||||||
# Are we nested another level (e.g., did we evaluate a function
|
|
||||||
# that had a breakpoint in it at the debugger prompt)?
|
|
||||||
diff --git a/lib/perl5db.t b/lib/perl5db.t
|
|
||||||
index 421229a54a..913a301d98 100644
|
|
||||||
--- a/lib/perl5db.t
|
|
||||||
+++ b/lib/perl5db.t
|
|
||||||
@@ -2799,6 +2799,28 @@ SKIP:
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
+{
|
|
||||||
+ # GitHub #17901
|
|
||||||
+ my $wrapper = DebugWrap->new(
|
|
||||||
+ {
|
|
||||||
+ cmds =>
|
|
||||||
+ [
|
|
||||||
+ 'a 4 $s++',
|
|
||||||
+ ('s') x 5,
|
|
||||||
+ 'x $s',
|
|
||||||
+ 'q'
|
|
||||||
+ ],
|
|
||||||
+ prog => '../lib/perl5db/t/test-a-statement-3',
|
|
||||||
+ switches => [ '-d' ],
|
|
||||||
+ stderr => 0,
|
|
||||||
+ }
|
|
||||||
+ );
|
|
||||||
+ $wrapper->contents_like(
|
|
||||||
+ qr/^0 +2$/m,
|
|
||||||
+ 'Test that the a command runs only on the given lines.',
|
|
||||||
+ );
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
{
|
|
||||||
# perl 5 RT #126735 regression bug.
|
|
||||||
local $ENV{PERLDB_OPTS} = "NonStop=0 RemotePort=non-existent-host.tld:9001";
|
|
||||||
diff --git a/lib/perl5db/t/test-a-statement-3 b/lib/perl5db/t/test-a-statement-3
|
|
||||||
new file mode 100644
|
|
||||||
index 0000000000..b188c1c5c5
|
|
||||||
--- /dev/null
|
|
||||||
+++ b/lib/perl5db/t/test-a-statement-3
|
|
||||||
@@ -0,0 +1,6 @@
|
|
||||||
+use strict; use warnings;
|
|
||||||
+
|
|
||||||
+for my $x (1 .. 2) {
|
|
||||||
+ my $y = $x + 1;
|
|
||||||
+ my $x = $x - 1;
|
|
||||||
+}
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,33 +0,0 @@
|
|||||||
From 589464a875768e4b4a609d972488e3b592103097 Mon Sep 17 00:00:00 2001
|
|
||||||
From: "E. Choroba" <choroba@matfyz.cz>
|
|
||||||
Date: Mon, 27 Jul 2020 11:32:51 +0200
|
|
||||||
Subject: [PATCH] Clearing DB::action at the end is no longer needed
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
as it's cleared right after it's been run.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
lib/perl5db.pl | 4 ----
|
|
||||||
1 file changed, 4 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
|
|
||||||
index e04a0e17fa..af3b972da0 100644
|
|
||||||
--- a/lib/perl5db.pl
|
|
||||||
+++ b/lib/perl5db.pl
|
|
||||||
@@ -3347,10 +3347,6 @@ use B<o> I<inhibit_exit> to avoid stopping after program termination,
|
|
||||||
B<h q>, B<h R> or B<h o> to get additional info.
|
|
||||||
EOP
|
|
||||||
|
|
||||||
- # Set the DB::eval context appropriately.
|
|
||||||
- # At program termination disable any user actions.
|
|
||||||
- $DB::action = undef;
|
|
||||||
-
|
|
||||||
$DB::package = 'main';
|
|
||||||
$DB::usercontext = DB::_calc_usercontext($DB::package);
|
|
||||||
} ## end elsif ($package eq 'DB::fake')
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,74 +0,0 @@
|
|||||||
From 8a2562bec7cd9f8eff6812f340f99dddd028bb33 Mon Sep 17 00:00:00 2001
|
|
||||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
|
||||||
Date: Thu, 6 Aug 2020 10:51:56 +0200
|
|
||||||
Subject: [PATCH] IO::Handle: Fix a spurious error reported for regular file
|
|
||||||
handles
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
89341f87 fix for GH #6799 introduced a regression when calling error()
|
|
||||||
on an IO::Handle object that was opened for reading a regular file:
|
|
||||||
|
|
||||||
$ perl -e 'open my $f, q{<}, q{/etc/hosts} or die; print qq{error\n} if $f->error'
|
|
||||||
error
|
|
||||||
|
|
||||||
In case of a regular file opened for reading, IoOFP() returns NULL and
|
|
||||||
PerlIO_error(NULL) reports -1. Compare to the case of a file opened
|
|
||||||
for writing when both IoIFP() and IoOFP() return non-NULL, equaled
|
|
||||||
pointer.
|
|
||||||
|
|
||||||
This patch fixes handling the case of the NULL output stream.
|
|
||||||
|
|
||||||
GH #18019
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
dist/IO/IO.xs | 4 ++--
|
|
||||||
dist/IO/t/io_xs.t | 10 +++++++++-
|
|
||||||
2 files changed, 11 insertions(+), 3 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
|
|
||||||
index 9158106416..fb009774c4 100644
|
|
||||||
--- a/dist/IO/IO.xs
|
|
||||||
+++ b/dist/IO/IO.xs
|
|
||||||
@@ -397,9 +397,9 @@ ferror(handle)
|
|
||||||
CODE:
|
|
||||||
if (in)
|
|
||||||
#ifdef PerlIO
|
|
||||||
- RETVAL = PerlIO_error(in) || (in != out && PerlIO_error(out));
|
|
||||||
+ RETVAL = PerlIO_error(in) || (out && in != out && PerlIO_error(out));
|
|
||||||
#else
|
|
||||||
- RETVAL = ferror(in) || (in != out && ferror(out));
|
|
||||||
+ RETVAL = ferror(in) || (out && in != out && ferror(out));
|
|
||||||
#endif
|
|
||||||
else {
|
|
||||||
RETVAL = -1;
|
|
||||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t
|
|
||||||
index a8833b0651..4657088629 100644
|
|
||||||
--- a/dist/IO/t/io_xs.t
|
|
||||||
+++ b/dist/IO/t/io_xs.t
|
|
||||||
@@ -11,7 +11,7 @@ BEGIN {
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
-use Test::More tests => 8;
|
|
||||||
+use Test::More tests => 10;
|
|
||||||
use IO::File;
|
|
||||||
use IO::Seekable;
|
|
||||||
|
|
||||||
@@ -69,3 +69,11 @@ SKIP: {
|
|
||||||
ok(!$fh->error, "check clearerr removed the error");
|
|
||||||
close $fh; # silently ignore the error
|
|
||||||
}
|
|
||||||
+
|
|
||||||
+{
|
|
||||||
+ # [GH #18019] IO::Handle->error misreported an error after successully
|
|
||||||
+ # opening a regular file for reading. It was a regression in GH #6799 fix.
|
|
||||||
+ ok(open(my $fh, '<', __FILE__), "a regular file opened for reading");
|
|
||||||
+ ok(!$fh->error, "no spurious error reported by error()");
|
|
||||||
+ close $fh;
|
|
||||||
+}
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,80 +0,0 @@
|
|||||||
From fc5f3468dcbee38eb202cfd552a5b8dbff990c7b Mon Sep 17 00:00:00 2001
|
|
||||||
From: Tony Cook <tony@develop-help.com>
|
|
||||||
Date: Tue, 12 May 2020 10:59:08 +1000
|
|
||||||
Subject: [PATCH 2/2] IO::Handle: clear the error on both input and output
|
|
||||||
streams
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Similarly to GH #6799 clearerr() only cleared the error status
|
|
||||||
of the input stream, so clear both.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
dist/IO/IO.xs | 14 +++++++++++---
|
|
||||||
dist/IO/t/io_xs.t | 8 +++++---
|
|
||||||
2 files changed, 16 insertions(+), 6 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
|
|
||||||
index 99d523d2c1..9158106416 100644
|
|
||||||
--- a/dist/IO/IO.xs
|
|
||||||
+++ b/dist/IO/IO.xs
|
|
||||||
@@ -410,13 +410,21 @@ ferror(handle)
|
|
||||||
|
|
||||||
int
|
|
||||||
clearerr(handle)
|
|
||||||
- InputStream handle
|
|
||||||
+ SV * handle
|
|
||||||
+ PREINIT:
|
|
||||||
+ IO *io = sv_2io(handle);
|
|
||||||
+ InputStream in = IoIFP(io);
|
|
||||||
+ OutputStream out = IoOFP(io);
|
|
||||||
CODE:
|
|
||||||
if (handle) {
|
|
||||||
#ifdef PerlIO
|
|
||||||
- PerlIO_clearerr(handle);
|
|
||||||
+ PerlIO_clearerr(in);
|
|
||||||
+ if (in != out)
|
|
||||||
+ PerlIO_clearerr(out);
|
|
||||||
#else
|
|
||||||
- clearerr(handle);
|
|
||||||
+ clearerr(in);
|
|
||||||
+ if (in != out)
|
|
||||||
+ clearerr(out);
|
|
||||||
#endif
|
|
||||||
RETVAL = 0;
|
|
||||||
}
|
|
||||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t
|
|
||||||
index f890e92558..a8833b0651 100644
|
|
||||||
--- a/dist/IO/t/io_xs.t
|
|
||||||
+++ b/dist/IO/t/io_xs.t
|
|
||||||
@@ -11,7 +11,7 @@ BEGIN {
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
-use Test::More tests => 7;
|
|
||||||
+use Test::More tests => 8;
|
|
||||||
use IO::File;
|
|
||||||
use IO::Seekable;
|
|
||||||
|
|
||||||
@@ -58,12 +58,14 @@ SKIP: {
|
|
||||||
# This isn't really a Linux/BSD specific test, but /dev/full is (I
|
|
||||||
# hope) reasonably well defined on these. Patches welcome if your platform
|
|
||||||
# also supports it (or something like it)
|
|
||||||
- skip "no /dev/full or not a /dev/full platform", 2
|
|
||||||
+ skip "no /dev/full or not a /dev/full platform", 3
|
|
||||||
unless $^O =~ /^(linux|netbsd|freebsd)$/ && -c "/dev/full";
|
|
||||||
open my $fh, ">", "/dev/full"
|
|
||||||
- or skip "Could not open /dev/full: $!", 2;
|
|
||||||
+ or skip "Could not open /dev/full: $!", 3;
|
|
||||||
$fh->print("a" x 1024);
|
|
||||||
ok(!$fh->flush, "should fail to flush");
|
|
||||||
ok($fh->error, "stream should be in error");
|
|
||||||
+ $fh->clearerr;
|
|
||||||
+ ok(!$fh->error, "check clearerr removed the error");
|
|
||||||
close $fh; # silently ignore the error
|
|
||||||
}
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,61 +0,0 @@
|
|||||||
From c6439962c995d4d7052af9fb3f92da93c1584b84 Mon Sep 17 00:00:00 2001
|
|
||||||
From: vividsnow <vividsnow@gmail.com>
|
|
||||||
Date: Fri, 31 Jul 2020 00:37:58 +0300
|
|
||||||
Subject: [PATCH] IO::Socket::UNIX: synchronize behavior with module
|
|
||||||
documentation (#17787)
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
* synchronize behavior with module documentation
|
|
||||||
|
|
||||||
IO::Socket docs states that passing Blocking => 0 will be set socket to non-blocking mode
|
|
||||||
|
|
||||||
* Update AUTHORS
|
|
||||||
* bump version
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
AUTHORS | 1 +
|
|
||||||
dist/IO/lib/IO/Socket/UNIX.pm | 6 +++++-
|
|
||||||
2 files changed, 6 insertions(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/AUTHORS b/AUTHORS
|
|
||||||
index 577ba7d0ee..299fdec8a8 100644
|
|
||||||
--- a/AUTHORS
|
|
||||||
+++ b/AUTHORS
|
|
||||||
@@ -1293,6 +1293,7 @@ Ville Skyttä <scop@cs132170.pp.htv.fi>
|
|
||||||
Vincent Pit <perl@profvince.com>
|
|
||||||
Vishal Bhatia <vishal@deja.com>
|
|
||||||
Vitali Peil <vitali.peil@uni-bielefeld.de>
|
|
||||||
+vividsnow <vividsnow@gmail.com>
|
|
||||||
Vlad Harchev <hvv@hippo.ru>
|
|
||||||
Vladimir Alexiev <vladimir@cs.ualberta.ca>
|
|
||||||
Vladimir Marek <vlmarek@volny.cz>
|
|
||||||
diff --git a/dist/IO/lib/IO/Socket/UNIX.pm b/dist/IO/lib/IO/Socket/UNIX.pm
|
|
||||||
index 04b36eaf74..14d0b27a8c 100644
|
|
||||||
--- a/dist/IO/lib/IO/Socket/UNIX.pm
|
|
||||||
+++ b/dist/IO/lib/IO/Socket/UNIX.pm
|
|
||||||
@@ -11,7 +11,7 @@ use IO::Socket;
|
|
||||||
use Carp;
|
|
||||||
|
|
||||||
our @ISA = qw(IO::Socket);
|
|
||||||
-our $VERSION = "1.41";
|
|
||||||
+our $VERSION = "1.42";
|
|
||||||
|
|
||||||
IO::Socket::UNIX->register_domain( AF_UNIX );
|
|
||||||
|
|
||||||
@@ -30,6 +30,10 @@ sub configure {
|
|
||||||
$sock->socket(AF_UNIX, $type, 0) or
|
|
||||||
return undef;
|
|
||||||
|
|
||||||
+ if(exists $arg->{Blocking}) {
|
|
||||||
+ $sock->blocking($arg->{Blocking}) or
|
|
||||||
+ return undef;
|
|
||||||
+ }
|
|
||||||
if(exists $arg->{Local}) {
|
|
||||||
my $addr = sockaddr_un($arg->{Local});
|
|
||||||
$sock->bind($addr) or
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,32 +0,0 @@
|
|||||||
From 6c2255e0e80e0dc00c7fd96e073f1f524bbaa3e0 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Mon, 29 Jun 2020 09:21:24 -0600
|
|
||||||
Subject: [PATCH] MUTABLE_PTR() Rmv non-standard syntax
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Variables in C are beginning with an underscore are reserved for use by
|
|
||||||
the C implementation. Change this non-conformant usage.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
handy.h | 2 +-
|
|
||||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/handy.h b/handy.h
|
|
||||||
index 287e2e206d..890b2b11a2 100644
|
|
||||||
--- a/handy.h
|
|
||||||
+++ b/handy.h
|
|
||||||
@@ -54,7 +54,7 @@ Null SV pointer. (No longer available when C<PERL_CORE> is defined.)
|
|
||||||
*/
|
|
||||||
|
|
||||||
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
|
|
||||||
-# define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
|
|
||||||
+# define MUTABLE_PTR(p) ({ void *p_ = (p); p_; })
|
|
||||||
#else
|
|
||||||
# define MUTABLE_PTR(p) ((void *) (p))
|
|
||||||
#endif
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,33 +0,0 @@
|
|||||||
From b26a606d84ae1a6da560c7cd71d1a33c0dc7178e Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Sun, 14 Jun 2020 12:26:02 -0600
|
|
||||||
Subject: [PATCH] Update pod for SvTRUE, to indicate single param evaluation
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
5.32 changed this macro into an inline function so that 'sv' only gets
|
|
||||||
evaluated once, but didn't update the documentation to reflect that.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
sv.h | 3 ++-
|
|
||||||
1 file changed, 2 insertions(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/sv.h b/sv.h
|
|
||||||
index 3721b2fb1b..ad8accbf1a 100644
|
|
||||||
--- a/sv.h
|
|
||||||
+++ b/sv.h
|
|
||||||
@@ -1607,7 +1607,8 @@ false. See C<L</SvOK>> for a defined/undefined test. Handles 'get' magic
|
|
||||||
unless the scalar is already C<SvPOK>, C<SvIOK> or C<SvNOK> (the public, not the
|
|
||||||
private flags).
|
|
||||||
|
|
||||||
-See C<L</SvTRUEx>> for a version which guarantees to evaluate C<sv> only once.
|
|
||||||
+As of Perl 5.32, this is guaranteed to evaluate C<sv> only once. Prior to that
|
|
||||||
+release, use C<L</SvTRUEx>> for single evaluation.
|
|
||||||
|
|
||||||
=for apidoc Am|bool|SvTRUE_nomg|SV* sv
|
|
||||||
Returns a boolean indicating whether Perl would evaluate the SV as true or
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,45 +0,0 @@
|
|||||||
From 313464947382fab07299af0061f419a55540356a Mon Sep 17 00:00:00 2001
|
|
||||||
From: Tomasz Konojacki <me@xenu.pl>
|
|
||||||
Date: Mon, 27 Apr 2020 08:31:47 +0200
|
|
||||||
Subject: [PATCH] XSUB.h: fix MARK and items variables inside BOOT XSUBs
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
ax was incremented by Perl_xs_handshake() and because of that
|
|
||||||
MARK and items were off by one inside BOOT XSUBs.
|
|
||||||
|
|
||||||
fixes #17755
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
XSUB.h | 6 +++---
|
|
||||||
1 file changed, 3 insertions(+), 3 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/XSUB.h b/XSUB.h
|
|
||||||
index e3147ce9fb..5f17a5acde 100644
|
|
||||||
--- a/XSUB.h
|
|
||||||
+++ b/XSUB.h
|
|
||||||
@@ -160,16 +160,16 @@ is a lexical C<$_> in scope.
|
|
||||||
PL_xsubfilename. */
|
|
||||||
#define dXSBOOTARGSXSAPIVERCHK \
|
|
||||||
I32 ax = XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \
|
|
||||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS
|
|
||||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS
|
|
||||||
#define dXSBOOTARGSAPIVERCHK \
|
|
||||||
I32 ax = XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \
|
|
||||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS
|
|
||||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS
|
|
||||||
/* dXSBOOTARGSNOVERCHK has no API in xsubpp to choose it so do
|
|
||||||
#undef dXSBOOTARGSXSAPIVERCHK
|
|
||||||
#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK */
|
|
||||||
#define dXSBOOTARGSNOVERCHK \
|
|
||||||
I32 ax = XS_SETXSUBFN_POPMARK; \
|
|
||||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS
|
|
||||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS
|
|
||||||
|
|
||||||
#define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
|
|
||||||
? PAD_SV(PL_op->op_targ) : sv_newmortal())
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,38 +0,0 @@
|
|||||||
From 73b535d23d98bd3bdc31a27da26222e2e56166ac Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Tue, 30 Jun 2020 13:58:50 -0600
|
|
||||||
Subject: [PATCH] ext/XS-APItest/t/utf8_warn_base.pl: Fix a couple tests
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
These had invalid values, which didn't show up execpt on EBCDIC
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
ext/XS-APItest/t/utf8_warn_base.pl | 2 --
|
|
||||||
1 file changed, 2 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/ext/XS-APItest/t/utf8_warn_base.pl b/ext/XS-APItest/t/utf8_warn_base.pl
|
|
||||||
index d86871cd0f..a0f732282e 100644
|
|
||||||
--- a/ext/XS-APItest/t/utf8_warn_base.pl
|
|
||||||
+++ b/ext/XS-APItest/t/utf8_warn_base.pl
|
|
||||||
@@ -486,7 +486,6 @@ my @tests;
|
|
||||||
: I8_to_native(
|
|
||||||
"\xff\xa7\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"),
|
|
||||||
0x7FFFFFFFFFFFFFFF,
|
|
||||||
- (isASCII) ? 1 : 2,
|
|
||||||
],
|
|
||||||
[ "first 64 bit code point",
|
|
||||||
(isASCII)
|
|
||||||
@@ -525,7 +524,6 @@ my @tests;
|
|
||||||
I8_to_native(
|
|
||||||
"\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
|
|
||||||
0x800000000,
|
|
||||||
- 40000000
|
|
||||||
],
|
|
||||||
[ "requires at least 32 bits",
|
|
||||||
I8_to_native(
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,193 +0,0 @@
|
|||||||
From b334474a337421c6643b872388245fb2c11bf995 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Tony Cook <tony@develop-help.com>
|
|
||||||
Date: Mon, 30 Mar 2020 16:32:46 +1100
|
|
||||||
Subject: [PATCH] fix C<i $obj> where $obj is a lexical
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
the DB::eval function depends on the special behaviour of eval ""
|
|
||||||
within the DB package, which evaluates the string within the context
|
|
||||||
of the first non-DB sub or eval scope, working up the call stack.
|
|
||||||
|
|
||||||
The debugger refactor moved handling for the 'i' command from the
|
|
||||||
DB package to the DB::Obj package, so the eval in DB::eval was
|
|
||||||
working in the context of the DB::Obj::cmd_i function, not in the
|
|
||||||
calling scope.
|
|
||||||
|
|
||||||
Fixed by moving the handling for the i command back to DB.
|
|
||||||
|
|
||||||
Fixes #17661.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
MANIFEST | 1 +
|
|
||||||
lib/perl5db.pl | 65 +++++++++++++++++++++---------------------
|
|
||||||
lib/perl5db.t | 20 +++++++++++++
|
|
||||||
lib/perl5db/t/gh-17661 | 14 +++++++++
|
|
||||||
4 files changed, 68 insertions(+), 32 deletions(-)
|
|
||||||
create mode 100644 lib/perl5db/t/gh-17661
|
|
||||||
|
|
||||||
diff --git a/MANIFEST b/MANIFEST
|
|
||||||
index 8c71995174..96af3618bd 100644
|
|
||||||
--- a/MANIFEST
|
|
||||||
+++ b/MANIFEST
|
|
||||||
@@ -4808,6 +4808,7 @@ lib/perl5db/t/eval-line-bug Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/fact Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/filename-line-breakpoint Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/gh-17660 Tests for the Perl debugger
|
|
||||||
+lib/perl5db/t/gh-17661 Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/load-modules Tests for the Perl debugger
|
|
||||||
lib/perl5db/t/lsub-n Test script used by perl5db.t
|
|
||||||
lib/perl5db/t/lvalue-bug Tests for the Perl debugger
|
|
||||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
|
|
||||||
index 96e56d559f..b647d24fb8 100644
|
|
||||||
--- a/lib/perl5db.pl
|
|
||||||
+++ b/lib/perl5db.pl
|
|
||||||
@@ -2512,6 +2512,37 @@ EOP
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
+=head3 C<_DB__handle_i_command> - inheritance display
|
|
||||||
+
|
|
||||||
+Display the (nested) parentage of the module or object given.
|
|
||||||
+
|
|
||||||
+=cut
|
|
||||||
+
|
|
||||||
+sub _DB__handle_i_command {
|
|
||||||
+ my $self = shift;
|
|
||||||
+
|
|
||||||
+ my $line = $self->cmd_args;
|
|
||||||
+ require mro;
|
|
||||||
+ foreach my $isa ( split( /\s+/, $line ) ) {
|
|
||||||
+ $evalarg = "$isa";
|
|
||||||
+ # The &-call is here to ascertain the mutability of @_.
|
|
||||||
+ ($isa) = &DB::eval;
|
|
||||||
+ no strict 'refs';
|
|
||||||
+ print join(
|
|
||||||
+ ', ',
|
|
||||||
+ map {
|
|
||||||
+ "$_"
|
|
||||||
+ . (
|
|
||||||
+ defined( ${"$_\::VERSION"} )
|
|
||||||
+ ? ' ' . ${"$_\::VERSION"}
|
|
||||||
+ : undef )
|
|
||||||
+ } @{mro::get_linear_isa(ref($isa) || $isa)}
|
|
||||||
+ );
|
|
||||||
+ print "\n";
|
|
||||||
+ }
|
|
||||||
+ next CMD;
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
# 't' is type.
|
|
||||||
# 'm' is method.
|
|
||||||
# 'v' is the value (i.e: method name or subroutine ref).
|
|
||||||
@@ -2531,6 +2562,7 @@ BEGIN
|
|
||||||
'W' => { t => 'm', v => '_handle_W_command', },
|
|
||||||
'c' => { t => 's', v => \&_DB__handle_c_command, },
|
|
||||||
'f' => { t => 's', v => \&_DB__handle_f_command, },
|
|
||||||
+ 'i' => { t => 's', v => \&_DB__handle_i_command, },
|
|
||||||
'm' => { t => 's', v => \&_DB__handle_m_command, },
|
|
||||||
'n' => { t => 'm', v => '_handle_n_command', },
|
|
||||||
'p' => { t => 'm', v => '_handle_p_command', },
|
|
||||||
@@ -2551,7 +2583,7 @@ BEGIN
|
|
||||||
{ t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
|
|
||||||
} qw(R rerun)),
|
|
||||||
(map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
|
|
||||||
- qw(a A b B e E h i l L M o O v w W)),
|
|
||||||
+ qw(a A b B e E h l L M o O v w W)),
|
|
||||||
);
|
|
||||||
};
|
|
||||||
|
|
||||||
@@ -5468,37 +5500,6 @@ sub cmd_h {
|
|
||||||
}
|
|
||||||
} ## end sub cmd_h
|
|
||||||
|
|
||||||
-=head3 C<cmd_i> - inheritance display
|
|
||||||
-
|
|
||||||
-Display the (nested) parentage of the module or object given.
|
|
||||||
-
|
|
||||||
-=cut
|
|
||||||
-
|
|
||||||
-sub cmd_i {
|
|
||||||
- my $cmd = shift;
|
|
||||||
- my $line = shift;
|
|
||||||
-
|
|
||||||
- require mro;
|
|
||||||
-
|
|
||||||
- foreach my $isa ( split( /\s+/, $line ) ) {
|
|
||||||
- $evalarg = $isa;
|
|
||||||
- # The &-call is here to ascertain the mutability of @_.
|
|
||||||
- ($isa) = &DB::eval;
|
|
||||||
- no strict 'refs';
|
|
||||||
- print join(
|
|
||||||
- ', ',
|
|
||||||
- map {
|
|
||||||
- "$_"
|
|
||||||
- . (
|
|
||||||
- defined( ${"$_\::VERSION"} )
|
|
||||||
- ? ' ' . ${"$_\::VERSION"}
|
|
||||||
- : undef )
|
|
||||||
- } @{mro::get_linear_isa(ref($isa) || $isa)}
|
|
||||||
- );
|
|
||||||
- print "\n";
|
|
||||||
- }
|
|
||||||
-} ## end sub cmd_i
|
|
||||||
-
|
|
||||||
=head3 C<cmd_l> - list lines (command)
|
|
||||||
|
|
||||||
Most of the command is taken up with transforming all the different line
|
|
||||||
diff --git a/lib/perl5db.t b/lib/perl5db.t
|
|
||||||
index 913a301d98..ffa659a215 100644
|
|
||||||
--- a/lib/perl5db.t
|
|
||||||
+++ b/lib/perl5db.t
|
|
||||||
@@ -2946,6 +2946,26 @@ SKIP:
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
+{
|
|
||||||
+ # gh #17661
|
|
||||||
+ my $wrapper = DebugWrap->new(
|
|
||||||
+ {
|
|
||||||
+ cmds =>
|
|
||||||
+ [
|
|
||||||
+ 'c',
|
|
||||||
+ 'i $obj',
|
|
||||||
+ 'q',
|
|
||||||
+ ],
|
|
||||||
+ prog => '../lib/perl5db/t/gh-17661',
|
|
||||||
+ }
|
|
||||||
+ );
|
|
||||||
+
|
|
||||||
+ $wrapper->output_like(
|
|
||||||
+ qr/C5, C1, C2, C3, C4/,
|
|
||||||
+ q/check for reasonable result/,
|
|
||||||
+ );
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
SKIP:
|
|
||||||
{
|
|
||||||
$Config{usethreads}
|
|
||||||
diff --git a/lib/perl5db/t/gh-17661 b/lib/perl5db/t/gh-17661
|
|
||||||
new file mode 100644
|
|
||||||
index 0000000000..0d85977b35
|
|
||||||
--- /dev/null
|
|
||||||
+++ b/lib/perl5db/t/gh-17661
|
|
||||||
@@ -0,0 +1,14 @@
|
|
||||||
+use v5.10.0;
|
|
||||||
+
|
|
||||||
+{ package C1; sub c1 { } our @ISA = qw(C2) }
|
|
||||||
+{ package C2; sub c2 { } our @ISA = qw(C3) }
|
|
||||||
+{ package C3; sub c3 { } our @ISA = qw( ) }
|
|
||||||
+{ package C4; sub c4 { } our @ISA = qw( ) }
|
|
||||||
+{ package C5; sub c5 { } our @ISA = qw(C1 C4) }
|
|
||||||
+
|
|
||||||
+my $obj = bless {}, 'C5';
|
|
||||||
+$main::global = bless {}, 'C5';
|
|
||||||
+
|
|
||||||
+$DB::single = 1;
|
|
||||||
+
|
|
||||||
+say "Done.";
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,87 +0,0 @@
|
|||||||
From 89341f87f9fc65c4d7133e497bb04586e86b8052 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Tony Cook <tony@develop-help.com>
|
|
||||||
Date: Tue, 12 May 2020 10:29:17 +1000
|
|
||||||
Subject: [PATCH 1/2] make $fh->error report errors from both input and output
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
For character devices and sockets perl uses separate PerlIO objects
|
|
||||||
for input and output so they can be buffered separately.
|
|
||||||
|
|
||||||
The IO::Handle::error() method only checked the input stream, so
|
|
||||||
if a write error occurs error() would still returned false.
|
|
||||||
|
|
||||||
Change this so both the input and output streams are checked.
|
|
||||||
|
|
||||||
fixes #6799
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
dist/IO/IO.xs | 12 ++++++++----
|
|
||||||
dist/IO/t/io_xs.t | 19 ++++++++++++++++++-
|
|
||||||
2 files changed, 26 insertions(+), 5 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
|
|
||||||
index 68b7352c38..99d523d2c1 100644
|
|
||||||
--- a/dist/IO/IO.xs
|
|
||||||
+++ b/dist/IO/IO.xs
|
|
||||||
@@ -389,13 +389,17 @@ ungetc(handle, c)
|
|
||||||
|
|
||||||
int
|
|
||||||
ferror(handle)
|
|
||||||
- InputStream handle
|
|
||||||
+ SV * handle
|
|
||||||
+ PREINIT:
|
|
||||||
+ IO *io = sv_2io(handle);
|
|
||||||
+ InputStream in = IoIFP(io);
|
|
||||||
+ OutputStream out = IoOFP(io);
|
|
||||||
CODE:
|
|
||||||
- if (handle)
|
|
||||||
+ if (in)
|
|
||||||
#ifdef PerlIO
|
|
||||||
- RETVAL = PerlIO_error(handle);
|
|
||||||
+ RETVAL = PerlIO_error(in) || (in != out && PerlIO_error(out));
|
|
||||||
#else
|
|
||||||
- RETVAL = ferror(handle);
|
|
||||||
+ RETVAL = ferror(in) || (in != out && ferror(out));
|
|
||||||
#endif
|
|
||||||
else {
|
|
||||||
RETVAL = -1;
|
|
||||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t
|
|
||||||
index 1e3c49a4a7..f890e92558 100644
|
|
||||||
--- a/dist/IO/t/io_xs.t
|
|
||||||
+++ b/dist/IO/t/io_xs.t
|
|
||||||
@@ -11,7 +11,7 @@ BEGIN {
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
-use Test::More tests => 5;
|
|
||||||
+use Test::More tests => 7;
|
|
||||||
use IO::File;
|
|
||||||
use IO::Seekable;
|
|
||||||
|
|
||||||
@@ -50,3 +50,20 @@ SKIP:
|
|
||||||
ok($fh->sync, "sync to a read only handle")
|
|
||||||
or diag "sync(): ", $!;
|
|
||||||
}
|
|
||||||
+
|
|
||||||
+
|
|
||||||
+SKIP: {
|
|
||||||
+ # gh 6799
|
|
||||||
+ #
|
|
||||||
+ # This isn't really a Linux/BSD specific test, but /dev/full is (I
|
|
||||||
+ # hope) reasonably well defined on these. Patches welcome if your platform
|
|
||||||
+ # also supports it (or something like it)
|
|
||||||
+ skip "no /dev/full or not a /dev/full platform", 2
|
|
||||||
+ unless $^O =~ /^(linux|netbsd|freebsd)$/ && -c "/dev/full";
|
|
||||||
+ open my $fh, ">", "/dev/full"
|
|
||||||
+ or skip "Could not open /dev/full: $!", 2;
|
|
||||||
+ $fh->print("a" x 1024);
|
|
||||||
+ ok(!$fh->flush, "should fail to flush");
|
|
||||||
+ ok($fh->error, "stream should be in error");
|
|
||||||
+ close $fh; # silently ignore the error
|
|
||||||
+}
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,58 +0,0 @@
|
|||||||
From 81169c06a76f62ff987ed990ac910c2ae08b3f91 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Tue, 10 Mar 2020 15:19:57 -0600
|
|
||||||
Subject: [PATCH] reentr.c: Buffer sizes for asctime_r,ctime_r are small
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
The needed sizes of these are stated in the man pages, and are much
|
|
||||||
smaller than were being allocated.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
reentr.c | 4 ++--
|
|
||||||
regen/reentr.pl | 5 ++++-
|
|
||||||
2 files changed, 6 insertions(+), 3 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/reentr.c b/reentr.c
|
|
||||||
index 8ddda7bfc0..8438c8f90f 100644
|
|
||||||
--- a/reentr.c
|
|
||||||
+++ b/reentr.c
|
|
||||||
@@ -52,14 +52,14 @@ Perl_reentrant_size(pTHX) {
|
|
||||||
# define REENTRANTUSUALSIZE 4096 /* Make something up. */
|
|
||||||
|
|
||||||
# ifdef HAS_ASCTIME_R
|
|
||||||
- PL_reentrant_buffer->_asctime_size = REENTRANTSMALLSIZE;
|
|
||||||
+ PL_reentrant_buffer->_asctime_size = 26;
|
|
||||||
# endif /* HAS_ASCTIME_R */
|
|
||||||
|
|
||||||
# ifdef HAS_CRYPT_R
|
|
||||||
# endif /* HAS_CRYPT_R */
|
|
||||||
|
|
||||||
# ifdef HAS_CTIME_R
|
|
||||||
- PL_reentrant_buffer->_ctime_size = REENTRANTSMALLSIZE;
|
|
||||||
+ PL_reentrant_buffer->_ctime_size = 26;
|
|
||||||
# endif /* HAS_CTIME_R */
|
|
||||||
|
|
||||||
# ifdef HAS_GETGRNAM_R
|
|
||||||
diff --git a/regen/reentr.pl b/regen/reentr.pl
|
|
||||||
index f5788c7ad9..94721e9dec 100644
|
|
||||||
--- a/regen/reentr.pl
|
|
||||||
+++ b/regen/reentr.pl
|
|
||||||
@@ -495,8 +495,11 @@ for my $func (@seenf) {
|
|
||||||
char* _${func}_buffer;
|
|
||||||
size_t _${func}_size;
|
|
||||||
EOF
|
|
||||||
+ my $size = ($func =~ /^(asctime|ctime)$/)
|
|
||||||
+ ? 26
|
|
||||||
+ : "REENTRANTSMALLSIZE";
|
|
||||||
push @size, <<EOF;
|
|
||||||
- PL_reentrant_buffer->_${func}_size = REENTRANTSMALLSIZE;
|
|
||||||
+ PL_reentrant_buffer->_${func}_size = $size;
|
|
||||||
EOF
|
|
||||||
pushinitfree $func;
|
|
||||||
pushssif $endif;
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,46 +0,0 @@
|
|||||||
From 981fbfc16220a15e72457d8ece4e014988746946 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Thu, 12 Mar 2020 12:48:47 -0600
|
|
||||||
Subject: [PATCH] reentr.c: Prevent infinite looping
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
This is an easy, though paranoid hedge to prevent something that should
|
|
||||||
never happen from causing an infinite loop if it were to happen.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
reentr.c | 2 +-
|
|
||||||
regen/reentr.pl | 2 +-
|
|
||||||
2 files changed, 2 insertions(+), 2 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/reentr.c b/reentr.c
|
|
||||||
index 8438c8f90f..2429aa2f5d 100644
|
|
||||||
--- a/reentr.c
|
|
||||||
+++ b/reentr.c
|
|
||||||
@@ -36,7 +36,7 @@
|
|
||||||
|
|
||||||
#define RenewDouble(data_pointer, size_pointer, type) \
|
|
||||||
STMT_START { \
|
|
||||||
- const size_t size = *(size_pointer) * 2; \
|
|
||||||
+ const size_t size = MAX(*(size_pointer), 1) * 2; \
|
|
||||||
Renew((data_pointer), (size), type); \
|
|
||||||
*(size_pointer) = size; \
|
|
||||||
} STMT_END
|
|
||||||
diff --git a/regen/reentr.pl b/regen/reentr.pl
|
|
||||||
index 94721e9dec..ba2e1c8fa6 100644
|
|
||||||
--- a/regen/reentr.pl
|
|
||||||
+++ b/regen/reentr.pl
|
|
||||||
@@ -818,7 +818,7 @@ print $c <<"EOF";
|
|
||||||
|
|
||||||
#define RenewDouble(data_pointer, size_pointer, type) \\
|
|
||||||
STMT_START { \\
|
|
||||||
- const size_t size = *(size_pointer) * 2; \\
|
|
||||||
+ const size_t size = MAX(*(size_pointer), 1) * 2; \\
|
|
||||||
Renew((data_pointer), (size), type); \\
|
|
||||||
*(size_pointer) = size; \\
|
|
||||||
} STMT_END
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,31 +0,0 @@
|
|||||||
From 530e9296a21b673d7e4c2b42f18d0d52d00f35c4 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Sun, 28 Jun 2020 12:03:54 -0600
|
|
||||||
Subject: [PATCH] sv.h: Wanted UOK, but said IOK
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
I don't know the consequences of this bug
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
sv.h | 2 +-
|
|
||||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/sv.h b/sv.h
|
|
||||||
index 2f6431a826..3721b2fb1b 100644
|
|
||||||
--- a/sv.h
|
|
||||||
+++ b/sv.h
|
|
||||||
@@ -1711,7 +1711,7 @@ Like C<sv_catsv> but doesn't process magic.
|
|
||||||
#define SvNV(sv) (SvNOK_nog(sv) ? SvNVX(sv) : sv_2nv(sv))
|
|
||||||
|
|
||||||
#define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0))
|
|
||||||
-#define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
|
|
||||||
+#define SvUV_nomg(sv) (SvUOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
|
|
||||||
#define SvNV_nomg(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv_flags(sv, 0))
|
|
||||||
|
|
||||||
/* ----*/
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,77 +0,0 @@
|
|||||||
From 390fe0c0d09aadc66f644e9eee4aa1245221188c Mon Sep 17 00:00:00 2001
|
|
||||||
From: David Mitchell <davem@iabyn.com>
|
|
||||||
Date: Tue, 25 Aug 2020 13:15:25 +0100
|
|
||||||
Subject: [PATCH] sort { return foo() } ...
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
GH #18081
|
|
||||||
|
|
||||||
A sub call via return in a sort block was called in void rather than
|
|
||||||
scalar context, causing the comparison result to be discarded.
|
|
||||||
|
|
||||||
This because when a sort block is called it is not a real function
|
|
||||||
call, even though a sort block can be returned from. Instead, a
|
|
||||||
CXt_NULL is pushed on the context stack. Because this isn't a sub-ish
|
|
||||||
context type (unlike CXt_SUB, CXt_EVAL etc) there is no 'caller sub'
|
|
||||||
on the context stack to be found to retrieve the caller's context
|
|
||||||
(i.e. cx->cx_gimme).
|
|
||||||
|
|
||||||
This commit fixes it by special-casing Perl_gimme_V().
|
|
||||||
|
|
||||||
Ideally at some future point, a new context type, CXt_SORT, should be
|
|
||||||
added. This would be used instead of CXt_NULL when a sort BLOCK is
|
|
||||||
called. Like other sub-ish context types, it would have an old_cxsubix
|
|
||||||
field and PL_curstackinfo->si_cxsubix would point to it. This would
|
|
||||||
eliminate needing special-case handling in places like Perl_gimme_V().
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
inline.h | 2 +-
|
|
||||||
t/op/sort.t | 12 +++++++++++-
|
|
||||||
2 files changed, 12 insertions(+), 2 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/inline.h b/inline.h
|
|
||||||
index a8240efb9c..6fbd5abfea 100644
|
|
||||||
--- a/inline.h
|
|
||||||
+++ b/inline.h
|
|
||||||
@@ -2086,7 +2086,7 @@ Perl_gimme_V(pTHX)
|
|
||||||
return gimme;
|
|
||||||
cxix = PL_curstackinfo->si_cxsubix;
|
|
||||||
if (cxix < 0)
|
|
||||||
- return G_VOID;
|
|
||||||
+ return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
|
|
||||||
assert(cxstack[cxix].blk_gimme & G_WANT);
|
|
||||||
return (cxstack[cxix].blk_gimme & G_WANT);
|
|
||||||
}
|
|
||||||
diff --git a/t/op/sort.t b/t/op/sort.t
|
|
||||||
index f2e139dff0..8e387fb90d 100644
|
|
||||||
--- a/t/op/sort.t
|
|
||||||
+++ b/t/op/sort.t
|
|
||||||
@@ -7,7 +7,7 @@ BEGIN {
|
|
||||||
set_up_inc('../lib');
|
|
||||||
}
|
|
||||||
use warnings;
|
|
||||||
-plan(tests => 203);
|
|
||||||
+plan(tests => 204);
|
|
||||||
use Tie::Array; # we need to test sorting tied arrays
|
|
||||||
|
|
||||||
# these shouldn't hang
|
|
||||||
@@ -1202,3 +1202,13 @@ SKIP:
|
|
||||||
$fillb = undef;
|
|
||||||
is $act, "01[sortb]2[fillb]";
|
|
||||||
}
|
|
||||||
+
|
|
||||||
+# GH #18081
|
|
||||||
+# sub call via return in sort block was called in void rather than scalar
|
|
||||||
+# context
|
|
||||||
+
|
|
||||||
+{
|
|
||||||
+ sub sort18081 { $a + 1 <=> $b + 1 }
|
|
||||||
+ my @a = sort { return &sort18081 } 6,1,2;
|
|
||||||
+ is "@a", "1 2 6", "GH #18081";
|
|
||||||
+}
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,77 +0,0 @@
|
|||||||
From bd5fa06648085e8c17efd55abeb6424aeeb1018e Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Tue, 29 Sep 2020 00:48:19 -0600
|
|
||||||
Subject: [PATCH] Remove Perl_av_top_index
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
I created this in 87306e0674dfe3af29804b4641347cd5ac9b0521, thinking it
|
|
||||||
was needed to preserve backward compatibility if someone were using this
|
|
||||||
instead of the macro. But it turned out that there never was such a
|
|
||||||
function, it was inlined, and the name was S_av_top_index, so there is
|
|
||||||
no reason to create a new function that no one has ever been able to
|
|
||||||
call. So just remove it, and let all accesses go through the macro
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
av.c | 10 ----------
|
|
||||||
embed.fnc | 2 +-
|
|
||||||
proto.h | 7 +++----
|
|
||||||
3 files changed, 4 insertions(+), 15 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/av.c b/av.c
|
|
||||||
index ada09cde9a..ad2429f90d 100644
|
|
||||||
--- a/av.c
|
|
||||||
+++ b/av.c
|
|
||||||
@@ -1095,16 +1095,6 @@ Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
|
|
||||||
return sv;
|
|
||||||
}
|
|
||||||
|
|
||||||
-SSize_t
|
|
||||||
-Perl_av_top_index(pTHX_ AV *av)
|
|
||||||
-{
|
|
||||||
- PERL_ARGS_ASSERT_AV_TOP_INDEX;
|
|
||||||
- assert(SvTYPE(av) == SVt_PVAV);
|
|
||||||
-
|
|
||||||
- return AvFILL(av);
|
|
||||||
-}
|
|
||||||
-
|
|
||||||
-
|
|
||||||
/*
|
|
||||||
* ex: set ts=8 sts=4 sw=4 et:
|
|
||||||
*/
|
|
||||||
diff --git a/embed.fnc b/embed.fnc
|
|
||||||
index a6b4d0350f..f5c5b29c2d 100644
|
|
||||||
--- a/embed.fnc
|
|
||||||
+++ b/embed.fnc
|
|
||||||
@@ -637,7 +637,7 @@ Apd |void |av_push |NN AV *av|NN SV *val
|
|
||||||
EXp |void |av_reify |NN AV *av
|
|
||||||
ApdR |SV* |av_shift |NN AV *av
|
|
||||||
Apd |SV** |av_store |NN AV *av|SSize_t key|NULLOK SV *val
|
|
||||||
-AMdRp |SSize_t|av_top_index |NN AV *av
|
|
||||||
+AmdR |SSize_t|av_top_index |NN AV *av
|
|
||||||
AidRp |Size_t |av_count |NN AV *av
|
|
||||||
AmdR |SSize_t|av_tindex |NN AV *av
|
|
||||||
Apd |void |av_undef |NN AV *av
|
|
||||||
diff --git a/proto.h b/proto.h
|
|
||||||
index c4490fc46e..2da1a07761 100644
|
|
||||||
--- a/proto.h
|
|
||||||
+++ b/proto.h
|
|
||||||
@@ -291,10 +291,9 @@ PERL_CALLCONV SV** Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val);
|
|
||||||
__attribute__warn_unused_result__; */
|
|
||||||
#define PERL_ARGS_ASSERT_AV_TINDEX
|
|
||||||
|
|
||||||
-PERL_CALLCONV SSize_t Perl_av_top_index(pTHX_ AV *av)
|
|
||||||
- __attribute__warn_unused_result__;
|
|
||||||
-#define PERL_ARGS_ASSERT_AV_TOP_INDEX \
|
|
||||||
- assert(av)
|
|
||||||
+/* PERL_CALLCONV SSize_t av_top_index(pTHX_ AV *av)
|
|
||||||
+ __attribute__warn_unused_result__; */
|
|
||||||
+#define PERL_ARGS_ASSERT_AV_TOP_INDEX
|
|
||||||
|
|
||||||
PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av);
|
|
||||||
#define PERL_ARGS_ASSERT_AV_UNDEF \
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,31 +0,0 @@
|
|||||||
From fa353c3d2833fc326233e0eb583753b4d7887a63 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Sun, 4 Oct 2020 11:07:19 -0600
|
|
||||||
Subject: [PATCH] mro.xs: Fix compiler warning
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Fixes GH #18155
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
ext/mro/mro.xs | 2 +-
|
|
||||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs
|
|
||||||
index f21216af6e..8ce5844904 100644
|
|
||||||
--- a/ext/mro/mro.xs
|
|
||||||
+++ b/ext/mro/mro.xs
|
|
||||||
@@ -253,7 +253,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
|
|
||||||
hierarchy is not C3-incompatible */
|
|
||||||
if(!winner) {
|
|
||||||
SV *errmsg;
|
|
||||||
- I32 i;
|
|
||||||
+ Size_t i;
|
|
||||||
|
|
||||||
errmsg = newSVpvf(
|
|
||||||
"Inconsistent hierarchy during C3 merge of class '%" HEKf "':\n\t"
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,32 +0,0 @@
|
|||||||
From 5777cf812c2812ea45eeb45e48979bab544d71af Mon Sep 17 00:00:00 2001
|
|
||||||
From: TAKAI Kousuke <62541129+t-a-k@users.noreply.github.com>
|
|
||||||
Date: Thu, 8 Oct 2020 19:02:10 +0900
|
|
||||||
Subject: [PATCH] sv.c: Added missing braces in Perl_sv_inc_nomg().
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
sv.c | 3 ++-
|
|
||||||
1 file changed, 2 insertions(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/sv.c b/sv.c
|
|
||||||
index 82248e3b1f..57fd65a5b8 100644
|
|
||||||
--- a/sv.c
|
|
||||||
+++ b/sv.c
|
|
||||||
@@ -8944,9 +8944,10 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv)
|
|
||||||
if (SvIsUV(sv)) {
|
|
||||||
if (SvUVX(sv) == UV_MAX)
|
|
||||||
sv_setnv(sv, UV_MAX_P1);
|
|
||||||
- else
|
|
||||||
+ else {
|
|
||||||
(void)SvIOK_only_UV(sv);
|
|
||||||
SvUV_set(sv, SvUVX(sv) + 1);
|
|
||||||
+ }
|
|
||||||
} else {
|
|
||||||
if (SvIVX(sv) == IV_MAX)
|
|
||||||
sv_setuv(sv, (UV)IV_MAX + 1);
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,36 +0,0 @@
|
|||||||
From e17dadf36f7b4348e59076240c880d0c78b33fa9 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Tue, 22 Sep 2020 08:47:52 -0600
|
|
||||||
Subject: [PATCH] sv.h: sv_collxfrm didn't work properly
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
It is supposed to be a wrapper for sv_collxfrm_flags, but it was just
|
|
||||||
calling sv_cmp_flags instead. The consequences are none except under
|
|
||||||
'use locale' in which case you always got the C locale. I did not add
|
|
||||||
tests, because it is really a pain to write portable locale tests, and
|
|
||||||
this doesn't seem to be much used. In core the '_flags' form was always
|
|
||||||
used.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
sv.h | 2 +-
|
|
||||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/sv.h b/sv.h
|
|
||||||
index 19ce718ac3..44414b35a9 100644
|
|
||||||
--- a/sv.h
|
|
||||||
+++ b/sv.h
|
|
||||||
@@ -2045,7 +2045,7 @@ Like C<sv_catsv> but doesn't process magic.
|
|
||||||
#define sv_eq(sv1, sv2) sv_eq_flags(sv1, sv2, SV_GMAGIC)
|
|
||||||
#define sv_cmp(sv1, sv2) sv_cmp_flags(sv1, sv2, SV_GMAGIC)
|
|
||||||
#define sv_cmp_locale(sv1, sv2) sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC)
|
|
||||||
-#define sv_collxfrm(sv, nxp) sv_cmp_flags(sv, nxp, SV_GMAGIC)
|
|
||||||
+#define sv_collxfrm(sv, nxp) sv_collxfrm_flags(sv, nxp, SV_GMAGIC)
|
|
||||||
#define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC)
|
|
||||||
#define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0)
|
|
||||||
#define sv_insert(bigstr, offset, len, little, littlelen) \
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,76 +0,0 @@
|
|||||||
From e050064b67c501e9fdc7bc3f513ba2b8b9e795f8 Mon Sep 17 00:00:00 2001
|
|
||||||
From: David Mitchell <davem@iabyn.com>
|
|
||||||
Date: Fri, 30 Oct 2020 20:50:58 +0000
|
|
||||||
Subject: [PATCH] Perl_custom_op_get_field(): remove undef behaviour
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Thus function has a couple a switches with
|
|
||||||
|
|
||||||
default:
|
|
||||||
NOT_REACHED; /* NOTREACHED */
|
|
||||||
|
|
||||||
but clang is complaining that the value returned by the function is
|
|
||||||
undefined if those default branches are taken, since the 'any' variable
|
|
||||||
doesn't get set in that path.
|
|
||||||
|
|
||||||
Replace the NOTREACHED with a croak("panic: ..."). It's possible (albeit
|
|
||||||
not intended) for Perl_custom_op_get_field() to be called with a 'field'
|
|
||||||
arg which triggers the default case. So if this ever happens, make it
|
|
||||||
clear that something has gone wrong, rather than just silently
|
|
||||||
continuing on non-debugging builds.
|
|
||||||
|
|
||||||
In any case, this shuts up clang.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
op.c | 14 ++++++--------
|
|
||||||
1 file changed, 6 insertions(+), 8 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/op.c b/op.c
|
|
||||||
index c30c6b7c8f..2933e2ed7d 100644
|
|
||||||
--- a/op.c
|
|
||||||
+++ b/op.c
|
|
||||||
@@ -18100,6 +18100,7 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
|
|
||||||
else
|
|
||||||
xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
|
|
||||||
}
|
|
||||||
+
|
|
||||||
{
|
|
||||||
XOPRETANY any;
|
|
||||||
if(field == XOPe_xop_ptr) {
|
|
||||||
@@ -18121,7 +18122,10 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
|
|
||||||
any.xop_peep = xop->xop_peep;
|
|
||||||
break;
|
|
||||||
default:
|
|
||||||
- NOT_REACHED; /* NOTREACHED */
|
|
||||||
+ field_panic:
|
|
||||||
+ Perl_croak(aTHX_
|
|
||||||
+ "panic: custom_op_get_field(): invalid field %d\n",
|
|
||||||
+ (int)field);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
@@ -18139,17 +18143,11 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
|
|
||||||
any.xop_peep = XOPd_xop_peep;
|
|
||||||
break;
|
|
||||||
default:
|
|
||||||
- NOT_REACHED; /* NOTREACHED */
|
|
||||||
+ goto field_panic;
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
- /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
|
|
||||||
- * op.c: In function 'Perl_custom_op_get_field':
|
|
||||||
- * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
|
|
||||||
- * This is because on those platforms (with -DEBUGGING) NOT_REACHED
|
|
||||||
- * expands to assert(0), which expands to ((0) ? (void)0 :
|
|
||||||
- * __assert(...)), and gcc doesn't know that __assert can never return. */
|
|
||||||
return any;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,57 +0,0 @@
|
|||||||
From f877e124a20d4f94c82c36e6b7a99b4e9663e204 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Tony Cook <tony@develop-help.com>
|
|
||||||
Date: Tue, 10 Nov 2020 15:50:27 +1100
|
|
||||||
Subject: [PATCH] fetch magic on the first stacked filetest, not the last
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
fixes #18293
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
pp_sys.c | 2 +-
|
|
||||||
t/op/filetest.t | 10 +++++++++-
|
|
||||||
2 files changed, 10 insertions(+), 2 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/pp_sys.c b/pp_sys.c
|
|
||||||
index 66c5d9aade..5c9f768eaf 100644
|
|
||||||
--- a/pp_sys.c
|
|
||||||
+++ b/pp_sys.c
|
|
||||||
@@ -3067,7 +3067,7 @@ S_try_amagic_ftest(pTHX_ char chr) {
|
|
||||||
SV *const arg = *PL_stack_sp;
|
|
||||||
|
|
||||||
assert(chr != '?');
|
|
||||||
- if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
|
|
||||||
+ if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg);
|
|
||||||
|
|
||||||
if (SvAMAGIC(arg))
|
|
||||||
{
|
|
||||||
diff --git a/t/op/filetest.t b/t/op/filetest.t
|
|
||||||
index fe9724c59a..7c471c050c 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 => 57 + 27*14);
|
|
||||||
+plan(tests => 58 + 27*14);
|
|
||||||
|
|
||||||
if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) {
|
|
||||||
require Win32; # for IsAdminUser()
|
|
||||||
@@ -385,3 +385,11 @@ SKIP: {
|
|
||||||
ok(!-f "TEST\0-", '-f on name with \0');
|
|
||||||
ok(!-r "TEST\0-", '-r on name with \0');
|
|
||||||
}
|
|
||||||
+
|
|
||||||
+{
|
|
||||||
+ # github #18293
|
|
||||||
+ "" =~ /(.*)/;
|
|
||||||
+ my $x = $1; # call magic on $1, setting the pv to ""
|
|
||||||
+ "test.pl" =~ /(.*)/;
|
|
||||||
+ ok(-f -r $1, "stacked handles on a name with magic");
|
|
||||||
+}
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,54 +0,0 @@
|
|||||||
From ab307de390c3459badcc89b3d77542b5b871b2e8 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Richard Leach <richardleach@users.noreply.github.com>
|
|
||||||
Date: Tue, 20 Oct 2020 18:16:38 +0100
|
|
||||||
Subject: [PATCH 2/2] pp_split: add TonyC's stack-not-refcounted-suggestion and
|
|
||||||
tests
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
pp.c | 5 ++++-
|
|
||||||
t/op/split.t | 5 +++++
|
|
||||||
2 files changed, 9 insertions(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/pp.c b/pp.c
|
|
||||||
index ce16c56e63..5b5e163011 100644
|
|
||||||
--- a/pp.c
|
|
||||||
+++ b/pp.c
|
|
||||||
@@ -6034,6 +6034,9 @@ PP(pp_split)
|
|
||||||
oldsave = PL_savestack_ix;
|
|
||||||
}
|
|
||||||
|
|
||||||
+ /* Some defence against stack-not-refcounted bugs */
|
|
||||||
+ (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary));
|
|
||||||
+
|
|
||||||
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
|
|
||||||
PUSHMARK(SP);
|
|
||||||
XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
|
|
||||||
@@ -6356,7 +6359,7 @@ PP(pp_split)
|
|
||||||
}
|
|
||||||
|
|
||||||
PUTBACK;
|
|
||||||
- LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
|
|
||||||
+ LEAVE_SCOPE(oldsave);
|
|
||||||
SPAGAIN;
|
|
||||||
if (realarray) {
|
|
||||||
if (!mg) {
|
|
||||||
diff --git a/t/op/split.t b/t/op/split.t
|
|
||||||
index 1d78a45bde..7a321645ac 100644
|
|
||||||
--- a/t/op/split.t
|
|
||||||
+++ b/t/op/split.t
|
|
||||||
@@ -703,3 +703,8 @@ fresh_perl_is('my @ary; @ary = split(/\w(?{ @ary[1000] = 1 })/, "abc");',
|
|
||||||
fresh_perl_is('my @ary; @ary = split(/\w(?{ undef @ary })/, "abc");',
|
|
||||||
'',{},'(@ary = split ...) survives an (undef @ary)');
|
|
||||||
|
|
||||||
+# check the (@ary = split) optimisation survives stack-not-refcounted bugs
|
|
||||||
+fresh_perl_is('our @ary; @ary = split(/\w(?{ *ary = 0 })/, "abc");',
|
|
||||||
+ '',{},'(@ary = split ...) survives @ary destruction via typeglob');
|
|
||||||
+fresh_perl_is('my $ary = []; @$ary = split(/\w(?{ $ary = [] })/, "abc");',
|
|
||||||
+ '',{},'(@ary = split ...) survives @ary destruction via reassignment');
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,71 +0,0 @@
|
|||||||
From b52b6c4029b51818442d64c6104d26e12e140f09 Mon Sep 17 00:00:00 2001
|
|
||||||
From: TAKAI Kousuke <62541129+t-a-k@users.noreply.github.com>
|
|
||||||
Date: Thu, 5 Nov 2020 22:06:16 +0900
|
|
||||||
Subject: [PATCH] t/op/inc.t, t/op/hexfp.t, t/op/sprintf2.t: Add missing d_
|
|
||||||
prefixes for Config variable names.
|
|
||||||
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/hexfp.t | 2 +-
|
|
||||||
t/op/inc.t | 4 ++--
|
|
||||||
t/op/sprintf2.t | 4 ++--
|
|
||||||
3 files changed, 5 insertions(+), 5 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/t/op/hexfp.t b/t/op/hexfp.t
|
|
||||||
index b0c85cfdc6..5fb80d3d74 100644
|
|
||||||
--- a/t/op/hexfp.t
|
|
||||||
+++ b/t/op/hexfp.t
|
|
||||||
@@ -246,7 +246,7 @@ SKIP: {
|
|
||||||
skip("non-80-bit-long-double", 4)
|
|
||||||
unless ($Config{uselongdouble} &&
|
|
||||||
($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
|
|
||||||
- ($Config{long_double_style_ieee_extended}));
|
|
||||||
+ ($Config{d_long_double_style_ieee_extended}));
|
|
||||||
is(0x1p-1074, 4.94065645841246544e-324);
|
|
||||||
is(0x1p-1075, 2.47032822920623272e-324, '[perl #128919]');
|
|
||||||
is(0x1p-1076, 1.23516411460311636e-324);
|
|
||||||
diff --git a/t/op/inc.t b/t/op/inc.t
|
|
||||||
index 0bb8b85b13..3d5cc024d3 100644
|
|
||||||
--- a/t/op/inc.t
|
|
||||||
+++ b/t/op/inc.t
|
|
||||||
@@ -188,10 +188,10 @@ cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double");
|
|
||||||
|
|
||||||
SKIP: {
|
|
||||||
if ($Config{uselongdouble} &&
|
|
||||||
- ($Config{long_double_style_ieee_doubledouble})) {
|
|
||||||
+ ($Config{d_long_double_style_ieee_doubledouble})) {
|
|
||||||
skip "the double-double format is weird", 1;
|
|
||||||
}
|
|
||||||
- unless ($Config{double_style_ieee}) {
|
|
||||||
+ unless ($Config{d_double_style_ieee}) {
|
|
||||||
skip "the doublekind $Config{doublekind} is not IEEE", 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
|
||||||
index bbc12ccd0a..38a550c281 100644
|
|
||||||
--- a/t/op/sprintf2.t
|
|
||||||
+++ b/t/op/sprintf2.t
|
|
||||||
@@ -701,7 +701,7 @@ SKIP: {
|
|
||||||
skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef')
|
|
||||||
. " longdblkind=$Config{longdblkind} os=$^O", 6)
|
|
||||||
unless ($Config{uselongdouble} &&
|
|
||||||
- ($Config{long_double_style_ieee_doubledouble})
|
|
||||||
+ ($Config{d_long_double_style_ieee_doubledouble})
|
|
||||||
# Gating on 'linux' (ppc) here is due to the differing
|
|
||||||
# double-double implementations: other (also big-endian)
|
|
||||||
# double-double platforms (e.g. AIX on ppc or IRIX on mips)
|
|
||||||
@@ -892,7 +892,7 @@ SKIP: {
|
|
||||||
skip("non-80-bit-long-double", 17)
|
|
||||||
unless ($Config{uselongdouble} &&
|
|
||||||
($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
|
|
||||||
- ($Config{long_double_style_ieee_extended}));
|
|
||||||
+ ($Config{d_long_double_style_ieee_extended}));
|
|
||||||
|
|
||||||
{
|
|
||||||
# The last normal for this format.
|
|
||||||
--
|
|
||||||
2.25.4
|
|
||||||
|
|
||||||
@ -1,32 +0,0 @@
|
|||||||
From 9289d4dc7a3d24b20c6e25045e687321ee3e8faf Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Mon, 30 Nov 2020 09:25:52 -0700
|
|
||||||
Subject: [PATCH] locale.c: Fix typo in #ifdef
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
This misspelling led to the code assuming that the platform didn't have
|
|
||||||
a feature that, if used, would result in faster execution.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
locale.c | 2 +-
|
|
||||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/locale.c b/locale.c
|
|
||||||
index 9500ab7960..5970423404 100644
|
|
||||||
--- a/locale.c
|
|
||||||
+++ b/locale.c
|
|
||||||
@@ -2621,7 +2621,7 @@ S_my_nl_langinfo(const int item, bool toggle)
|
|
||||||
#if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */
|
|
||||||
# if ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \
|
|
||||||
|| ! defined(HAS_POSIX_2008_LOCALE) \
|
|
||||||
- || ! defined(DUPLOCALE)
|
|
||||||
+ || ! defined(HAS_DUPLOCALE)
|
|
||||||
|
|
||||||
/* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC
|
|
||||||
* for those items dependent on it. This must be copied to a buffer before
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,140 +0,0 @@
|
|||||||
From 4cfbe5474a5c5f852a6dbf0138dc796c2800be93 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Wed, 30 Dec 2020 05:55:08 -0700
|
|
||||||
Subject: [PATCH] Fix buggy fc() in Turkish locale
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
When Turkish handling was added, fc() wasn't properly updated
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
pp.c | 12 +++++++++---
|
|
||||||
t/op/lc.t | 23 ++++++++++++++++-------
|
|
||||||
2 files changed, 25 insertions(+), 10 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/pp.c b/pp.c
|
|
||||||
index 5e1706346d..23cc6c8adb 100644
|
|
||||||
--- a/pp.c
|
|
||||||
+++ b/pp.c
|
|
||||||
@@ -4813,7 +4813,7 @@ PP(pp_fc)
|
|
||||||
do {
|
|
||||||
extra++;
|
|
||||||
|
|
||||||
- s_peek = (U8 *) memchr(s_peek + 1, 'i',
|
|
||||||
+ s_peek = (U8 *) memchr(s_peek + 1, 'I',
|
|
||||||
send - (s_peek + 1));
|
|
||||||
} while (s_peek != NULL);
|
|
||||||
}
|
|
||||||
@@ -4828,8 +4828,14 @@ PP(pp_fc)
|
|
||||||
+ 1 /* Trailing NUL */ );
|
|
||||||
d = (U8*)SvPVX(dest) + len;
|
|
||||||
|
|
||||||
- *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
|
|
||||||
- *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
|
|
||||||
+ if (*s == 'I') {
|
|
||||||
+ *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
|
|
||||||
+ *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
|
|
||||||
+ }
|
|
||||||
+ else {
|
|
||||||
+ *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
|
|
||||||
+ *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
|
|
||||||
+ }
|
|
||||||
s++;
|
|
||||||
|
|
||||||
for (; s < send; s++) {
|
|
||||||
diff --git a/t/op/lc.t b/t/op/lc.t
|
|
||||||
index fce77f3d34..812c41d6b6 100644
|
|
||||||
--- a/t/op/lc.t
|
|
||||||
+++ b/t/op/lc.t
|
|
||||||
@@ -17,7 +17,7 @@ BEGIN {
|
|
||||||
|
|
||||||
use feature qw( fc );
|
|
||||||
|
|
||||||
-plan tests => 139 + 2 * (4 * 256) + 15;
|
|
||||||
+plan tests => 139 + 2 * (5 * 256) + 17;
|
|
||||||
|
|
||||||
is(lc(undef), "", "lc(undef) is ''");
|
|
||||||
is(lcfirst(undef), "", "lcfirst(undef) is ''");
|
|
||||||
@@ -352,13 +352,14 @@ foreach my $turkic (0 .. 1) {
|
|
||||||
my $locale = ($turkic) ? $turkic_locale : $non_turkic_locale;
|
|
||||||
|
|
||||||
SKIP: {
|
|
||||||
- skip "Can't find a $type UTF-8 locale", 4*256 unless defined $locale;
|
|
||||||
+ skip "Can't find a $type UTF-8 locale", 5*256 unless defined $locale;
|
|
||||||
|
|
||||||
use feature qw( unicode_strings );
|
|
||||||
|
|
||||||
no locale;
|
|
||||||
|
|
||||||
my @unicode_lc;
|
|
||||||
+ my @unicode_fc;
|
|
||||||
my @unicode_uc;
|
|
||||||
my @unicode_lcfirst;
|
|
||||||
my @unicode_ucfirst;
|
|
||||||
@@ -366,6 +367,7 @@ foreach my $turkic (0 .. 1) {
|
|
||||||
# Get all the values outside of 'locale'
|
|
||||||
for my $i (0 .. 255) {
|
|
||||||
push @unicode_lc, lc(chr $i);
|
|
||||||
+ push @unicode_fc, fc(chr $i);
|
|
||||||
push @unicode_uc, uc(chr $i);
|
|
||||||
push @unicode_lcfirst, lcfirst(chr $i);
|
|
||||||
push @unicode_ucfirst, ucfirst(chr $i);
|
|
||||||
@@ -373,6 +375,7 @@ foreach my $turkic (0 .. 1) {
|
|
||||||
|
|
||||||
if ($turkic) {
|
|
||||||
$unicode_lc[ord 'I'] = chr 0x131;
|
|
||||||
+ $unicode_fc[ord 'I'] = chr 0x131;
|
|
||||||
$unicode_lcfirst[ord 'I'] = chr 0x131;
|
|
||||||
$unicode_uc[ord 'i'] = chr 0x130;
|
|
||||||
$unicode_ucfirst[ord 'i'] = chr 0x130;
|
|
||||||
@@ -384,6 +387,7 @@ foreach my $turkic (0 .. 1) {
|
|
||||||
for my $i (0 .. 255) {
|
|
||||||
is(lc(chr $i), $unicode_lc[$i], "In a $type UTF-8 locale, lc(chr $i) is the same as official Unicode");
|
|
||||||
is(uc(chr $i), $unicode_uc[$i], "In a $type UTF-8 locale, uc(chr $i) is the same as official Unicode");
|
|
||||||
+ is(fc(chr $i), $unicode_fc[$i], "In a $type UTF-8 locale, fc(chr $i) is the same as official Unicode");
|
|
||||||
is(lcfirst(chr $i), $unicode_lcfirst[$i], "In a $type UTF-8 locale, lcfirst(chr $i) is the same as official Unicode");
|
|
||||||
is(ucfirst(chr $i), $unicode_ucfirst[$i], "In a $type UTF-8 locale, ucfirst(chr $i) is the same as official Unicode");
|
|
||||||
}
|
|
||||||
@@ -391,27 +395,32 @@ foreach my $turkic (0 .. 1) {
|
|
||||||
}
|
|
||||||
|
|
||||||
SKIP: {
|
|
||||||
- skip "Can't find a turkic UTF-8 locale", 15 unless defined $turkic_locale;
|
|
||||||
+ skip "Can't find a turkic UTF-8 locale", 17 unless defined $turkic_locale;
|
|
||||||
|
|
||||||
# These are designed to stress the calculation of space needed for the
|
|
||||||
# strings. $filler contains a variety of characters that have special
|
|
||||||
# handling in the casing functions, and some regular chars as well.
|
|
||||||
+ # (0x49 = 'I')
|
|
||||||
my $filler_length = 10000;
|
|
||||||
- my $filler = uni_to_native("\x{df}\x{b5}\x{e0}\x{c1}\x{b6}\x{ff}") x $filler_length;
|
|
||||||
+ my $filler = uni_to_native("\x{df}\x{49}\x{69}\x{b5}\x{e0}\x{c1}\x{b6}\x{ff}") x $filler_length;
|
|
||||||
|
|
||||||
# These are the correct answers to what should happen when the given
|
|
||||||
# casing function is called on $filler;
|
|
||||||
- my $filler_lc = uni_to_native("\x{df}\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}") x $filler_length;
|
|
||||||
- my $filler_fc = ("ss" . uni_to_native("\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}")) x $filler_length;
|
|
||||||
- my $filler_uc = ("SS" . uni_to_native("\x{39c}\x{c0}\x{c1}\x{b6}\x{178}")) x $filler_length;
|
|
||||||
+ my $filler_lc = uni_to_native("\x{df}\x{131}\x{69}\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}") x $filler_length;
|
|
||||||
+ my $filler_fc = ("ss" . uni_to_native("\x{131}\x{69}\x{3bc}\x{e0}\x{e1}\x{b6}\x{ff}")) x $filler_length;
|
|
||||||
+ my $filler_uc = ("SS" . uni_to_native("\x{49}\x{130}\x{39c}\x{c0}\x{c1}\x{b6}\x{178}")) x $filler_length;
|
|
||||||
|
|
||||||
use locale;
|
|
||||||
setlocale(&POSIX::LC_CTYPE, $turkic_locale);
|
|
||||||
|
|
||||||
is (lc "IIIIIII$filler", "\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc",
|
|
||||||
"lc non-UTF-8, in Turkic locale, beginning with a bunch of I's");
|
|
||||||
+ is (fc "IIIIIII$filler", "\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_fc",
|
|
||||||
+ "fc non-UTF-8, in Turkic locale, beginning with a bunch of I's");
|
|
||||||
is (lc "${filler}IIIIIII$filler", "$filler_lc\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc",
|
|
||||||
"lc non-UTF-8, in Turkic locale, a bunch of I's, but not at the beginning");
|
|
||||||
+ is (fc "${filler}IIIIIII$filler", "$filler_fc\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_fc",
|
|
||||||
+ "fc non-UTF-8, in Turkic locale, a bunch of I's, but not at the beginning");
|
|
||||||
is (lc "${filler}I\x{307}$filler", "${filler_lc}i$filler_lc",
|
|
||||||
"lc in Turkic locale with DOT ABOVE immediately following I");
|
|
||||||
is (lc "${filler}I\x{307}IIIIII$filler", "${filler_lc}i\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc",
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,43 +0,0 @@
|
|||||||
From 036189b0a003875df7bf09c7f7fd702267f549e5 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Sat, 26 Dec 2020 08:44:08 -0700
|
|
||||||
Subject: [PATCH] Use perl.h versions of PERL_UNUSED_foo in XSUB.h
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
This commit was applied to perl.h, but not to XSUB.h:
|
|
||||||
|
|
||||||
commit a730e3f230f364cffe49370f816f975ae7c9c403
|
|
||||||
Author: Jarkko Hietaniemi <jhi@iki.fi>
|
|
||||||
Date: Thu Sep 4 09:08:33 2014 -0400
|
|
||||||
|
|
||||||
Use sizeof() in UNUSED_ARG and UNUSED_VAR to avoid accessing the values.
|
|
||||||
|
|
||||||
The values might even be uninitialized in the case of PERL_UNUSED_VAR.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
XSUB.h | 4 ++--
|
|
||||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/XSUB.h b/XSUB.h
|
|
||||||
index 616d813840..c1e3959885 100644
|
|
||||||
--- a/XSUB.h
|
|
||||||
+++ b/XSUB.h
|
|
||||||
@@ -108,10 +108,10 @@ is a lexical C<$_> in scope.
|
|
||||||
*/
|
|
||||||
|
|
||||||
#ifndef PERL_UNUSED_ARG
|
|
||||||
-# define PERL_UNUSED_ARG(x) ((void)x)
|
|
||||||
+# define PERL_UNUSED_ARG(x) ((void)sizeof(x))
|
|
||||||
#endif
|
|
||||||
#ifndef PERL_UNUSED_VAR
|
|
||||||
-# define PERL_UNUSED_VAR(x) ((void)x)
|
|
||||||
+# define PERL_UNUSED_VAR(x) ((void)sizeof(x))
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#define ST(off) PL_stack_base[ax + (off)]
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,78 +0,0 @@
|
|||||||
From 07319fdbb283f93cb655c3106b5237cbc7272038 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Tomasz Konojacki <me@xenu.pl>
|
|
||||||
Date: Wed, 30 Dec 2020 14:03:02 +0100
|
|
||||||
Subject: [PATCH] op.c: croak on "my $_" when "use utf8" is in effect
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
Fixes #18449
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
op.c | 16 +++++++++-------
|
|
||||||
t/op/mydef.t | 11 +++++++++--
|
|
||||||
2 files changed, 18 insertions(+), 9 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/op.c b/op.c
|
|
||||||
index b2e12dd0c0..dce844d297 100644
|
|
||||||
--- a/op.c
|
|
||||||
+++ b/op.c
|
|
||||||
@@ -730,6 +730,7 @@ PADOFFSET
|
|
||||||
Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
|
|
||||||
{
|
|
||||||
PADOFFSET off;
|
|
||||||
+ bool is_idfirst, is_default;
|
|
||||||
const bool is_our = (PL_parser->in_my == KEY_our);
|
|
||||||
|
|
||||||
PERL_ARGS_ASSERT_ALLOCMY;
|
|
||||||
@@ -738,14 +739,15 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
|
|
||||||
Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
|
|
||||||
(UV)flags);
|
|
||||||
|
|
||||||
+ is_idfirst = flags & SVf_UTF8
|
|
||||||
+ ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
|
|
||||||
+ : isIDFIRST_A(name[1]);
|
|
||||||
+
|
|
||||||
+ /* $_, @_, etc. */
|
|
||||||
+ is_default = len == 2 && name[1] == '_';
|
|
||||||
+
|
|
||||||
/* complain about "my $<special_var>" etc etc */
|
|
||||||
- if ( len
|
|
||||||
- && !( is_our
|
|
||||||
- || isALPHA(name[1])
|
|
||||||
- || ( (flags & SVf_UTF8)
|
|
||||||
- && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
|
|
||||||
- || (name[1] == '_' && len > 2)))
|
|
||||||
- {
|
|
||||||
+ if (!is_our && (!is_idfirst || is_default)) {
|
|
||||||
const char * const type =
|
|
||||||
PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
|
|
||||||
PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
|
|
||||||
diff --git a/t/op/mydef.t b/t/op/mydef.t
|
|
||||||
index 42a81d9ab0..225ce98e51 100644
|
|
||||||
--- a/t/op/mydef.t
|
|
||||||
+++ b/t/op/mydef.t
|
|
||||||
@@ -6,10 +6,17 @@ BEGIN {
|
|
||||||
set_up_inc('../lib');
|
|
||||||
}
|
|
||||||
|
|
||||||
-plan tests => 1;
|
|
||||||
-
|
|
||||||
use strict;
|
|
||||||
|
|
||||||
eval 'my $_';
|
|
||||||
like $@, qr/^Can't use global \$_ in "my" at /;
|
|
||||||
|
|
||||||
+{
|
|
||||||
+ # using utf8 allows $_ to be declared with 'my'
|
|
||||||
+ # GH #18449
|
|
||||||
+ use utf8;
|
|
||||||
+ eval 'my $_;';
|
|
||||||
+ like $@, qr/^Can't use global \$_ in "my" at /;
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
+done_testing;
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,100 +0,0 @@
|
|||||||
From cac138107138a9814b32c4de74426225628f1646 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Sun, 17 Jan 2021 21:45:20 -0700
|
|
||||||
Subject: [PATCH] Add missing entries to perldiag; GH #18276
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
The ticket mentions yet another message, not addressed in this
|
|
||||||
commit, "Insecure private-use override". That message is part of a
|
|
||||||
hook for a so-far unimplemented module, so it actually doesn't ever get
|
|
||||||
raised.
|
|
||||||
|
|
||||||
Committer: One correction per Grinnz comment in
|
|
||||||
https://github.com/Perl/perl5/pull/18491
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
pod/perldiag.pod | 45 +++++++++++++++++++++++++++++++++++++++++++++
|
|
||||||
1 file changed, 45 insertions(+)
|
|
||||||
|
|
||||||
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
|
|
||||||
index 9c91630d39..63f57f220e 100644
|
|
||||||
--- a/pod/perldiag.pod
|
|
||||||
+++ b/pod/perldiag.pod
|
|
||||||
@@ -2195,6 +2195,20 @@ single form when it must operate on them directly. Either you've passed
|
|
||||||
an invalid file specification to Perl, or you've found a case the
|
|
||||||
conversion routines don't handle. Drat.
|
|
||||||
|
|
||||||
+=item Error %s in expansion of %s
|
|
||||||
+
|
|
||||||
+(F) An error was encountered in handling a user-defined property
|
|
||||||
+(L<perlunicode/User-Defined Character Properties>). These are
|
|
||||||
+programmer written subroutines, hence subject to errors that may
|
|
||||||
+prevent them from compiling or running. The calls to these subs are
|
|
||||||
+C<eval>'d, and if there is a failure, this message is raised, using the
|
|
||||||
+contents of C<$@> from the failed C<eval>.
|
|
||||||
+
|
|
||||||
+Another possibility is that tainted data was encountered somewhere in
|
|
||||||
+the chain of expanding the property. If so, the message wording will
|
|
||||||
+indicate that this is the problem. See L</Insecure user-defined
|
|
||||||
+property %s>.
|
|
||||||
+
|
|
||||||
=item Eval-group in insecure regular expression
|
|
||||||
|
|
||||||
(F) Perl detected tainted data when trying to compile a regular
|
|
||||||
@@ -2836,6 +2850,16 @@ not match 8 spaces.
|
|
||||||
text. You should check the pattern to ensure that recursive patterns
|
|
||||||
either consume text or fail.
|
|
||||||
|
|
||||||
+=item Infinite recursion in user-defined property
|
|
||||||
+
|
|
||||||
+(F) A user-defined property (L<perlunicode/User-Defined Character
|
|
||||||
+Properties>) can depend on the definitions of other user-defined
|
|
||||||
+properties. If the chain of dependencies leads back to this property,
|
|
||||||
+infinite recursion would occur, were it not for the check that raised
|
|
||||||
+this error.
|
|
||||||
+
|
|
||||||
+Restructure your property definitions to avoid this.
|
|
||||||
+
|
|
||||||
=item Infinite recursion via empty pattern
|
|
||||||
|
|
||||||
(F) You tried to use the empty pattern inside of a regex code block,
|
|
||||||
@@ -6273,6 +6297,20 @@ lexicals that are initialized only once (see L<feature>):
|
|
||||||
This use of C<my()> in a false conditional was deprecated beginning in
|
|
||||||
Perl 5.10 and became a fatal error in Perl 5.30.
|
|
||||||
|
|
||||||
+=item Timeout waiting for another thread to define \p{%s}
|
|
||||||
+
|
|
||||||
+(F) The first time a user-defined property
|
|
||||||
+(L<perlunicode/User-Defined Character Properties>) is used, its
|
|
||||||
+definition is looked up and converted into an internal form for more
|
|
||||||
+efficient handling in subsequent uses. There could be a race if two or
|
|
||||||
+more threads tried to do this processing nearly simultaneously.
|
|
||||||
+Instead, a critical section is created around this task, locking out all
|
|
||||||
+but one thread from doing it. This message indicates that the thread
|
|
||||||
+that is doing the conversion is taking an unexpectedly long time. The
|
|
||||||
+timeout exists solely to prevent deadlock; it's long enough that the
|
|
||||||
+system was likely thrashing and about to crash. There is no real remedy but
|
|
||||||
+rebooting.
|
|
||||||
+
|
|
||||||
=item times not implemented
|
|
||||||
|
|
||||||
(F) Your version of the C library apparently doesn't do times(). I
|
|
||||||
@@ -6846,6 +6884,13 @@ for the list of known options.
|
|
||||||
L<perlrun|perlrun/-C [numberE<sol>list]> documentation of the C<-C> switch
|
|
||||||
for the list of known options.
|
|
||||||
|
|
||||||
+=item Unknown user-defined property name \p{%s}
|
|
||||||
+
|
|
||||||
+(F) You specified to use a property within the C<\p{...}> which was a
|
|
||||||
+syntactically valid user-defined property, but no definition was found
|
|
||||||
+for it by the time one was required to proceed. Check your spelling.
|
|
||||||
+See L<perlunicode/User-Defined Character Properties>.
|
|
||||||
+
|
|
||||||
=item Unknown verb pattern '%s' in regex; marked by S<<-- HERE> in m/%s/
|
|
||||||
|
|
||||||
(F) You either made a typo or have incorrectly put a C<*> quantifier
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,32 +0,0 @@
|
|||||||
From a2f57b06b018b254bee93e1a1265cfc09833366f Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Tue, 9 Feb 2021 11:32:15 -0700
|
|
||||||
Subject: [PATCH] t/run/locale.t: Rmv LANGUAGE from environment
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
This could cause interference with our tests on some platforms that have
|
|
||||||
this environment variable.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
t/run/locale.t | 2 +-
|
|
||||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/t/run/locale.t b/t/run/locale.t
|
|
||||||
index 8a04d1aea6..0f2a2ba457 100644
|
|
||||||
--- a/t/run/locale.t
|
|
||||||
+++ b/t/run/locale.t
|
|
||||||
@@ -38,7 +38,7 @@ if (defined $ARGV[0] && $ARGV[0] ne "") {
|
|
||||||
}
|
|
||||||
|
|
||||||
# reset the locale environment
|
|
||||||
-delete local @ENV{'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};
|
|
||||||
+delete local @ENV{'LANGUAGE', 'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};
|
|
||||||
|
|
||||||
# If user wants this to happen, they set the environment variable AND use
|
|
||||||
# 'debug'
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,74 +0,0 @@
|
|||||||
From 5f41fa466a67b5535aa8bcf4b814f242545ac7bd Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Sat, 27 Feb 2021 11:43:41 -0700
|
|
||||||
Subject: [PATCH] regcomp.c: Remove memory leak
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
This fixes GH #18604. There was a path through the code where a
|
|
||||||
particular SV did not get its reference count decremented.
|
|
||||||
|
|
||||||
I did an audit of the function and came up with several other
|
|
||||||
possiblities that are included in this commit.
|
|
||||||
|
|
||||||
Further, there would be leaks for some instances of finding syntax
|
|
||||||
errors in the input pattern, or when warnings are fatalized. Those
|
|
||||||
would require mortalizing some SVs, but that is beyond the scope of this
|
|
||||||
commit.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
regcomp.c | 7 +++++++
|
|
||||||
t/op/svleak.t | 3 ++-
|
|
||||||
2 files changed, 9 insertions(+), 1 deletion(-)
|
|
||||||
|
|
||||||
diff --git a/regcomp.c b/regcomp.c
|
|
||||||
index e44c7a37e5..f5e5f581dc 100644
|
|
||||||
--- a/regcomp.c
|
|
||||||
+++ b/regcomp.c
|
|
||||||
@@ -18765,6 +18765,12 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
|
|
||||||
RExC_end = save_end;
|
|
||||||
RExC_in_multi_char_class = 0;
|
|
||||||
SvREFCNT_dec_NN(multi_char_matches);
|
|
||||||
+ SvREFCNT_dec(properties);
|
|
||||||
+ SvREFCNT_dec(cp_list);
|
|
||||||
+ SvREFCNT_dec(simple_posixes);
|
|
||||||
+ SvREFCNT_dec(posixes);
|
|
||||||
+ SvREFCNT_dec(nposixes);
|
|
||||||
+ SvREFCNT_dec(cp_foldable_list);
|
|
||||||
return ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
@@ -20122,6 +20128,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
|
|
||||||
RExC_parse - orig_parse);;
|
|
||||||
SvREFCNT_dec(cp_list);;
|
|
||||||
SvREFCNT_dec(only_utf8_locale_list);
|
|
||||||
+ SvREFCNT_dec(upper_latin1_only_utf8_matches);
|
|
||||||
return ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
diff --git a/t/op/svleak.t b/t/op/svleak.t
|
|
||||||
index 6acc298c3d..3df4838be8 100644
|
|
||||||
--- a/t/op/svleak.t
|
|
||||||
+++ b/t/op/svleak.t
|
|
||||||
@@ -15,7 +15,7 @@ BEGIN {
|
|
||||||
|
|
||||||
use Config;
|
|
||||||
|
|
||||||
-plan tests => 150;
|
|
||||||
+plan tests => 151;
|
|
||||||
|
|
||||||
# run some code N times. If the number of SVs at the end of loop N is
|
|
||||||
# greater than (N-1)*delta at the end of loop 1, we've got a leak
|
|
||||||
@@ -278,6 +278,7 @@ eleak(2,0,'/[[:ascii:]]/');
|
|
||||||
eleak(2,0,'/[[.zog.]]/');
|
|
||||||
eleak(2,0,'/[.zog.]/');
|
|
||||||
eleak(2,0,'/|\W/', '/|\W/ [perl #123198]');
|
|
||||||
+eleak(2,0,'/a\sb/', '/a\sb/ [GH #18604]');
|
|
||||||
eleak(2,0,'no warnings; /(?[])/');
|
|
||||||
eleak(2,0,'no warnings; /(?[[a]+[b]])/');
|
|
||||||
eleak(2,0,'no warnings; /(?[[a]-[b]])/');
|
|
||||||
--
|
|
||||||
2.26.2
|
|
||||||
|
|
||||||
@ -1,62 +0,0 @@
|
|||||||
From 4e82c85b1c9c9b30253b8624470da6f20a6c0604 Mon Sep 17 00:00:00 2001
|
|
||||||
From: Karl Williamson <khw@cpan.org>
|
|
||||||
Date: Mon, 15 Mar 2021 21:01:47 -0600
|
|
||||||
Subject: [PATCH] Fix broken left shift of IV_MIN under 'use integer'
|
|
||||||
MIME-Version: 1.0
|
|
||||||
Content-Type: text/plain; charset=UTF-8
|
|
||||||
Content-Transfer-Encoding: 8bit
|
|
||||||
|
|
||||||
This fixes GH 18639
|
|
||||||
|
|
||||||
When I wrote this code, I conflated casting and complementing.
|
|
||||||
|
|
||||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
||||||
---
|
|
||||||
pp.c | 3 ---
|
|
||||||
t/op/bop.t | 9 ++++++++-
|
|
||||||
2 files changed, 8 insertions(+), 4 deletions(-)
|
|
||||||
|
|
||||||
diff --git a/pp.c b/pp.c
|
|
||||||
index d365afea4c..baf0777a47 100644
|
|
||||||
--- a/pp.c
|
|
||||||
+++ b/pp.c
|
|
||||||
@@ -2007,9 +2007,6 @@ static IV S_iv_shift(IV iv, int shift, bool left)
|
|
||||||
* 18446744073709551552
|
|
||||||
* */
|
|
||||||
if (left) {
|
|
||||||
- if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
|
|
||||||
- return 0;
|
|
||||||
- }
|
|
||||||
return (IV) (((UV) iv) << shift);
|
|
||||||
}
|
|
||||||
|
|
||||||
diff --git a/t/op/bop.t b/t/op/bop.t
|
|
||||||
index 07f057d0a9..31b6531a03 100644
|
|
||||||
--- a/t/op/bop.t
|
|
||||||
+++ b/t/op/bop.t
|
|
||||||
@@ -18,7 +18,7 @@ BEGIN {
|
|
||||||
# If you find tests are failing, please try adding names to tests to track
|
|
||||||
# down where the failure is, and supply your new names as a patch.
|
|
||||||
# (Just-in-time test naming)
|
|
||||||
-plan tests => 502;
|
|
||||||
+plan tests => 503;
|
|
||||||
|
|
||||||
# numerics
|
|
||||||
ok ((0xdead & 0xbeef) == 0x9ead);
|
|
||||||
@@ -33,6 +33,13 @@ ok ((33023 >> 7) == 257);
|
|
||||||
# signed vs. unsigned
|
|
||||||
ok ((~0 > 0 && do { use integer; ~0 } == -1));
|
|
||||||
|
|
||||||
+{ # GH #18639
|
|
||||||
+ my $iv_min = -(~0 >> 1) - 1;
|
|
||||||
+ my $shifted;
|
|
||||||
+ { use integer; $shifted = $iv_min << 0 };
|
|
||||||
+ is($shifted, $iv_min, "IV_MIN << 0 yields IV_MIN under 'use integer'");
|
|
||||||
+}
|
|
||||||
+
|
|
||||||
my $bits = 0;
|
|
||||||
for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
|
|
||||||
my $cusp = 1 << ($bits - 1);
|
|
||||||
--
|
|
||||||
2.26.3
|
|
||||||
|
|
||||||
@ -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
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in new issue