rpms
/
perl
21
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

import perl-5.26.2-412.module_el8.1.0+225+978beb03

Browse Source
i8c-stream-5.26 changed/i8c-stream-5.26/perl-5.26.2-412.module_el8.1.0+225+978beb03
MSVSphere Packaging Team 7 months ago
commit e2c811bce0
61 changed files with 14805 additions and 0 deletions
Show Stats Download Patch File Download Diff File

1
.gitignore vendored
Unescape View File

@ -0,0 +1 @@
SOURCES/perl-5.26.2.tar.bz2

1
.perl.metadata
Unescape View File

@ -0,0 +1 @@
2057b65e3a6ac71287c973402cd01084a1edc35b SOURCES/perl-5.26.2.tar.bz2

41
SOURCES/Pod-Html-license-clarification
Unescape View File

@ -0,0 +1,41 @@
Date: Sun, 15 Mar 2015 21:22:10 -0600
Subject: Re: Pod::Html license
From: Tom Christiansen <tchrist53147@gmail.com>
To: Petr Šabata <contyk@redhat.com>
Cc: Tom Christiansen <tchrist@perl.com>, marcgreen@cpan.org,
jplesnik@redhat.com
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
Content-Type: text/plain; charset=utf-8
Yes, it was supposed to be licensed just like the rest of Perl.
Sent from my Sprint phone
Petr Šabata <contyk@redhat.com> wrote:
>Marc, Tom,
>
>I'm reviewing licensing of our perl package in Fedora and
>noticed Pod::HTML and its pod2html script are licensed under
>the Artistic license (only).
>
>This is an issue for us as this license isn't considered free by
>FSF [0]. Unless the license of this core component changes, we
>will have to drop it from the tarball and remove support for it
>from all the modules we ship that use it, such as Module::Build
>or Module::Install.
>
>What I've seen in the past is authors originally claiming their
>module was released under Artistic while what they actually meant
>was the common `the same as perl itself', i.e. `GPL+/Aristic' [1],
>an FSF free license. Is it possible this is also the case
>of Pod::Html?
>
>Thanks,
>Petr
>
>(also CC'ing Jitka, the primary package maintainer in Fedora)
>
>[0] https://www.gnu.org/licenses/license-list.html#ArtisticLicense
>[1] https://www.gnu.org/licenses/license-list.html#PerlLicense

2100
SOURCES/gendep.macros
View File

File diff suppressed because it is too large Load Diff

151
SOURCES/macros.perl
Unescape View File

@ -0,0 +1,151 @@
# Sensible Perl-specific RPM build macros.
#
# Note that these depend on the generic filtering system being in place in
# rpm core; but won't cause a build to fail if they're not present.
#
# Chris Weyl <cweyl@alumni.drew.edu> 2009
# Marcela Mašláňová <mmaslano@redhat.com> 2011
# This macro unsets several common vars used to control how Makefile.PL (et
# al) build and install packages. We also set a couple to help some of the
# common systems be less interactive. This was blatantly stolen from
# cpanminus, and helps building rpms locally when one makes extensive use of
# local::lib, etc.
#
# Usage, in %build, before "%{__perl} Makefile.PL ..."
#
# %{?perl_ext_env_unset}
%perl_ext_env_unset %{expand:
unset PERL_MM_OPT MODULEBUILDRC PERL5INC
export PERL_AUTOINSTALL="--defaultdeps"
export PERL_MM_USE_DEFAULT=1
}
#############################################################################
# Filtering macro incantations
# keep track of what "revision" of the filtering we're at. Each time we
# change the filter we should increment this.
%perl_default_filter_revision 3
# By default, for perl packages we want to filter all files in _docdir from
# req/prov scanning.
# Filtering out any provides caused by private libs in vendorarch/archlib
# (vendor/core) is done by rpmbuild since Fedora 20
# <https://fedorahosted.org/fpc/ticket/353>.
#
# Note that this must be invoked in the spec file, preferably as
# "%{?perl_default_filter}", before any %description block.
%perl_default_filter %{expand: \
%global __provides_exclude_from %{?__provides_exclude_from:%__provides_exclude_from|}^%{_docdir}
%global __requires_exclude_from %{?__requires_exclude_from:%__requires_exclude_from|}^%{_docdir}
%global __provides_exclude %{?__provides_exclude:%__provides_exclude|}^perl\\\\(VMS|^perl\\\\(Win32|^perl\\\\(DB\\\\)|^perl\\\\(UNIVERSAL\\\\)
%global __requires_exclude %{?__requires_exclude:%__requires_exclude|}^perl\\\\(VMS|^perl\\\\(Win32
}
#############################################################################
# Macros to assist with generating a "-tests" subpackage in a semi-automatic
# manner.
#
# The following macros are still in a highly experimental stage and users
# should be aware that the interface and behaviour may change.
#
# PLEASE, PLEASE CONDITIONALIZE THESE MACROS IF YOU USE THEM.
#
# See http://gist.github.com/284409
# These macros should be invoked as above, right before the first %description
# section, and conditionalized. e.g., for the common case where all our tests
# are located under t/, the correct usage is:
#
# %{?perl_default_subpackage_tests}
#
# If custom files/directories need to be specified, this can be done as such:
#
# %{?perl_subpackage_tests:%perl_subpackage_tests t/ one/ three.sql}
#
# etc, etc.
%perl_version %(eval "`%{__perl} -V:version`"; echo $version)
%perl_testdir %{_libexecdir}/perl5-tests
%cpan_dist_name %(eval echo %{name} | %{__sed} -e 's/^perl-//')
# easily mark something as required by -tests and BR to the main package
%tests_req() %{expand:\
BuildRequires: %*\
%%tests_subpackage_requires %*\
}
# fixup (and create if needed) the shbang lines in tests, so they work and
# rpmlint doesn't (correctly) have a fit
%fix_shbang_line() \
TMPHEAD=`mktemp`\
TMPBODY=`mktemp`\
for file in %* ; do \
head -1 $file > $TMPHEAD\
tail -n +2 $file > $TMPBODY\
%{__perl} -pi -e '$f = /^#!/ ? "" : "#!%{__perl}$/"; $_="$f$_"' $TMPHEAD\
cat $TMPHEAD $TMPBODY > $file\
done\
%{__perl} -MExtUtils::MakeMaker -e "ExtUtils::MM_Unix->fixin(qw{%*})"\
%{__rm} $TMPHEAD $TMPBODY\
%{nil}
# additional -tests subpackage requires, if any
%tests_subpackage_requires() %{expand: \
%global __tests_spkg_req %{?__tests_spkg_req} %* \
}
# additional -tests subpackage provides, if any
%tests_subpackage_provides() %{expand: \
%global __tests_spkg_prov %{?__tests_spkg_prov} %* \
}
#
# Runs after the body of %check completes.
#
%__perl_check_pre %{expand: \
%{?__spec_check_pre} \
pushd %{buildsubdir} \
%define perl_br_testdir %{buildroot}%{perl_testdir}/%{cpan_dist_name} \
%{__mkdir_p} %{perl_br_testdir} \
%{__tar} -cf - %{__perl_test_dirs} | ( cd %{perl_br_testdir} && %{__tar} -xf - ) \
find . -maxdepth 1 -type f -name '*META*' -exec %{__cp} -vp {} %{perl_br_testdir} ';' \
find %{perl_br_testdir} -type f -exec %{__chmod} -c -x {} ';' \
T_FILES=`find %{perl_br_testdir} -type f -name '*.t'` \
%fix_shbang_line $T_FILES \
%{__chmod} +x $T_FILES \
%{_fixperms} %{perl_br_testdir} \
popd \
}
#
# The actual invoked macro
#
%perl_subpackage_tests() %{expand: \
%global __perl_package 1\
%global __perl_test_dirs %* \
%global __spec_check_pre %{expand:%{__perl_check_pre}} \
%package tests\
Summary: Test suite for package %{name}\
Group: Development/Debug\
Requires: %{name} = %{?epoch:%{epoch}:}%{version}-%{release}\
Requires: /usr/bin/prove \
%{?__tests_spkg_req:Requires: %__tests_spkg_req}\
%{?__tests_spkg_prov:Provides: %__tests_spkg_prov}\
AutoReqProv: 0 \
%description tests\
This package provides the test suite for package %{name}.\
%files tests\
%defattr(-,root,root,-)\
%{perl_testdir}\
}
# shortcut sugar
%perl_default_subpackage_tests %perl_subpackage_tests t/

12
SOURCES/perl-5.10.0-libresolv.patch
Unescape View File

@ -0,0 +1,12 @@
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=''
usereentrant='undef'
: List of libraries we want.
: If anyone needs extra -lxxx, put those in a hint file.
-libswanted="cl pthread socket bind inet nsl ndbm gdbm dbm db malloc dl ld"
+libswanted="cl pthread socket resolv inet nsl ndbm gdbm dbm db malloc dl ld"
libswanted="$libswanted sun m crypt sec util c cposix posix ucb bsd BSD"
: We probably want to search /usr/shlib before most other libraries.
: This is only used by the lib/ExtUtils/MakeMaker.pm routine extliblist.

12
SOURCES/perl-5.10.0-x86_64-io-test-failure.patch
Unescape View File

@ -0,0 +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');
SKIP: {
- skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define";
+ skip "no futimes", 6;
open(my $fh, "<", 'b');
$foo = (utime 500000000,500000000 + $delta, $fh);
is($foo, 1, "futime");

17
SOURCES/perl-5.14.1-offtest.patch
Unescape View File

@ -0,0 +1,17 @@
diff -up perl-5.14.1/cpan/File-Temp/t/fork.t.off perl-5.14.1/cpan/File-Temp/t/fork.t
--- perl-5.14.1/cpan/File-Temp/t/fork.t.off 2011-04-13 13:36:34.000000000 +0200
+++ perl-5.14.1/cpan/File-Temp/t/fork.t 2011-06-20 10:29:31.536282611 +0200
@@ -12,12 +12,8 @@ BEGIN {
$Config::Config{useithreads} and
$Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
);
- if ( $can_fork ) {
- print "1..8\n";
- } else {
- print "1..0 # Skip No fork available\n";
+ print "1..0 # Skip Koji doesn't work with Perl fork tests\n";
exit;
- }
}
use File::Temp;

65
SOURCES/perl-5.16.3-Link-XS-modules-to-libperl.so-with-EU-CBuilder-on-Li.patch
Unescape View File

@ -0,0 +1,65 @@
From b598ba3f2d4b8347c6621cff022b8e2329b79ea5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Wed, 3 Jul 2013 11:01:02 +0200
Subject: [PATCH] Link XS modules to libperl.so with EU::CBuilder on Linux
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
<https://bugzilla.redhat.com/show_bug.cgi?id=960048>
<http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=327585#50>
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
.../lib/ExtUtils/CBuilder/Platform/linux.pm | 26 ++++++++++++++++++++++
2 files changed, 27 insertions(+)
create mode 100644 dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm
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
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
+dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm CBuilder methods for Linux
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm CBuilder methods for OS/2
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm CBuilder methods for Unix
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm CBuilder methods for VMS
diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm
new file mode 100644
index 0000000..e3251c4
--- /dev/null
+++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/linux.pm
@@ -0,0 +1,26 @@
+package ExtUtils::CBuilder::Platform::linux;
+
+use strict;
+use ExtUtils::CBuilder::Platform::Unix;
+use File::Spec;
+
+use vars qw($VERSION @ISA);
+$VERSION = '0.280206';
+@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
+
+sub link {
+ my ($self, %args) = @_;
+ my $cf = $self->{config};
+
+ # Link XS modules to libperl.so explicitly because multiple
+ # dlopen(, RTLD_LOCAL) hides libperl symbols from XS module.
+ local $cf->{lddlflags} = $cf->{lddlflags};
+ if ($ENV{PERL_CORE}) {
+ $cf->{lddlflags} .= ' -L' . $self->perl_inc();
+ }
+ $cf->{lddlflags} .= ' -lperl';
+
+ return $self->SUPER::link(%args);
+}
+
+1;
--
1.8.1.4

52
SOURCES/perl-5.16.3-Link-XS-modules-to-libperl.so-with-EU-MM-on-Linux.patch
Unescape View File

@ -0,0 +1,52 @@
From fc1f8ac36c34c35bad84fb7b99a26ab83c9ba075 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Wed, 3 Jul 2013 12:59:09 +0200
Subject: [PATCH] Link XS modules to libperl.so with EU::MM on Linux
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
<https://bugzilla.redhat.com/show_bug.cgi?id=960048>
<http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=327585#50>
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
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 {
$Is{IRIX} = $^O eq 'irix';
$Is{NetBSD} = $^O eq 'netbsd';
$Is{Interix} = $^O eq 'interix';
+ $Is{Linux} = $^O eq 'linux';
$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).
push(@m," \$(RM_F) \$\@\n");
my $libs = '$(LDLOADLIBS)';
- if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
+ if (($Is{Linux} || $Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
# 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).
# The Android linker will not recognize symbols from
# libperl unless the module explicitly depends on it.
$libs .= ' "-L$(PERL_INC)" -lperl';
+ } else {
+ if ($ENV{PERL_CORE}) {
+ $libs .= ' "-L$(PERL_INC)"';
+ }
+ $libs .= ' -lperl';
}
}
--
1.8.1.4

52
SOURCES/perl-5.16.3-create_libperl_soname.patch
Unescape View File

@ -0,0 +1,52 @@
From fa2f0dd5a7767223df10149d3f16d7ed7013e16f Mon Sep 17 00:00:00 2001
From: Torsten Veller <tove@gentoo.org>
Date: Sat, 14 Apr 2012 13:49:18 +0200
Subject: Set libperl soname
Bug-Gentoo: https://bugs.gentoo.org/286840
Patch-Name: gentoo/create_libperl_soname.diff
---
Makefile.SH | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
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"
;;
cygwin*)
shrpldflags="$shrpldflags -Wl,--out-implib=libperl.dll.a -Wl,--image-base,0x52000000"
@@ -66,13 +66,15 @@ true)
;;
sunos*)
linklibperl="-lperl"
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;;
netbsd*|freebsd[234]*|openbsd*|dragonfly*|bitrig*)
linklibperl="-L. -lperl"
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;;
interix*)
linklibperl="-L. -lperl"
- shrpldflags="$shrpldflags -Wl,--image-base,0x57000000"
+ shrpldflags="$shrpldflags -Wl,--image-base,0x57000000 -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;;
aix*)
case "$cc" in
@@ -110,6 +112,9 @@ true)
linklibperl='libperl.x'
DPERL_EXTERNAL_GLOB=''
;;
+ linux*)
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
+ ;;
esac
case "$ldlibpthname" in
'') ;;

