Compare commits

...

No commits in common. "c8" and "c8s-stream-5.32" have entirely different histories.

103 changed files with 7633 additions and 8086 deletions

2
.gitignore vendored
View File

@ -1 +1 @@
SOURCES/perl-5.26.3.tar.bz2
SOURCES/perl-5.32.1.tar.xz

View File

@ -1 +1 @@
4c61872bab631427cbb5b519ef8809d3a4c7f921 SOURCES/perl-5.26.3.tar.bz2
1fb4f710d139da1e1a3e1fa4eaba201fcaa8e18e SOURCES/perl-5.32.1.tar.xz

File diff suppressed because it is too large Load Diff

View File

@ -22,6 +22,13 @@ export PERL_AUTOINSTALL="--defaultdeps"
export PERL_MM_USE_DEFAULT=1
}
#############################################################################
# Perl specific macros, no longer part of rpm >= 4.15
%perl_vendorarch %(eval "`%{__perl} -V:installvendorarch`"; echo $installvendorarch)
%perl_vendorlib %(eval "`%{__perl} -V:installvendorlib`"; echo $installvendorlib)
%perl_archlib %(eval "`%{__perl} -V:installarchlib`"; echo $installarchlib)
%perl_privlib %(eval "`%{__perl} -V:installprivlib`"; echo $installprivlib)
#############################################################################
# Filtering macro incantations

View File

@ -1,7 +1,7 @@
diff -up perl-5.10.0/Configure.didi perl-5.10.0/Configure
--- perl-5.10.0/Configure.didi 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/Configure 2008-07-21 10:51:16.000000000 +0200
@@ -1479,7 +1479,7 @@ archname=''
@@ -1483,7 +1483,7 @@ archname=''
usereentrant='undef'
: List of libraries we want.
: If anyone needs extra -lxxx, put those in a hint file.

View File

@ -1,12 +1,12 @@
diff -up perl-5.10.0/t/io/fs.t.BAD perl-5.10.0/t/io/fs.t
--- perl-5.10.0/t/io/fs.t.BAD 2008-01-30 13:36:43.000000000 -0500
+++ perl-5.10.0/t/io/fs.t 2008-01-30 13:41:27.000000000 -0500
@@ -227,7 +227,7 @@ isnt($atime, 500000000, 'atime');
isnt($mtime, 500000000 + $delta, 'mtime');
@@ -257,7 +257,7 @@ isnt($atime, 500000000, 'atime');
isnt($mtime, $ut + $delta, 'mtime: utime called with two undefs');
SKIP: {
- skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define";
+ skip "no futimes", 6;
note("check futimes");
open(my $fh, "<", 'b');
$foo = (utime 500000000,500000000 + $delta, $fh);
is($foo, 1, "futime");
$foo = (utime $ut,$ut + $delta, $fh);

View File

@ -20,7 +20,7 @@ diff --git a/MANIFEST b/MANIFEST
index 397252a..d7c519b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3093,6 +3093,7 @@ dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm CBuilder methods fo
@@ -3424,6 +3424,7 @@ dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm CBuilder methods fo
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm CBuilder methods for cygwin
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm CBuilder methods for darwin
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm CBuilder methods for OSF

View File

@ -18,7 +18,7 @@ diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm b/cpan/ExtUtils-Mak
index a8b172f..a3fbce2 100644
--- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
+++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
@@ -31,6 +31,7 @@ BEGIN {
@@ -30,6 +30,7 @@ BEGIN {
$Is{IRIX} = $^O eq 'irix';
$Is{NetBSD} = $^O eq 'netbsd';
$Is{Interix} = $^O eq 'interix';
@ -26,7 +26,7 @@ index a8b172f..a3fbce2 100644
$Is{SunOS4} = $^O eq 'sunos';
$Is{Solaris} = $^O eq 'solaris';
$Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
@@ -932,7 +933,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
@@ -1028,7 +1029,7 @@ sub xs_make_dynamic_lib {
push(@m," \$(RM_F) \$\@\n");
my $libs = '$(LDLOADLIBS)';
@ -35,7 +35,7 @@ index a8b172f..a3fbce2 100644
# Use nothing on static perl platforms, and to the flags needed
# to link against the shared libperl library on shared perl
# platforms. We peek at lddlflags to see if we need -Wl,-R
@@ -941,6 +942,11 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).
@@ -1041,6 +1042,11 @@ sub xs_make_dynamic_lib {
# The Android linker will not recognize symbols from
# libperl unless the module explicitly depends on it.
$libs .= ' "-L$(PERL_INC)" -lperl';

View File

@ -14,16 +14,21 @@ diff --git a/Makefile.SH b/Makefile.SH
index d1da0a0..7733a32 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -58,7 +58,7 @@ true)
${api_revision}.${api_version}.${api_subversion} \
-current_version \
${revision}.${patchlevel}.${subversion} \
- -install_name \$(shrpdir)/\$@"
+ -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
@@ -70,11 +70,11 @@ true)
${revision}.${patchlevel}.${subversion}"
case "$osvers" in
1[5-9]*|[2-9]*)
- shrpldflags="$shrpldflags -install_name `pwd`/\$@ -Xlinker -headerpad_max_install_names"
+ shrpldflags="$shrpldflags -install_name `pwd`/libperl.${revision}.${patchlevel}.dylib -Xlinker -headerpad_max_install_names"
exeldflags="-Xlinker -headerpad_max_install_names"
;;
*)
- shrpldflags="$shrpldflags -install_name \$(shrpdir)/\$@"
+ shrpldflags="$shrpldflags -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
;;
esac
;;
cygwin*)
shrpldflags="$shrpldflags -Wl,--out-implib=libperl.dll.a -Wl,--image-base,0x52000000"
@@ -66,13 +66,15 @@ true)
@@ -76,13 +76,15 @@ true)
;;
sunos*)
linklibperl="-lperl"
@ -40,7 +45,7 @@ index d1da0a0..7733a32 100755
;;
aix*)
case "$cc" in
@@ -110,6 +112,9 @@ true)
@@ -120,6 +122,9 @@ true)
linklibperl='libperl.x'
DPERL_EXTERNAL_GLOB=''
;;

View File

@ -1,30 +0,0 @@
From 862c89c81d26dae0dcef138e19df8b45615e69c9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Mon, 2 Dec 2013 10:10:56 +0100
Subject: [PATCH] Document Math::BigInt::CalcEmu requires Math::BigInt
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
<https://rt.cpan.org/Public/Bug/Display.html?id=85015>
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm | 1 +
1 file changed, 1 insertion(+)
diff --git a/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm b/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
index c82e153..0c0b496 100644
--- a/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
+++ b/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm
@@ -290,6 +290,7 @@ Math::BigInt::CalcEmu - Emulate low-level math with BigInt code
=head1 SYNOPSIS
+ use Math::BigInt;
use Math::BigInt::CalcEmu;
=head1 DESCRIPTION
--
1.8.3.1

View File

@ -41,15 +41,15 @@ index 33e08e2..7160f54 100644
GDBM_FILE dbp ;
SV * filter[4];
int filtering ;
@@ -89,6 +90,7 @@ gdbm_TIEHASH(dbtype, name, read_write, mode)
if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode,
(FATALFUNC) croak_string))) {
RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type)) ;
+ RETVAL->owner = aTHX;
RETVAL->dbp = dbp ;
}
@@ -109,12 +111,14 @@ gdbm_DESTROY(db)
@@ -98,6 +99,7 @@ gdbm_TIEHASH(dbtype, name, read_write, m
}
if (dbp) {
RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type));
+ RETVAL->owner = aTHX;
RETVAL->dbp = dbp;
} else {
RETVAL = NULL;
@@ -118,12 +120,14 @@ gdbm_DESTROY(db)
PREINIT:
int i = store_value;
CODE:
@ -115,7 +115,7 @@ diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
index d1ece7f..f7e00a0 100644
--- a/ext/ODBM_File/ODBM_File.xs
+++ b/ext/ODBM_File/ODBM_File.xs
@@ -45,6 +45,7 @@ datum nextkey(datum key);
@@ -49,6 +49,7 @@ datum nextkey(datum key);
#define store_value 3
typedef struct {
@ -123,7 +123,7 @@ index d1ece7f..f7e00a0 100644
void * dbp ;
SV * filter[4];
int filtering ;
@@ -112,6 +113,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
@@ -137,6 +138,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
}
dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
@ -131,7 +131,7 @@ index d1ece7f..f7e00a0 100644
RETVAL->dbp = dbp ;
}
OUTPUT:
@@ -124,13 +126,15 @@ DESTROY(db)
@@ -149,13 +151,15 @@ DESTROY(db)
dMY_CXT;
int i = store_value;
CODE:
@ -166,7 +166,7 @@ index 291e41b..0bdae9a 100644
DBM * dbp ;
SV * filter[4];
int filtering ;
@@ -49,6 +50,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
@@ -51,6 +52,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
}
if (dbp) {
RETVAL = (SDBM_File)safecalloc(1, sizeof(SDBM_File_type));
@ -174,7 +174,7 @@ index 291e41b..0bdae9a 100644
RETVAL->dbp = dbp ;
}
@@ -60,7 +62,7 @@ void
@@ -62,7 +64,7 @@ void
sdbm_DESTROY(db)
SDBM_File db
CODE:
@ -187,7 +187,7 @@ diff --git a/t/lib/dbmt_common.pl b/t/lib/dbmt_common.pl
index 5d4098c..a0a4d52 100644
--- a/t/lib/dbmt_common.pl
+++ b/t/lib/dbmt_common.pl
@@ -511,5 +511,40 @@ unlink <Op_dbmx*>, $Dfile;
@@ -510,5 +510,40 @@ unlink <Op_dbmx*>, $Dfile;
unlink <Op1_dbmx*>;
}

View File

@ -16,7 +16,7 @@ diff --git a/Configure b/Configure
index 2f30261..825496e 100755
--- a/Configure
+++ b/Configure
@@ -8249,7 +8249,9 @@ esac
@@ -8762,7 +8762,9 @@ esac
# Detect old use of shrpdir via undocumented Configure -Dshrpdir
case "$shrpdir" in
@ -27,7 +27,7 @@ index 2f30261..825496e 100755
*) $cat >&4 <<EOM
WARNING: Use of the shrpdir variable for the installation location of
the shared $libperl is not supported. It was never documented and
@@ -8279,7 +8281,6 @@ esac
@@ -8792,7 +8794,6 @@ esac
# Add $xxx to ccdlflags.
# If we can't figure out a command-line option, use $shrpenv to
# set env LD_RUN_PATH. The main perl makefile uses this.
@ -35,7 +35,7 @@ index 2f30261..825496e 100755
xxx=''
tmp_shrpenv=''
if "$useshrplib"; then
@@ -8294,7 +8295,7 @@ if "$useshrplib"; then
@@ -8807,7 +8808,7 @@ if "$useshrplib"; then
xxx="-Wl,-R$shrpdir"
;;
bsdos|linux|irix*|dec_osf|gnu*|haiku)
@ -48,7 +48,7 @@ diff --git a/Makefile.SH b/Makefile.SH
index 7733a32..a481183 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -266,7 +266,7 @@ ranlib = $ranlib
@@ -288,7 +288,7 @@ ranlib = $ranlib
# installman commandline.
bin = $installbin
scriptdir = $scriptdir

View File

@ -23,7 +23,7 @@ diff --git a/MANIFEST b/MANIFEST
index 6af238c..d4f0c56 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1045,6 +1045,7 @@ cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
@@ -784,6 +784,7 @@ cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm MakeMaker methods for QNX
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm MakeMaker methods for Unix

View File