30
SOURCES/perl-5.18.1-Document-Math-BigInt-CalcEmu-requires-Math-BigInt.patch
Unescape View File

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

233
SOURCES/perl-5.18.2-Destroy-GDBM-NDBM-ODBM-SDBM-_File-objects-only-from-.patch
Unescape View File

@ -0,0 +1,233 @@
From f793042f2bac2ace9a5c0030b47b41c4db561a5b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Fri, 6 Jun 2014 14:31:59 +0200
Subject: [PATCH] Destroy {GDBM,NDBM,ODBM,SDBM}_File objects only from original
thread context
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This patch fixes a crash when destroing a hash tied to a *_File
database after spawning a thread:
use Fcntl;
use SDBM_File;
use threads;
tie(my %dbtest, 'SDBM_File', "test.db", O_RDWR|O_CREAT, 0666);
threads->new(sub {})->join;
This crashed or paniced depending on how perl was configured.
Closes RT#61912.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/GDBM_File/GDBM_File.xs | 16 ++++++++++------
ext/NDBM_File/NDBM_File.xs | 16 ++++++++++------
ext/ODBM_File/ODBM_File.xs | 18 +++++++++++-------
ext/SDBM_File/SDBM_File.xs | 4 +++-
t/lib/dbmt_common.pl | 35 +++++++++++++++++++++++++++++++++++
5 files changed, 69 insertions(+), 20 deletions(-)
diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
index 33e08e2..7160f54 100644
--- a/ext/GDBM_File/GDBM_File.xs
+++ b/ext/GDBM_File/GDBM_File.xs
@@ -13,6 +13,7 @@
#define store_value 3
typedef struct {
+ tTHX owner;
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)
PREINIT:
int i = store_value;
CODE:
- gdbm_close(db);
- do {
- if (db->filter[i])
- SvREFCNT_dec(db->filter[i]);
- } while (i-- > 0);
- safefree(db);
+ if (db && db->owner == aTHX) {
+ gdbm_close(db);
+ do {
+ if (db->filter[i])
+ SvREFCNT_dec(db->filter[i]);
+ } while (i-- > 0);
+ safefree(db);
+ }
#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key)
datum_value
diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs
index 52e60fc..af223e5 100644
--- a/ext/NDBM_File/NDBM_File.xs
+++ b/ext/NDBM_File/NDBM_File.xs
@@ -33,6 +33,7 @@ END_EXTERN_C
#define store_value 3
typedef struct {
+ tTHX owner;
DBM * dbp ;
SV * filter[4];
int filtering ;
@@ -71,6 +72,7 @@ ndbm_TIEHASH(dbtype, filename, flags, mode)
RETVAL = NULL ;
if ((dbp = dbm_open(filename, flags, mode))) {
RETVAL = (NDBM_File)safecalloc(1, sizeof(NDBM_File_type));
+ RETVAL->owner = aTHX;
RETVAL->dbp = dbp ;
}
@@ -84,12 +86,14 @@ ndbm_DESTROY(db)
PREINIT:
int i = store_value;
CODE:
- dbm_close(db->dbp);
- do {
- if (db->filter[i])
- SvREFCNT_dec(db->filter[i]);
- } while (i-- > 0);
- safefree(db);
+ if (db && db->owner == aTHX) {
+ dbm_close(db->dbp);
+ do {
+ if (db->filter[i])
+ SvREFCNT_dec(db->filter[i]);
+ } while (i-- > 0);
+ safefree(db);
+ }
#define ndbm_FETCH(db,key) dbm_fetch(db->dbp,key)
datum_value
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);
#define store_value 3
typedef struct {
+ tTHX owner;
void * dbp ;
SV * filter[4];
int filtering ;
@@ -112,6 +113,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
}
dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
+ RETVAL->owner = aTHX;
RETVAL->dbp = dbp ;
}
OUTPUT:
@@ -124,13 +126,15 @@ DESTROY(db)
dMY_CXT;
int i = store_value;
CODE:
- dbmrefcnt--;
- dbmclose();
- do {
- if (db->filter[i])
- SvREFCNT_dec(db->filter[i]);
- } while (i-- > 0);
- safefree(db);
+ if (db && db->owner == aTHX) {
+ dbmrefcnt--;
+ dbmclose();
+ do {
+ if (db->filter[i])
+ SvREFCNT_dec(db->filter[i]);
+ } while (i-- > 0);
+ safefree(db);
+ }
datum_value
odbm_FETCH(db, key)
diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs
index 291e41b..0bdae9a 100644
--- a/ext/SDBM_File/SDBM_File.xs
+++ b/ext/SDBM_File/SDBM_File.xs
@@ -10,6 +10,7 @@
#define store_value 3
typedef struct {
+ tTHX owner;
DBM * dbp ;
SV * filter[4];
int filtering ;
@@ -49,6 +50,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
}
if (dbp) {
RETVAL = (SDBM_File)safecalloc(1, sizeof(SDBM_File_type));
+ RETVAL->owner = aTHX;
RETVAL->dbp = dbp ;
}
@@ -60,7 +62,7 @@ void
sdbm_DESTROY(db)
SDBM_File db
CODE:
- if (db) {
+ if (db && db->owner == aTHX) {
int i = store_value;
sdbm_close(db->dbp);
do {
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;
unlink <Op1_dbmx*>;
}
+{
+ # Check DBM back-ends do not destroy objects from then-spawned threads.
+ # RT#61912.
+ SKIP: {
+ my $threads_count = 2;
+ skip 'Threads are disabled', 3 + 2 * $threads_count
+ unless $Config{usethreads};
+ use_ok('threads');
+
+ my %h;
+ unlink <Op1_dbmx*>;
+
+ my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640;
+ isa_ok($db, $DBM_Class);
+
+ for (1 .. 2) {
+ ok(threads->create(
+ sub {
+ $SIG{'__WARN__'} = sub { fail(shift) }; # debugging perl panics
+ # report it by spurious TAP line
+ 1;
+ }), "Thread $_ created");
+ }
+ for (threads->list) {
+ is($_->join, 1, "A thread exited successfully");
+ }
+
+ pass("Tied object survived exiting threads");
+
+ undef $db;
+ untie %h;
+ unlink <Op1_dbmx*>;
+ }
+}
+
done_testing();
1;
--
1.9.3

61
SOURCES/perl-5.22.0-Install-libperl.so-to-shrpdir-on-Linux.patch
Unescape View File

@ -0,0 +1,61 @@
From 9644657c4 10326749fd321d9c24944ec25afad2f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Thu, 20 Jun 2013 15:22:53 +0200
Subject: [PATCH] Install libperl.so to shrpdir on Linux
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
Configure | 7 ++++---
Makefile.SH | 2 +-
2 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/Configure b/Configure
index 2f30261..825496e 100755
--- a/Configure
+++ b/Configure
@@ -8249,7 +8249,9 @@ esac
# Detect old use of shrpdir via undocumented Configure -Dshrpdir
case "$shrpdir" in
-'') ;;
+'')
+shrpdir=$archlibexp/CORE
+;;
*) $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
# 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.
-shrpdir=$archlibexp/CORE
xxx=''
tmp_shrpenv=''
if "$useshrplib"; then
@@ -8294,7 +8295,7 @@ if "$useshrplib"; then
xxx="-Wl,-R$shrpdir"
;;
bsdos|linux|irix*|dec_osf|gnu*|haiku)
- xxx="-Wl,-rpath,$shrpdir"
+ # We want standard path
;;
hpux*)
# hpux doesn't like the default, either.
diff --git a/Makefile.SH b/Makefile.SH
index 7733a32..a481183 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -266,7 +266,7 @@ ranlib = $ranlib
# installman commandline.
bin = $installbin
scriptdir = $scriptdir
-shrpdir = $archlibexp/CORE
+shrpdir = $shrpdir
privlib = $installprivlib
man1dir = $man1dir
man1ext = $man1ext
--
1.8.1.4

110
SOURCES/perl-5.22.1-Provide-ExtUtils-MM-methods-as-standalone-ExtUtils-M.patch
Unescape View File

@ -0,0 +1,110 @@
From 9575301256f67116eccdbb99b38fc804ba3dcf53 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Mon, 18 Apr 2016 16:24:03 +0200
Subject: [PATCH] Provide ExtUtils::MM methods as standalone
ExtUtils::MM::Utils
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
If you cannot afford depending on ExtUtils::MakeMaker, you can
depend on ExtUtils::MM::Utils instead.
<https://bugzilla.redhat.com/show_bug.cgi?id=1129443>
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm | 68 ++++++++++++++++++++++++
2 files changed, 69 insertions(+)
create mode 100644 cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm
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
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
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm Independed MM methods
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm MakeMaker methods for U/WIN
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm MakeMaker methods for VMS
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm MakeMaker methods for VOS
diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm
new file mode 100644
index 0000000..6bbc0d8
--- /dev/null
+++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM/Utils.pm
@@ -0,0 +1,68 @@
+package ExtUtils::MM::Utils;
+
+require 5.006;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '7.11_06';
+$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
+
+=head1 NAME
+
+ExtUtils::MM::Utils - ExtUtils::MM methods without dependency on ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ require ExtUtils::MM::Utils;
+ MM->maybe_command($file);
+
+=head1 DESCRIPTION
+
+This is a collection of L<ExtUtils::MM> subroutines that are used by many
+other modules but that do not need full-featured L<ExtUtils::MakeMaker>. The
+issue with L<ExtUtils::MakeMaker> is it pulls in Perl header files and that is
+an overkill for small subroutines.
+
+An example is the L<IPC::Cmd> that caused installing GCC just because of
+three-line I<maybe_command()> from L<ExtUtils::MM_Unix>.
+
+The intentions is to use L<ExtUtils::MM::Utils> instead of
+L<ExtUtils::MakeMaker> for these trivial methods. You can still call them via
+L<MM> class name.
+
+=head1 METHODS
+
+=over 4
+
+=item maybe_command
+
+Returns true, if the argument is likely to be a command.
+
+=cut
+
+if (!exists $INC{'ExtUtils/MM.pm'}) {
+ *MM::maybe_command = *ExtUtils::MM::maybe_command = \&maybe_command;
+}
+
+sub maybe_command {
+ my($self,$file) = @_;
+ return $file if -x $file && ! -d $file;
+ return;
+}
+
+1;
+
+=back
+
+=head1 BUGS
+
+These methods are copied from L<ExtUtils::MM_Unix>. Other operating systems
+are not supported yet. The reason is this
+L<a hack for Linux
+distributions|https://bugzilla.redhat.com/show_bug.cgi?id=1129443>.
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>, L<ExtUtils::MM>
+
+=cut
--
2.5.5