@ -20,7 +20,7 @@ diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
index 6a82bdf..b6cd7ef 100644
--- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm
+++ b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
@@ -230,7 +230,7 @@ sub can_run {
@@ -232,7 +232,7 @@ sub can_run {
}
require File::Spec;

View File

@ -1,73 +0,0 @@
From 8985b12868f07d9ef501580d600e49fe8f230eb4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Tue, 22 Aug 2017 09:49:42 +0200
Subject: [PATCH] Time-HiRes: Fix unreliable t/usleep.t and t/utime.t
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported from Time-HiRes-1.9746.
The tests randomly failed on loaded machines because a CPU scheduler
could add unpredictable delays.
CPAN RT#122819
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
dist/Time-HiRes/t/usleep.t | 4 ++--
dist/Time-HiRes/t/utime.t | 9 +++++----
2 files changed, 7 insertions(+), 6 deletions(-)
diff --git a/dist/Time-HiRes/t/usleep.t b/dist/Time-HiRes/t/usleep.t
index 9322458..bb66cbe 100644
--- a/dist/Time-HiRes/t/usleep.t
+++ b/dist/Time-HiRes/t/usleep.t
@@ -32,7 +32,7 @@ SKIP: {
Time::HiRes::usleep(500_000);
my $f2 = Time::HiRes::time();
my $d = $f2 - $f;
- ok $d > 0.4 && $d < 0.9 or print("# slept $d secs $f to $f2\n");
+ ok $d > 0.49 or print("# slept $d secs $f to $f2\n");
}
SKIP: {
@@ -40,7 +40,7 @@ SKIP: {
my $r = [ Time::HiRes::gettimeofday() ];
Time::HiRes::sleep( 0.5 );
my $f = Time::HiRes::tv_interval $r;
- ok $f > 0.4 && $f < 0.9 or print("# slept $f instead of 0.5 secs.\n");
+ ok $f > 0.49 or print("# slept $f instead of 0.5 secs.\n");
}
SKIP: {
diff --git a/dist/Time-HiRes/t/utime.t b/dist/Time-HiRes/t/utime.t
index 22fd48e..c5c7e55 100644
--- a/dist/Time-HiRes/t/utime.t
+++ b/dist/Time-HiRes/t/utime.t
@@ -106,17 +106,18 @@ print "# utime undef sets time to now\n";
my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
my $now = Time::HiRes::time;
+ sleep(1);
is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed";
{
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
- cmp_ok abs( $got_atime - $now), '<', 0.1, "File 1 atime set correctly";
- cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 1 mtime set correctly";
+ cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly";
+ cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly";
}
{
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
- cmp_ok abs( $got_atime - $now), '<', 0.1, "File 2 atime set correctly";
- cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 2 mtime set correctly";
+ cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly";
+ cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly";
}
};
--
2.9.5

View File

@ -1,72 +0,0 @@
From 7b3e03bd309fcc48a135123a60678ae2596b1c38 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 7 Jun 2017 15:00:26 +1000
Subject: [PATCH] clear the UTF8 flag on a glob if it isn't UTF8
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.26.0:
commit 1097da16b21fe0a2257dba9937e55c0cca18f7e1
Author: Tony Cook <tony@develop-help.com>
Date: Wed Jun 7 15:00:26 2017 +1000
[perl #131263] clear the UTF8 flag on a glob if it isn't UTF8
Previously sv_2pv_flags() would set the UTF8 flag on a glob if it
had a UTF8 name, but wouldn't clear tha flag if it didn't.
This meant a name change, eg. if assigned another glob, from a UTF8
name to a non-UTF8 name would leave the flag set.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
sv.c | 2 ++
t/op/gv.t | 10 +++++++++-
2 files changed, 11 insertions(+), 1 deletion(-)
diff --git a/sv.c b/sv.c
index 9f3e28e..ae3dc95 100644
--- a/sv.c
+++ b/sv.c
@@ -3179,6 +3179,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
assert(SvPOK(buffer));
if (SvUTF8(buffer))
SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
if (lp)
*lp = SvCUR(buffer);
return SvPVX(buffer);
diff --git a/t/op/gv.t b/t/op/gv.t
index 4fe6b00..670ccf6 100644
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
use warnings;
-plan(tests => 280);
+plan(tests => 282);
# type coercion on assignment
$foo = 'foo';
@@ -1170,6 +1170,14 @@ SKIP: {
is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
}
+{
+ # [perl #131263]
+ *sym = "\N{U+0080}";
+ ok(*sym eq "*main::\N{U+0080}", "utf8 flag properly set");
+ *sym = "\xC3\x80";
+ ok(*sym eq "*main::\xC3\x80", "utf8 flag properly cleared");
+}
+
# test gv_try_downgrade()
# If a GV can be stored in a stash in a compact, non-GV form, then
# whenever ops are freed which reference the GV, an attempt is made to
--
2.9.4

View File

@ -1,61 +0,0 @@
From cb2fda94b02c5b7e8d16582410034f5a3dae526f Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 25 Jul 2017 16:21:22 +1000
Subject: [PATCH] (perl #131588) be a little more careful in arybase::_tie_it()
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Original patch by John Leitch <john@autosectools.com>
Petr Pisar: Ported to 5.26.0.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/arybase/arybase.xs | 10 ++++++----
ext/arybase/t/arybase.t | 4 +++-
2 files changed, 9 insertions(+), 5 deletions(-)
diff --git a/ext/arybase/arybase.xs b/ext/arybase/arybase.xs
index 880bbe3..216442a 100644
--- a/ext/arybase/arybase.xs
+++ b/ext/arybase/arybase.xs
@@ -438,10 +438,12 @@ _tie_it(SV *sv)
INIT:
GV * const gv = (GV *)sv;
CODE:
- if (GvSV(gv))
- /* This is *our* scalar now! */
- sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
- tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
+ if (isGV(gv)) {
+ if (GvSV(gv))
+ /* This is *our* scalar now! */
+ sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
+ tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
+ }
void
FETCH(...)
diff --git a/ext/arybase/t/arybase.t b/ext/arybase/t/arybase.t
index f3d3287..41e90df 100644
--- a/ext/arybase/t/arybase.t
+++ b/ext/arybase/t/arybase.t
@@ -4,7 +4,7 @@
# plus miscellaneous bug fix tests
no warnings 'deprecated';
-use Test::More tests => 7;
+use Test::More tests => 8;
sub outside_base_scope { return "${'['}" }
@@ -34,4 +34,6 @@ is $@, "That use of \$[ is unsupported at $f line $l.\n",
sub foo { my $x; $x = wait } # compilation of this routine used to crash
+ok eval { arybase::_tie_it(1); 1 }, "don't crash on bad call to _tie_it()";
+
1;
--
2.9.4

View File

@ -1,37 +0,0 @@
From 37268580c0cfbf190ff9aa7859a604713cb366ee Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 27 Jun 2017 16:36:57 +0200
Subject: [PATCH] t/op/hash.t: fixup intermittently failing test
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Port to 5.26.0:
commit b2ac59d1d0fda74d6612701d8316fe8dfb6a1b90
Author: Yves Orton <demerphq@gmail.com>
Date: Tue Jun 27 16:36:57 2017 +0200
t/op/hash.t: fixup intermittently failing test
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/op/hash.t | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/t/op/hash.t b/t/op/hash.t
index a0e79c7..b941c57 100644
--- a/t/op/hash.t
+++ b/t/op/hash.t
@@ -206,7 +206,7 @@ sub torture_hash {
my $keys = pop @groups;
++$h->{$_} foreach @$keys;
my (undef, $total) = validate_hash("$desc " . keys %$h, $h);
- is($total, $total0, "bucket count is constant when rebuilding");
+ ok($total == $total0 || $total == ($total0*2), "bucket count is expected size when rebuilding");
is(scalar %$h, pop @groups, "scalar keys is identical when rebuilding");
++$h1->{$_} foreach @$keys;
validate_hash("$desc copy " . keys %$h1, $h1);
--
2.9.4

View File

@ -1,48 +0,0 @@
From abd17348111a99642da217c45d836f2df5713594 Mon Sep 17 00:00:00 2001
From: John Lightsey <lightsey@debian.org>
Date: Tue, 31 Oct 2017 18:12:26 -0500
Subject: [PATCH] Fix deparsing of transliterations with unprintable
characters.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
RT #132405
Signed-off-by: Nicolas R <atoomic@cpan.org>
Petr Písař: Port to 5.26.1.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
lib/B/Deparse.pm | 2 +-
lib/B/Deparse.t | 5 +++++
2 files changed, 6 insertions(+), 1 deletion(-)
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 3166415..cc74552 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -5200,7 +5200,7 @@ sub pchr { # ASCII
} elsif ($n == ord "\r") {
return '\\r';
} elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
- return '\\c' . unctrl{chr $n};
+ return '\\c' . $unctrl{chr $n};
} else {
# return '\x' . sprintf("%02x", $n);
return '\\' . sprintf("%03o", $n);
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index 7eeb4f8..eae9c49 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -2610,3 +2610,8 @@ sub ($a, $=) {
$a;
}
;
+####
+# tr with unprintable characters
+my $str;
+$str = 'foo';
+$str =~ tr/\cA//;
--
2.13.6

View File

@ -1,111 +0,0 @@
From 3dfcac940930a8aa6779f5debea6ea6357372419 Mon Sep 17 00:00:00 2001
From: Daniel Dragan <bulk88@hotmail.com>
Date: Sun, 16 Aug 2015 04:30:23 -0400
Subject: [PATCH] fix do dir returning no $!
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
do()ing a directory was returning false/empty string in $!, which isn't
an error, yet documentation says $! should have the error code in it.
Fix this by returning EISDIR for dirs, and EINVAL for block devices.
[perl #125774]
Remove "errno = 0" and comment added in b2da7ead68, since now there is no
scenario where errno is uninitialized, since the dir and block device
failure branches now set errno, where previously they didn't.
Petr Písař: Ported to 5.26.1.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_ctl.c | 25 +++++++++++++++++--------
t/op/do.t | 14 +++++++++++++-
2 files changed, 30 insertions(+), 9 deletions(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index e24d7b6..f136f91 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3534,15 +3534,22 @@ S_check_type_and_open(pTHX_ SV *name)
errno EACCES, so only do a stat to separate a dir from a real EACCES
caused by user perms */
#ifndef WIN32
- /* we use the value of errno later to see how stat() or open() failed.
- * We don't want it set if the stat succeeded but we still failed,
- * such as if the name exists, but is a directory */
- errno = 0;
-
st_rc = PerlLIO_stat(p, &st);
- if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
+ if (st_rc < 0)
return NULL;
+ else {
+ int eno;
+ if(S_ISBLK(st.st_mode)) {
+ eno = EINVAL;
+ goto not_file;
+ }
+ else if(S_ISDIR(st.st_mode)) {
+ eno = EISDIR;
+ not_file:
+ errno = eno;
+ return NULL;
+ }
}
#endif
@@ -3554,8 +3561,10 @@ S_check_type_and_open(pTHX_ SV *name)
int eno;
st_rc = PerlLIO_stat(p, &st);
if (st_rc >= 0) {
- if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
- eno = 0;
+ if(S_ISDIR(st.st_mode))
+ eno = EISDIR;
+ else if(S_ISBLK(st.st_mode))
+ eno = EINVAL;
else
eno = EACCES;
errno = eno;
diff --git a/t/op/do.t b/t/op/do.t
index 78d8800..1c54f0b 100644
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -7,6 +7,7 @@ BEGIN {
}
use strict;
no warnings 'void';
+use Errno qw(ENOENT EISDIR);
my $called;
my $result = do{ ++$called; 'value';};
@@ -247,7 +248,7 @@ SKIP: {
my $saved_errno = $!;
ok(!$rv, "do returns false on io errror");
ok(!$saved_error, "\$\@ not set on io error");
- ok($saved_errno, "\$! set on io error");
+ ok($saved_errno == ENOENT, "\$! is ENOENT for nonexistent file");
}
# do subname should not be do "subname"
@@ -305,4 +306,15 @@ SKIP: {
}
+# do file $!s must be correct
+{
+ local @INC = ('.'); #want EISDIR not ENOENT
+ my $rv = do 'op'; # /t/op dir
+ my $saved_error = $@;
+ my $saved_errno = $!+0;
+ ok(!$rv, "do dir returns false");
+ ok(!$saved_error, "\$\@ is false on do dir");
+ ok($saved_errno == EISDIR, "\$! is EISDIR on do dir");
+}
+
done_testing();
--
2.13.6

View File

@ -1,24 +0,0 @@
commit 13e70b397dcb0d1bf4a869b670f041c1d7b730d0
Author: Björn Esser <besser82@fedoraproject.org>
Date: Sat Jan 20 20:22:53 2018 +0100
pp: Guard fix for really old bug in glibc libcrypt
diff --git a/pp.c b/pp.c
index d50ad7ddbf..6510c7b15c 100644
--- a/pp.c
+++ b/pp.c
@@ -3650,8 +3650,12 @@ PP(pp_crypt)
#if defined(__GLIBC__) || defined(__EMX__)
if (PL_reentrant_buffer->_crypt_struct_buffer) {
PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
- /* work around glibc-2.2.5 bug */
+#if (defined(__GLIBC__) && __GLIBC__ == 2) && \
+ (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
+ /* work around glibc-2.2.5 bug, has been fixed at some
+ * time in glibc-2.3.X */
PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
+#endif
}
#endif
}

View File

@ -1,107 +0,0 @@
From 7a962424149cc60f3a187d0213a12689dd5e806b Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 14 Aug 2017 11:52:39 +1000
Subject: [PATCH] (perl #131746) avoid undefined behaviour in Copy() etc
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
These functions depend on C library functions which have undefined
behaviour when passed NULL pointers, even when passed a zero 'n' value.
Some compilers use this information, ie. assume the pointers are
non-NULL when optimizing any following code, so we do need to
prevent such unguarded calls.
My initial thought was to add conditionals to each macro to skip the
call to the library function when n is zero, but this adds a cost to
every use of these macros, even when the n value is always true.
So instead I added asserts() which will give us a much more visible
indicator of such broken code and revealed the pp_caller and Glob.xs
issues also patched here.
Petr Písař: Ported to 5.26.1 from
f14cf3632059d421de83cf901c7e849adc1fcd03.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/File-Glob/Glob.xs | 2 +-
handy.h | 14 +++++++-------
pp_ctl.c | 3 ++-
pp_hot.c | 3 ++-
4 files changed, 12 insertions(+), 10 deletions(-)
diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
index e0a3681..9779d54 100644
--- a/ext/File-Glob/Glob.xs
+++ b/ext/File-Glob/Glob.xs
@@ -121,7 +121,7 @@ iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, boo
/* chuck it all out, quick or slow */
if (gimme == G_ARRAY) {
- if (!on_stack) {
+ if (!on_stack && AvFILLp(entries) + 1) {
EXTEND(SP, AvFILLp(entries)+1);
Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
SP += AvFILLp(entries)+1;
diff --git a/handy.h b/handy.h
index 80f9cf4..88b5b55 100644
--- a/handy.h
+++ b/handy.h
@@ -2409,17 +2409,17 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe
#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d)))
#endif
-#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
-#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
-#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memzero((char*)(d), (n) * sizeof(t)))
+#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), (void)memzero((char*)(d), (n) * sizeof(t)))
-#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
-#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
#ifdef HAS_MEMSET
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)))
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)))
#else
/* Using bzero(), which returns void. */
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)),d)
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)),d)
#endif
#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)))
diff --git a/pp_ctl.c b/pp_ctl.c
index 15c193b..f1c57bc 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1971,7 +1971,8 @@ PP(pp_caller)
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
av_extend(PL_dbargs, AvFILLp(ary) + off);
- Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
+ if (AvFILLp(ary) + 1 + off)
+ Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
}
mPUSHi(CopHINTS_get(cx->blk_oldcop));
diff --git a/pp_hot.c b/pp_hot.c
index 5899413..66b79ea 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -4138,7 +4138,8 @@ PP(pp_entersub)
AvARRAY(av) = ary;
}
- Copy(MARK+1,AvARRAY(av),items,SV*);
+ if (items)
+ Copy(MARK+1,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
}
if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
--
2.13.6

View File