34
SOURCES/perl-5.22.1-Replace-EU-MM-dependnecy-with-EU-MM-Utils-in-IPC-Cmd.patch
Unescape View File

@ -0,0 +1,34 @@
From 216ddd39adb0043930acad70ff242c30a1b0c6cf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Mon, 18 Apr 2016 16:39:32 +0200
Subject: [PATCH] Replace EU::MM dependnecy with EU::MM::Utils in IPC::Cmd
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This allows to free from a run-time dependency on fat
ExtUtils::MakeMaker.
<https://bugzilla.redhat.com/show_bug.cgi?id=1129443>
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
cpan/IPC-Cmd/lib/IPC/Cmd.pm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
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 {
}
require File::Spec;
- require ExtUtils::MakeMaker;
+ require ExtUtils::MM::Utils;
my @possibles;
--
2.5.5

73
SOURCES/perl-5.26.0-Time-HiRes-Fix-unreliable-t-usleep.t-and-t-utime.t.patch
Unescape View File

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

72
SOURCES/perl-5.26.0-perl-131263-clear-the-UTF8-flag-on-a-glob-if-it-isn-.patch
Unescape View File

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

61
SOURCES/perl-5.26.0-perl-131588-be-a-little-more-careful-in-arybase-_tie.patch
Unescape View File

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

37
SOURCES/perl-5.26.0-t-op-hash.t-fixup-intermittently-failing-test.patch
Unescape View File

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

48
SOURCES/perl-5.26.1-Fix-deparsing-of-transliterations-with-unprintable-c.patch
Unescape View File

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

111
SOURCES/perl-5.26.1-fix-do-dir-returning-no.patch
Unescape View File

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

1075
SOURCES/perl-5.26.1-fix-parsing-of-braced-subscript-after-parens.patch
View File

File diff suppressed because it is too large Load Diff

24
SOURCES/perl-5.26.1-guard_old_libcrypt_fix.patch
Unescape View File

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

107
SOURCES/perl-5.26.1-perl-131746-avoid-undefined-behaviour-in-Copy-etc.patch
Unescape View File

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

223
SOURCES/perl-5.26.1-perl-131895-fail-stat-on-names-with-0-embedded.patch
Unescape View File

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

54
SOURCES/perl-5.26.1-perl-132245-don-t-try-to-process-a-char-range-with-n.patch
Unescape View File

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

211
SOURCES/perl-5.26.1-set-when-statting-a-closed-filehandle.patch
Unescape View File

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

105
SOURCES/perl-5.26.2-PATCH-perl-133185-Infinite-loop-in-qr.patch
Unescape View File

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