@ -1,223 +0,0 @@
From 4ac7295514f35016a79dbcc07500f6c9ca4729b7 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 2 Nov 2017 20:18:56 +0000
Subject: [PATCH] (perl #131895) fail stat on names with \0 embedded
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Also lstat() and the file test ops.
Petr Písař: Port to 5.26.1.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
doio.c | 21 ++++++++++++++++-----
pp_sys.c | 29 +++++++++++++++++++++++------
t/lib/warnings/pp_sys | 14 ++++++++++++++
t/op/filetest.t | 10 +++++++++-
t/op/stat.t | 12 +++++++++++-
5 files changed, 73 insertions(+), 13 deletions(-)
diff --git a/doio.c b/doio.c
index becb19b..70d7747 100644
--- a/doio.c
+++ b/doio.c
@@ -1466,7 +1466,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
return PL_laststatval;
else {
SV* const sv = TOPs;
- const char *s;
+ const char *s, *d;
STRLEN len;
if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
goto do_fstat;
@@ -1480,9 +1480,14 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
s = SvPV_flags_const(sv, len, flags);
PL_statgv = NULL;
sv_setpvn(PL_statname, s, len);
- s = SvPVX_const(PL_statname); /* s now NUL-terminated */
+ d = SvPVX_const(PL_statname); /* s now NUL-terminated */
PL_laststype = OP_STAT;
- PL_laststatval = PerlLIO_stat(s, &PL_statcache);
+ if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
+ PL_laststatval = -1;
+ }
+ else {
+ PL_laststatval = PerlLIO_stat(d, &PL_statcache);
+ }
if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
@@ -1499,6 +1504,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
dSP;
const char *file;
+ STRLEN len;
SV* const sv = TOPs;
bool isio = FALSE;
if (PL_op->op_flags & OPf_REF) {
@@ -1542,9 +1548,14 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
HEKfARG(GvENAME_HEK((const GV *)
(SvROK(sv) ? SvRV(sv) : sv))));
}
- file = SvPV_flags_const_nolen(sv, flags);
+ file = SvPV_flags_const(sv, len, flags);
sv_setpv(PL_statname,file);
- PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
+ if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
+ PL_laststatval = -1;
+ }
+ else {
+ PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
+ }
if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
diff --git a/pp_sys.c b/pp_sys.c
index 0b60584..1b81fda 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2963,19 +2963,24 @@ PP(pp_stat)
}
else {
const char *file;
+ const char *temp;
+ STRLEN len;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
io = MUTABLE_IO(SvRV(sv));
if (PL_op->op_type == OP_LSTAT)
goto do_fstat_warning_check;
goto do_fstat_have_io;
}
-
SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
+ temp = SvPV_nomg_const(sv, len);
+ sv_setpv(PL_statname, temp);
PL_statgv = NULL;
PL_laststype = PL_op->op_type;
file = SvPV_nolen_const(PL_statname);
- if (PL_op->op_type == OP_LSTAT)
+ if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
+ PL_laststatval = -1;
+ }
+ else if (PL_op->op_type == OP_LSTAT)
PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
else
PL_laststatval = PerlLIO_stat(file, &PL_statcache);
@@ -3211,8 +3216,12 @@ PP(pp_ftrread)
if (use_access) {
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
- const char *name = SvPV_nolen(*PL_stack_sp);
- if (effective) {
+ STRLEN len;
+ const char *name = SvPV(*PL_stack_sp, len);
+ if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
+ result = -1;
+ }
+ else if (effective) {
# ifdef PERL_EFF_ACCESS
result = PERL_EFF_ACCESS(name, access_mode);
# else
@@ -3537,10 +3546,18 @@ PP(pp_fttext)
}
else {
const char *file;
+ const char *temp;
+ STRLEN temp_len;
int fd;
assert(sv);
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
+ temp = SvPV_nomg_const(sv, temp_len);
+ sv_setpv(PL_statname, temp);
+ if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
+ PL_laststatval = -1;
+ PL_laststype = OP_STAT;
+ FT_RETURNUNDEF;
+ }
really_filename:
file = SvPVX_const(PL_statname);
PL_statgv = NULL;
diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
index 9c544e0..c599aa3 100644
--- a/t/lib/warnings/pp_sys
+++ b/t/lib/warnings/pp_sys
@@ -972,3 +972,17 @@ close $fh;
unlink $file;
EXPECT
syswrite() is deprecated on :utf8 handles. This will be a fatal error in Perl 5.30 at - line 5.
+########
+# NAME stat on name with \0
+use warnings;
+my @x = stat("./\0-");
+my @y = lstat("./\0-");
+-T ".\0-";
+-x ".\0-";
+-l ".\0-";
+EXPECT
+Invalid \0 character in pathname for stat: ./\0- at - line 2.
+Invalid \0 character in pathname for lstat: ./\0- at - line 3.
+Invalid \0 character in pathname for fttext: .\0- at - line 4.
+Invalid \0 character in pathname for fteexec: .\0- at - line 5.
+Invalid \0 character in pathname for ftlink: .\0- at - line 6.
diff --git a/t/op/filetest.t b/t/op/filetest.t
index 8883381..bd1d08c 100644
--- a/t/op/filetest.t
+++ b/t/op/filetest.t
@@ -9,7 +9,7 @@ BEGIN {
set_up_inc(qw '../lib ../cpan/Perl-OSType/lib');
}
-plan(tests => 53 + 27*14);
+plan(tests => 57 + 27*14);
if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) {
require Win32; # for IsAdminUser()
@@ -393,3 +393,11 @@ SKIP: {
is $failed_stat2, $failed_stat1,
'failed -r($gv_with_io_but_no_fp) with and w/out fatal warnings';
}
+
+{
+ # [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
+ ok(!-T "TEST\0-", '-T on name with \0');
+ ok(!-B "TEST\0-", '-B on name with \0');
+ ok(!-f "TEST\0-", '-f on name with \0');
+ ok(!-r "TEST\0-", '-r on name with \0');
+}
diff --git a/t/op/stat.t b/t/op/stat.t
index 323c498..dbbe6ec 100644
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -25,7 +25,7 @@ if ($^O eq 'MSWin32') {
${^WIN32_SLOPPY_STAT} = 0;
}
-plan tests => 118;
+plan tests => 120;
my $Perl = which_perl();
@@ -653,6 +653,16 @@ SKIP:
'stat on an array of valid paths should return ENOENT';
}
+# [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
+ok !stat("TEST\0-"), 'stat on filename with \0';
+SKIP: {
+ my $link = "TEST.symlink.$$";
+ my $can_symlink = eval { symlink "TEST", $link };
+ skip "cannot symlink", 1 unless $can_symlink;
+ ok !lstat("$link\0-"), 'lstat on filename with \0';
+ unlink $link;
+}
+
END {
chmod 0666, $tmpfile;
unlink_all $tmpfile;
--
2.13.6

View File

@ -1,54 +0,0 @@
From dc5c68130b7c8b727e9e792506183c255fc2bc70 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 19 Oct 2017 10:46:04 +1100
Subject: [PATCH] (perl #132245) don't try to process a char range with no
preceding char
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
A range like \N{}-0 eventually results in compilation failing, but
before that, get_and_check_backslash_N_name() attempts to treat
the memory before the empty output of \N{} as a character.
Petr Písař: Ported to 5.26.1.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/lib/warnings/toke | 5 +++++
toke.c | 6 +++---
2 files changed, 8 insertions(+), 3 deletions(-)
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
index fc51d9f..398ee22 100644
--- a/t/lib/warnings/toke
+++ b/t/lib/warnings/toke
@@ -1651,3 +1651,8 @@ Execution of - aborted due to compilation errors.
use utf8;
qw∘foo ∞ ♥ bar∘
EXPECT
+########
+# NAME tr/// range with empty \N{} at the start
+tr//\N{}-0/;
+EXPECT
+Unknown charname '' is deprecated. Its use will be fatal in Perl 5.28 at - line 1.
diff --git a/toke.c b/toke.c
index 6f84d2d..6ee7a68 100644
--- a/toke.c
+++ b/toke.c
@@ -2958,9 +2958,9 @@ S_scan_const(pTHX_ char *start)
/* Here, we don't think we're in a range. If the new character
* is not a hyphen; or if it is a hyphen, but it's too close to
- * either edge to indicate a range, then it's a regular
- * character. */
- if (*s != '-' || s >= send - 1 || s == start) {
+ * either edge to indicate a range, or if we haven't output any
+ * characters yet then it's a regular character. */
+ if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
/* A regular character. Process like any other, but first
* clear any flags */
--
2.13.6

View File

@ -1,211 +0,0 @@
From 8c7182b26a43f14cd8afbfbe4448cbbd691c3609 Mon Sep 17 00:00:00 2001
From: Zefram <zefram@fysh.org>
Date: Wed, 15 Nov 2017 08:11:37 +0000
Subject: [PATCH] set $! when statting a closed filehandle
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
When a stat fails because it's on a closed or otherwise invalid
filehandle, $! was often not being set, depending on the operation
and the nature of the invalidity. Consistently set it to EBADF.
Fixes [perl #108288].
Petr Písař: Ported to 5.26.1.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
doio.c | 10 +++++++++-
pp_sys.c | 22 ++++++++++++---------
t/op/stat_errors.t | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 80 insertions(+), 10 deletions(-)
create mode 100644 t/op/stat_errors.t
diff --git a/MANIFEST b/MANIFEST
index fcbf5cc..996759e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5670,6 +5670,7 @@ t/op/srand.t See if srand works
t/op/sselect.t See if 4 argument select works
t/op/stash.t See if %:: stashes work
t/op/stat.t See if stat works
+t/op/stat_errors.t See if stat and file tests handle threshold errors
t/op/state.t See if state variables work
t/op/study.t See if study works
t/op/studytied.t See if study works with tied scalars
diff --git a/doio.c b/doio.c
index 70d7747..71dc6e4 100644
--- a/doio.c
+++ b/doio.c
@@ -1437,8 +1437,11 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
if (PL_op->op_flags & OPf_REF) {
gv = cGVOP_gv;
do_fstat:
- if (gv == PL_defgv)
+ if (gv == PL_defgv) {
+ if (PL_laststatval < 0)
+ SETERRNO(EBADF,RMS_IFI);
return PL_laststatval;
+ }
io = GvIO(gv);
do_fstat_have_io:
PL_laststype = OP_STAT;
@@ -1449,6 +1452,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
int fd = PerlIO_fileno(IoIFP(io));
if (fd < 0) {
/* E.g. PerlIO::scalar has no real fd. */
+ SETERRNO(EBADF,RMS_IFI);
return (PL_laststatval = -1);
} else {
return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
@@ -1459,6 +1463,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
}
PL_laststatval = -1;
report_evil_fh(gv);
+ SETERRNO(EBADF,RMS_IFI);
return -1;
}
else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
@@ -1511,6 +1516,8 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
if (cGVOP_gv == PL_defgv) {
if (PL_laststype != OP_LSTAT)
Perl_croak(aTHX_ "%s", no_prev_lstat);
+ if (PL_laststatval < 0)
+ SETERRNO(EBADF,RMS_IFI);
return PL_laststatval;
}
PL_laststatval = -1;
@@ -1520,6 +1527,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
"Use of -l on filehandle %" HEKf,
HEKfARG(GvENAME_HEK(cGVOP_gv)));
}
+ SETERRNO(EBADF,RMS_IFI);
return -1;
}
if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
diff --git a/pp_sys.c b/pp_sys.c
index fefbea3..87961f1 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2925,10 +2925,11 @@ PP(pp_stat)
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
}
- if (gv != PL_defgv) {
- bool havefp;
+ if (gv == PL_defgv) {
+ if (PL_laststatval < 0)
+ SETERRNO(EBADF,RMS_IFI);
+ } else {
do_fstat_have_io:
- havefp = FALSE;
PL_laststype = OP_STAT;
PL_statgv = gv ? gv : (GV *)io;
SvPVCLEAR(PL_statname);
@@ -2939,22 +2940,25 @@ PP(pp_stat)
if (IoIFP(io)) {
int fd = PerlIO_fileno(IoIFP(io));
if (fd < 0) {
+ report_evil_fh(gv);
PL_laststatval = -1;
SETERRNO(EBADF,RMS_IFI);
} else {
PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
- havefp = TRUE;
}
} else if (IoDIRP(io)) {
PL_laststatval =
PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
- havefp = TRUE;
} else {
+ report_evil_fh(gv);
PL_laststatval = -1;
+ SETERRNO(EBADF,RMS_IFI);
}
- }
- else PL_laststatval = -1;
- if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
+ } else {
+ report_evil_fh(gv);
+ PL_laststatval = -1;
+ SETERRNO(EBADF,RMS_IFI);
+ }
}
if (PL_laststatval < 0) {
@@ -3451,7 +3455,7 @@ PP(pp_fttty)
else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
fd = (int)uv;
else
- FT_RETURNUNDEF;
+ fd = -1;
if (fd < 0) {
SETERRNO(EBADF,RMS_IFI);
FT_RETURNUNDEF;
diff --git a/t/op/stat_errors.t b/t/op/stat_errors.t
new file mode 100644
index 0000000..e043c61
--- /dev/null
+++ b/t/op/stat_errors.t
@@ -0,0 +1,57 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
+}
+
+plan(tests => 2*11*29);
+
+use Errno qw(EBADF ENOENT);
+
+open(SCALARFILE, "<", \"wibble") or die $!;
+open(CLOSEDFILE, "<", "./test.pl") or die $!;
+close(CLOSEDFILE) or die $!;
+opendir(CLOSEDDIR, "../lib") or die $!;
+closedir(CLOSEDDIR) or die $!;
+
+foreach my $op (
+ qw(stat lstat),
+ (map { "-$_" } qw(r w x o R W X O e z s f d l p S b c t u g k T B M A C)),
+) {
+ foreach my $arg (
+ (map { ($_, "\\*$_") }
+ qw(NEVEROPENED SCALARFILE CLOSEDFILE CLOSEDDIR _)),
+ "\"tmpnotexist\"",
+ ) {
+ my $argdesc = $arg;
+ if ($arg eq "_") {
+ my @z = lstat "tmpnotexist";
+ $argdesc .= " with prior stat fail";
+ }
+ SKIP: {
+ if ($op eq "-l" && $arg =~ /\A\\/) {
+ # The op weirdly stringifies the globref and uses it as
+ # a filename, rather than treating it as a file handle.
+ # That might be a bug, but while that behaviour exists it
+ # needs to be exempted from these tests.
+ skip "-l on globref", 2;
+ }
+ if ($op eq "-t" && $arg eq "\"tmpnotexist\"") {
+ # The op doesn't operate on filenames.
+ skip "-t on filename", 2;
+ }
+ $! = 0;
+ my $res = eval "$op $arg";
+ my $err = $!;
+ is $res, $op =~ /\A-/ ? undef : !!0, "result of $op $arg";
+ is 0+$err,
+ $arg eq "\"tmpnotexist\"" ||
+ ($op =~ /\A-[TB]\z/ && $arg =~ /_\z/) ? ENOENT : EBADF,
+ "error from $op $arg";
+ }
+ }
+}
+
+1;
--
2.13.6

View File

@ -1,105 +0,0 @@
From dc1f8f6b581a8e4efbb782398ab3e7c3a52b062f Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Tue, 8 May 2018 12:13:18 -0600
Subject: [PATCH] PATCH: [perl #133185] Infinite loop in qr//
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This loop was inadvertently introduced as part of patches to fix
(perl #132227 CVE-2018-6797] heap-buffer-overflow". The commit in 5.27
responsible was f8fb8615ddc5a80e3bbd4386a8914497f921b62d.
To be vulnerable, the pattern must start out as /d (hence no use 5.012
or higher), and then there must be something that implicitly forces /u
(which the \pp does in the test case added by this patch), and then
(?aa), and then the code point \xDF. (German Sharp S). The /i must be
in effect by the time the DF is encountered, but it needn't come in the
(?aa) which the test does.
The problem is that the conditional that is testing that we switched
away from /d rules is assuming that this happened during the
construction of the current EXACTFish node. The comments I wrote
indicate this assumption. But this example shows that the switch can
come before this node started getting constructed, and so it loops.
The patch explicitly saves the state at the beginning of this node's
construction, and only retries if it changed during that construction.
Therefore the next time through, it will see that it hasn't changed
since the previous time, and won't loop.
Petr Písař: Ported to 5.26.2 from:
commit 0b9cb33b146b3eb55634853f883a880771dd1413
Author: Karl Williamson <khw@cpan.org>
Date: Tue May 8 12:13:18 2018 -0600
PATCH: [perl #133185] Infinite loop in qr//
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 10 +++++++++-
t/re/speed.t | 5 ++++-
2 files changed, 13 insertions(+), 2 deletions(-)
diff --git a/regcomp.c b/regcomp.c
index 845e660..18fa465 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -13100,6 +13100,10 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
bool maybe_exactfu = PASS2
&& (node_type == EXACTF || node_type == EXACTFL);
+ /* To see if RExC_uni_semantics changes during parsing of the node.
+ * */
+ bool uni_semantics_at_node_start;
+
/* If a folding node contains only code points that don't
* participate in folds, it can be changed into an EXACT node,
* which allows the optimizer more things to look for */
@@ -13147,6 +13151,8 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|| UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
|| UTF8_IS_START(UCHARAT(RExC_parse)));
+ uni_semantics_at_node_start = RExC_uni_semantics;
+
/* Here, we have a literal character. Find the maximal string of
* them in the input that we can fit into a single EXACTish node.
* We quit at the first non-literal or when the node gets full */
@@ -13550,7 +13556,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
* didn't think it needed to reparse. But this
* sharp s now does indicate the need for
* reparsing. */
- if (RExC_uni_semantics) {
+ if ( uni_semantics_at_node_start
+ != RExC_uni_semantics)
+ {
p = oldp;
goto loopdone;
}
diff --git a/t/re/speed.t b/t/re/speed.t
index 4a4830f..9a57de1 100644
--- a/t/re/speed.t
+++ b/t/re/speed.t
@@ -24,7 +24,7 @@ BEGIN {
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
skip_all_without_unicode_tables();
-plan tests => 58; #** update watchdog timeouts proportionally when adding tests
+plan tests => 59; #** update watchdog timeouts proportionally when adding tests
use strict;
use warnings;
@@ -156,6 +156,9 @@ PROG
ok( $elapsed <= 1, "should not COW on long string with substr and m//g");
}
+ # [perl #133185] Infinite loop
+ like("!\xdf", eval 'qr/\pp(?aai)\xdf/',
+ 'Compiling qr/\pp(?aai)\xdf/ doesn\'t loop');
} # End of sub run_tests
--
2.14.3

View File

@ -1,143 +0,0 @@
From 07ebe9c4fb1028d17e61caabe8c15abd0cd48983 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Thu, 29 Jun 2017 11:31:14 +0200
Subject: [PATCH] Parse caret vars with subscripts the same as normal vars
inside of ${..} escaping
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This behavior is discussed in perl #131664, which complains that
"${^CAPTURE}[0]" does not work as expected. Abigail explains the
behavior is by design and Eirik Berg Hanssen expands on that explanation
pointing out that what /should/ work, "${^CAPTURE[0]}" does not,
which Sawyer then ruled was a bug.
So this patch makes "${^CAPTURE[0]}" (and "${^CAPTURE [0]}" [hi
abigial]) work the same as they would if the var was called @foo.
Petr Písař: Ported to 5.26.2-RC1.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/base/lex.t | 28 +++++++++++++++++++++++++++-
toke.c | 46 +++++++++++++++++++++++++---------------------
2 files changed, 52 insertions(+), 22 deletions(-)
diff --git a/t/base/lex.t b/t/base/lex.t
index 99fd3bb..ae17bbd 100644
--- a/t/base/lex.t
+++ b/t/base/lex.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..112\n";
+print "1..119\n";
$x = 'x';
@@ -154,6 +154,32 @@ my $test = 31;
print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1;
print "ok $test\n"; $test++;
# print "($@)\n" if $@;
+#
+ ${^TEST}= "splat";
+ @{^TEST}= ("foo", "bar");
+ %{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
+
+ print "not " if "${^TEST}" ne "splat";
+ print "ok $test\n"; $test++;
+
+ print "not " if "${^TEST}[0]" ne "splat[0]";
+ print "ok $test\n"; $test++;
+
+ print "not " if "${^TEST[0]}" ne "foo";
+ print "ok $test\n"; $test++;
+
+ print "not " if "${ ^TEST [1] }" ne "bar";
+ print "ok $test\n"; $test++;
+
+ print "not " if "${^TEST}{foo}" ne "splat{foo}";
+ print "ok $test\n"; $test++;
+
+ print "not " if "${^TEST{foo}}" ne "FOO";
+ print "ok $test\n"; $test++;
+
+ print "not " if "${ ^TEST {bar} }" ne "BAR";
+ print "ok $test\n"; $test++;
+
# Now let's make sure that caret variables are all forced into the main package.
package Someother;
diff --git a/toke.c b/toke.c
index ee9c464..aff785b 100644
--- a/toke.c
+++ b/toke.c
@@ -9416,19 +9416,36 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
bool skip;
char *s2;
/* If we were processing {...} notation then... */
- if (isIDFIRST_lazy_if_safe(d, e, is_utf8)) {
- /* if it starts as a valid identifier, assume that it is one.
- (the later check for } being at the expected point will trap
- cases where this doesn't pan out.) */
- d += is_utf8 ? UTF8SKIP(d) : 1;
- parse_ident(&s, &d, e, 1, is_utf8, TRUE);
- *d = '\0';
+ if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
+ || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
+ && isWORDCHAR(*s))
+ ) {
+ /* note we have to check for a normal identifier first,
+ * as it handles utf8 symbols, and only after that has
+ * been ruled out can we look at the caret words */
+ if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
+ /* if it starts as a valid identifier, assume that it is one.
+ (the later check for } being at the expected point will trap
+ cases where this doesn't pan out.) */
+ d += is_utf8 ? UTF8SKIP(d) : 1;
+ parse_ident(&s, &d, e, 1, is_utf8, TRUE);
+ *d = '\0';
+ }
+ else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
+ d++;
+ while (isWORDCHAR(*s) && d < e) {
+ *d++ = *s++;
+ }
+ if (d >= e)
+ Perl_croak(aTHX_ "%s", ident_too_long);
+ *d = '\0';
+ }
tmp_copline = CopLINE(PL_curcop);
if (s < PL_bufend && isSPACE(*s)) {
s = skipspace(s);
}
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- /* ${foo[0]} and ${foo{bar}} notation. */
+ /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
const char * const brack =
(const char *)
@@ -9447,19 +9464,6 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
return s;
}
}
- /* Handle extended ${^Foo} variables
- * 1999-02-27 mjd-perl-patch@plover.com */
- else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
- && isWORDCHAR(*s))
- {
- d++;
- while (isWORDCHAR(*s) && d < e) {
- *d++ = *s++;
- }
- if (d >= e)
- Perl_croak(aTHX_ "%s", ident_too_long);
- *d = '\0';
- }
if ( !tmp_copline )
tmp_copline = CopLINE(PL_curcop);
--
2.14.3

View File