143
SOURCES/perl-5.26.2-RC1-Parse-caret-vars-with-subscripts-the-same-as-normal-.patch
Unescape View File

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

45
SOURCES/perl-5.26.2-RC1-add-an-additional-test-for-whitespace-tolerance-in-c.patch
Unescape View File

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

90
SOURCES/perl-5.26.2-RC1-perform-system-arg-processing-before-fork.patch
Unescape View File

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

32
SOURCES/perl-5.27.0-perl-129183-don-t-treat-as-an-escape-in-PATH-for-S.patch
Unescape View File

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

258
SOURCES/perl-5.27.0-perl-131211-fixup-File-Glob-degenerate-matching.patch
Unescape View File

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

45
SOURCES/perl-5.27.1-File-Glob-tweak-rt131211.t-to-be-less-sensitive-on-w.patch
Unescape View File

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

226
SOURCES/perl-5.27.1-RT-130907-Fix-the-Unicode-Bug-in-split.patch
Unescape View File

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

51
SOURCES/perl-5.27.1-perl-131679-Fix-our-sub-foo-bar-message.patch
Unescape View File

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

30
SOURCES/perl-5.27.1-t-lib-warnings-utf8-Fix-test.patch
Unescape View File

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

43
SOURCES/perl-5.27.1-utf8n_to_uvchr-Don-t-display-too-many-bytes-in-msg.patch
Unescape View File

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

57
SOURCES/perl-5.27.10-PATCH-perl-132167-Parse-error-in-regex_sets.patch
Unescape View File

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

71
SOURCES/perl-5.27.10-PATCH-perl-133074-5.26.1-some-coverity-fixes.patch
Unescape View File

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

45
SOURCES/perl-5.27.2-Avoid-compiler-warnings-due-to-mismatched-types-in-p.patch
Unescape View File

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

69
SOURCES/perl-5.27.2-EU-Constant-avoid-uninit-warning.patch
Unescape View File

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

60
SOURCES/perl-5.27.3-avoid-the-address-of-.-will-always-evaluate-as-.-war.patch
Unescape View File

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

30
SOURCES/perl-5.27.3-perl-132008-try-to-prevent-the-similar-mistakes-in-t.patch
Unescape View File

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

32
SOURCES/perl-5.27.5-Avoid-a-segfault-when-untying-an-object.patch
Unescape View File

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

73
SOURCES/perl-5.27.5-Carp-Don-t-choke-on-ISA-constant.patch
Unescape View File

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

593
SOURCES/perl-5.27.5-fix-tainting-of-s-with-overloaded-replacement.patch
Unescape View File

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

105
SOURCES/perl-5.27.5-perl-132442-Fix-stack-with-do-my-sub-l-1.patch
Unescape View File

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

34
SOURCES/perl-5.27.7-Reenable-numeric-first-argument-of-system-on-VMS.patch
Unescape View File

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

73
SOURCES/perl-5.27.7-preserve-numericness-of-system-args-on-Win32.patch
Unescape View File

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

127
SOURCES/perl-5.27.8-don-t-clobber-file-bytes-in-encoding-layer.patch
Unescape View File

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

61
SOURCES/perl-5.27.8-hints-linux-Add-lphtread-to-lddlflags.patch
Unescape View File

@ -0,0 +1,61 @@
From f6bc8fb3d26892ba1a84ba2df76beedd51998dd2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Mon, 29 Jan 2018 16:34:17 +0100
Subject: [PATCH] hints/linux: Add -lphtread to lddlflags
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Passing -z defs to linker flags causes perl to fail to build if threads are
enabled:
gcc -shared -Wl,-z,relro -Wl,-z,defs -specs=/usr/lib/rpm/redhat/redhat-hardened-ld -L/usr/local/lib -fstack-protector-strong Bzip2.o -o ../../lib/auto/Compress/Raw/Bzip2/Bzip2.so \
-L/usr/lib64 -lbz2 "-L../.." -lperl \
Bzip2.o: In function `deRef':
/builddir/build/BUILD/perl-5.26.1/cpan/Compress-Raw-Bzip2/Bzip2.xs:256: undefined reference to `pthread_getspecific'
The reason is Bzip2.xs calls dTHX macro included from thread.h via perl.h that
expands to pthread_getspecific() function call that is defined in pthread
library. But the pthread library is not explicitly linked to Bzip.so (see the
gcc command). This is exactly what -z defs linker flag enforces.
Underlinking ELFs can be dangerous because in case of versioned
symbols it can cause run-time binding to an improper version symbol or
even to an symbold from different library.
This patch fixes hints for Linux by adding -lpthreads to lddlflags. It
also adds -shared there because Configure.sh adds it only hints return
lddlflags empty.
<https://lists.fedoraproject.org/archives/list/devel@lists.fedoraproject.org/message/3RHZEHLRUHJFF2XGHI5RB6YPDNLDR4HG/>
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
hints/linux.sh | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/hints/linux.sh b/hints/linux.sh
index 3f38ea07f1..9ec3bc02ef 100644
--- a/hints/linux.sh
+++ b/hints/linux.sh
@@ -353,12 +353,16 @@ if [ -f /etc/synoinfo.conf -a -d /usr/syno ]; then
echo "$libswanted" >&4
fi
+# Flags needed to produce shared libraries.
+lddlflags='-shared'
+
# This script UU/usethreads.cbu will get 'called-back' by Configure
# after it has prompted the user for whether to use threads.
cat > UU/usethreads.cbu <<'EOCBU'
case "$usethreads" in
$define|true|[yY]*)
ccflags="-D_REENTRANT -D_GNU_SOURCE $ccflags"
+ lddlflags="-lpthread $lddlflags"
if echo $libswanted | grep -v pthread >/dev/null
then
set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
--
2.13.6

68
SOURCES/perl-5.27.9-fix-line-numbers-in-multi-line-s.patch
Unescape View File

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

94
SOURCES/perl-5.29.0-Remove-ext-GDBM_File-t-fatal.t.patch
Unescape View File

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

46
SOURCES/perl-5.8.0-libdir64.patch
Unescape View File

@ -0,0 +1,46 @@
--- 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 @@
: Reproduce behavior of 5.005 and earlier, maybe drop that in 5.7.
case "$installstyle" in
'') case "$prefix" in
- *perl*) dflt='lib';;
- *) dflt='lib/perl5' ;;
+ *perl*) dflt='lib64';;
+ *) dflt='lib64/perl5' ;;
esac
;;
*) dflt="$installstyle" ;;
@@ -6475,8 +6475,8 @@
: /opt/perl/lib/perl5... would be redundant.
: The default "style" setting is made in installstyle.U
case "$installstyle" in
-*lib/perl5*) set dflt privlib lib/$package/$version ;;
-*) set dflt privlib lib/$version ;;
+*lib64/perl5*) set dflt privlib lib64/$package/$version ;;
+*) set dflt privlib lib64/$version ;;
esac
eval $prefixit
$cat <<EOM
@@ -6934,8 +6934,8 @@
prog=`echo $package | $sed 's/-*[0-9.]*$//'`
case "$sitelib" in
'') case "$installstyle" in
- *lib/perl5*) dflt=$siteprefix/lib/$package/site_$prog/$version ;;
- *) dflt=$siteprefix/lib/site_$prog/$version ;;
+ *lib64/perl5*) dflt=$siteprefix/lib64/$package/site_$prog/$version ;;
+ *) dflt=$siteprefix/lib64/site_$prog/$version ;;
esac
;;
*) dflt="$sitelib"
@@ -7061,8 +7061,8 @@
'')
prog=`echo $package | $sed 's/-*[0-9.]*$//'`
case "$installstyle" in
- *lib/perl5*) dflt=$vendorprefix/lib/$package/vendor_$prog/$version ;;
- *) dflt=$vendorprefix/lib/vendor_$prog/$version ;;
+ *lib64/perl5*) dflt=$vendorprefix/lib64/$package/vendor_$prog/$version ;;
+ *) dflt=$vendorprefix/lib64/vendor_$prog/$version ;;
esac
;;
*) dflt="$vendorlib"

109
SOURCES/perl-USE_MM_LD_RUN_PATH.patch
Unescape View File