@ -1,45 +0,0 @@
From edea384e57453b0a62de58445eed1fded18c1cca Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Thu, 29 Jun 2017 13:20:49 +0200
Subject: [PATCH] add an additional test for whitespace tolerance in caret
word-vars
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Písař: Ported to 5.26.2-RC1.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/base/lex.t | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/t/base/lex.t b/t/base/lex.t
index ae17bbd..414aa1f 100644
--- a/t/base/lex.t
+++ b/t/base/lex.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..119\n";
+print "1..120\n";
$x = 'x';
@@ -158,9 +158,12 @@ my $test = 31;
${^TEST}= "splat";
@{^TEST}= ("foo", "bar");
%{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
-
+
print "not " if "${^TEST}" ne "splat";
print "ok $test\n"; $test++;
+
+ print "not " if "${ ^TEST }" ne "splat";
+ print "ok $test\n"; $test++;
print "not " if "${^TEST}[0]" ne "splat[0]";
print "ok $test\n"; $test++;
--
2.14.3

View File

@ -1,90 +0,0 @@
From 3e6e57e89f298f450cbe14c61609f08fc01bf233 Mon Sep 17 00:00:00 2001
From: Zefram <zefram@fysh.org>
Date: Sat, 16 Dec 2017 05:33:20 +0000
Subject: [PATCH] perform system() arg processing before fork
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
A lot of things can happen when stringifying an argument list: side
effects, warnings, exceptions. In the case of system(), these effects
should happen in the context of the parent process. The stringification
can also depend on which process it happens in, as in the case of
$$, and in that case it should also happen in the parent process.
Therefore reduce the argument scalars to strings first thing in pp_system.
Fixes [perl #121105].
Petr Písař: Ported to 5.26.2-RC1 from
64def2aeaeb63f92dadc6dfa33486c1d7b311963.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_sys.c | 16 ++++++++++------
t/op/exec.t | 15 ++++++++++++++-
2 files changed, 24 insertions(+), 7 deletions(-)
diff --git a/pp_sys.c b/pp_sys.c
index 87961f1..07e552a 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -4375,14 +4375,18 @@ PP(pp_system)
int result;
# endif
+ while (++MARK <= SP) {
+ SV *origsv = *MARK;
+ STRLEN len;
+ char *pv;
+ pv = SvPV(origsv, len);
+ *MARK = newSVpvn_flags(pv, len,
+ (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
+ }
+ MARK = ORIGMARK;
+
if (TAINTING_get) {
TAINT_ENV();
- while (++MARK <= SP) {
- (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (TAINT_get)
- break;
- }
- MARK = ORIGMARK;
TAINT_PROPER("system");
}
PERL_FLUSHALL_FOR_CHILD;
diff --git a/t/op/exec.t b/t/op/exec.t
index 237388b..e29de82 100644
--- a/t/op/exec.t
+++ b/t/op/exec.t
@@ -36,7 +36,7 @@ $ENV{LANGUAGE} = 'C'; # Ditto in GNU.
my $Is_VMS = $^O eq 'VMS';
my $Is_Win32 = $^O eq 'MSWin32';
-plan(tests => 34);
+plan(tests => 37);
my $Perl = which_perl();
@@ -177,6 +177,19 @@ TODO: {
"exec failure doesn't terminate process");
}
+package CountRead {
+ sub TIESCALAR { bless({ n => 0 }, $_[0]) }
+ sub FETCH { ++$_[0]->{n} }
+}
+my $cr;
+tie $cr, "CountRead";
+is system($^X, "-e", "exit(\$ARGV[0] eq '1' ? 0 : 1)", $cr), 0,
+ "system args have magic processed exactly once";
+is tied($cr)->{n}, 1, "system args have magic processed before fork";
+
+is system($^X, "-e", "exit(\$ARGV[0] eq \$ARGV[1] ? 0 : 1)", "$$", $$), 0,
+ "system args have magic processed before fork";
+
my $test = curr_test();
exec $Perl, '-le', qq{${quote}print 'ok $test - exec PROG, LIST'${quote}};
fail("This should never be reached if the exec() worked");
--
2.14.3

View File

@ -1,35 +0,0 @@
From 7714b11d11da2bfd0dc11638e9dd6836b6a32e90 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Mon, 11 Jun 2018 13:26:24 -0600
Subject: [PATCH] perl.h: Add parens around macro arguments
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Arguments used within macros need to be parenthesized in case they are
called with an expression. This commit changes
_CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG() to do that.
Petr Písař: Ported to 5.26.2 from upstream ff58ca57f844 commit.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
perl.h | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/perl.h b/perl.h
index 1c613bc..d278c2a 100644
--- a/perl.h
+++ b/perl.h
@@ -5980,7 +5980,7 @@ typedef struct am_table_short AMTS;
# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \
STMT_START { /* Check if to warn before doing the conversion work */\
if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \
- UV cp = utf8_to_uvchr_buf((U8 *) s, (U8 *) send, NULL); \
+ UV cp = utf8_to_uvchr_buf((U8 *) (s), (U8 *) (send), NULL); \
Perl_warner(aTHX_ packWARN(WARN_LOCALE), \
"Wide character (U+%" UVXf ") in %s", \
(cp == 0) \
--
2.14.4

View File

@ -1,34 +0,0 @@
From 208dea486fa24081cbc0cf05fa5a15c802e2bc68 Mon Sep 17 00:00:00 2001
From: John Lightsey <jd@cpanel.net>
Date: Wed, 20 Nov 2019 20:02:45 -0600
Subject: [PATCH v528 1/3] regcomp.c: Prevent integer overflow from nested
regex quantifiers.
(CVE-2020-10543) On 32bit systems the size calculations for nested regular
expression quantifiers could overflow causing heap memory corruption.
Fixes: Perl/perl5-security#125
---
regcomp.c | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/regcomp.c b/regcomp.c
index e1da15a77c..dd18add1db 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -5102,6 +5139,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
(void)ReREFCNT_inc(RExC_rx_sv);
}
+ if ( ( minnext > 0 && mincount >= SSize_t_MAX / minnext )
+ || min >= SSize_t_MAX - minnext * mincount )
+ {
+ FAIL("Regexp out of space");
+ }
+
min += minnext * mincount;
is_inf_internal |= deltanext == SSize_t_MAX
|| (maxcount == REG_INFTY && minnext + deltanext > 0);
--
2.20.1

View File

@ -1,148 +0,0 @@
From a3a7598c8ec6efb0eb9c0b786d80c4d2a3751b70 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Tue, 18 Feb 2020 13:51:16 +0000
Subject: [PATCH v528 2/3] study_chunk: extract rck_elide_nothing
(CVE-2020-10878)
---
embed.fnc | 1 +
embed.h | 1 +
proto.h | 3 +++
regcomp.c | 70 ++++++++++++++++++++++++++++++++++---------------------
4 files changed, 48 insertions(+), 27 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index e762fe1eec..cf89277163 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2398,6 +2398,7 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|I32 stopparen|U32 recursed_depth \
|NULLOK regnode_ssc *and_withp \
|U32 flags|U32 depth|bool was_mutate_ok
+Es |void |rck_elide_nothing|NN regnode *node
EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
|NN const char* const s|const U32 n
rs |void |re_croak2 |bool utf8|NN const char* pat1|NN const char* pat2|...
diff --git a/embed.h b/embed.h
index a5416a1148..886551ce5c 100644
--- a/embed.h
+++ b/embed.h
@@ -1046,6 +1046,7 @@
#define output_or_return_posix_warnings(a,b,c) S_output_or_return_posix_warnings(aTHX_ a,b,c)
#define parse_lparen_question_flags(a) S_parse_lparen_question_flags(aTHX_ a)
#define populate_ANYOF_from_invlist(a,b) S_populate_ANYOF_from_invlist(aTHX_ a,b)
+#define rck_elide_nothing(a) S_rck_elide_nothing(aTHX_ a)
#define reg(a,b,c,d) S_reg(aTHX_ a,b,c,d)
#define reg2Lanode(a,b,c,d) S_reg2Lanode(aTHX_ a,b,c,d)
#define reg_node(a,b) S_reg_node(aTHX_ a,b)
diff --git a/proto.h b/proto.h
index 66bb29b132..d3f8802c1d 100644
--- a/proto.h
+++ b/proto.h
@@ -5150,6 +5150,9 @@ STATIC void S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state);
STATIC void S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr);
#define PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST \
assert(node); assert(invlist_ptr)
+STATIC void S_rck_elide_nothing(pTHX_ regnode *node);
+#define PERL_ARGS_ASSERT_RCK_ELIDE_NOTHING \
+ assert(node)
PERL_STATIC_NO_RET void S_re_croak2(pTHX_ bool utf8, const char* pat1, const char* pat2, ...)
__attribute__noreturn__;
#define PERL_ARGS_ASSERT_RE_CROAK2 \
diff --git a/regcomp.c b/regcomp.c
index dd18add1db..0a9c6a8085 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -4094,6 +4094,43 @@ S_unwind_scan_frames(pTHX_ const void *p)
} while (f);
}
+/* Follow the next-chain of the current node and optimize away
+ all the NOTHINGs from it.
+ */
+STATIC void
+S_rck_elide_nothing(pTHX_ regnode *node)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_RCK_ELIDE_NOTHING;
+
+ if (OP(node) != CURLYX) {
+ const int max = (reg_off_by_arg[OP(node)]
+ ? I32_MAX
+ /* I32 may be smaller than U16 on CRAYs! */
+ : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
+ int off = (reg_off_by_arg[OP(node)] ? ARG(node) : NEXT_OFF(node));
+ int noff;
+ regnode *n = node;
+
+ /* Skip NOTHING and LONGJMP. */
+ while (
+ (n = regnext(n))
+ && (
+ (PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
+ || ((OP(n) == LONGJMP) && (noff = ARG(n)))
+ )
+ && off + noff < max
+ ) {
+ off += noff;
+ }
+ if (reg_off_by_arg[OP(node)])
+ ARG(node) = off;
+ else
+ NEXT_OFF(node) = off;
+ }
+ return;
+}
STATIC SSize_t
S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
@@ -4197,28 +4234,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
if (mutate_ok)
JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
- /* Follow the next-chain of the current node and optimize
- away all the NOTHINGs from it. */
- if (OP(scan) != CURLYX) {
- const int max = (reg_off_by_arg[OP(scan)]
- ? I32_MAX
- /* I32 may be smaller than U16 on CRAYs! */
- : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
- int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
- int noff;
- regnode *n = scan;
-
- /* Skip NOTHING and LONGJMP. */
- while ((n = regnext(n))
- && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
- || ((OP(n) == LONGJMP) && (noff = ARG(n))))
- && off + noff < max)
- off += noff;
- if (reg_off_by_arg[OP(scan)])
- ARG(scan) = off;
- else
- NEXT_OFF(scan) = off;
- }
+ /* Follow the next-chain of the current node and optimize
+ away all the NOTHINGs from it.
+ */
+ rck_elide_nothing(scan);
/* The principal pseudo-switch. Cannot be a switch, since we
look into several different things. */
@@ -5348,11 +5367,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
if (data && (fl & SF_HAS_EVAL))
data->flags |= SF_HAS_EVAL;
optimize_curly_tail:
- if (OP(oscan) != CURLYX) {
- while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
- && NEXT_OFF(next))
- NEXT_OFF(oscan) += NEXT_OFF(next);
- }
+ rck_elide_nothing(oscan);
continue;
default:
--
2.20.1

View File

@ -1,279 +0,0 @@
From c031e3ec7c713077659f5f7dc6638d926c69d7b2 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Sat, 11 Apr 2020 14:10:24 +0100
Subject: [PATCH v528 3/3] study_chunk: avoid mutating regexp program within
GOSUB
gh16947 and gh17743: studying GOSUB may restudy in an inner call
(via a mix of recursion and enframing) something that an outer call
is in the middle of looking at. Let the outer frame deal with it.
(CVE-2020-12723)
---
embed.fnc | 2 +-
embed.h | 2 +-
proto.h | 2 +-
regcomp.c | 48 ++++++++++++++++++++++++++++++++----------------
t/re/pat.t | 26 +++++++++++++++++++++++++-
5 files changed, 60 insertions(+), 20 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index cf89277163..4b1ba28277 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2397,7 +2397,7 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|NULLOK struct scan_data_t *data \
|I32 stopparen|U32 recursed_depth \
|NULLOK regnode_ssc *and_withp \
- |U32 flags|U32 depth
+ |U32 flags|U32 depth|bool was_mutate_ok
EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
|NN const char* const s|const U32 n
rs |void |re_croak2 |bool utf8|NN const char* pat1|NN const char* pat2|...
diff --git a/embed.h b/embed.h
index 886551ce5c..50fcabc140 100644
--- a/embed.h
+++ b/embed.h
@@ -1075,7 +1075,7 @@
#define ssc_is_cp_posixl_init S_ssc_is_cp_posixl_init
#define ssc_or(a,b,c) S_ssc_or(aTHX_ a,b,c)
#define ssc_union(a,b,c) S_ssc_union(aTHX_ a,b,c)
-#define study_chunk(a,b,c,d,e,f,g,h,i,j,k) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k)
+#define study_chunk(a,b,c,d,e,f,g,h,i,j,k,l) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k,l)
# endif
# if defined(PERL_IN_REGCOMP_C) || defined (PERL_IN_DUMP_C)
#define _invlist_dump(a,b,c,d) Perl__invlist_dump(aTHX_ a,b,c,d)
diff --git a/proto.h b/proto.h
index d3f8802c1d..e276f69bd1 100644
--- a/proto.h
+++ b/proto.h
@@ -5258,7 +5258,7 @@ PERL_STATIC_INLINE void S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, c
#define PERL_ARGS_ASSERT_SSC_UNION \
assert(ssc); assert(invlist)
#endif
-STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U32 recursed_depth, regnode_ssc *and_withp, U32 flags, U32 depth);
+STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U32 recursed_depth, regnode_ssc *and_withp, U32 flags, U32 depth, bool was_mutate_ok);
#define PERL_ARGS_ASSERT_STUDY_CHUNK \
assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last)
#endif
diff --git a/regcomp.c b/regcomp.c
index 0a9c6a8085..e66032a16a 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -110,6 +110,7 @@ typedef struct scan_frame {
regnode *next_regnode; /* next node to process when last is reached */
U32 prev_recursed_depth;
I32 stopparen; /* what stopparen do we use */
+ bool in_gosub; /* this or an outer frame is for GOSUB */
U32 is_top_frame; /* what flags do we use? */
struct scan_frame *this_prev_frame; /* this previous frame */
@@ -4102,7 +4103,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
I32 stopparen,
U32 recursed_depth,
regnode_ssc *and_withp,
- U32 flags, U32 depth)
+ U32 flags, U32 depth, bool was_mutate_ok)
/* scanp: Start here (read-write). */
/* deltap: Write maxlen-minlen here. */
/* last: Stop before this one. */
@@ -4179,6 +4180,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
node length to get a real minimum (because
the folded version may be shorter) */
bool unfolded_multi_char = FALSE;
+ /* avoid mutating ops if we are anywhere within the recursed or
+ * enframed handling for a GOSUB: the outermost level will handle it.
+ */
+ bool mutate_ok = was_mutate_ok && !(frame && frame->in_gosub);
/* Peephole optimizer: */
DEBUG_STUDYDATA("Peep:", data, depth);
DEBUG_PEEP("Peep", scan, depth);
@@ -4189,7 +4194,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
* parsing code, as each (?:..) is handled by a different invocation of
* reg() -- Yves
*/
- JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
+ if (mutate_ok)
+ JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
/* Follow the next-chain of the current node and optimize
away all the NOTHINGs from it. */
@@ -4238,7 +4244,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
* NOTE we dont use the return here! */
(void)study_chunk(pRExC_state, &scan, &minlen,
&deltanext, next, &data_fake, stopparen,
- recursed_depth, NULL, f, depth+1);
+ recursed_depth, NULL, f, depth+1, mutate_ok);
scan = next;
} else
@@ -4305,7 +4311,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
/* we suppose the run is continuous, last=next...*/
minnext = study_chunk(pRExC_state, &scan, minlenp,
&deltanext, next, &data_fake, stopparen,
- recursed_depth, NULL, f,depth+1);
+ recursed_depth, NULL, f, depth+1,
+ mutate_ok);
if (min1 > minnext)
min1 = minnext;
@@ -4372,9 +4379,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
}
}
- if (PERL_ENABLE_TRIE_OPTIMISATION &&
- OP( startbranch ) == BRANCH )
- {
+ if (PERL_ENABLE_TRIE_OPTIMISATION
+ && OP(startbranch) == BRANCH
+ && mutate_ok
+ ) {
/* demq.
Assuming this was/is a branch we are dealing with: 'scan'
@@ -4825,6 +4833,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
newframe->stopparen = stopparen;
newframe->prev_recursed_depth = recursed_depth;
newframe->this_prev_frame= frame;
+ newframe->in_gosub = (
+ (frame && frame->in_gosub) || OP(scan) == GOSUB
+ );
DEBUG_STUDYDATA("frame-new:",data,depth);
DEBUG_PEEP("fnew", scan, depth);
@@ -5043,7 +5054,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
(mincount == 0
? (f & ~SCF_DO_SUBSTR)
: f)
- ,depth+1);
+ , depth+1, mutate_ok);
if (flags & SCF_DO_STCLASS)
data->start_class = oclass;
@@ -5105,7 +5116,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
if ( OP(oscan) == CURLYX && data
&& data->flags & SF_IN_PAR
&& !(data->flags & SF_HAS_EVAL)
- && !deltanext && minnext == 1 ) {
+ && !deltanext && minnext == 1
+ && mutate_ok
+ ) {
/* Try to optimize to CURLYN. */
regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
regnode * const nxt1 = nxt;
@@ -5151,10 +5164,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
&& !(data->flags & SF_HAS_EVAL)
&& !deltanext /* atom is fixed width */
&& minnext != 0 /* CURLYM can't handle zero width */
-
/* Nor characters whose fold at run-time may be
* multi-character */
&& ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
+ && mutate_ok
) {
/* XXXX How to optimize if data == 0? */
/* Optimize to a simpler form. */
@@ -5201,7 +5214,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
#endif
/* Optimize again: */
study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
- NULL, stopparen, recursed_depth, NULL, 0,depth+1);
+ NULL, stopparen, recursed_depth, NULL, 0,
+ depth+1, mutate_ok);
}
else
oscan->flags = 0;
@@ -5592,7 +5606,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
nscan = NEXTOPER(NEXTOPER(scan));
minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
last, &data_fake, stopparen,
- recursed_depth, NULL, f, depth+1);
+ recursed_depth, NULL, f, depth+1,
+ mutate_ok);
if (scan->flags) {
if (deltanext) {
FAIL("Variable length lookbehind not implemented");
@@ -5681,7 +5696,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
*minnextp = study_chunk(pRExC_state, &nscan, minnextp,
&deltanext, last, &data_fake,
stopparen, recursed_depth, NULL,
- f,depth+1);
+ f, depth+1, mutate_ok);
if (scan->flags) {
if (deltanext) {
FAIL("Variable length lookbehind not implemented");
@@ -5841,7 +5856,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
branches even though they arent otherwise used. */
minnext = study_chunk(pRExC_state, &scan, minlenp,
&deltanext, (regnode *)nextbranch, &data_fake,
- stopparen, recursed_depth, NULL, f,depth+1);
+ stopparen, recursed_depth, NULL, f, depth+1,
+ mutate_ok);
}
if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
nextbranch= regnext((regnode*)nextbranch);
@@ -7524,7 +7540,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
&data, -1, 0, NULL,
SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
| (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
- 0);
+ 0, TRUE);
CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
@@ -7670,7 +7686,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
? SCF_TRIE_DOING_RESTUDY
: 0),
- 0);
+ 0, TRUE);
CHECK_RESTUDY_GOTO_butfirst(NOOP);
diff --git a/t/re/pat.t b/t/re/pat.t
index 1d98fe77d7..1488259b02 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -23,7 +23,7 @@ BEGIN {
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
skip_all_without_unicode_tables();
-plan tests => 840; # Update this when adding/deleting tests.
+plan tests => 844; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1929,6 +1929,30 @@ EOP
fresh_perl_is('"AA" =~ m/AA{1,0}/','',{},"handle OPFAIL insert properly");
}
+ # gh16947: test regexp corruption (GOSUB)
+ {
+ fresh_perl_is(q{
+ 'xy' =~ /x(?0)|x(?|y|y)/ && print 'ok'
+ }, 'ok', {}, 'gh16947: test regexp corruption (GOSUB)');
+ }
+ # gh16947: test fix doesn't break SUSPEND
+ {
+ fresh_perl_is(q{ 'sx' =~ m{ss++}i; print 'ok' },
+ 'ok', {}, "gh16947: test fix doesn't break SUSPEND");
+ }
+
+ # gh17743: more regexp corruption via GOSUB
+ {
+ fresh_perl_is(q{
+ "0" =~ /((0(?0)|000(?|0000|0000)(?0))|)/; print "ok"
+ }, 'ok', {}, 'gh17743: test regexp corruption (1)');
+
+ fresh_perl_is(q{
+ "000000000000" =~ /(0(())(0((?0)())|000(?|\x{ef}\x{bf}\x{bd}|\x{ef}\x{bf}\x{bd}))|)/;
+ print "ok"
+ }, 'ok', {}, 'gh17743: test regexp corruption (2)');
+ }
+
} # End of sub run_tests
1;
--
2.20.1