@ -0,0 +1,109 @@
diff -up perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm.usem perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm
--- perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm.usem 2011-05-08 05:10:08.000000000 +0200
+++ perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm 2011-05-17 11:14:22.169115984 +0200
@@ -88,6 +88,11 @@ libraries. LD_RUN_PATH is a colon separ
in LDLOADLIBS. It is passed as an environment variable to the process
that links the shared library.
+Fedora extension: This generation of LD_RUN_PATH is disabled by default.
+To use the generated LD_RUN_PATH for all links, set the USE_MM_LD_RUN_PATH
+MakeMaker object attribute / argument, (or set the $USE_MM_LD_RUN_PATH
+environment variable).
+
=head2 BSLOADLIBS
List of those libraries that are needed but can be linked in
diff -up perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm.usem perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm
--- perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm.usem 2011-05-08 05:10:08.000000000 +0200
+++ perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm 2011-05-17 13:39:26.912586030 +0200
@@ -278,7 +278,7 @@ sub full_setup {
PERM_DIR PERM_RW PERM_RWX MAGICXS
PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
- SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS
+ SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST USE_MM_LD_RUN_PATH VERSION VERSION_FROM XS
XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION
clean depend dist dynamic_lib linkext macro realclean tool_autosplit
@@ -422,7 +422,27 @@ sub new {
# PRINT_PREREQ is RedHatism.
if ("@ARGV" =~ /\bPRINT_PREREQ\b/) {
$self->_PRINT_PREREQ;
- }
+ }
+
+ # USE_MM_LD_RUN_PATH - another RedHatism to disable automatic RPATH generation
+ if ( ( ! $self->{USE_MM_LD_RUN_PATH} )
+ &&( ("@ARGV" =~ /\bUSE_MM_LD_RUN_PATH(=([01]))?\b/)
+ ||( exists( $ENV{USE_MM_LD_RUN_PATH} )
+ &&( $ENV{USE_MM_LD_RUN_PATH} =~ /([01])?$/ )
+ )
+ )
+ )
+ {
+ my $v = $1;
+ if( $v )
+ {
+ $v = ($v=~/=([01])$/)[0];
+ }else
+ {
+ $v = 1;
+ };
+ $self->{USE_MM_LD_RUN_PATH}=$v;
+ };
print "MakeMaker (v$VERSION)\n" if $Verbose;
if (-f "MANIFEST" && ! -f "Makefile" && ! $UNDER_CORE){
@@ -2352,6 +2372,40 @@ precedence. A typemap in the current di
precedence, even if it isn't listed in TYPEMAPS. The default system
typemap has lowest precedence.
+=item USE_MM_LD_RUN_PATH
+
+boolean
+The Fedora perl MakeMaker distribution differs from the standard
+upstream release in that it disables use of the MakeMaker generated
+LD_RUN_PATH by default, UNLESS this attribute is specified , or the
+USE_MM_LD_RUN_PATH environment variable is set during the MakeMaker run.
+
+The upstream MakeMaker will set the ld(1) environment variable LD_RUN_PATH
+to the concatenation of every -L ld(1) option directory in which a -l ld(1)
+option library is found, which is used as the ld(1) -rpath option if none
+is specified. This means that, if your application builds shared libraries
+and your MakeMaker application links to them, that the absolute paths of the
+libraries in the build tree will be inserted into the RPATH header of all
+MakeMaker generated binaries, and that such binaries will be unable to link
+to these libraries if they do not still reside in the build tree directories
+(unlikely) or in the system library directories (/lib or /usr/lib), regardless
+of any LD_LIBRARY_PATH setting. So if you specified -L../mylib -lmylib , and
+ your 'libmylib.so' gets installed into /some_directory_other_than_usr_lib,
+ your MakeMaker application will be unable to link to it, even if LD_LIBRARY_PATH
+is set to include /some_directory_other_than_usr_lib, because RPATH overrides
+LD_LIBRARY_PATH.
+
+So for Fedora MakeMaker builds LD_RUN_PATH is NOT generated by default for
+every link. You can still use explicit -rpath ld options or the LD_RUN_PATH
+environment variable during the build to generate an RPATH for the binaries.
+
+You can set the USE_MM_LD_RUN_PATH attribute to 1 on the MakeMaker command
+line or in the WriteMakefile arguments to enable generation of LD_RUN_PATH
+for every link command.
+
+USE_MM_LD_RUN_PATH will default to 1 (LD_RUN_PATH will be used) IF the
+$USE_MM_LD_RUN_PATH environment variable is set during a MakeMaker run.
+
=item VENDORPREFIX
Like PERLPREFIX, but only for the vendor install locations.
diff -up perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm.usem perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm
--- perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm.usem 2011-05-08 05:10:08.000000000 +0200
+++ perl-5.14.0/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm 2011-05-17 11:14:22.172115972 +0200
@@ -944,7 +944,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $
}
my $ld_run_path_shell = "";
- if ($self->{LD_RUN_PATH} ne "") {
+ if (($self->{LD_RUN_PATH} ne "") && ($self->{USE_MM_LD_RUN_PATH})) {
$ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
}

21
SOURCES/perl-example.stp
Unescape View File

@ -0,0 +1,21 @@
/*
Example of the perl systemtap tapset shows a nested view of perl subroutine
calls and returns across the whole system.
To run:
stap perl-example.stp (for all perl processes)
For specific perl process:
stap perl-example.stp -c COMMAND
*/
probe perl.sub.call
{
printf("%s => sub: %s, filename: %s, line: %d, package: %s\n",
thread_indent(1), sub, filename, lineno, package)
}
probe perl.sub.return
{
printf("%s <= sub: %s, filename: %s, line: %d, package: %s\n",
thread_indent(-1), sub, filename, lineno, package)
}

21
SOURCES/perl-perlbug-tag.patch
Unescape View File

@ -0,0 +1,21 @@
diff -up perl-5.16.0-RC2/utils/perlbug.PL.fedora perl-5.16.0-RC2/utils/perlbug.PL
--- perl-5.16.0-RC2/utils/perlbug.PL.fedora 2012-05-16 16:15:51.000000000 +0200
+++ perl-5.16.0-RC2/utils/perlbug.PL 2012-05-16 16:18:36.018894464 +0200
@@ -271,17 +271,6 @@ sub Init {
$ok = '';
if ($opt{o}) {
if ($opt{o} eq 'k' or $opt{o} eq 'kay') {
- my $age = time - $patchlevel_date;
- if ($opt{o} eq 'k' and $age > 60 * 24 * 60 * 60 ) {
- my $date = localtime $patchlevel_date;
- print <<"EOF";
-"perlbug -ok" and "perlbug -nok" do not report on Perl versions which
-are more than 60 days old. This Perl version was constructed on
-$date. If you really want to report this, use
-"perlbug -okay" or "perlbug -nokay".
-EOF
- exit();
- }
# force these options
unless ($opt{n}) {
$opt{S} = 1; # don't prompt for send

71
SOURCES/perl.stp
Unescape View File

@ -0,0 +1,71 @@
/*
This probe will fire when the perl script enters a subroutine.
*/
probe perl.sub.call = process("LIBRARY_PATH").mark("sub__entry")
{
sub = user_string($arg1)
filename = user_string($arg2)
lineno = $arg3
package = user_string($arg4)
}
/*
This probe will fire when the return from a subroutine has been
hit.
*/
probe perl.sub.return = process("LIBRARY_PATH").mark("sub__return")
{
sub = user_string($arg1)
filename = user_string($arg2)
lineno = $arg3
package = user_string($arg4)
}
/*
This probe will fire when the Perl interperter changes state.
*/
probe perl.phase.change = process("LIBRARY_PATH").mark("phase__change")
{
newphase = user_string($arg1)
oldphase = user_string($arg2)
}
/*
Fires when Perl has successfully loaded an individual file.
*/
probe perl.loaded.file = process("LIBRARY_PATH").mark("loaded__file")
{
filename = user_string($arg1)
}
/*
Fires when Perl is about to load an individual file.
*/
probe perl.loading.file = process("LIBRARY_PATH").mark("loading__file")
{
filename = user_string($arg1)
}
/*
Traces the execution of each opcode in the Perl runloop.
*/
probe perl.op.entry = process("LIBRARY_PATH").mark("op__entry")
{
opname = user_string($arg1)
}

6809
SPECS/perl.spec
View File

File diff suppressed because it is too large Load Diff
Write Preview
Loading…
Cancel
Save