View File

@ -1,62 +0,0 @@
From 47d2c70bde8c0bdc67e85578133338fc63c33f13 Mon Sep 17 00:00:00 2001
From: Jitka Plesnikova <jplesnik@redhat.com>
Date: Thu, 17 Jun 2021 11:41:48 +0200
Subject: [PATCH 2/2] Fix _resolv return value
in case of the new warnings.
Thanks to @nlv02636
Backported fromn Net-Ping 2.68
---
dist/Net-Ping/lib/Net/Ping.pm | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm
index 9e2497c..87087fc 100644
--- a/dist/Net-Ping/lib/Net/Ping.pm
+++ b/dist/Net-Ping/lib/Net/Ping.pm
@@ -1794,6 +1794,7 @@ sub _resolv {
# Clean up port
if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) {
croak("Invalid port `$h{port}' in `$name'");
+ return undef;
}
# END - host:port
@@ -1850,18 +1851,21 @@ sub _resolv {
} else {
(undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
}
- return \%h
+ return \%h;
} else {
carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
+ return undef;
}
} else {
warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
$family == AF_INET ? "AF_INET" : "AF_INET6"));
+ return undef;
}
# old way
} else {
if ($family == $AF_INET6) {
croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION");
+ return undef;
}
my @gethost = gethostbyname($h{host});
@@ -1872,8 +1876,10 @@ sub _resolv {
return \%h
} else {
carp("gethostbyname($h{host}) failed - $^E");
+ return undef;
}
}
+ return undef;
}
sub _pack_sockaddr_in($$) {
--
2.31.1

View File

@ -1,99 +0,0 @@
From 5a3f94a3f0e21d8e685ede4e851a318578a2151f Mon Sep 17 00:00:00 2001
From: Jitka Plesnikova <jplesnik@redhat.com>
Date: Thu, 17 Jun 2021 11:12:30 +0200
Subject: [PATCH 1/2] carp, not croak on most name lookup failures
See RT #124830, a regression.
Return undef instead.
Backported from Net-Ping 2.67
---
dist/Net-Ping/lib/Net/Ping.pm | 24 ++++++++++++------------
1 file changed, 12 insertions(+), 12 deletions(-)
diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm
index 13cbe81..9e2497c 100644
--- a/dist/Net-Ping/lib/Net/Ping.pm
+++ b/dist/Net-Ping/lib/Net/Ping.pm
@@ -144,7 +144,7 @@ sub new
if ($self->{'host'}) {
my $host = $self->{'host'};
my $ip = _resolv($host)
- or croak("could not resolve host $host");
+ or carp("could not resolve host $host");
$self->{host} = $ip;
$self->{family} = $ip->{family};
}
@@ -152,7 +152,7 @@ sub new
if ($self->{bind}) {
my $addr = $self->{bind};
my $ip = _resolv($addr)
- or croak("could not resolve local addr $addr");
+ or carp("could not resolve local addr $addr");
$self->{local_addr} = $ip;
} else {
$self->{local_addr} = undef; # Don't bind by default
@@ -323,7 +323,7 @@ sub bind
($self->{proto} eq "udp" || $self->{proto} eq "icmp");
$ip = $self->_resolv($local_addr);
- croak("nonexistent local address $local_addr") unless defined($ip);
+ carp("nonexistent local address $local_addr") unless defined($ip);
$self->{local_addr} = $ip;
if (($self->{proto} ne "udp") &&
@@ -1129,13 +1129,14 @@ sub open
$self->{family_local} = $self->{family};
}
- $ip = $self->_resolv($host);
$timeout = $self->{timeout} unless $timeout;
+ $ip = $self->_resolv($host);
- if($self->{proto} eq "stream") {
- if(defined($self->{fh}->fileno())) {
+ if ($self->{proto} eq "stream") {
+ if (defined($self->{fh}->fileno())) {
croak("socket is already open");
} else {
+ return () unless $ip;
$self->tcp_connect($ip, $timeout);
}
}
@@ -1851,12 +1852,11 @@ sub _resolv {
}
return \%h
} else {
- croak("getnameinfo($getaddr[0]->{addr}) failed - $err");
+ carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
}
} else {
- my $error = sprintf "getaddrinfo($h{host},,%s) failed - $err",
- ($family == AF_INET) ? "AF_INET" : "AF_INET6";
- croak("$error");
+ warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
+ $family == AF_INET ? "AF_INET" : "AF_INET6"));
}
# old way
} else {
@@ -1871,7 +1871,7 @@ sub _resolv {
$h{family} = AF_INET;
return \%h
} else {
- croak("gethostbyname($h{host}) failed - $^E");
+ carp("gethostbyname($h{host}) failed - $^E");
}
}
}
@@ -1913,7 +1913,7 @@ sub _inet_ntoa {
if (defined($address)) {
$ret = $address;
} else {
- croak("getnameinfo($addr) failed - $err");
+ carp("getnameinfo($addr) failed - $err");
}
} else {
$ret = inet_ntoa($addr)
--
2.31.1

View File

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

View File

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

View File

@ -1,45 +0,0 @@
From b4d257e2d408f0f1c6686dcdc112f3ebfec68f44 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 27 Jun 2017 10:22:23 +0200
Subject: [PATCH] File::Glob - tweak rt131211.t to be less sensitive on wonky
boxes
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
make the test less senstive and avoid divide by zero errors,
also we skip the test if either elapsed_match or elapsed_fail is
true, as we can not rely on the timings then. For the operations
we are doing we should get a non-zero timing from Time::HiRes.
This should mean that running this test on boxes with heavy
load, etc, will no longer result in false positives.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/File-Glob/t/rt131211.t | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
diff --git a/ext/File-Glob/t/rt131211.t b/ext/File-Glob/t/rt131211.t
index c1bcbe0..b29cd04 100644
--- a/ext/File-Glob/t/rt131211.t
+++ b/ext/File-Glob/t/rt131211.t
@@ -49,8 +49,13 @@ while (++$count < 10) {
is $count,10,
"tried all the patterns without bailing out";
-cmp_ok $elapsed_fail/$elapsed_match,"<",2,
- "time to fail less than twice the time to match";
+SKIP: {
+ skip "unstable timing", 1 unless $elapsed_match && $elapsed_fail;
+ ok $elapsed_fail <= 10 * $elapsed_match,
+ "time to fail less than 10x the time to match"
+ or diag("elapsed_match=$elapsed_match elapsed_fail=$elapsed_fail");
+}
+
is "@got_files", catfile($path, $files[0]),
"only got the expected file for xa*..b";
is "@no_files", "", "shouldnt have files for xa*..c";
--
2.9.4

View File

@ -1,226 +0,0 @@
From 5aca16e032861ea3dfcc96ad417ea87e2b1552e5 Mon Sep 17 00:00:00 2001
From: Aaron Crane <arc@cpan.org>
Date: Sat, 4 Mar 2017 12:50:58 +0000
Subject: [PATCH] RT #130907: Fix the Unicode Bug in split " "
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Ported to 5.26.0:
commit 20ae58f7a9bbf84d043d6e90f5988b6e3ca4ee3d
Author: Aaron Crane <arc@cpan.org>
Date: Sat Mar 4 12:50:58 2017 +0000
RT #130907: Fix the Unicode Bug in split " "
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
lib/feature.pm | 5 +++--
pod/perldelta.pod | 9 +++++++++
pod/perlfunc.pod | 8 ++++++++
pod/perlunicode.pod | 11 +++++++++++
pod/perluniintro.pod | 5 +++--
pp.c | 13 +++++++++++++
regen/feature.pl | 5 +++--
t/op/split.t | 20 +++++++++++++++++++-
8 files changed, 69 insertions(+), 7 deletions(-)
diff --git a/lib/feature.pm b/lib/feature.pm
index ed13273..93e020b 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -175,8 +175,9 @@ C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
This feature is available starting with Perl 5.12; was almost fully
implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>;
-and extended further in Perl 5.26 to cover L<the range
-operator|perlop/Range Operators>.
+was extended further in Perl 5.26 to cover L<the range
+operator|perlop/Range Operators>; and was extended again in Perl 5.28 to
+cover L<special-cased whitespace splitting|perlfunc/split>.
=head2 The 'unicode_eval' and 'evalbytes' features
#diff --git a/pod/perldelta.pod b/pod/perldelta.pod
#index 06dcd1d..d31335f 100644
#--- a/pod/perldelta.pod
#+++ b/pod/perldelta.pod
#@@ -3206,6 +3206,15 @@ calls.
# Parsing bad POSIX charclasses no longer leaks memory.
# L<[perl #128313]|https://rt.perl.org/Public/Bug/Display.html?id=128313>
#
#+=item *
#+
#+C<split ' '> now correctly handles the argument being split when in the
#+scope of the L<< C<unicode_strings>|feature/"The 'unicode_strings' feature"
#+>> feature. Previously, when a string using the single-byte internal
#+representation contained characters that are whitespace by Unicode rules but
#+not by ASCII rules, it treated those characters as part of fields rather
#+than as field separators. [perl #130907]
#+
# =back
#
# =head1 Known Problems
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index b8dca6e..9abadf4 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -7616,6 +7616,14 @@ special case was restricted to the use of a plain S<C<" ">> as the
pattern argument to split; in Perl 5.18.0 and later this special case is
triggered by any expression which evaluates to the simple string S<C<" ">>.
+As of Perl 5.28, this special-cased whitespace splitting works as expected in
+the scope of L<< S<C<"use feature 'unicode_strings">>|feature/The
+'unicode_strings' feature >>. In previous versions, and outside the scope of
+that feature, it exhibits L<perlunicode/The "Unicode Bug">: characters that are
+whitespace according to Unicode rules but not according to ASCII rules can be
+treated as part of fields rather than as field separators, depending on the
+string's internal encoding.
+
If omitted, PATTERN defaults to a single space, S<C<" ">>, triggering
the previously described I<awk> emulation.
diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod
index 9c13c35..2e84e95 100644
--- a/pod/perlunicode.pod
+++ b/pod/perlunicode.pod
@@ -1835,6 +1835,17 @@ outside its scope, it could produce strings whose length in characters
exceeded that of the right-hand side, where the right-hand side took up more
bytes than the correct range endpoint.
+=item *
+
+In L<< C<split>'s special-case whitespace splitting|perlfunc/split >>.
+
+Starting in Perl 5.28.0, the C<split> function with a pattern specified as
+a string containing a single space handles whitespace characters consistently
+within the scope of of C<unicode_strings>. Prior to that, or outside its scope,
+characters that are whitespace according to Unicode rules but not according to
+ASCII rules were treated as field contents rather than field separators when
+they appear in byte-encoded strings.
+
=back
You can see from the above that the effect of C<unicode_strings>
diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod
index d35de34..595ec46 100644
--- a/pod/perluniintro.pod
+++ b/pod/perluniintro.pod
@@ -151,11 +151,12 @@ serious Unicode work. The maintenance release 5.6.1 fixed many of the
problems of the initial Unicode implementation, but for example
regular expressions still do not work with Unicode in 5.6.1.
Perl v5.14.0 is the first release where Unicode support is
-(almost) seamlessly integrable without some gotchas. (There are two
+(almost) seamlessly integrable without some gotchas. (There are a few
exceptions. Firstly, some differences in L<quotemeta|perlfunc/quotemeta>
were fixed starting in Perl 5.16.0. Secondly, some differences in
L<the range operator|perlop/Range Operators> were fixed starting in
-Perl 5.26.0.)
+Perl 5.26.0. Thirdly, some differences in L<split|perlfunc/split> were fixed
+started in Perl 5.28.0.)
To enable this
seamless support, you should C<use feature 'unicode_strings'> (which is
diff --git a/pp.c b/pp.c
index cc4cb59..d9dd005 100644
--- a/pp.c
+++ b/pp.c
@@ -5740,6 +5740,7 @@ PP(pp_split)
STRLEN len;
const char *s = SvPV_const(sv, len);
const bool do_utf8 = DO_UTF8(sv);
+ const bool in_uni_8_bit = IN_UNI_8_BIT;
const char *strend = s + len;
PMOP *pm = cPMOPx(PL_op);
REGEXP *rx;
@@ -5826,6 +5827,10 @@ PP(pp_split)
while (s < strend && isSPACE_LC(*s))
s++;
}
+ else if (in_uni_8_bit) {
+ while (s < strend && isSPACE_L1(*s))
+ s++;
+ }
else {
while (s < strend && isSPACE(*s))
s++;
@@ -5857,6 +5862,10 @@ PP(pp_split)
{
while (m < strend && !isSPACE_LC(*m))
++m;
+ }
+ else if (in_uni_8_bit) {
+ while (m < strend && !isSPACE_L1(*m))
+ ++m;
} else {
while (m < strend && !isSPACE(*m))
++m;
@@ -5891,6 +5900,10 @@ PP(pp_split)
{
while (s < strend && isSPACE_LC(*s))
++s;
+ }
+ else if (in_uni_8_bit) {
+ while (s < strend && isSPACE_L1(*s))
+ ++s;
} else {
while (s < strend && isSPACE(*s))
++s;
diff --git a/regen/feature.pl b/regen/feature.pl
index 579120e..8a4ce63 100755
--- a/regen/feature.pl
+++ b/regen/feature.pl
@@ -485,8 +485,9 @@ C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
This feature is available starting with Perl 5.12; was almost fully
implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>;
-and extended further in Perl 5.26 to cover L<the range
-operator|perlop/Range Operators>.
+was extended further in Perl 5.26 to cover L<the range
+operator|perlop/Range Operators>; and was extended again in Perl 5.28 to
+cover L<special-cased whitespace splitting|perlfunc/split>.
=head2 The 'unicode_eval' and 'evalbytes' features
diff --git a/t/op/split.t b/t/op/split.t
index d60bcaf..038c5d7 100644
--- a/t/op/split.t
+++ b/t/op/split.t
@@ -7,7 +7,7 @@ BEGIN {
set_up_inc('../lib');
}
-plan tests => 163;
+plan tests => 172;
$FS = ':';
@@ -480,6 +480,24 @@ is($cnt, scalar(@ary));
qq{split(\$cond ? qr/ / : " ", "$exp") behaves as expected over repeated similar patterns};
}
+SKIP: {
+ # RT #130907: unicode_strings feature doesn't work with split ' '
+
+ my ($sp) = grep /\s/u, map chr, reverse 128 .. 255 # prefer \xA0 over \x85
+ or skip 'no unicode whitespace found in high-8-bit range', 9;
+
+ for (["$sp$sp. /", "leading unicode whitespace"],
+ [".$sp$sp/", "unicode whitespace separator"],
+ [". /$sp$sp", "trailing unicode whitespace"]) {
+ my ($str, $desc) = @$_;
+ use feature "unicode_strings";
+ my @got = split " ", $str;
+ is @got, 2, "whitespace split: $desc: field count";
+ is $got[0], '.', "whitespace split: $desc: field 0";
+ is $got[1], '/', "whitespace split: $desc: field 1";
+ }
+}
+
{
# 'RT #116086: split "\x20" does not work as documented';
my @results;
--
2.9.4

View File

@ -1,51 +0,0 @@
From b9a58d500dd75ba783abac92a56e57d41227f62b Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 2 Jul 2017 11:35:20 -0700
Subject: [PATCH] =?UTF-8?q?[perl=20#131679]=20Fix=20=E2=80=98our=20sub=20f?=
=?UTF-8?q?oo::bar=E2=80=99=20message?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
It should say subroutine, not variable.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/lib/croak/toke | 6 ++++++
toke.c | 3 ++-
2 files changed, 8 insertions(+), 1 deletion(-)
diff --git a/t/lib/croak/toke b/t/lib/croak/toke
index 7aa15ef..2603224 100644
--- a/t/lib/croak/toke
+++ b/t/lib/croak/toke
@@ -133,6 +133,12 @@ state sub;
EXPECT
Missing name in "state sub" at - line 2.
########
+# NAME our sub pack::foo
+our sub foo::bar;
+EXPECT
+No package name allowed for subroutine &foo::bar in "our" at - line 1, near "our sub foo::bar"
+Execution of - aborted due to compilation errors.
+########
# NAME my sub pack::foo
use feature 'lexical_subs', 'state';
my sub foo::bar;
diff --git a/toke.c b/toke.c
index ace92e3..6aa5f26 100644
--- a/toke.c
+++ b/toke.c
@@ -8848,7 +8848,8 @@ S_pending_ident(pTHX)
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
if (has_colon)
yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
- "variable %s in \"our\"",
+ "%se %s in \"our\"",
+ *PL_tokenbuf=='&' ?"subroutin":"variabl",
PL_tokenbuf), UTF ? SVf_UTF8 : 0);
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
--
2.9.4

View File

@ -1,30 +0,0 @@
From 97e57bec1f0ba4f0c3b1dc18ee146632010e3373 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Sat, 15 Jul 2017 19:36:25 -0600
Subject: [PATCH] t/lib/warnings/utf8: Fix test
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
There is some randomness to this test added to fix [perl #131646].
Change what passes to be a pattern that matches the correct template
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/lib/warnings/utf8 | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8
index 9066308..dfc58c1 100644
--- a/t/lib/warnings/utf8
+++ b/t/lib/warnings/utf8
@@ -781,4 +781,5 @@ no warnings;
use warnings 'utf8';
for(uc 0..t){0~~pack"UXc",exp}
EXPECT
-Malformed UTF-8 character: \xc2\x00 (unexpected non-continuation byte 0x00, immediately after start byte 0xc2; need 2 bytes, got 1) in smart match at - line 9.
+OPTIONS regex
+Malformed UTF-8 character: \\x([[:xdigit:]]{2})\\x([[:xdigit:]]{2}) \(unexpected non-continuation byte 0x\2, immediately after start byte 0x\1; need 2 bytes, got 1\) in smart match at - line 9.
--
2.9.4

View File

@ -1,43 +0,0 @@
From 05b9033b464ce8dd2c9b33238f9aa14755d7a91a Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Sat, 17 Jun 2017 17:56:10 -0600
Subject: [PATCH] utf8n_to_uvchr(): Don't display too many bytes in msg
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
When raising a message about malformed UTF-8, we shouldn't display bytes
from the next character, unless those bytes were expected to have been
part of the current one. Tests for this will be added in future commits
in ext/XS-APItest/t/utf8_warn_base.pl
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
utf8.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/utf8.c b/utf8.c
index ee5405f..e55a6f1 100644
--- a/utf8.c
+++ b/utf8.c
@@ -1428,7 +1428,7 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
if (pack_warn) {
message = Perl_form(aTHX_ "%s: %s (overflows)",
malformed_text,
- _byte_dump_string(s0, send - s0, 0));
+ _byte_dump_string(s0, curlen, 0));
}
}
}
@@ -1554,7 +1554,7 @@ Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
"%s: %s (overlong; instead use %s to represent"
" U+%0*" UVXf ")",
malformed_text,
- _byte_dump_string(s0, send - s0, 0),
+ _byte_dump_string(s0, curlen, 0),
_byte_dump_string(tmpbuf, e - tmpbuf, 0),
((uv < 256) ? 2 : 4), /* Field width of 2 for
small code points */
--
2.9.4

View File

@ -1,57 +0,0 @@
From 8121278aa8fe72e9e8aca8651c7f1d4fa204ac1d Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Mon, 2 Apr 2018 21:54:59 -0600
Subject: [PATCH] PATCH: [perl #132167] Parse error in regex_sets
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
When popping the stack, the code inappropriately also subtracted one
from the result. This is probably left over from an earlier change in
the implementation. The top of the stack contained the correct value;
subtracting was a mistake.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regcomp.c | 2 +-
t/re/regex_sets.t | 11 +++++++++++
2 files changed, 12 insertions(+), 1 deletion(-)
diff --git a/regcomp.c b/regcomp.c
index 018d5646fc..39ab260efa 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -15689,7 +15689,7 @@ redo_curchar:
* fence. Get rid of it */
fence_ptr = av_pop(fence_stack);
assert(fence_ptr);
- fence = SvIV(fence_ptr) - 1;
+ fence = SvIV(fence_ptr);
SvREFCNT_dec_NN(fence_ptr);
fence_ptr = NULL;
diff --git a/t/re/regex_sets.t b/t/re/regex_sets.t
index e9644bd4e6..e70df81254 100644
--- a/t/re/regex_sets.t
+++ b/t/re/regex_sets.t
@@ -204,6 +204,17 @@ for my $char ("٠", "٥", "٩") {
like("a", qr/$pat/, "/$pat/ compiles and matches 'a'");
}
+{ # [perl #132167]
+ fresh_perl_is('no warnings "experimental::regex_sets";
+ print "c" =~ qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ])/;',
+ 1, {},
+ 'qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ]) compiles and properly matches');
+ fresh_perl_is('no warnings "experimental::regex_sets";
+ print "b" =~ qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ])/;',
+ "", {},
+ 'qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ]) compiles and properly matches');
+}
+
done_testing();
1;
--
2.14.3

View File

@ -1,71 +0,0 @@
From 62e6b70574842d7f2c547d33c85c50228522f685 Mon Sep 17 00:00:00 2001
From: Marc-Philip <marc-philip.werner@sap.com>
Date: Sun, 8 Apr 2018 12:15:29 -0600
Subject: [PATCH] PATCH: [perl #133074] 5.26.1: some coverity fixes
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
we have some coverity code scans here. They have found this
uninilialized variable in pp.c and the integer overrun in toke.c.
Though it might be possible that these are false positives (no
reasonable control path gets there), it's good to mute the scan here to
see the real problems easier.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp.c | 1 +
toke.c | 8 ++++----
2 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/pp.c b/pp.c
index 5524131658..d777ae4309 100644
--- a/pp.c
+++ b/pp.c
@@ -3727,6 +3727,7 @@ PP(pp_ucfirst)
if (! slen) { /* If empty */
need = 1; /* still need a trailing NUL */
ulen = 0;
+ *tmpbuf = '\0';
}
else if (DO_UTF8(source)) { /* Is the source utf8? */
doing_utf8 = TRUE;
diff --git a/toke.c b/toke.c
index 3405dc6c89..fc87252bb1 100644
--- a/toke.c
+++ b/toke.c
@@ -9052,7 +9052,7 @@ S_pending_ident(pTHX)
HEK * const stashname = HvNAME_HEK(stash);
SV * const sym = newSVhek(stashname);
sv_catpvs(sym, "::");
- sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
+ sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
pl_yylval.opval->op_private = OPpCONST_ENTERED;
if (pit != '&')
@@ -9080,7 +9080,7 @@ S_pending_ident(pTHX)
&& PL_lex_state != LEX_NORMAL
&& !PL_lex_brackets)
{
- GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
+ GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
SVt_PVAV);
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
@@ -9097,11 +9097,11 @@ S_pending_ident(pTHX)
/* build ops for a bareword */
pl_yylval.opval = newSVOP(OP_CONST, 0,
newSVpvn_flags(PL_tokenbuf + 1,
- tokenbuf_len - 1,
+ tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
UTF ? SVf_UTF8 : 0 ));
pl_yylval.opval->op_private = OPpCONST_ENTERED;
if (pit != '&')
- gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
+ gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
(PL_in_eval ? GV_ADDMULTI : GV_ADD)
| ( UTF ? SVf_UTF8 : 0 ),
((PL_tokenbuf[0] == '$') ? SVt_PV
--
2.14.3

View File

@ -1,45 +0,0 @@
From 357c35e6f18e65f372e7a1b22ee39a3c7c9e5810 Mon Sep 17 00:00:00 2001
From: Robin Barker <RMBarker@cpan.org>
Date: Mon, 17 Dec 2012 18:20:14 +0100
Subject: [PATCH] Avoid compiler warnings due to mismatched types in *printf
format strings.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
gcc (and probably others) was warning about a mismatch for between `int`
(implied by the format %d) and the actual type passed, `line_t`. Avoid this
by explicitly casting to UV, and using UVuf.
CPAN #63832
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm | 7 ++++---
1 file changed, 4 insertions(+), 3 deletions(-)
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
index 545d322..c7e6d05 100644
--- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
+++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm
@@ -629,13 +629,14 @@ EOA
if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
- ", used at %" COP_FILE_F " line %d\\n", sv,
- COP_FILE(cop), CopLINE(cop));
+ ", used at %" COP_FILE_F " line %" UVuf "\\n",
+ sv, COP_FILE(cop), (UV)CopLINE(cop));
} else
#endif
{
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro at %"
- COP_FILE_F " line %d\\n", sv, COP_FILE(cop), CopLINE(cop));
+ COP_FILE_F " line %" UVuf "\\n",
+ sv, COP_FILE(cop), (UV)CopLINE(cop));
}
croak_sv(sv_2mortal(sv));
EOC
--
2.9.4

View File

@ -1,69 +0,0 @@
From 389f3ef2fdfbba2c2816e7334a69a5f540c0a33d Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 15 Dec 2014 16:14:13 +0000
Subject: [PATCH] EU::Constant: avoid 'uninit' warning
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
The code generated by ExtUtils::Constant can look something like:
static int
constant (..., IV *iv_return) {
switch (...) {
case ...:
*iv_return = ...;
return PERL_constant_ISIV;
...
}
}
{
int type;
IV iv;
type = constant(..., &iv);
switch (type) {
case PERL_constant_ISIV:
PUSHi(iv);
...
}
}
and the compiler isn't clever enough to realise that the value of iv
is only used in the code path where its been set.
So initialise it to zero to shut gcc up. Ditto nv and pv.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
index 0dc9258..cf0e1ca 100644
--- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
+++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm
@@ -198,17 +198,17 @@ $XS_subname(sv)
EOT
if ($params->{IV}) {
- $xs .= " IV iv;\n";
+ $xs .= " IV iv = 0; /* avoid uninit var warning */\n";
} else {
$xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
}
if ($params->{NV}) {
- $xs .= " NV nv;\n";
+ $xs .= " NV nv = 0.0; /* avoid uninit var warning */\n";
} else {
$xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
}
if ($params->{PV}) {
- $xs .= " const char *pv;\n";
+ $xs .= " const char *pv = NULL; /* avoid uninit var warning */\n";
} else {
$xs .=
" /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
--
2.9.4

View File

@ -1,60 +0,0 @@
From 45908e4d120d33a558a8b052036c56cd0c90b898 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Wed, 13 Sep 2017 13:30:25 +0200
Subject: [PATCH] avoid 'the address of ... will always evaluate as ...' warns
in mem macros
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
In f14cf363205 we added asserts to our memory macros (Copy(), Zero() etc)
to ensure that the target is non-null. These asserts throw warnings like
perl.c: In function Perl_eval_sv:
perl.c:2976:264: warning: the address of myop will always evaluate
as true [-Waddress]
Zero(&myop, 1, UNOP);
which is annoying. This patch changes how these asserts are coded so
we avoid the warning. Thanks to Zefram for the fix.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
handy.h | 17 ++++++++++-------
1 file changed, 10 insertions(+), 7 deletions(-)
diff --git a/handy.h b/handy.h
index 31afaae65e..85e8f70721 100644
--- a/handy.h
+++ b/handy.h
@@ -2409,17 +2409,20 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe
#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d)))
#endif
-#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
-#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
-#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), (void)memzero((char*)(d), (n) * sizeof(t)))
+#define perl_assert_ptr(p) assert( ((void*)(p)) != 0 )
-#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
-#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), assert(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
+
+#define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define Copy(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), (void)memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define Zero(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), (void)memzero((char*)(d), (n) * sizeof(t)))
+
+#define MoveD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), memmove((char*)(d),(const char*)(s), (n) * sizeof(t)))
+#define CopyD(s,d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), perl_assert_ptr(s), memcpy((char*)(d),(const char*)(s), (n) * sizeof(t)))
#ifdef HAS_MEMSET
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)))
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), memzero((char*)(d), (n) * sizeof(t)))
#else
/* Using bzero(), which returns void. */
-#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) assert(d), memzero((char*)(d), (n) * sizeof(t)),d)
+#define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) perl_assert_ptr(d), memzero((char*)(d), (n) * sizeof(t)),d)
#endif
#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)))
--
2.13.6

View File

@ -1,30 +0,0 @@
From 4369267db9ca4982c1a9bd1ef680bc4350decc3a Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 18 Sep 2017 15:07:21 +1000
Subject: [PATCH] (perl #132008) try to prevent the similar mistakes in the
future
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
dist/Term-ReadLine/lib/Term/ReadLine.pm | 2 ++
1 file changed, 2 insertions(+)
diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm
index e00fb376cd..78c1ebf5b6 100644
--- a/dist/Term-ReadLine/lib/Term/ReadLine.pm
+++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm
@@ -75,6 +75,8 @@ history. Returns the old value.
returns an array with two strings that give most appropriate names for
files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
+The strings returned may not be useful for 3-argument open().
+
=item Attribs
returns a reference to a hash which describes internal configuration
--
2.13.6

View File

@ -1,32 +0,0 @@
From e7e69c85c7e8e0cb75b831e606ad4f26f18b11ff Mon Sep 17 00:00:00 2001
From: Nicolas R <atoomic@cpan.org>
Date: Mon, 31 Oct 2016 11:53:17 -0600
Subject: [PATCH] Avoid a segfault when untying an object
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Check if the tied object has a stash set
before calling UNTIE method.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_sys.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/pp_sys.c b/pp_sys.c
index 672e7de08e..6d4dd86b7f 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1017,7 +1017,7 @@ PP(pp_untie)
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
- if (obj) {
+ if (obj && SvSTASH(obj)) {
GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
CV *cv;
if (gv && isGV(gv) && (cv = GvCV(gv))) {
--
2.13.6

View File

@ -1,73 +0,0 @@
From b3937e202aaf10c2f8996e2993c880bb38a7a268 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Wed, 1 Nov 2017 13:11:27 -0700
Subject: [PATCH] =?UTF-8?q?Carp:=20Don=E2=80=99t=20choke=20on=20ISA=20cons?=
=?UTF-8?q?tant?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This broke some time between 1.29 (perl 5.18) and 1.3301 (perl 5.20):
$ perl5.20.1 -e 'package Foo { use constant ISA => 42; Bar::f() } package Bar { use Carp; sub f { carp "tun syn" } }'
Not a GLOB reference at /usr/local/lib/perl5/5.20.1/Carp.pm line 560.
and still persisted in bleadperl (Carp 1.43) until this commit.
The code that goes poking through the symbol table needs to take into
account that not all stash elements are globs.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
dist/Carp/lib/Carp.pm | 3 ++-
dist/Carp/t/Carp.t | 13 ++++++++++++-
2 files changed, 14 insertions(+), 2 deletions(-)
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
index 6127b26f54..ef11a0c046 100644
--- a/dist/Carp/lib/Carp.pm
+++ b/dist/Carp/lib/Carp.pm
@@ -593,7 +593,8 @@ sub trusts_directly {
for my $var (qw/ CARP_NOT ISA /) {
# Don't try using the variable until we know it exists,
# to avoid polluting the caller's namespace.
- if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
+ if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
+ && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
return @{$stash->{$var}}
}
}
diff --git a/dist/Carp/t/Carp.t b/dist/Carp/t/Carp.t
index 65daed7c6c..b1e399d143 100644
--- a/dist/Carp/t/Carp.t
+++ b/dist/Carp/t/Carp.t
@@ -3,7 +3,7 @@ no warnings "once";
use Config;
use IPC::Open3 1.0103 qw(open3);
-use Test::More tests => 67;
+use Test::More tests => 68;
sub runperl {
my(%args) = @_;
@@ -488,6 +488,17 @@ SKIP:
);
}
+{
+ package Mpar;
+ sub f { Carp::croak "tun syn" }
+
+ package Phou;
+ $Phou::{ISA} = \42;
+ eval { Mpar::f };
+}
+like $@, qr/tun syn/, 'Carp can handle non-glob ISA stash elems';
+
+
# New tests go here
# line 1 "XA"
--
2.13.6

View File

@ -1,593 +0,0 @@
From 3f8a98327dfdb171bd6e447fec23721b0e74c7a6 Mon Sep 17 00:00:00 2001
From: Zefram <zefram@fysh.org>
Date: Sun, 19 Nov 2017 09:15:53 +0000
Subject: [PATCH] fix tainting of s/// with overloaded replacement
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
The substitution code was trying to track the taintedness of the
replacement string itself, but it didn't account for the replacement
being an untainted object with overloading that returns a tainted
stringification. It looked at the taintedness of the object value, not
realising that taint could arise during the string concatenation per se.
Change the taint checks to look at the actual TAINT_get flag after string
concatenation. This may falsely ascribe to the replacement taint that
actually came from somewhere else, but the end result is the same anyway:
there's no visible behaviour that distinguishes taint specifically from
the replacement. Also remove a related taint check that seems to be
not needed at all. Fixes [perl #115266].
Petr Písař: Ported to 5.26.1.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_ctl.c | 4 +-
pp_hot.c | 4 +-
t/op/taint.t | 428 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
3 files changed, 422 insertions(+), 14 deletions(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index f136f91..15c193b 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -219,9 +219,9 @@ PP(pp_substcont)
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
/* See "how taint works" above pp_subst() */
- if (SvTAINTED(TOPs))
- cx->sb_rxtainted |= SUBST_TAINT_REPL;
sv_catsv_nomg(dstr, POPs);
+ if (UNLIKELY(TAINT_get))
+ cx->sb_rxtainted |= SUBST_TAINT_REPL;
if (CxONCE(cx) || s < orig ||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
(s == m), cx->sb_targ, NULL,
diff --git a/pp_hot.c b/pp_hot.c
index f445fd9..5899413 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -3250,7 +3250,7 @@ PP(pp_subst)
doutf8 = DO_UTF8(dstr);
}
- if (SvTAINTED(dstr))
+ if (UNLIKELY(TAINT_get))
rxtainted |= SUBST_TAINT_REPL;
}
else {
@@ -3421,8 +3421,6 @@ PP(pp_subst)
}
else {
sv_catsv(dstr, repl);
- if (UNLIKELY(SvTAINTED(repl)))
- rxtainted |= SUBST_TAINT_REPL;
}
if (once)
break;
diff --git a/t/op/taint.t b/t/op/taint.t
index c13eaf6..be5eaa8 100644
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -17,7 +17,7 @@ BEGIN {
use strict;
use Config;
-plan tests => 828;
+plan tests => 1040;
$| = 1;
@@ -83,6 +83,8 @@ EndOfCleanup
# Sources of taint:
# The empty tainted value, for tainting strings
my $TAINT = substr($^X, 0, 0);
+# A tainted non-empty string
+my $TAINTXYZ = "xyz".$TAINT;
# A tainted zero, useful for tainting numbers
my $TAINT0;
{
@@ -565,7 +567,7 @@ my $TEST = 'TEST';
is($one, 'abcd', "$desc: \$1 value");
}
- $desc = "substitution with replacement tainted";
+ $desc = "substitution with partial replacement tainted";
$s = 'abcd';
$res = $s =~ s/(.+)/xyz$TAINT/;
@@ -577,7 +579,7 @@ my $TEST = 'TEST';
is($res, 1, "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
- $desc = "substitution /g with replacement tainted";
+ $desc = "substitution /g with partial replacement tainted";
$s = 'abcd';
$res = $s =~ s/(.)/x$TAINT/g;
@@ -589,7 +591,7 @@ my $TEST = 'TEST';
is($res, 4, "$desc: res value");
is($one, 'd', "$desc: \$1 value");
- $desc = "substitution /ge with replacement tainted";
+ $desc = "substitution /ge with partial replacement tainted";
$s = 'abc';
{
@@ -618,7 +620,7 @@ my $TEST = 'TEST';
is($res, 3, "$desc: res value");
is($one, 'c', "$desc: \$1 value");
- $desc = "substitution /r with replacement tainted";
+ $desc = "substitution /r with partial replacement tainted";
$s = 'abcd';
$res = $s =~ s/(.+)/xyz$TAINT/r;
@@ -630,6 +632,71 @@ my $TEST = 'TEST';
is($res, 'xyz', "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
+ $desc = "substitution with whole replacement tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$TAINTXYZ/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyz', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /g with whole replacement tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$TAINTXYZ/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyz' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with whole replacement tainted";
+
+ $s = 'abc';
+ {
+ my $i = 0;
+ my $j;
+ $res = $s =~ s{(.)}{
+ $j = $i; # make sure code not tainted
+ $one = $1;
+ isnt_tainted($j, "$desc: code not tainted within /e");
+ $i++;
+ if ($i == 1) {
+ isnt_tainted($s, "$desc: s not tainted loop 1");
+ }
+ else {
+ is_tainted($s, "$desc: s tainted loop $i");
+ }
+ isnt_tainted($one, "$desc: \$1 not tainted within /e");
+ $TAINTXYZ;
+ }ge;
+ $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyz' x 3, "$desc: s value");
+ is($res, 3, "$desc: res value");
+ is($one, 'c', "$desc: \$1 value");
+
+ $desc = "substitution /r with whole replacement tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$TAINTXYZ/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyz', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
{
# now do them all again with "use re 'taint"
@@ -955,7 +1022,7 @@ my $TEST = 'TEST';
is($one, 'abcd', "$desc: \$1 value");
}
- $desc = "use re 'taint': substitution with replacement tainted";
+ $desc = "use re 'taint': substitution with partial replacement tainted";
$s = 'abcd';
$res = $s =~ s/(.+)/xyz$TAINT/;
@@ -967,7 +1034,7 @@ my $TEST = 'TEST';
is($res, 1, "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
- $desc = "use re 'taint': substitution /g with replacement tainted";
+ $desc = "use re 'taint': substitution /g with partial replacement tainted";
$s = 'abcd';
$res = $s =~ s/(.)/x$TAINT/g;
@@ -979,7 +1046,7 @@ my $TEST = 'TEST';
is($res, 4, "$desc: res value");
is($one, 'd', "$desc: \$1 value");
- $desc = "use re 'taint': substitution /ge with replacement tainted";
+ $desc = "use re 'taint': substitution /ge with partial replacement tainted";
$s = 'abc';
{
@@ -1008,7 +1075,7 @@ my $TEST = 'TEST';
is($res, 3, "$desc: res value");
is($one, 'c', "$desc: \$1 value");
- $desc = "use re 'taint': substitution /r with replacement tainted";
+ $desc = "use re 'taint': substitution /r with partial replacement tainted";
$s = 'abcd';
$res = $s =~ s/(.+)/xyz$TAINT/r;
@@ -1020,6 +1087,71 @@ my $TEST = 'TEST';
is($res, 'xyz', "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
+ $desc = "use re 'taint': substitution with whole replacement tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$TAINTXYZ/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyz', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': substitution /g with whole replacement tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$TAINTXYZ/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyz' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "use re 'taint': substitution /ge with whole replacement tainted";
+
+ $s = 'abc';
+ {
+ my $i = 0;
+ my $j;
+ $res = $s =~ s{(.)}{
+ $j = $i; # make sure code not tainted
+ $one = $1;
+ isnt_tainted($j, "$desc: code not tainted within /e");
+ $i++;
+ if ($i == 1) {
+ isnt_tainted($s, "$desc: s not tainted loop 1");
+ }
+ else {
+ is_tainted($s, "$desc: s tainted loop $i");
+ }
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ $TAINTXYZ;
+ }ge;
+ $one = $1;
+ }
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyz' x 3, "$desc: s value");
+ is($res, 3, "$desc: res value");
+ is($one, 'c', "$desc: \$1 value");
+
+ $desc = "use re 'taint': substitution /r with whole replacement tainted";
+
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$TAINTXYZ/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyz', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
# [perl #121854] match taintedness became sticky
# when one match has a taintess result, subseqent matches
# using the same pattern shouldn't necessarily be tainted
@@ -2448,6 +2580,284 @@ is eval { eval $::x.1 }, 1, 'reset does not taint undef';
isnt_tainted $b, "list assign post tainted expression b";
}
+# taint passing through overloading
+package OvTaint {
+ sub new { bless({ t => $_[1] }, $_[0]) }
+ use overload '""' => sub { $_[0]->{t} ? "hi".$TAINT : "hello" };
+}
+my $ovclean = OvTaint->new(0);
+my $ovtaint = OvTaint->new(1);
+isnt_tainted("$ovclean", "overload preserves cleanliness");
+is_tainted("$ovtaint", "overload preserves taint");
+
+# substitutions with overloaded replacement
+{
+ my ($desc, $s, $res, $one);
+
+ $desc = "substitution with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$ovclean/;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$ovtaint/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovclean/;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovtaint/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/"xyz".$ovclean/e;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/"xyz".$ovtaint/e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovclean/e;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovtaint/e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with extra code and partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/(my $z++), "xyz".$ovclean/e;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with extra code and partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/(my $z++), "xyz".$ovtaint/e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with extra code and whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/(my $z++), $ovclean/e;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with extra code and whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/(my $z++), $ovtaint/e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /r with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$ovclean/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyzhello', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /r with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$ovtaint/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyzhi', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /r with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovclean/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'hello', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /r with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovtaint/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'hi', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /g with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/x$ovclean/g;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xhello' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /g with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/x$ovtaint/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xhi' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /g with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$ovclean/g;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /g with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$ovtaint/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/"x".$ovclean/ge;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xhello' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/"x".$ovtaint/ge;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xhi' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$ovclean/ge;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$ovtaint/ge;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+}
# This may bomb out with the alarm signal so keep it last
SKIP: {
--
2.13.6

View File

@ -1,105 +0,0 @@
From 695d6585affc8f13711f013329fb4810ab89d833 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Tue, 14 Nov 2017 18:55:55 -0800
Subject: [PATCH] [perl #132442] Fix stack with do {my sub l; 1}
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
A block in perl usually compiles to a leave op with an enter inside
it, followed by the statements:
leave
enter
nextstate
... expr ...
nextstate
... expr ...
If a block contains only one statement, and that statement is suffic-
iently innocuous, then the enter/leave pair to create the scope at run
time get skipped, and instead we have a simple scope op which is not
even executed:
scope
ex-nextstate
... expr ...
The nextstate in this case also gets nulled.
In the case of do { my sub l; 1 } we were getting a variation of the
latter, that looked like this:
scope
introcv
clonecv
nextstate
... expr ...
The problem here is that nextstate resets the stack, even though a new
scope has not been pushed, so we end up with all existing stack items
from the *outer* scope getting clobbered.
One can have fun with this and erase everything pushed on to the stack
so far in a given statement:
$ ./perl -le 'print join "-", 1..10, do {my sub l; ","}, 11..20'
11,12,13,14,15,16,17,18,19,20
Here I replaced the first argument to join() from within the do{}
block, after having cleared the stack.
Why was the op tree was getting muddled up like this? The my sub
declaration does not immediately add any ops to the op tree; those ops
get added when the current scope finishing compiling, since those ops
must be inserted at the beginning of the block.
I have not fully looked into the order that things happen, and why the
nextstate op does not get nulled; but it did not matter, because of
the simple fix: Treat lexical sub declarations as not innocuous by
setting the HINT_BLOCK_SCOPE flag when a lexical sub is declared.
Thus, we end up with an enter/leave pair, which creates a
proper scope.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
op.c | 2 ++
t/op/lexsub.t | 5 ++++-
2 files changed, 6 insertions(+), 1 deletion(-)
diff --git a/op.c b/op.c
index 8fa5aad876..c617ad2a00 100644
--- a/op.c
+++ b/op.c
@@ -9243,6 +9243,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
PERL_ARGS_ASSERT_NEWMYSUB;
+ PL_hints |= HINT_BLOCK_SCOPE;
+
/* Find the pad slot for storing the new sub.
We cannot use PL_comppad, as it is the pad owned by the new sub. We
need to look in CvOUTSIDE and find the pad belonging to the enclos-
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
index 3fa17acdda..f085cd97e8 100644
--- a/t/op/lexsub.t
+++ b/t/op/lexsub.t
@@ -7,7 +7,7 @@ BEGIN {
*bar::is = *is;
*bar::like = *like;
}
-plan 149;
+plan 150;
# -------------------- our -------------------- #
@@ -957,3 +957,6 @@ like runperl(
{
my sub h; sub{my $x; sub{h}}
}
+
+is join("-", qw(aa bb), do { my sub lleexx; 123 }, qw(cc dd)),
+ "aa-bb-123-cc-dd", 'do { my sub...} in a list [perl #132442]';
--
2.13.6

View File

@ -1,34 +0,0 @@
From 8e7c2faafb74d3b07e8a5818608dfe065e361604 Mon Sep 17 00:00:00 2001
From: "Craig A. Berry" <craigberry@mac.com>
Date: Mon, 1 Jan 2018 10:10:33 -0600
Subject: [PATCH] Reenable numeric first argument of system() on VMS.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This was broken in 64def2aeaeb63f92dadc6dfa334, and fixed for Win32
only in 8fe3452cc6ac7af8c08. But VMS also uses a numeric first
argument to system() as a flag indicating spawn without waiting for
completion.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_sys.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/pp_sys.c b/pp_sys.c
index 0c9147bc4e..5154b9baa8 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -4375,7 +4375,7 @@ PP(pp_system)
STRLEN len;
char *pv;
SvGETMAGIC(origsv);
-#ifdef WIN32
+#if defined(WIN32) || defined(__VMS)
/*
* Because of a nasty platform-specific variation on the meaning
* of arguments to this op, we must preserve numeric arguments
--
2.13.6

View File

@ -1,73 +0,0 @@
From 8fe3452cc6ac7af8c08c2044cd3757018a9c8887 Mon Sep 17 00:00:00 2001
From: Zefram <zefram@fysh.org>
Date: Fri, 22 Dec 2017 05:32:41 +0000
Subject: [PATCH] preserve numericness of system() args on Win32
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
On Windows there's a nasty variation in the meaning of arguments
to Perl's system(), in which a numeric first argument isn't used as
part of the command to run, but instead selects between two different
operations to perform with the command (whether to wait for the command
to complete or not). Therefore the reduction of argument scalars to
their operative values in the parent process, which was added in commit
64def2aeaeb63f92dadc6dfa33486c1d7b311963, needs to preserve numericness
of arguments on Windows. Fixes [perl #132633].
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_sys.c | 35 +++++++++++++++++++++++++++++++----
1 file changed, 31 insertions(+), 4 deletions(-)
diff --git a/pp_sys.c b/pp_sys.c
index beb60da4c6..0649794104 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -4393,12 +4393,39 @@ PP(pp_system)
# endif
while (++MARK <= SP) {
- SV *origsv = *MARK;
+ SV *origsv = *MARK, *copysv;
STRLEN len;
char *pv;
- pv = SvPV(origsv, len);
- *MARK = newSVpvn_flags(pv, len,
- (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
+ SvGETMAGIC(origsv);
+#ifdef WIN32
+ /*
+ * Because of a nasty platform-specific variation on the meaning
+ * of arguments to this op, we must preserve numeric arguments
+ * as numeric, not just retain the string value.
+ */
+ if (SvNIOK(origsv) || SvNIOKp(origsv)) {
+ copysv = newSV_type(SVt_PVNV);
+ sv_2mortal(copysv);
+ if (SvPOK(origsv) || SvPOKp(origsv)) {
+ pv = SvPV_nomg(origsv, len);
+ sv_setpvn(copysv, pv, len);
+ SvPOK_off(copysv);
+ }
+ if (SvIOK(origsv) || SvIOKp(origsv))
+ SvIV_set(copysv, SvIVX(origsv));
+ if (SvNOK(origsv) || SvNOKp(origsv))
+ SvNV_set(copysv, SvNVX(origsv));
+ SvFLAGS(copysv) |= SvFLAGS(origsv) &
+ (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK|
+ SVf_UTF8|SVf_IVisUV);
+ } else
+#endif
+ {
+ pv = SvPV_nomg(origsv, len);
+ copysv = newSVpvn_flags(pv, len,
+ (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
+ }
+ *MARK = copysv;
}
MARK = ORIGMARK;
--
2.13.6

View File

@ -1,127 +0,0 @@
From fed9fe5b48ccdffef9065a03c12c237cc7418de6 Mon Sep 17 00:00:00 2001
From: Zefram <zefram@fysh.org>
Date: Fri, 16 Feb 2018 17:20:34 +0000
Subject: [PATCH] don't clobber file bytes in :encoding layer
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
The PerlIO::encoding layer, when used on input, was creating an SvLEN==0
scalar pointing into the byte buffer, to pass to the ->decode method
of the encoding object. Since the method mutates this scalar, for some
encodings this led to mutating the byte buffer, and depending on where
it came from that might be something visible elsewhere that should not
be mutated. Remove the code for the SvLEN==0 scalar, instead always
using the alternate code that would copy the bytes into a separate buffer
owned by the scalar. Fixes [perl #132833].
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/PerlIO-encoding/encoding.pm | 2 +-
ext/PerlIO-encoding/encoding.xs | 43 ++++++++++------------------------------
ext/PerlIO-encoding/t/encoding.t | 12 ++++++++++-
3 files changed, 22 insertions(+), 35 deletions(-)
diff --git a/ext/PerlIO-encoding/encoding.pm b/ext/PerlIO-encoding/encoding.pm
index 08d2df4713..3d740b181a 100644
--- a/ext/PerlIO-encoding/encoding.pm
+++ b/ext/PerlIO-encoding/encoding.pm
@@ -1,7 +1,7 @@
package PerlIO::encoding;
use strict;
-our $VERSION = '0.25';
+our $VERSION = '0.26';
our $DEBUG = 0;
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs
index bb4754f3d9..941d786266 100644
--- a/ext/PerlIO-encoding/encoding.xs
+++ b/ext/PerlIO-encoding/encoding.xs
@@ -307,42 +307,19 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
goto end_of_file;
}
}
- if (SvCUR(e->dataSV)) {
- /* something left over from last time - create a normal
- SV with new data appended
- */
- if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
- if (e->flags & NEEDS_LINES) {
- /* Have to grow buffer */
- e->base.bufsiz = use + SvCUR(e->dataSV);
- PerlIOEncode_get_base(aTHX_ f);
- }
- else {
- use = e->base.bufsiz - SvCUR(e->dataSV);
- }
- }
- sv_catpvn(e->dataSV,(char*)ptr,use);
- }
- else {
- /* Create a "dummy" SV to represent the available data from layer below */
- if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
- Safefree(SvPVX_mutable(e->dataSV));
- }
- if (use > (SSize_t)e->base.bufsiz) {
- if (e->flags & NEEDS_LINES) {
- /* Have to grow buffer */
- e->base.bufsiz = use;
- PerlIOEncode_get_base(aTHX_ f);
- }
- else {
- use = e->base.bufsiz;
+ if (!SvCUR(e->dataSV))
+ SvPVCLEAR(e->dataSV);
+ if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
+ if (e->flags & NEEDS_LINES) {
+ /* Have to grow buffer */
+ e->base.bufsiz = use + SvCUR(e->dataSV);
+ PerlIOEncode_get_base(aTHX_ f);
}
+ else {
+ use = e->base.bufsiz - SvCUR(e->dataSV);
}
- SvPV_set(e->dataSV, (char *) ptr);
- SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
- SvCUR_set(e->dataSV,use);
- SvPOK_only(e->dataSV);
}
+ sv_catpvn(e->dataSV,(char*)ptr,use);
SvUTF8_off(e->dataSV);
PUSHMARK(sp);
XPUSHs(e->enc);
diff --git a/ext/PerlIO-encoding/t/encoding.t b/ext/PerlIO-encoding/t/encoding.t
index 088f89ee20..41cefcb137 100644
--- a/ext/PerlIO-encoding/t/encoding.t
+++ b/ext/PerlIO-encoding/t/encoding.t
@@ -16,7 +16,7 @@ BEGIN {
require "../../t/charset_tools.pl";
}
-use Test::More tests => 24;
+use Test::More tests => 27;
my $grk = "grk$$";
my $utf = "utf$$";
@@ -231,6 +231,16 @@ is $x, "To hymn him who heard her herd herd\n",
} # SKIP
+# decoding shouldn't mutate the original bytes [perl #132833]
+{
+ my $b = "a\0b\0\n\0";
+ open my $fh, "<:encoding(UTF16-LE)", \$b or die;
+ is scalar(<$fh>), "ab\n";
+ is $b, "a\0b\0\n\0";
+ close $fh or die;
+ is $b, "a\0b\0\n\0";
+}
+
END {
1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
}
--
2.14.3

View File

@ -1,68 +0,0 @@
From 823ba440369100de3f2693420a3887a645a57d28 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Wed, 7 Mar 2018 09:27:26 +0000
Subject: [PATCH] fix line numbers in multi-line s///
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
my commit v5.25.6-230-g6432a58, "Eliminate SVrepl_EVAL and SvEVALED()",
introduced a regression: __LINE__ no longer took account of multiple
lines in the s///.
Now fixed.
Spotted by Abigail.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
t/re/subst.t | 12 +++++++++++-
toke.c | 2 +-
2 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/t/re/subst.t b/t/re/subst.t
index b9b9939b11..dd62e95ee6 100644
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -11,7 +11,7 @@ BEGIN {
require './loc_tools.pl';
}
-plan(tests => 275);
+plan(tests => 276);
$_ = 'david';
$a = s/david/rules/r;
@@ -1163,6 +1163,16 @@ __EOF__
pass("RT #130188");
}
+# RT #131930
+# a multi-line s/// wasn't resetting the cop_line correctly
+{
+ my $l0 = __LINE__;
+ my $s = "a";
+ $s =~ s[a]
+ [b];
+ my $lines = __LINE__ - $l0;
+ is $lines, 4, "RT #131930";
+}
diff --git a/toke.c b/toke.c
index 9dbad98408..0ef33415c0 100644
--- a/toke.c
+++ b/toke.c
@@ -9884,7 +9884,7 @@ S_scan_subst(pTHX_ char *start)
* the NVX field indicates how many src code lines the replacement
* spreads over */
sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
- ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
+ ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
cBOOL(es);
}
--
2.14.3

View File

@ -10,7 +10,7 @@ diff --git a/Makefile.SH b/Makefile.SH
index 5fc6d1c..e89ad70 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -457,6 +457,8 @@ CCCMD = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@
@@ -462,6 +462,8 @@ CCCMD = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@
CCCMDSRC = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $<
@ -19,7 +19,7 @@ index 5fc6d1c..e89ad70 100755
CONFIGPM_FROM_CONFIG_SH = lib/Config.pm lib/Config_heavy.pl
CONFIGPM = $(CONFIGPM_FROM_CONFIG_SH) lib/Config_git.pl
@@ -890,19 +892,19 @@ $(DTRACE_MINI_O): perldtrace.d $(miniperl_objs_nodt)
@@ -895,19 +897,19 @@ $(DTRACE_MINI_O): perldtrace.d $(miniperl_objs_nodt)
-rm -rf mpdtrace
mkdir mpdtrace
cp $(miniperl_objs_nodt) mpdtrace/
@ -46,10 +46,10 @@ diff --git a/cflags.SH b/cflags.SH
index 3af1e97..b845127 100755
--- a/cflags.SH
+++ b/cflags.SH
@@ -516,7 +516,10 @@ for file do
@@ -519,7 +519,10 @@ for file do
toke) optimize=-O0 ;;
esac
# Can we perhaps use $ansi2knr here
- echo "$cc -c -DPERL_CORE $ccflags $stdflags $optimize $warn $extra"
+ case "$file" in
+ dtrace_*) echo "$ccflags $stdflags $optimize $warn $extra";;

View File

@ -1,113 +0,0 @@
From 381d51822fccaa333cbd0ab9fca8b69f650c05f9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Fri, 14 Feb 2020 14:10:10 +0100
Subject: [PATCH] Only pass 2-digit years to tests when testing 2-digit year
handling
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This will start breaking in 2020 if done without working around the whole
breakpoint thing. See https://rt.cpan.org/Ticket/Display.html?id=124787.
Ported from Time-Local 63265fd81c7f6177bf28dfe0d1ada9cb897de566 commit
by Dave Rolsky <autarch@urth.org> to perl 5.28.2.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
cpan/Time-Local/t/Local.t | 40 +++++++++++++++++++++++++++++----------
1 file changed, 30 insertions(+), 10 deletions(-)
diff --git a/cpan/Time-Local/t/Local.t b/cpan/Time-Local/t/Local.t
index 6341396..701d22d 100644
--- a/cpan/Time-Local/t/Local.t
+++ b/cpan/Time-Local/t/Local.t
@@ -85,19 +85,17 @@ my $epoch_is_64
for ( @time, @neg_time ) {
my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
- $year -= 1900;
$mon--;
SKIP: {
skip '1970 test on VOS fails.', 12
- if $^O eq 'vos' && $year == 70;
+ if $^O eq 'vos' && $year == 1970;
skip 'this platform does not support negative epochs.', 12
- if $year < 70 && !$neg_epoch_ok;
+ if $year < 1970 && !$neg_epoch_ok;
# Test timelocal()
{
- my $year_in = $year < 70 ? $year + 1900 : $year;
- my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year_in );
+ my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year );
my ( $s, $m, $h, $D, $M, $Y ) = localtime($time);
@@ -106,13 +104,12 @@ SKIP: {
is( $h, $hour, "timelocal hour for @$_" );
is( $D, $mday, "timelocal day for @$_" );
is( $M, $mon, "timelocal month for @$_" );
- is( $Y, $year, "timelocal year for @$_" );
+ is( $Y, $year - 1900, "timelocal year for @$_" );
}
# Test timegm()
{
- my $year_in = $year < 70 ? $year + 1900 : $year;
- my $time = timegm( $sec, $min, $hour, $mday, $mon, $year_in );
+ my $time = timegm( $sec, $min, $hour, $mday, $mon, $year );
my ( $s, $m, $h, $D, $M, $Y ) = gmtime($time);
@@ -121,14 +118,13 @@ SKIP: {
is( $h, $hour, "timegm hour for @$_" );
is( $D, $mday, "timegm day for @$_" );
is( $M, $mon, "timegm month for @$_" );
- is( $Y, $year, "timegm year for @$_" );
+ is( $Y, $year - 1900, "timegm year for @$_" );
}
}
}
for (@bad_time) {
my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
- $year -= 1900;
$mon--;
eval { timegm( $sec, $min, $hour, $mday, $mon, $year ) };
@@ -229,6 +225,30 @@ SKIP:
);
}
+# 2-digit years
+{
+ my $current_year = ( localtime() )[5];
+ my $pre_break = ( $current_year + 49 ) - 100;
+ my $break = ( $current_year + 50 ) - 100;
+ my $post_break = ( $current_year + 51 ) - 100;
+
+ is(
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $pre_break ) ) )[5] ),
+ $pre_break + 100,
+ "year $pre_break is treated as next century",
+ );
+ is(
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $break ) ) )[5] ),
+ $break + 100,
+ "year $break is treated as next century",
+ );
+ is(
+ ( ( localtime( timelocal( 0, 0, 0, 1, 1, $post_break ) ) )[5] ),
+ $post_break,
+ "year $post_break is treated as current century",
+ );
+}
+
SKIP:
{
skip 'These tests only run for the package maintainer.', 8
--
2.21.1

View File

@ -1,94 +0,0 @@
From 892e8b006aa99ac2c880cdc2a81fd16f06c1a0f3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Mon, 9 Jul 2018 16:18:36 +0200
Subject: [PATCH] Remove ext/GDBM_File/t/fatal.t
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
gdbm-1.15 defaults to a memory-mapped I/O and does not report any I/O
errors on store and close operations. Thus ext/GDBM_File/t/fatal.t
test that expects these fatal error reports fails. Because there is
no other way to provoke a fatal error in gdbm-1.15 this patch
removes the test. Future gdbm version promisses reporting a regular
error on closing a database.
RT#133295
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 -
ext/GDBM_File/t/fatal.t | 49 -------------------------------------------------
2 files changed, 50 deletions(-)
delete mode 100644 ext/GDBM_File/t/fatal.t
diff --git a/MANIFEST b/MANIFEST
index 95fa539095..b07fed1f54 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4100,7 +4100,6 @@ ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
ext/GDBM_File/Makefile.PL GDBM extension makefile writer
-ext/GDBM_File/t/fatal.t Test the fatal_func argument to gdbm_open
ext/GDBM_File/t/gdbm.t See if GDBM_File works
ext/GDBM_File/typemap GDBM extension interface types
ext/Hash-Util/Changes Change history of Hash::Util
diff --git a/ext/GDBM_File/t/fatal.t b/ext/GDBM_File/t/fatal.t
deleted file mode 100644
index 0e426d4dbc..0000000000
--- a/ext/GDBM_File/t/fatal.t
+++ /dev/null
@@ -1,49 +0,0 @@
-#!./perl -w
-use strict;
-
-use Test::More;
-use Config;
-
-BEGIN {
- plan(skip_all => "GDBM_File was not built")
- unless $Config{extensions} =~ /\bGDBM_File\b/;
-
- # https://rt.perl.org/Public/Bug/Display.html?id=117967
- plan(skip_all => "GDBM_File is flaky in $^O")
- if $^O =~ /darwin/;
-
- plan(tests => 8);
- use_ok('GDBM_File');
-}
-
-unlink <Op_dbmx*>;
-
-open my $fh, '<', $^X or die "Can't open $^X: $!";
-my $fileno = fileno $fh;
-isnt($fileno, undef, "Can find next available file descriptor");
-close $fh or die $!;
-
-is((open $fh, "<&=$fileno"), undef,
- "Check that we cannot open fileno $fileno. \$! is $!");
-
-umask(0);
-my %h;
-isa_ok(tie(%h, 'GDBM_File', 'Op_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
-
-isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno")
- or diag("\$! = $!");
-isnt(close $fh, undef,
- "close fileno $fileno, out from underneath the GDBM_File");
-is(eval {
- $h{Perl} = 'Rules';
- untie %h;
- 1;
-}, undef, 'Trapped error when attempting to write to knobbled GDBM_File');
-
-# Observed "File write error" and "lseek error" from two different systems.
-# So there might be more variants. Important part was that we trapped the error
-# via croak.
-like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/,
- 'expected error message from GDBM_File');
-
-unlink <Op_dbmx*>;
--
2.14.4

View File

@ -1,32 +0,0 @@
From e1a2878a55b1a7f11f19b384c4ea5235c29866b2 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Mon, 11 Jun 2018 13:28:53 -0600
Subject: [PATCH] regexec.c: Call macro with correct args.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
The second argument to this macro is a pointer to the end, as opposed to
a length.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
regexec.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/regexec.c b/regexec.c
index 7ed8f4fabc..ba52ae97c7 100644
--- a/regexec.c
+++ b/regexec.c
@@ -1808,7 +1808,7 @@ STMT_START {
case trie_flu8: \
_CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
if (UTF8_IS_ABOVE_LATIN1(*uc)) { \
- _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end - uc); \
+ _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end); \
} \
goto do_trie_utf8_fold; \
case trie_utf8_exactfa_fold: \
--
2.14.4

View File

@ -1,22 +0,0 @@
From 70f089724b15d1b2ed9264f277454aa559d50232 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Fri, 15 Nov 2019 15:01:15 -0700
Subject: [PATCH] PATCH: gh#17218 memory leak
Indeed, a variable's ref count was not getting decremented.
---
regcomp.c | 1 +
1 file changed, 1 insertion(+)
diff --git a/regcomp.c b/regcomp.c
index ddac290d2bf0..de4f6f24dac8 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -17602,6 +17602,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
/* Likewise for 'posixes' */
_invlist_union(posixes, cp_list, &cp_list);
+ SvREFCNT_dec(posixes);
/* Likewise for anything else in the range that matched only
* under UTF-8 */

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1,6 +1,7 @@
--- perl-5.8.0/Configure.orig 2002-09-09 11:31:19.000000000 -0400
+++ perl-5.8.0/Configure 2002-09-09 11:40:37.000000000 -0400
@@ -6458,8 +6458,8 @@
diff -up perl-5.28.0-RC1/Configure.orig perl-5.28.0-RC1/Configure
--- perl-5.28.0-RC1/Configure.orig 2018-05-21 12:44:04.000000000 +0200
+++ perl-5.28.0-RC1/Configure 2018-05-22 12:21:53.908599933 +0200
@@ -7269,8 +7269,8 @@ esac'
: Reproduce behavior of 5.005 and earlier, maybe drop that in 5.7.
case "$installstyle" in
'') case "$prefix" in
@ -11,7 +12,7 @@
esac
;;
*) dflt="$installstyle" ;;
@@ -6475,8 +6475,8 @@
@@ -7336,8 +7336,8 @@ esac
: /opt/perl/lib/perl5... would be redundant.
: The default "style" setting is made in installstyle.U
case "$installstyle" in
@ -22,7 +23,7 @@
esac
eval $prefixit
$cat <<EOM
@@ -6934,8 +6934,8 @@
@@ -7584,8 +7584,8 @@ siteprefixexp="$ansexp"
prog=`echo $package | $sed 's/-*[0-9.]*$//'`
case "$sitelib" in
'') case "$installstyle" in
@ -33,7 +34,7 @@
esac
;;
*) dflt="$sitelib"
@@ -7061,8 +7061,8 @@
@@ -8001,8 +8001,8 @@ case "$vendorprefix" in
'')
prog=`echo $package | $sed 's/-*[0-9.]*$//'`
case "$installstyle" in

Some files were not shown because too many files have changed in this diff Show More