import perl-5.30.1-450.module+el8.3.0+6702+b3e67f28
This commit is contained in:
commit
2b9973eb1c
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
||||
SOURCES/perl-5.30.1.tar.xz
|
1
.perl.metadata
Normal file
1
.perl.metadata
Normal file
@ -0,0 +1 @@
|
||||
4bc190b6ac368f573e6a028f91430f831d40d30a SOURCES/perl-5.30.1.tar.xz
|
41
SOURCES/Pod-Html-license-clarification
Normal file
41
SOURCES/Pod-Html-license-clarification
Normal 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
|
2076
SOURCES/gendep.macros
Normal file
2076
SOURCES/gendep.macros
Normal file
File diff suppressed because it is too large
Load Diff
158
SOURCES/macros.perl
Normal file
158
SOURCES/macros.perl
Normal file
@ -0,0 +1,158 @@
|
||||
# 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
|
||||
}
|
||||
|
||||
#############################################################################
|
||||
# Perl specific macros, no longer part of rpm >= 4.15
|
||||
%perl_vendorarch %(eval "`%{__perl} -V:installvendorarch`"; echo $installvendorarch)
|
||||
%perl_vendorlib %(eval "`%{__perl} -V:installvendorlib`"; echo $installvendorlib)
|
||||
%perl_archlib %(eval "`%{__perl} -V:installarchlib`"; echo $installarchlib)
|
||||
%perl_privlib %(eval "`%{__perl} -V:installprivlib`"; echo $installprivlib)
|
||||
|
||||
#############################################################################
|
||||
# Filtering macro incantations
|
||||
|
||||
# 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
Normal file
12
SOURCES/perl-5.10.0-libresolv.patch
Normal 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
|
||||
@@ -1483,7 +1483,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
Normal file
12
SOURCES/perl-5.10.0-x86_64-io-test-failure.patch
Normal 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
|
||||
@@ -257,7 +257,7 @@ isnt($atime, 500000000, 'atime');
|
||||
isnt($mtime, $ut + $delta, 'mtime: utime called with two undefs');
|
||||
|
||||
SKIP: {
|
||||
- skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define";
|
||||
+ skip "no futimes", 6;
|
||||
note("check futimes");
|
||||
open(my $fh, "<", 'b');
|
||||
$foo = (utime $ut,$ut + $delta, $fh);
|
17
SOURCES/perl-5.14.1-offtest.patch
Normal file
17
SOURCES/perl-5.14.1-offtest.patch
Normal 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;
|
@ -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
|
||||
@@ -3424,6 +3424,7 @@ dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm CBuilder methods fo
|
||||
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm CBuilder methods for cygwin
|
||||
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm CBuilder methods for darwin
|
||||
dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm CBuilder methods for OSF
|
||||
+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
|
||||
|
@ -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
|
||||
@@ -30,6 +30,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};
|
||||
@@ -1028,7 +1029,7 @@ sub xs_make_dynamic_lib {
|
||||
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
|
||||
@@ -1041,6 +1042,11 @@ sub xs_make_dynamic_lib {
|
||||
# The Android linker will not recognize symbols from
|
||||
# libperl unless the module explicitly depends on it.
|
||||
$libs .= ' "-L$(PERL_INC)" -lperl';
|
||||
+ } else {
|
||||
+ if ($ENV{PERL_CORE}) {
|
||||
+ $libs .= ' "-L$(PERL_INC)"';
|
||||
+ }
|
||||
+ $libs .= ' -lperl';
|
||||
}
|
||||
}
|
||||
|
||||
--
|
||||
1.8.1.4
|
||||
|
57
SOURCES/perl-5.16.3-create_libperl_soname.patch
Normal file
57
SOURCES/perl-5.16.3-create_libperl_soname.patch
Normal file
@ -0,0 +1,57 @@
|
||||
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
|
||||
@@ -70,11 +70,11 @@ true)
|
||||
${revision}.${patchlevel}.${subversion}"
|
||||
case "$osvers" in
|
||||
1[5-9]*|[2-9]*)
|
||||
- shrpldflags="$shrpldflags -install_name `pwd`/\$@ -Xlinker -headerpad_max_install_names"
|
||||
+ shrpldflags="$shrpldflags -install_name `pwd`/libperl.${revision}.${patchlevel}.dylib -Xlinker -headerpad_max_install_names"
|
||||
exeldflags="-Xlinker -headerpad_max_install_names"
|
||||
;;
|
||||
*)
|
||||
- shrpldflags="$shrpldflags -install_name \$(shrpdir)/\$@"
|
||||
+ shrpldflags="$shrpldflags -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
|
||||
;;
|
||||
esac
|
||||
;;
|
||||
@@ -76,13 +76,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
|
||||
@@ -120,6 +122,9 @@ true)
|
||||
linklibperl='libperl.x'
|
||||
DPERL_EXTERNAL_GLOB=''
|
||||
;;
|
||||
+ linux*)
|
||||
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
|
||||
+ ;;
|
||||
esac
|
||||
case "$ldlibpthname" in
|
||||
'') ;;
|
@ -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 ;
|
||||
@@ -98,6 +99,7 @@ gdbm_TIEHASH(dbtype, name, read_write, m
|
||||
}
|
||||
if (dbp) {
|
||||
RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type));
|
||||
+ RETVAL->owner = aTHX;
|
||||
RETVAL->dbp = dbp;
|
||||
} else {
|
||||
RETVAL = NULL;
|
||||
@@ -118,12 +120,14 @@ gdbm_DESTROY(db)
|
||||
PREINIT:
|
||||
int i = store_value;
|
||||
CODE:
|
||||
- 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
|
||||
@@ -49,6 +49,7 @@ datum nextkey(datum key);
|
||||
#define store_value 3
|
||||
|
||||
typedef struct {
|
||||
+ tTHX owner;
|
||||
void * dbp ;
|
||||
SV * filter[4];
|
||||
int filtering ;
|
||||
@@ -137,6 +138,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
|
||||
}
|
||||
dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
|
||||
RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
|
||||
+ RETVAL->owner = aTHX;
|
||||
RETVAL->dbp = dbp ;
|
||||
}
|
||||
OUTPUT:
|
||||
@@ -149,13 +151,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 ;
|
||||
@@ -51,6 +52,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
|
||||
}
|
||||
if (dbp) {
|
||||
RETVAL = (SDBM_File)safecalloc(1, sizeof(SDBM_File_type));
|
||||
+ RETVAL->owner = aTHX;
|
||||
RETVAL->dbp = dbp ;
|
||||
}
|
||||
|
||||
@@ -62,7 +64,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
|
||||
@@ -510,5 +510,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
|
||||
|
@ -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
|
||||
@@ -8762,7 +8762,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
|
||||
@@ -8792,7 +8794,6 @@ esac
|
||||
# Add $xxx to ccdlflags.
|
||||
# If we can't figure out a command-line option, use $shrpenv to
|
||||
# set env LD_RUN_PATH. The main perl makefile uses this.
|
||||
-shrpdir=$archlibexp/CORE
|
||||
xxx=''
|
||||
tmp_shrpenv=''
|
||||
if "$useshrplib"; then
|
||||
@@ -8807,7 +8808,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
|
||||
@@ -288,7 +288,7 @@ ranlib = $ranlib
|
||||
# installman commandline.
|
||||
bin = $installbin
|
||||
scriptdir = $scriptdir
|
||||
-shrpdir = $archlibexp/CORE
|
||||
+shrpdir = $shrpdir
|
||||
privlib = $installprivlib
|
||||
man1dir = $man1dir
|
||||
man1ext = $man1ext
|
||||
--
|
||||
1.8.1.4
|
@ -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
|
||||
@@ -784,6 +784,7 @@ cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
|
||||
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
|
||||
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm MakeMaker methods for QNX
|
||||
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm MakeMaker methods for Unix
|
||||
+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
|
||||
|
@ -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
|
||||
@@ -232,7 +232,7 @@ sub can_run {
|
||||
}
|
||||
|
||||
require File::Spec;
|
||||
- require ExtUtils::MakeMaker;
|
||||
+ require ExtUtils::MM::Utils;
|
||||
|
||||
my @possibles;
|
||||
|
||||
--
|
||||
2.5.5
|
||||
|
@ -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
|
||||
|
63
SOURCES/perl-5.28.0-Pass-CFLAGS-to-dtrace.patch
Normal file
63
SOURCES/perl-5.28.0-Pass-CFLAGS-to-dtrace.patch
Normal file
@ -0,0 +1,63 @@
|
||||
Subject: [PATCH] Pass CFLAGS to dtrace
|
||||
|
||||
Signed-off-by: Petr PĂsaĹ <ppisar@redhat.com>
|
||||
---
|
||||
Makefile.SH | 8 +++++---
|
||||
cflags.SH | 5 ++++-
|
||||
2 files changed, 9 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/Makefile.SH b/Makefile.SH
|
||||
index 5fc6d1c..e89ad70 100755
|
||||
--- a/Makefile.SH
|
||||
+++ b/Makefile.SH
|
||||
@@ -462,6 +462,8 @@ CCCMD = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@
|
||||
|
||||
CCCMDSRC = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $<
|
||||
|
||||
+DTRACEFLAGS = sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@
|
||||
+
|
||||
CONFIGPM_FROM_CONFIG_SH = lib/Config.pm lib/Config_heavy.pl
|
||||
CONFIGPM = $(CONFIGPM_FROM_CONFIG_SH) lib/Config_git.pl
|
||||
|
||||
@@ -895,19 +897,19 @@ $(DTRACE_MINI_O): perldtrace.d $(miniperl_objs_nodt)
|
||||
-rm -rf mpdtrace
|
||||
mkdir mpdtrace
|
||||
cp $(miniperl_objs_nodt) mpdtrace/
|
||||
- $(DTRACE) -G -s perldtrace.d -o $(DTRACE_MINI_O) $(miniperl_dtrace_objs)
|
||||
+ CFLAGS="`$(DTRACEFLAGS)`" $(DTRACE) -G -s perldtrace.d -o $(DTRACE_MINI_O) $(miniperl_dtrace_objs)
|
||||
|
||||
$(DTRACE_PERLLIB_O): perldtrace.d $(perllib_objs_nodt)
|
||||
-rm -rf libpdtrace
|
||||
mkdir libpdtrace
|
||||
cp $(perllib_objs_nodt) libpdtrace/
|
||||
- $(DTRACE) -G -s perldtrace.d -o $(DTRACE_PERLLIB_O) $(perllib_dtrace_objs)
|
||||
+ CFLAGS="`$(DTRACEFLAGS)`" $(DTRACE) -G -s perldtrace.d -o $(DTRACE_PERLLIB_O) $(perllib_dtrace_objs)
|
||||
|
||||
$(DTRACE_MAIN_O): perldtrace.d perlmain$(OBJ_EXT)
|
||||
-rm -rf maindtrace
|
||||
mkdir maindtrace
|
||||
cp perlmain$(OBJ_EXT) maindtrace/
|
||||
- $(DTRACE) -G -s perldtrace.d -o $(DTRACE_MAIN_O) $(perlmain_dtrace_objs) || \
|
||||
+ CFLAGS="`$(DTRACEFLAGS)`" $(DTRACE) -G -s perldtrace.d -o $(DTRACE_MAIN_O) $(perlmain_dtrace_objs) || \
|
||||
( $(ECHO) "No probes in perlmain$(OBJ_EXT), generating a dummy $(DTRACE_MAIN_O)" && \
|
||||
$(ECHO) >dtrace_main.c && \
|
||||
`$(CCCMD)` $(PLDLFLAGS) dtrace_main.c && \
|
||||
diff --git a/cflags.SH b/cflags.SH
|
||||
index 3af1e97..b845127 100755
|
||||
--- a/cflags.SH
|
||||
+++ b/cflags.SH
|
||||
@@ -519,7 +519,10 @@ for file do
|
||||
toke) optimize=-O0 ;;
|
||||
esac
|
||||
|
||||
- echo "$cc -c -DPERL_CORE $ccflags $stdflags $optimize $warn $extra"
|
||||
+ case "$file" in
|
||||
+ dtrace_*) echo "$ccflags $stdflags $optimize $warn $extra";;
|
||||
+ *) echo "$cc -c -DPERL_CORE $ccflags $stdflags $optimize $warn $extra";;
|
||||
+ esac
|
||||
|
||||
. $TOP/config.sh
|
||||
|
||||
--
|
||||
2.17.1
|
||||
|
@ -0,0 +1,389 @@
|
||||
From fd30a7c49a661aecfb361045646da264cdadea8f Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Fri, 23 Aug 2019 12:40:24 -0600
|
||||
Subject: [PATCH] PATCH: [perl #134329] Use after free in regcomp.c
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
A compiled regex is composed of nodes, forming a linked list, with
|
||||
normally a maximum of 16 bits used to specify the offset of the next
|
||||
link. For patterns that require more space than this, the nodes that
|
||||
jump around are replaced with ones that have wider offsets. Most nodes
|
||||
are unaffected, as they just contain the offset of the next node, and
|
||||
that number is always small. The jump nodes are the ones affected.
|
||||
|
||||
When compiling a pattern, the 16 bit mechanism is used, until it
|
||||
overflows, at which point the pattern is recompiled with the long jumps
|
||||
instead.
|
||||
|
||||
When I rewrote the compiler last year to make it generally one pass, I
|
||||
noticed a lot of the cases where a node was added didn't check if the
|
||||
result overflowed (the function that does this returns FALSE in that
|
||||
case). I presumed the prior authors knew better, and did not change
|
||||
things, except to put in a bogus value in the link (offset) field that
|
||||
should cause a crash if it were used. That's what's happening in this
|
||||
ticket.
|
||||
|
||||
But seeing this example, it's clear that the return value should be
|
||||
checked every time, because you can reach the limit at any time. This
|
||||
commit changes to do that, and to require the function's return value to
|
||||
not be ignored, to guard against future changes.
|
||||
|
||||
My guess is that the reason it generally worked when there were multiple
|
||||
passes is that the first pass didn't do anything except count space, and
|
||||
that at some point before the end of the pass the return value did get
|
||||
checked, so by the time the nodes were allocated for real, it knew
|
||||
enough to use the long jumps.
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
3b2e5620ed4a6b341f97ffd1d4b6466cc2c4bc5b.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 1 +
|
||||
embed.fnc | 4 +-
|
||||
proto.h | 8 ++-
|
||||
regcomp.c | 109 ++++++++++++++++++++++++++++-----------
|
||||
t/re/bigfuzzy_not_utf8.t | Bin 0 -> 36399 bytes
|
||||
5 files changed, 88 insertions(+), 34 deletions(-)
|
||||
create mode 100644 t/re/bigfuzzy_not_utf8.t
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 10e2cc0..cc24cd7 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -5839,6 +5839,7 @@ t/porting/test_bootstrap.t Test that the instructions for test bootstrapping are
|
||||
t/porting/utils.t Check that utility scripts still compile
|
||||
t/re/alpha_assertions.t See if things like '(*postive_lookahed:...) work properly
|
||||
t/re/anyof.t See if bracketed char classes [...] compile properly
|
||||
+t/re/bigfuzzy_not_utf8.t Big and ugly tests not storable as UTF-8
|
||||
t/re/charset.t See if regex modifiers like /d, /u work properly
|
||||
t/re/fold_grind.pl Core file to see if regex case folding works properly
|
||||
t/re/fold_grind_8.t Wrapper for fold_grind.pl for /l testing with a UTF-8 locale
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index c977d39..c2c5f16 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -2427,7 +2427,7 @@ Es |void |reginsert |NN RExC_state_t *pRExC_state \
|
||||
|const U8 op \
|
||||
|const regnode_offset operand \
|
||||
|const U32 depth
|
||||
-Es |bool |regtail |NN RExC_state_t * pRExC_state \
|
||||
+EsR |bool |regtail |NN RExC_state_t * pRExC_state \
|
||||
|NN const regnode_offset p \
|
||||
|NN const regnode_offset val \
|
||||
|const U32 depth
|
||||
@@ -2561,7 +2561,7 @@ Es |void |dump_trie_interim_list|NN const struct _reg_trie_data *trie\
|
||||
Es |void |dump_trie_interim_table|NN const struct _reg_trie_data *trie\
|
||||
|NULLOK HV* widecharmap|NN AV *revcharmap\
|
||||
|U32 next_alloc|U32 depth
|
||||
-Es |bool |regtail_study |NN RExC_state_t *pRExC_state \
|
||||
+EsR |bool |regtail_study |NN RExC_state_t *pRExC_state \
|
||||
|NN regnode_offset p|NN const regnode_offset val|U32 depth
|
||||
# endif
|
||||
#endif
|
||||
diff --git a/proto.h b/proto.h
|
||||
index e0ea55b..2ef7ce2 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -4457,9 +4457,11 @@ PERL_CALLCONV int Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...);
|
||||
assert(fmt)
|
||||
STATIC void S_regdump_extflags(pTHX_ const char *lead, const U32 flags);
|
||||
STATIC void S_regdump_intflags(pTHX_ const char *lead, const U32 flags);
|
||||
-STATIC bool S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, const regnode_offset val, U32 depth);
|
||||
+STATIC bool S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, const regnode_offset val, U32 depth)
|
||||
+ __attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_REGTAIL_STUDY \
|
||||
assert(pRExC_state); assert(p); assert(val)
|
||||
+
|
||||
# endif
|
||||
# if defined(PERL_IN_REGEXEC_C)
|
||||
STATIC void S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8, const char *start, const char *end, const char *blurb);
|
||||
@@ -5599,9 +5601,11 @@ STATIC regnode_offset S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 o
|
||||
STATIC regnode_offset S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth);
|
||||
#define PERL_ARGS_ASSERT_REGPIECE \
|
||||
assert(pRExC_state); assert(flagp)
|
||||
-STATIC bool S_regtail(pTHX_ RExC_state_t * pRExC_state, const regnode_offset p, const regnode_offset val, const U32 depth);
|
||||
+STATIC bool S_regtail(pTHX_ RExC_state_t * pRExC_state, const regnode_offset p, const regnode_offset val, const U32 depth)
|
||||
+ __attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_REGTAIL \
|
||||
assert(pRExC_state); assert(p); assert(val)
|
||||
+
|
||||
STATIC void S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, struct scan_data_t *data, SSize_t *minlenp, int is_inf);
|
||||
#define PERL_ARGS_ASSERT_SCAN_COMMIT \
|
||||
assert(pRExC_state); assert(data); assert(minlenp)
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index dfc22bc..b93fbe7 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -11307,10 +11307,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
return 0;
|
||||
}
|
||||
|
||||
- REGTAIL(pRExC_state, ret, atomic);
|
||||
+ if (! REGTAIL(pRExC_state, ret, atomic)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
|
||||
- REGTAIL(pRExC_state, atomic,
|
||||
- reg_node(pRExC_state, SRCLOSE));
|
||||
+ if (! REGTAIL(pRExC_state, atomic, reg_node(pRExC_state,
|
||||
+ SRCLOSE)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
|
||||
RExC_in_script_run = 0;
|
||||
return ret;
|
||||
@@ -11769,7 +11774,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
RExC_flags & RXf_PMf_COMPILETIME
|
||||
);
|
||||
FLAGS(REGNODE_p(ret)) = 2;
|
||||
- REGTAIL(pRExC_state, ret, eval);
|
||||
+ if (! REGTAIL(pRExC_state, ret, eval)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
/* deal with the length of this later - MJD */
|
||||
return ret;
|
||||
}
|
||||
@@ -11822,7 +11829,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
|
||||
tail = reg(pRExC_state, 1, &flag, depth+1);
|
||||
RETURN_FAIL_ON_RESTART(flag, flagp);
|
||||
- REGTAIL(pRExC_state, ret, tail);
|
||||
+ if (! REGTAIL(pRExC_state, ret, tail)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
goto insert_if;
|
||||
}
|
||||
else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
|
||||
@@ -11914,15 +11923,22 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
}
|
||||
nextchar(pRExC_state);
|
||||
insert_if:
|
||||
- REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
|
||||
+ if (! REGTAIL(pRExC_state, ret, reganode(pRExC_state,
|
||||
+ IFTHEN, 0)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
br = regbranch(pRExC_state, &flags, 1, depth+1);
|
||||
if (br == 0) {
|
||||
RETURN_FAIL_ON_RESTART(flags,flagp);
|
||||
FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
|
||||
(UV) flags);
|
||||
} else
|
||||
- REGTAIL(pRExC_state, br, reganode(pRExC_state,
|
||||
- LONGJMP, 0));
|
||||
+ if (! REGTAIL(pRExC_state, br, reganode(pRExC_state,
|
||||
+ LONGJMP, 0)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
c = UCHARAT(RExC_parse);
|
||||
nextchar(pRExC_state);
|
||||
if (flags&HASWIDTH)
|
||||
@@ -11939,7 +11955,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
|
||||
(UV) flags);
|
||||
}
|
||||
- REGTAIL(pRExC_state, ret, lastbr);
|
||||
+ if (! REGTAIL(pRExC_state, ret, lastbr)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (flags&HASWIDTH)
|
||||
*flagp |= HASWIDTH;
|
||||
c = UCHARAT(RExC_parse);
|
||||
@@ -11954,16 +11972,26 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
vFAIL("Switch (?(condition)... contains too many branches");
|
||||
}
|
||||
ender = reg_node(pRExC_state, TAIL);
|
||||
- REGTAIL(pRExC_state, br, ender);
|
||||
+ if (! REGTAIL(pRExC_state, br, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (lastbr) {
|
||||
- REGTAIL(pRExC_state, lastbr, ender);
|
||||
- REGTAIL(pRExC_state, REGNODE_OFFSET(
|
||||
- NEXTOPER(
|
||||
- NEXTOPER(REGNODE_p(lastbr)))),
|
||||
- ender);
|
||||
+ if (! REGTAIL(pRExC_state, lastbr, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
+ if (! REGTAIL(pRExC_state,
|
||||
+ REGNODE_OFFSET(
|
||||
+ NEXTOPER(
|
||||
+ NEXTOPER(REGNODE_p(lastbr)))),
|
||||
+ ender))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
#if 0 /* Removing this doesn't cause failures in the test suite -- khw */
|
||||
RExC_size++; /* XXX WHY do we need this?!!
|
||||
For large programs it seems to be required
|
||||
@@ -12113,7 +12141,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
*flagp |= flags&SIMPLE;
|
||||
}
|
||||
if (is_open) { /* Starts with OPEN. */
|
||||
- REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
|
||||
+ if (! REGTAIL(pRExC_state, ret, br)) { /* OPEN -> first. */
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else if (paren != '?') /* Not Conditional */
|
||||
ret = br;
|
||||
@@ -12121,12 +12151,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
lastbr = br;
|
||||
while (*RExC_parse == '|') {
|
||||
if (RExC_use_BRANCHJ) {
|
||||
+ bool shut_gcc_up;
|
||||
+
|
||||
ender = reganode(pRExC_state, LONGJMP, 0);
|
||||
|
||||
/* Append to the previous. */
|
||||
- REGTAIL(pRExC_state,
|
||||
- REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
|
||||
- ender);
|
||||
+ shut_gcc_up = REGTAIL(pRExC_state,
|
||||
+ REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
|
||||
+ ender);
|
||||
+ PERL_UNUSED_VAR(shut_gcc_up);
|
||||
}
|
||||
nextchar(pRExC_state);
|
||||
if (freeze_paren) {
|
||||
@@ -12237,9 +12270,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
|
||||
is_nothing= 0;
|
||||
}
|
||||
else if (op == BRANCHJ) {
|
||||
- REGTAIL_STUDY(pRExC_state,
|
||||
- REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
|
||||
- ender);
|
||||
+ bool shut_gcc_up = REGTAIL_STUDY(pRExC_state,
|
||||
+ REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
|
||||
+ ender);
|
||||
+ PERL_UNUSED_VAR(shut_gcc_up);
|
||||
/* for now we always disable this optimisation * /
|
||||
if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
|
||||
|| regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender))
|
||||
@@ -12551,7 +12585,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
const regnode_offset w = reg_node(pRExC_state, WHILEM);
|
||||
|
||||
FLAGS(REGNODE_p(w)) = 0;
|
||||
- REGTAIL(pRExC_state, ret, w);
|
||||
+ if (! REGTAIL(pRExC_state, ret, w)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
if (RExC_use_BRANCHJ) {
|
||||
reginsert(pRExC_state, LONGJMP, ret, depth+1);
|
||||
reginsert(pRExC_state, NOTHING, ret, depth+1);
|
||||
@@ -12566,7 +12602,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
if (RExC_use_BRANCHJ)
|
||||
NEXT_OFF(REGNODE_p(ret)) = 3; /* Go over NOTHING to
|
||||
LONGJMP. */
|
||||
- REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
|
||||
+ if (! REGTAIL(pRExC_state, ret, reg_node(pRExC_state,
|
||||
+ NOTHING)))
|
||||
+ {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
RExC_whilem_seen++;
|
||||
MARK_NAUGHTY_EXP(1, 4); /* compound interest */
|
||||
}
|
||||
@@ -12638,16 +12678,22 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
|
||||
if (*RExC_parse == '?') {
|
||||
nextchar(pRExC_state);
|
||||
reginsert(pRExC_state, MINMOD, ret, depth+1);
|
||||
- REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
else if (*RExC_parse == '+') {
|
||||
regnode_offset ender;
|
||||
nextchar(pRExC_state);
|
||||
ender = reg_node(pRExC_state, SUCCEED);
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
reginsert(pRExC_state, SUSPEND, ret, depth+1);
|
||||
ender = reg_node(pRExC_state, TAIL);
|
||||
- REGTAIL(pRExC_state, ret, ender);
|
||||
+ if (! REGTAIL(pRExC_state, ret, ender)) {
|
||||
+ REQUIRE_BRANCHJ(flagp, 0);
|
||||
+ }
|
||||
}
|
||||
|
||||
if (ISMULT2(RExC_parse)) {
|
||||
@@ -19815,8 +19861,8 @@ S_regtail(pTHX_ RExC_state_t * pRExC_state,
|
||||
}
|
||||
else {
|
||||
if (val - scan > U16_MAX) {
|
||||
- /* Since not all callers check the return value, populate this with
|
||||
- * something that won't loop and will likely lead to a crash if
|
||||
+ /* Populate this with something that won't loop and will likely
|
||||
+ * lead to a crash if the caller ignores the failure return, and
|
||||
* execution continues */
|
||||
NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
|
||||
return FALSE;
|
||||
@@ -19927,6 +19973,9 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p,
|
||||
}
|
||||
else {
|
||||
if (val - scan > U16_MAX) {
|
||||
+ /* Populate this with something that won't loop and will likely
|
||||
+ * lead to a crash if the caller ignores the failure return, and
|
||||
+ * execution continues */
|
||||
NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
|
||||
return FALSE;
|
||||
}
|
||||
diff --git a/t/re/bigfuzzy_not_utf8.t b/t/re/bigfuzzy_not_utf8.t
|
||||
new file mode 100644
|
||||
index 0000000000000000000000000000000000000000..b4dfd150a9297172af5d8e7811357fd68931f8d7
|
||||
GIT binary patch
|
||||
literal 36399
|
||||
zcmeI5y>Ht_6u>V)vj`|)bnw`ot)P-@MMCTpNTQ@6nzlsHpvaKGfa6%8#FNC9CKZxu
|
||||
z;)Jf$YRJ%zoeHDqo_|0?hWr89EXQ;I1&?0XN7}J$MN%l4pVm7V_T9aA@8fqzil1_F
|
||||
zE|;$}O->{eN&28B=@fnhT2nU|t*9E+ShXPw8fDMw8q;-2Rj9#qL#IYfFlbp&QU)zC
|
||||
zsvD}tL@Ma?;e+olU(13qL4mf$Xi2KlMpfR-(n>>?sal~`K`RMWM$0up6UqkD^enA1
|
||||
zg=vB;ZywbQuvXdxGnK~k=b({GBpSNyN0Z7%!KptLG(}RXdLfa}8zrhWl%f+Fv@e<T
|
||||
z7QF(MZ@%O2{zzXWD3o$dlr)+$QdFwY%c5N?I0B75X-E+19aX7F)dH0^>Z)eEZ=O;~
|
||||
z<?^<VTwP8TfX(4J=(JPOnNc)URn{G8|1eoC_e<>oje1d1%IQ=tmzSkdDoay2=T|Pz
|
||||
zo*8+Kr80%Y79{wyR4)RabV^adFWpeZh73a5P-K`EDzb{C0J1N?-Bg5osvt7$#*LDy
|
||||
z8pU1*;Hb;O`}w=|H2|VCNgvil!C)|-F!4`oOre4(0@l39WM)9+aK3^6G2ryE+cJd2
|
||||
zG%)O}9%o(Xh5+npOk+9dJvA{f4-S<VFd0eu$X<3dd1d+P^3wIkj=-L!jZMnkKb#l4
|
||||
zS%FnoE840>Nl&MqX!&&dnrWK5-2KkXUdJ@kJhZYzBs1%)nFU8yw#)YRc86bC;+Jl5
|
||||
zgy&7Z`^Fw(?OiZUet&)S)$APMGYhtb_713ZrNwu<++Ih39!HYq+wJzw?PH0VT{$4+
|
||||
zz%lmLw7_MJYpy#@2q4sQ7fUP%j9esxG8j3)cOk6*w(m~R0TQqY5H30#e)2t(Pe1U0
|
||||
zo7x9RuwyuZKZc9WF8Sr`COoz9_eZT+t&ggp!nq?r$P9^7Qf{`Z-{X`J#)<@xfTsj3
|
||||
zt7*Z}u%|ZB*f}Q9ILEnRY6A%n(u&6pLLV6Zhn*Je^046bHe3TpU@8gBV?hE)AbtcU
|
||||
z+*`#j(Lf`1Pqq2ly)J6Thrs2aLgj*Tgns-Zu;!m>A1&i8UmxMd)HGfL@L=Np^}xmu
|
||||
z6KnnbWTw9d+eiQj_)Fjmf6b$HBoG*ZvmFNFos+;OYFZqXdWnYd{P*jg`)Jij({(%|
|
||||
z`6Q@2v~b4IiYzkMz+$L)vsWgF{`mxB#u(y$sg7Y3RpU)yZB+QhQ9`d|Ekc6YFM1X7
|
||||
zv7KL!Yu;A|z5IoJ9um0Yp{;0|@_teFTYTByaiWdaEl<FRQ}wer1&gsF0VEJ%0z*Cq
|
||||
zPFzulaPT39=F90?E5wAR)%Dpf=7vno3fVuppO8RoQO7l$E%7!gQ^8*6kwlia=^
|
||||
z7B0VddLMEq9(*#931rOF{~Aj_u33(iBr5k4z;mpAB2(G^Zz{9Kq>+G^1Vp#S{&b=E
|
||||
zj|&}JWy0IK6Ap73lq)qn<QR$RqGeqiso;SyjOXJ#2pdfx0VLp>z?y5#A&T&w<H48c
|
||||
zUiJx|1$vwg0zrO}lpkL`u+~3K_<CVK5ue+x_nNLxR(uXP3g#_eo?nPUW*EaL0(kl}
|
||||
zicZin*SoHPf#Jg+1F=k5r(avNUv|&?^aT4NA<j}5>#6r1;mt7IkM<dnBRjm-J$jnL
|
||||
zl=}L=Xoe&f=@$t@+-3rNH|>W2eFfxdF(5w^x}jvkffEfIvgHNTjXV5+K%<*L3ET_R
|
||||
z+c|c&wLM;PQ@lgr#v_H=NB{{Sfw2f&z<1F4c?Err>gK7){ur^11cD`i`-xzApY~Qf
|
||||
z-Soco%zKmLS;Xfudc5$tj2??=s^NXSD9!fSp38_*Cb5m>t!bHAQk&zN(xREQTJ4>c
|
||||
zC4OI8w7BN_>Y<Q`P|Yl)JEqC+?<=onyWQ@36FPXvI!i<{<A|?8t9(>=zWZjEyWg?)
|
||||
z-~n%be|`1U>>S}U3wvP0@z9kP-|cdH9RYeANt%btP&>Dm_#=s#T{$4+fFnF_9>oX|
|
||||
zooo&c`N+|sIY^}|4akg;3*^W-WYBK!OJAAU-%N9Mt_49ZzRWCquG}WPRkz@uPUllu
|
||||
jIzOMKFSg+CqdL=Mn!K`nb$RLf<M~V>L7{9Vwi5pX0LDXb
|
||||
|
||||
literal 0
|
||||
HcmV?d00001
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,75 @@
|
||||
From 7e5b390a008ccad094a39c350f385d58e8a5102a Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Fri, 3 May 2019 13:57:47 -0600
|
||||
Subject: [PATCH] Remove undefined behavior from IV shifting
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
It is undefined behavior to shift a negative integer to the left. This
|
||||
commit avoids that by treating the value as unsigned, then casting back
|
||||
to integer for return.
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
814735a391b874af8f00eaf89469e5ec7f38cd4aa.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
asan_ignore | 5 -----
|
||||
pp.c | 21 ++++++++++++++++++++-
|
||||
2 files changed, 20 insertions(+), 6 deletions(-)
|
||||
|
||||
diff --git a/asan_ignore b/asan_ignore
|
||||
index e0f5685..f520546 100644
|
||||
--- a/asan_ignore
|
||||
+++ b/asan_ignore
|
||||
@@ -18,11 +18,6 @@
|
||||
|
||||
fun:Perl_pp_i_*
|
||||
|
||||
-# Perl's << is defined as using the underlying C's << operator, with the
|
||||
-# same undefined behaviour for shifts greater than the word size.
|
||||
-# (UVs normally, IVs with 'use integer')
|
||||
-
|
||||
-fun:Perl_pp_left_shift
|
||||
|
||||
# this function numifies the field width in eg printf "%10f".
|
||||
# It has its own overflow detection, so don't warn about it
|
||||
diff --git a/pp.c b/pp.c
|
||||
index 7afb090..3ca04e1 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1991,10 +1991,29 @@ static IV S_iv_shift(IV iv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
+
|
||||
if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return iv < 0 && !left ? -1 : 0;
|
||||
}
|
||||
- return left ? iv << shift : iv >> shift;
|
||||
+ /* For left shifts, perl 5 has chosen to treat the value as unsigned for
|
||||
+ * the * purposes of shifting, then cast back to signed. This is very
|
||||
+ * different from perl 6:
|
||||
+ *
|
||||
+ * $ perl6 -e 'say -2 +< 5'
|
||||
+ * -64
|
||||
+ *
|
||||
+ * $ ./perl -le 'print -2 << 5'
|
||||
+ * 18446744073709551552
|
||||
+ * */
|
||||
+ if (left) {
|
||||
+ if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
|
||||
+ return 0;
|
||||
+ }
|
||||
+ return (IV) (((UV) iv) << shift);
|
||||
+ }
|
||||
+
|
||||
+ /* Here is right shift */
|
||||
+ return iv >> shift;
|
||||
}
|
||||
|
||||
#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,191 @@
|
||||
From 8e9cf86aa69cb79c91edf5ff0586f87bfe4c91bd Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 2 Jul 2019 14:16:35 +1000
|
||||
Subject: [PATCH] (perl #134221) support append mode for open .. undef
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
45b29440d38be155c5177c8d6f9a5d4e7c2c098c.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
doio.c | 15 +++++++++++++++
|
||||
embed.fnc | 1 +
|
||||
perlio.c | 26 +++++++++++++++++++++-----
|
||||
perlio.h | 3 +++
|
||||
proto.h | 5 +++++
|
||||
t/io/perlio_open.t | 14 ++++++++++++--
|
||||
6 files changed, 57 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/doio.c b/doio.c
|
||||
index 05a0696..424e0e3 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -265,6 +265,21 @@ Perl_my_mkstemp_cloexec(char *templte)
|
||||
#endif
|
||||
}
|
||||
|
||||
+int
|
||||
+Perl_my_mkostemp_cloexec(char *templte, int flags)
|
||||
+{
|
||||
+ dVAR;
|
||||
+ PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC;
|
||||
+#if defined(O_CLOEXEC)
|
||||
+ DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
|
||||
+ PL_strategy_mkstemp,
|
||||
+ Perl_my_mkostemp(templte, flags | O_CLOEXEC),
|
||||
+ Perl_my_mkostemp(templte, flags));
|
||||
+#else
|
||||
+ DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags));
|
||||
+#endif
|
||||
+}
|
||||
+
|
||||
#ifdef HAS_PIPE
|
||||
int
|
||||
Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index 259affd..c977d39 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -476,6 +476,7 @@ p |int |PerlLIO_dup2_cloexec|int oldfd|int newfd
|
||||
pR |int |PerlLIO_open_cloexec|NN const char *file|int flag
|
||||
pR |int |PerlLIO_open3_cloexec|NN const char *file|int flag|int perm
|
||||
pnoR |int |my_mkstemp_cloexec|NN char *templte
|
||||
+pnoR |int |my_mkostemp_cloexec|NN char *templte|int flags
|
||||
#ifdef HAS_PIPE
|
||||
pR |int |PerlProc_pipe_cloexec|NN int *pipefd
|
||||
#endif
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index 904d47a..5a0cd36 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -1490,7 +1490,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
|
||||
int imode, int perm, PerlIO *f, int narg, SV **args)
|
||||
{
|
||||
if (!f && narg == 1 && *args == &PL_sv_undef) {
|
||||
- if ((f = PerlIO_tmpfile())) {
|
||||
+ int imode = PerlIOUnix_oflags(mode);
|
||||
+
|
||||
+ if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
|
||||
if (!layers || !*layers)
|
||||
layers = Perl_PerlIO_context_layers(aTHX_ mode);
|
||||
if (layers && *layers)
|
||||
@@ -5048,6 +5050,15 @@ PerlIO_stdoutf(const char *fmt, ...)
|
||||
#undef PerlIO_tmpfile
|
||||
PerlIO *
|
||||
PerlIO_tmpfile(void)
|
||||
+{
|
||||
+ return PerlIO_tmpfile_flags(0);
|
||||
+}
|
||||
+
|
||||
+#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
|
||||
+#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
|
||||
+
|
||||
+PerlIO *
|
||||
+PerlIO_tmpfile_flags(int imode)
|
||||
{
|
||||
#ifndef WIN32
|
||||
dTHX;
|
||||
@@ -5063,27 +5074,32 @@ PerlIO_tmpfile(void)
|
||||
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
|
||||
SV * sv = NULL;
|
||||
int old_umask = umask(0177);
|
||||
+ imode &= ~MKOSTEMP_MODE_MASK;
|
||||
if (tmpdir && *tmpdir) {
|
||||
/* if TMPDIR is set and not empty, we try that first */
|
||||
sv = newSVpv(tmpdir, 0);
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
}
|
||||
if (fd < 0) {
|
||||
SvREFCNT_dec(sv);
|
||||
sv = NULL;
|
||||
/* else we try /tmp */
|
||||
- fd = Perl_my_mkstemp_cloexec(tempname);
|
||||
+ fd = Perl_my_mkostemp_cloexec(tempname, imode);
|
||||
}
|
||||
if (fd < 0) {
|
||||
/* Try cwd */
|
||||
sv = newSVpvs(".");
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
}
|
||||
umask(old_umask);
|
||||
if (fd >= 0) {
|
||||
- f = PerlIO_fdopen(fd, "w+");
|
||||
+ /* fdopen() with a numeric mode */
|
||||
+ char mode[8];
|
||||
+ int writing = 1;
|
||||
+ (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
|
||||
+ f = PerlIO_fdopen(fd, mode);
|
||||
if (f)
|
||||
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
|
||||
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
|
||||
diff --git a/perlio.h b/perlio.h
|
||||
index d515020..ee16ab8 100644
|
||||
--- a/perlio.h
|
||||
+++ b/perlio.h
|
||||
@@ -286,6 +286,9 @@ PERL_CALLCONV SSize_t PerlIO_get_bufsiz(PerlIO *);
|
||||
#ifndef PerlIO_tmpfile
|
||||
PERL_CALLCONV PerlIO *PerlIO_tmpfile(void);
|
||||
#endif
|
||||
+#ifndef PerlIO_tmpfile_flags
|
||||
+PERL_CALLCONV PerlIO *PerlIO_tmpfile_flags(int flags);
|
||||
+#endif
|
||||
#ifndef PerlIO_stdin
|
||||
PERL_CALLCONV PerlIO *PerlIO_stdin(void);
|
||||
#endif
|
||||
diff --git a/proto.h b/proto.h
|
||||
index 74a8e46..e0ea55b 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -2270,6 +2270,11 @@ PERL_CALLCONV Pid_t Perl_my_fork(void);
|
||||
PERL_CALLCONV I32 Perl_my_lstat(pTHX);
|
||||
#endif
|
||||
PERL_CALLCONV I32 Perl_my_lstat_flags(pTHX_ const U32 flags);
|
||||
+PERL_CALLCONV int Perl_my_mkostemp_cloexec(char *templte, int flags)
|
||||
+ __attribute__warn_unused_result__;
|
||||
+#define PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC \
|
||||
+ assert(templte)
|
||||
+
|
||||
PERL_CALLCONV int Perl_my_mkstemp_cloexec(char *templte)
|
||||
__attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC \
|
||||
diff --git a/t/io/perlio_open.t b/t/io/perlio_open.t
|
||||
index 99d7e51..56c354b 100644
|
||||
--- a/t/io/perlio_open.t
|
||||
+++ b/t/io/perlio_open.t
|
||||
@@ -11,7 +11,7 @@ BEGIN {
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
-plan tests => 6;
|
||||
+plan tests => 10;
|
||||
|
||||
use Fcntl qw(:seek);
|
||||
|
||||
@@ -31,6 +31,16 @@ use Fcntl qw(:seek);
|
||||
is($data, "the right read stuff", "found the right stuff");
|
||||
}
|
||||
|
||||
-
|
||||
+SKIP:
|
||||
+{
|
||||
+ ok((open my $fh, "+>>", undef), "open my \$fh, '+>>', undef")
|
||||
+ or skip "can't open temp for append: $!", 3;
|
||||
+ print $fh "abc";
|
||||
+ ok(seek($fh, 0, SEEK_SET), "seek to zero");
|
||||
+ print $fh "xyz";
|
||||
+ ok(seek($fh, 0, SEEK_SET), "seek to zero again");
|
||||
+ my $data = <$fh>;
|
||||
+ is($data, "abcxyz", "check the second write appended");
|
||||
+}
|
||||
|
||||
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,102 @@
|
||||
From 3f8dbf40138bd2bcb569b23c88888a41ede9c355 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 5 Aug 2019 15:23:45 +1000
|
||||
Subject: [PATCH] (perl #134266) make sure $@ is writable when we write to it
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
when unwinding.
|
||||
|
||||
Since except_sv might be ERRSV we try to preserve it's value,
|
||||
if not the actual SV (which we have an extra refcount on if it is
|
||||
except_sv).
|
||||
|
||||
Petr Písař: Ported to 5.30.0 from
|
||||
933e3e630076d4fdbe32a101eeb5f12e37ec4ac2.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perl.h | 17 +++++++++++++++++
|
||||
pp_ctl.c | 10 ++++++++--
|
||||
t/lib/croak/pp_ctl | 8 ++++++++
|
||||
3 files changed, 33 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/perl.h b/perl.h
|
||||
index e5a5585..383487c 100644
|
||||
--- a/perl.h
|
||||
+++ b/perl.h
|
||||
@@ -1357,6 +1357,23 @@ EXTERN_C char *crypt(const char *, const char *);
|
||||
} \
|
||||
} STMT_END
|
||||
|
||||
+/* contains inlined gv_add_by_type */
|
||||
+#define SANE_ERRSV() STMT_START { \
|
||||
+ SV ** const svp = &GvSV(PL_errgv); \
|
||||
+ if (!*svp) { \
|
||||
+ *svp = newSVpvs(""); \
|
||||
+ } else if (SvREADONLY(*svp)) { \
|
||||
+ SV *dupsv = newSVsv(*svp); \
|
||||
+ SvREFCNT_dec_NN(*svp); \
|
||||
+ *svp = dupsv; \
|
||||
+ } else { \
|
||||
+ SV *const errsv = *svp; \
|
||||
+ if (SvMAGICAL(errsv)) { \
|
||||
+ mg_free(errsv); \
|
||||
+ } \
|
||||
+ } \
|
||||
+ } STMT_END
|
||||
+
|
||||
|
||||
#ifdef PERL_CORE
|
||||
# define DEFSV (0 + GvSVn(PL_defgv))
|
||||
diff --git a/pp_ctl.c b/pp_ctl.c
|
||||
index a38b9c1..1f2d812 100644
|
||||
--- a/pp_ctl.c
|
||||
+++ b/pp_ctl.c
|
||||
@@ -1720,9 +1720,13 @@ Perl_die_unwind(pTHX_ SV *msv)
|
||||
* perls 5.13.{1..7} which had late setting of $@ without this
|
||||
* early-setting hack.
|
||||
*/
|
||||
- if (!(in_eval & EVAL_KEEPERR))
|
||||
+ if (!(in_eval & EVAL_KEEPERR)) {
|
||||
+ /* remove any read-only/magic from the SV, so we don't
|
||||
+ get infinite recursion when setting ERRSV */
|
||||
+ SANE_ERRSV();
|
||||
sv_setsv_flags(ERRSV, exceptsv,
|
||||
(SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
|
||||
+ }
|
||||
|
||||
if (in_eval & EVAL_KEEPERR) {
|
||||
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
|
||||
@@ -1784,8 +1788,10 @@ Perl_die_unwind(pTHX_ SV *msv)
|
||||
*/
|
||||
S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
|
||||
|
||||
- if (!(in_eval & EVAL_KEEPERR))
|
||||
+ if (!(in_eval & EVAL_KEEPERR)) {
|
||||
+ SANE_ERRSV();
|
||||
sv_setsv(ERRSV, exceptsv);
|
||||
+ }
|
||||
PL_restartjmpenv = restartjmpenv;
|
||||
PL_restartop = restartop;
|
||||
JMPENV_JUMP(3);
|
||||
diff --git a/t/lib/croak/pp_ctl b/t/lib/croak/pp_ctl
|
||||
index b1e754c..de0221b 100644
|
||||
--- a/t/lib/croak/pp_ctl
|
||||
+++ b/t/lib/croak/pp_ctl
|
||||
@@ -51,3 +51,11 @@ use 5.01;
|
||||
default{}
|
||||
EXPECT
|
||||
Can't "default" outside a topicalizer at - line 2.
|
||||
+########
|
||||
+# NAME croak with read only $@
|
||||
+eval '"a" =~ /${*@=\_})/';
|
||||
+die;
|
||||
+# this would previously recurse infinitely in the eval
|
||||
+EXPECT
|
||||
+Unmatched ) in regex; marked by <-- HERE in m/_) <-- HERE / at (eval 1) line 1.
|
||||
+ ...propagated at - line 2.
|
||||
--
|
||||
2.21.0
|
||||
|
42
SOURCES/perl-5.30.0-pp.c-Add-two-UNLIKELY-s.patch
Normal file
42
SOURCES/perl-5.30.0-pp.c-Add-two-UNLIKELY-s.patch
Normal file
@ -0,0 +1,42 @@
|
||||
From 4f0ded009bf6de2da6a2a2022bec03576dcb80ca Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Wed, 1 May 2019 10:41:38 -0600
|
||||
Subject: [PATCH] pp.c: Add two UNLIKELY()s
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
It should be uncommon to shift beyond a full word
|
||||
|
||||
Signed-off-by: Ported to 5.30.0 from
|
||||
bae047b68c92622bb4bb04499e36cdaa48138909.
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp.c | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pp.c b/pp.c
|
||||
index 90db3a0..7afb090 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1979,7 +1979,7 @@ static UV S_uv_shift(UV uv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
- if (shift >= IV_BITS) {
|
||||
+ if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return 0;
|
||||
}
|
||||
return left ? uv << shift : uv >> shift;
|
||||
@@ -1991,7 +1991,7 @@ static IV S_iv_shift(IV iv, int shift, bool left)
|
||||
shift = -shift;
|
||||
left = !left;
|
||||
}
|
||||
- if (shift >= IV_BITS) {
|
||||
+ if (UNLIKELY(shift >= IV_BITS)) {
|
||||
return iv < 0 && !left ? -1 : 0;
|
||||
}
|
||||
return left ? iv << shift : iv >> shift;
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,47 @@
|
||||
From a0148bb8496444302b087bc0ffcf8dad42f8e475 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 11 Nov 2019 14:43:42 +1100
|
||||
Subject: [PATCH] handle s being updated without len being updated
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
fix #17279
|
||||
|
||||
Petr Písař: Ported to 5.30.1 from
|
||||
e56dfd967ce460481a9922d14e931b438548093d.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
numeric.c | 2 +-
|
||||
t/lib/croak/regcomp | 4 ++++
|
||||
2 files changed, 5 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/numeric.c b/numeric.c
|
||||
index d6ce53e..35adebe 100644
|
||||
--- a/numeric.c
|
||||
+++ b/numeric.c
|
||||
@@ -1552,7 +1552,7 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
|
||||
/* strtold() accepts 0x-prefixed hex and in POSIX implementations,
|
||||
0b-prefixed binary numbers, which is backward incompatible
|
||||
*/
|
||||
- if ((len == 0 || len >= 2) && *s == '0' &&
|
||||
+ if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
|
||||
(isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
|
||||
*value = 0;
|
||||
return (char *)s+1;
|
||||
diff --git a/t/lib/croak/regcomp b/t/lib/croak/regcomp
|
||||
index 0ba705e..c0c2710 100644
|
||||
--- a/t/lib/croak/regcomp
|
||||
+++ b/t/lib/croak/regcomp
|
||||
@@ -70,3 +70,7 @@ qr/((a))/;
|
||||
EXPECT
|
||||
Too many nested open parens in regex; marked by <-- HERE in m/(( <-- HERE a))/ at - line 3.
|
||||
########
|
||||
+# NAME numeric parsing buffer overflow in numeric.c
|
||||
+0=~/\p{nV:-0}/
|
||||
+EXPECT
|
||||
+Can't find Unicode property definition "nV:-0" in regex; marked by <-- HERE in m/\p{nV:-0} <-- HERE / at - line 1.
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,116 @@
|
||||
From b061e315b4eac4d82edb3ca14581805417a68936 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 11 Sep 2019 11:50:23 +1000
|
||||
Subject: [PATCH] (perl #125557) correctly handle overload for bin/oct floats
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The hexfp code doesn't check that the shift is 4, and so also
|
||||
accepts binary and octal fp numbers.
|
||||
|
||||
Unfortunately the call to S_new_constant() always passed a prefix
|
||||
of 0x, so overloading would be trying to parse the wrong number.
|
||||
|
||||
Another option is to simply allow only hex floats, though some work
|
||||
was done in 131894 to improve oct/bin float support.
|
||||
|
||||
Petr Písař: Ported to 5.30.1 from
|
||||
2cb5a7e8af11acb0eca22421ec5a4df7ef18e2a9.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/hexfp.t | 16 +++++++++++++++-
|
||||
toke.c | 21 ++++++++++++++++-----
|
||||
2 files changed, 31 insertions(+), 6 deletions(-)
|
||||
|
||||
diff --git a/t/op/hexfp.t b/t/op/hexfp.t
|
||||
index 64f8136..0f239d4 100644
|
||||
--- a/t/op/hexfp.t
|
||||
+++ b/t/op/hexfp.t
|
||||
@@ -10,7 +10,7 @@ use strict;
|
||||
|
||||
use Config;
|
||||
|
||||
-plan(tests => 123);
|
||||
+plan(tests => 125);
|
||||
|
||||
# Test hexfloat literals.
|
||||
|
||||
@@ -277,6 +277,20 @@ is(0b1p0, 1);
|
||||
is(0b10p0, 2);
|
||||
is(0b1.1p0, 1.5);
|
||||
|
||||
+# previously these would pass "0x..." to the overload instead of the appropriate
|
||||
+# "0b" or "0" prefix.
|
||||
+fresh_perl_is(<<'CODE', "1", {}, "overload binary fp");
|
||||
+use overload;
|
||||
+BEGIN { overload::constant float => sub { return eval $_[0]; }; }
|
||||
+print 0b0.1p1;
|
||||
+CODE
|
||||
+
|
||||
+fresh_perl_is(<<'CODE', "1", {}, "overload octal fp");
|
||||
+use overload;
|
||||
+BEGIN { overload::constant float => sub { return eval $_[0]; }; }
|
||||
+print 00.1p3;
|
||||
+CODE
|
||||
+
|
||||
# sprintf %a/%A testing is done in sprintf2.t,
|
||||
# trickier than necessary because of long doubles,
|
||||
# and because looseness of the spec.
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 03c4f2b..3fa20dc 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -10966,6 +10966,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
const char *lastub = NULL; /* position of last underbar */
|
||||
static const char* const number_too_long = "Number too long";
|
||||
bool warned_about_underscore = 0;
|
||||
+ I32 shift; /* shift per digit for hex/oct/bin, hoisted here for fp */
|
||||
#define WARN_ABOUT_UNDERSCORE() \
|
||||
do { \
|
||||
if (!warned_about_underscore) { \
|
||||
@@ -11012,8 +11013,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
{
|
||||
/* variables:
|
||||
u holds the "number so far"
|
||||
- shift the power of 2 of the base
|
||||
- (hex == 4, octal == 3, binary == 1)
|
||||
overflowed was the number more than we can hold?
|
||||
|
||||
Shift is used when we add a digit. It also serves as an "are
|
||||
@@ -11022,7 +11021,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
*/
|
||||
NV n = 0.0;
|
||||
UV u = 0;
|
||||
- I32 shift;
|
||||
bool overflowed = FALSE;
|
||||
bool just_zero = TRUE; /* just plain 0 or binary number? */
|
||||
static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
|
||||
@@ -11369,8 +11367,21 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
|
||||
if (hexfp) {
|
||||
floatit = TRUE;
|
||||
*d++ = '0';
|
||||
- *d++ = 'x';
|
||||
- s = start + 2;
|
||||
+ switch (shift) {
|
||||
+ case 4:
|
||||
+ *d++ = 'x';
|
||||
+ s = start + 2;
|
||||
+ break;
|
||||
+ case 3:
|
||||
+ s = start + 1;
|
||||
+ break;
|
||||
+ case 1:
|
||||
+ *d++ = 'b';
|
||||
+ s = start + 2;
|
||||
+ break;
|
||||
+ default:
|
||||
+ NOT_REACHED; /* NOTREACHED */
|
||||
+ }
|
||||
}
|
||||
|
||||
/* read next group of digits and _ and copy into d */
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,85 @@
|
||||
From 1a1d29aaa2e0c668f9a8c960d52b516415f28983 Mon Sep 17 00:00:00 2001
|
||||
From: Vickenty Fesunov <kent@setattr.net>
|
||||
Date: Fri, 22 Sep 2017 19:00:46 -0400
|
||||
Subject: [PATCH] %{^CAPTURE_ALL} was intended to be an alias for %-; make it
|
||||
so.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
For: RT #131867
|
||||
|
||||
Add Vickenty Fesunov to AUTHORS.
|
||||
|
||||
Signed-off-by: Ported to 5.30 from 1a1d29aaa2e0c668f9a8c960d52b516415f28983.
|
||||
|
||||
---
|
||||
AUTHORS | 1 +
|
||||
ext/Tie-Hash-NamedCapture/NamedCapture.xs | 5 ++++-
|
||||
ext/Tie-Hash-NamedCapture/t/tiehash.t | 11 ++++++++---
|
||||
|
||||
diff --git a/AUTHORS b/AUTHORS
|
||||
index 0091100600..c920d52e96 100644
|
||||
--- a/AUTHORS
|
||||
+++ b/AUTHORS
|
||||
@@ -1265,6 +1265,7 @@ Unicode Consortium <unicode.org>
|
||||
Vadim Konovalov <vkonovalov@lucent.com>
|
||||
Valeriy E. Ushakov <uwe@ptc.spbu.ru>
|
||||
Vernon Lyon <vlyon@cpan.org>
|
||||
+Vickenty Fesunov <kent@setattr.net>
|
||||
Victor Adam <victor@drawall.cc>
|
||||
Victor Efimov <victor@vsespb.ru>
|
||||
Viktor Turskyi <koorchik@gmail.com>
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/NamedCapture.xs b/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
index 7eaae5614d..a607c10090 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
+++ b/ext/Tie-Hash-NamedCapture/NamedCapture.xs
|
||||
@@ -25,8 +25,11 @@ _tie_it(SV *sv)
|
||||
GV * const gv = (GV *)sv;
|
||||
HV * const hv = GvHVn(gv);
|
||||
SV *rv = newSV_type(SVt_RV);
|
||||
+ const char *gv_name = GvNAME(gv);
|
||||
CODE:
|
||||
- SvRV_set(rv, newSVuv(*GvNAME(gv) == '-' ? RXapif_ALL : RXapif_ONE));
|
||||
+ SvRV_set(rv, newSVuv(
|
||||
+ strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
|
||||
+ ? RXapif_ALL : RXapif_ONE));
|
||||
SvROK_on(rv);
|
||||
sv_bless(rv, GvSTASH(CvGV(cv)));
|
||||
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/t/tiehash.t b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
index 3ebc81ad68..962754085f 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
+++ b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
@@ -3,7 +3,12 @@ use strict;
|
||||
|
||||
use Test::More;
|
||||
|
||||
-my %hashes = ('+' => \%+, '-' => \%-);
|
||||
+my %hashes = (
|
||||
+ '+' => \%+,
|
||||
+ '-' => \%-,
|
||||
+ '{^CAPTURE}' => \%{^CAPTURE},
|
||||
+ '{^CAPTURE_ALL}' => \%{^CAPTURE_ALL},
|
||||
+);
|
||||
|
||||
foreach (['plus1'],
|
||||
['minus1', all => 1],
|
||||
@@ -20,12 +25,12 @@ foreach (['plus1'],
|
||||
is("abcdef" =~ /(?<foo>[ab])*(?<bar>c)(?<foo>d)(?<bar>[ef]*)/, 1,
|
||||
"We matched");
|
||||
|
||||
-foreach my $name (qw(+ plus1 plus2 plus3)) {
|
||||
+foreach my $name (qw(+ {^CAPTURE} plus1 plus2 plus3)) {
|
||||
my $hash = $hashes{$name};
|
||||
is_deeply($hash, { foo => 'b', bar => 'c' }, "%$name is as expected");
|
||||
}
|
||||
|
||||
-foreach my $name (qw(- minus1 minus2)) {
|
||||
+foreach my $name (qw(- {^CAPTURE_ALL} minus1 minus2)) {
|
||||
my $hash = $hashes{$name};
|
||||
is_deeply($hash, { foo => [qw(b d)], bar => [qw(c ef)] },
|
||||
"%$name is as expected");
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,181 @@
|
||||
From 3a019afd6f6291c3249c254b5c01e244e4ec83ab Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sun, 28 Apr 2019 17:42:44 -0600
|
||||
Subject: [PATCH 1/3] Create fcn for lossless conversion of NV to IV
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Essentially the same code was being used in three places, and had
|
||||
undefined C behavior for some inputs.
|
||||
|
||||
This consolidates the code into one inline function, and rewrites it to
|
||||
avoid undefined behavior.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
embed.fnc | 1 +
|
||||
embed.h | 3 +++
|
||||
inline.h | 34 ++++++++++++++++++++++++++++++++++
|
||||
pp.c | 20 ++++----------------
|
||||
pp_hot.c | 10 ++--------
|
||||
proto.h | 7 +++++++
|
||||
6 files changed, 51 insertions(+), 24 deletions(-)
|
||||
|
||||
diff --git a/embed.fnc b/embed.fnc
|
||||
index 45597f67b6..259affded0 100644
|
||||
--- a/embed.fnc
|
||||
+++ b/embed.fnc
|
||||
@@ -2272,6 +2272,7 @@ sR |SV* |refto |NN SV* sv
|
||||
: Used in pp_hot.c
|
||||
pRxo |GV* |softref2xv |NN SV *const sv|NN const char *const what \
|
||||
|const svtype type|NN SV ***spp
|
||||
+inR |bool |lossless_NV_to_IV|const NV nv|NN IV * ivp
|
||||
#endif
|
||||
|
||||
#if defined(PERL_IN_PP_PACK_C)
|
||||
diff --git a/embed.h b/embed.h
|
||||
index 75c91f77f4..9178c51e92 100644
|
||||
--- a/embed.h
|
||||
+++ b/embed.h
|
||||
@@ -1924,6 +1924,9 @@
|
||||
#define do_delete_local() S_do_delete_local(aTHX)
|
||||
#define refto(a) S_refto(aTHX_ a)
|
||||
# endif
|
||||
+# if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+#define lossless_NV_to_IV S_lossless_NV_to_IV
|
||||
+# endif
|
||||
# if defined(PERL_IN_PP_CTL_C)
|
||||
#define check_type_and_open(a) S_check_type_and_open(aTHX_ a)
|
||||
#define destroy_matcher(a) S_destroy_matcher(aTHX_ a)
|
||||
diff --git a/inline.h b/inline.h
|
||||
index 654f801b75..de1e33e8ce 100644
|
||||
--- a/inline.h
|
||||
+++ b/inline.h
|
||||
@@ -1913,6 +1913,40 @@ S_should_warn_nl(const char *pv) {
|
||||
|
||||
#endif
|
||||
|
||||
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+
|
||||
+PERL_STATIC_INLINE bool
|
||||
+S_lossless_NV_to_IV(const NV nv, IV *ivp)
|
||||
+{
|
||||
+ /* This function determines if the input NV 'nv' may be converted without
|
||||
+ * loss of data to an IV. If not, it returns FALSE taking no other action.
|
||||
+ * But if it is possible, it does the conversion, returning TRUE, and
|
||||
+ * storing the converted result in '*ivp' */
|
||||
+
|
||||
+ PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
|
||||
+
|
||||
+# if defined(Perl_isnan)
|
||||
+
|
||||
+ if (UNLIKELY(Perl_isnan(nv))) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+# endif
|
||||
+
|
||||
+ if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+ if ((IV) nv != nv) {
|
||||
+ return FALSE;
|
||||
+ }
|
||||
+
|
||||
+ *ivp = (IV) nv;
|
||||
+ return TRUE;
|
||||
+}
|
||||
+
|
||||
+#endif
|
||||
+
|
||||
/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
|
||||
|
||||
#define MAX_CHARSET_NAME_LENGTH 2
|
||||
diff --git a/pp.c b/pp.c
|
||||
index c89cb7198c..0956121b27 100644
|
||||
--- a/pp.c
|
||||
+++ b/pp.c
|
||||
@@ -1268,16 +1268,10 @@ PP(pp_multiply)
|
||||
NV nr = SvNVX(svr);
|
||||
NV result;
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
result = nl * nr;
|
||||
# if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
|
||||
@@ -1849,16 +1843,10 @@ PP(pp_subtract)
|
||||
NV nl = SvNVX(svl);
|
||||
NV nr = SvNVX(svr);
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
|
||||
SETs(TARG);
|
||||
diff --git a/pp_hot.c b/pp_hot.c
|
||||
index 7d5ffc02fd..2df5df8303 100644
|
||||
--- a/pp_hot.c
|
||||
+++ b/pp_hot.c
|
||||
@@ -1435,16 +1435,10 @@ PP(pp_add)
|
||||
NV nl = SvNVX(svl);
|
||||
NV nr = SvNVX(svr);
|
||||
|
||||
- if (
|
||||
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
|
||||
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
|
||||
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
|
||||
-#else
|
||||
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
|
||||
-#endif
|
||||
- )
|
||||
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
|
||||
/* nothing was lost by converting to IVs */
|
||||
goto do_iv;
|
||||
+ }
|
||||
SP--;
|
||||
TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
|
||||
SETs(TARG);
|
||||
diff --git a/proto.h b/proto.h
|
||||
index 0f8feed187..74a8e46ab7 100644
|
||||
--- a/proto.h
|
||||
+++ b/proto.h
|
||||
@@ -5224,6 +5224,13 @@ STATIC SV* S_refto(pTHX_ SV* sv)
|
||||
|
||||
#endif
|
||||
#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
|
||||
+#ifndef PERL_NO_INLINE_FUNCTIONS
|
||||
+PERL_STATIC_INLINE bool S_lossless_NV_to_IV(const NV nv, IV * ivp)
|
||||
+ __attribute__warn_unused_result__;
|
||||
+#define PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV \
|
||||
+ assert(ivp)
|
||||
+#endif
|
||||
+
|
||||
PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const svtype type, SV ***spp)
|
||||
__attribute__warn_unused_result__;
|
||||
#define PERL_ARGS_ASSERT_SOFTREF2XV \
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,87 @@
|
||||
From 1d31efef7dd4388fd606972e67bda3318e8838fe Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= <ilmari@ilmari.org>
|
||||
Date: Tue, 21 May 2019 17:34:49 +0100
|
||||
Subject: [PATCH] Don't use PL_check[op_type] to check for filetets ops to
|
||||
stack
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This breaks hooking the filetest ops' check function by modules like
|
||||
bareword::filehandles. Instead use the OP_IS_FILETEST() macro to decide
|
||||
check for filetest ops. Also add an OP_IS_STAT() macro for when we want
|
||||
to check for (l)stat as well as the filetest ops.
|
||||
|
||||
c.f. https://rt.cpan.org/Ticket/Display.html?id=127073
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 11 ++++-------
|
||||
op.h | 2 ++
|
||||
regen/opcodes | 1 +
|
||||
3 files changed, 7 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index 29181ba731..dba7ac7fea 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -991,8 +991,7 @@ Perl_op_clear(pTHX_ OP *o)
|
||||
o->op_targ = 0;
|
||||
break;
|
||||
default:
|
||||
- if (!(o->op_flags & OPf_REF)
|
||||
- || (PL_check[o->op_type] != Perl_ck_ftst))
|
||||
+ if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
|
||||
break;
|
||||
/* FALLTHROUGH */
|
||||
case OP_GVSV:
|
||||
@@ -4413,8 +4412,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
|
||||
/* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
|
||||
their argument is a filehandle; thus \stat(".") should not set
|
||||
it. AMS 20011102 */
|
||||
- if (type == OP_REFGEN &&
|
||||
- PL_check[o->op_type] == Perl_ck_ftst)
|
||||
+ if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
|
||||
return o;
|
||||
|
||||
if (type != OP_LEAVESUBLV)
|
||||
@@ -11696,9 +11694,8 @@ Perl_ck_ftst(pTHX_ OP *o)
|
||||
scalar((OP *) kid);
|
||||
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
|
||||
o->op_private |= OPpFT_ACCESS;
|
||||
- if (type != OP_STAT && type != OP_LSTAT
|
||||
- && PL_check[kidtype] == Perl_ck_ftst
|
||||
- && kidtype != OP_STAT && kidtype != OP_LSTAT
|
||||
+ if (OP_IS_FILETEST(type)
|
||||
+ && OP_IS_FILETEST(kidtype)
|
||||
) {
|
||||
o->op_private |= OPpFT_STACKED;
|
||||
kid->op_private |= OPpFT_STACKING;
|
||||
diff --git a/op.h b/op.h
|
||||
index c9f05b2271..ad6cf7fe49 100644
|
||||
--- a/op.h
|
||||
+++ b/op.h
|
||||
@@ -1021,6 +1021,8 @@ C<sib> is non-null. For a higher-level interface, see C<L</op_sibling_splice>>.
|
||||
#define OP_TYPE_ISNT_AND_WASNT(o, type) \
|
||||
( (o) && OP_TYPE_ISNT_AND_WASNT_NN(o, type) )
|
||||
|
||||
+/* should match anything that uses ck_ftst in regen/opcodes */
|
||||
+#define OP_IS_STAT(op) (OP_IS_FILETEST(op) || (op) == OP_LSTAT || (op) == OP_STAT)
|
||||
|
||||
# define OpHAS_SIBLING(o) (cBOOL((o)->op_moresib))
|
||||
# define OpSIBLING(o) (0 + (o)->op_moresib ? (o)->op_sibparent : NULL)
|
||||
diff --git a/regen/opcodes b/regen/opcodes
|
||||
index b4bf904fdc..4e8236947a 100644
|
||||
--- a/regen/opcodes
|
||||
+++ b/regen/opcodes
|
||||
@@ -397,6 +397,7 @@ getsockname getsockname ck_fun is% Fs
|
||||
getpeername getpeername ck_fun is% Fs
|
||||
|
||||
# Stat calls. OP_IS_FILETEST wants them consecutive.
|
||||
+# Also needs to match OP_IS_STAT() in op.h
|
||||
|
||||
lstat lstat ck_ftst u- F?
|
||||
stat stat ck_ftst u- F?
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,75 @@
|
||||
From cc16d262eb72677cdda2aa9395e943818b85ba38 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 29 Apr 2019 15:24:18 -0600
|
||||
Subject: [PATCH] PATCH: [perl #134059] panic outputting a warning
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This was due to a logic error on my part. We need to save and restore a
|
||||
value. Instead, it was getting restored to the wrong value.
|
||||
|
||||
This particular instance of the bug was outputting a fatal error
|
||||
message, so that the only harm is not giving the user the correct info,
|
||||
and creating unnecessary work for them and us when it gets reported.
|
||||
But this bug could manifest itself when trying to output just a warning
|
||||
that the program otherwise would carry on from.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 12 ++++++++++--
|
||||
t/re/reg_mesg.t | 1 +
|
||||
2 files changed, 11 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 3ad09c52b2..1c54fe3f38 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -131,6 +131,8 @@ struct RExC_state_t {
|
||||
char *parse; /* Input-scan pointer. */
|
||||
char *copy_start; /* start of copy of input within
|
||||
constructed parse string */
|
||||
+ char *save_copy_start; /* Provides one level of saving
|
||||
+ and restoring 'copy_start' */
|
||||
char *copy_start_in_input; /* Position in input string
|
||||
corresponding to copy_start */
|
||||
SSize_t whilem_seen; /* number of WHILEM in this expr */
|
||||
@@ -229,6 +231,7 @@ struct RExC_state_t {
|
||||
#define RExC_precomp (pRExC_state->precomp)
|
||||
#define RExC_copy_start_in_input (pRExC_state->copy_start_in_input)
|
||||
#define RExC_copy_start_in_constructed (pRExC_state->copy_start)
|
||||
+#define RExC_save_copy_start_in_constructed (pRExC_state->save_copy_start)
|
||||
#define RExC_precomp_end (pRExC_state->precomp_end)
|
||||
#define RExC_rx_sv (pRExC_state->rx_sv)
|
||||
#define RExC_rx (pRExC_state->rx)
|
||||
@@ -821,8 +824,13 @@ static const scan_data_t zero_scan_data = {
|
||||
} STMT_END
|
||||
|
||||
/* Setting this to NULL is a signal to not output warnings */
|
||||
-#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE RExC_copy_start_in_constructed = NULL
|
||||
-#define RESTORE_WARNINGS RExC_copy_start_in_constructed = RExC_precomp
|
||||
+#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE \
|
||||
+ STMT_START { \
|
||||
+ RExC_save_copy_start_in_constructed = RExC_copy_start_in_constructed;\
|
||||
+ RExC_copy_start_in_constructed = NULL; \
|
||||
+ } STMT_END
|
||||
+#define RESTORE_WARNINGS \
|
||||
+ RExC_copy_start_in_constructed = RExC_save_copy_start_in_constructed
|
||||
|
||||
/* Since a warning can be generated multiple times as the input is reparsed, we
|
||||
* output it the first time we come to that point in the parse, but suppress it
|
||||
diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t
|
||||
index c5c79f0323..d10fa2c09a 100644
|
||||
--- a/t/re/reg_mesg.t
|
||||
+++ b/t/re/reg_mesg.t
|
||||
@@ -318,6 +318,7 @@ my @death =
|
||||
'/\p{Is_Other_Alphabetic=F}/ ' => 'Can\'t find Unicode property definition "Is_Other_Alphabetic=F" {#} m/\p{Is_Other_Alphabetic=F}{#}/',
|
||||
'/\x{100}(?(/' => 'Unknown switch condition (?(...)) {#} m/\\x{100}(?({#}/', # [perl #133896]
|
||||
'/(?[\N{KEYCAP DIGIT NINE}/' => '\N{} in inverted character class or as a range end-point is restricted to one character {#} m/(?[\\N{U+39.FE0F.20E3{#}}/', # [perl #133988]
|
||||
+ '/0000000000000000[\N{U+0.00}0000/' => 'Unmatched [ {#} m/0000000000000000[{#}\N{U+0.00}0000/', # [perl #134059]
|
||||
);
|
||||
|
||||
# These are messages that are death under 'use re "strict"', and may or may
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,49 @@
|
||||
From 89f69032d6a71f41b96ae6becbf3df4e2f9509a5 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 27 Apr 2019 13:56:39 -0600
|
||||
Subject: [PATCH] S_scan_const() Properly test if need to grow
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
As we parse the input, creating a string constant, we may have to grow
|
||||
the destination if it fills up as we go along. It allocates space in an
|
||||
SV and populates the string, but it doesn' update the SvCUR until the
|
||||
end, so in single stepping the debugger through the code, the SV looks
|
||||
empty until the end. It turns out that as a result SvEND also doesn't
|
||||
get updated and still points to the beginning of the string until SvCUR
|
||||
is finally set. That means that the test changed by this commit was
|
||||
always succeeding, because it was using SvEND that didn't get updated,
|
||||
so it would attempt to grow each time through the loop. By moving a
|
||||
couple of statements earlier, and using SvLEN instead, which does always
|
||||
have the correct value, those extra growth attempts are avoided.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
toke.c | 10 ++++++----
|
||||
1 file changed, 6 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 68eea0cae6..03c4f2ba26 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -4097,10 +4097,12 @@ S_scan_const(pTHX_ char *start)
|
||||
goto default_action; /* Redo, having upgraded so both are UTF-8 */
|
||||
}
|
||||
else { /* UTF8ness matters: convert this non-UTF8 source char to
|
||||
- UTF-8 for output. It will occupy 2 bytes */
|
||||
- if (d + 2 >= SvEND(sv)) {
|
||||
- const STRLEN extra = 2 + (send - s - 1) + 1;
|
||||
- const STRLEN off = d - SvPVX_const(sv);
|
||||
+ UTF-8 for output. It will occupy 2 bytes, but don't include
|
||||
+ the input byte since we haven't incremented 's' yet. See
|
||||
+ Note on sizing above. */
|
||||
+ const STRLEN off = d - SvPVX(sv);
|
||||
+ const STRLEN extra = 2 + (send - s - 1) + 1;
|
||||
+ if (off + extra > SvLEN(sv)) {
|
||||
d = off + SvGROW(sv, off + extra);
|
||||
}
|
||||
*d++ = UTF8_EIGHT_BIT_HI(*s);
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,70 @@
|
||||
From 35608a1658fe75c79ca53d96aea6cf7cb2a98615 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 9 May 2019 09:52:30 +1000
|
||||
Subject: [PATCH] (perl #122112) a simpler fix for pclose() aborted by a signal
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This change results in a zombie child process for the lifetime of
|
||||
the process, but I think that's the responsibility of the signal
|
||||
handler that aborted pclose().
|
||||
|
||||
We could add some magic to retry (and retry and retry) waiting on
|
||||
child process as we rewind (since there's no other way to remove
|
||||
the zombie), but the program has chosen implicitly to abort the
|
||||
wait() done by pclose() and it's best to honor that.
|
||||
|
||||
If we do choose to retry the wait() we might be blocking an attempt
|
||||
by the process to terminate, whether by exit() or die().
|
||||
|
||||
If a program does need more flexible handling there's always
|
||||
pipe()/fork()/exec() and/or the various event-driven frameworks on
|
||||
CPAN.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
doio.c | 12 +++++++++++-
|
||||
t/io/pipe.t | 2 --
|
||||
2 files changed, 11 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/doio.c b/doio.c
|
||||
index 0cc4e55404..05a06968dc 100644
|
||||
--- a/doio.c
|
||||
+++ b/doio.c
|
||||
@@ -1779,7 +1779,17 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
|
||||
|
||||
if (IoIFP(io)) {
|
||||
if (IoTYPE(io) == IoTYPE_PIPE) {
|
||||
- const int status = PerlProc_pclose(IoIFP(io));
|
||||
+ PerlIO *fh = IoIFP(io);
|
||||
+ int status;
|
||||
+
|
||||
+ /* my_pclose() can propagate signals which might bypass any code
|
||||
+ after the call here if the signal handler throws an exception.
|
||||
+ This would leave the handle in the IO object and try to close it again
|
||||
+ when the SV is destroyed on unwind or global destruction.
|
||||
+ So NULL it early.
|
||||
+ */
|
||||
+ IoOFP(io) = IoIFP(io) = NULL;
|
||||
+ status = PerlProc_pclose(fh);
|
||||
if (not_implicit) {
|
||||
STATUS_NATIVE_CHILD_SET(status);
|
||||
retval = (STATUS_UNIX == 0);
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index 1d01db6af6..fc3071300d 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -255,9 +255,7 @@ close \$fh;
|
||||
PROG
|
||||
print $prog;
|
||||
my $out = fresh_perl($prog, {});
|
||||
- $::TODO = "not fixed yet";
|
||||
cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
- undef $::TODO;
|
||||
# checks that that program did something rather than failing to
|
||||
# compile
|
||||
cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,28 @@
|
||||
From 2fe0d7f40a94163d6c242c3e695fdcd19e387422 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 11 Jun 2019 14:59:23 +1000
|
||||
Subject: [PATCH] (perl #122112) remove some interfering debug output
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/io/pipe.t | 1 -
|
||||
1 file changed, 1 deletion(-)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index fc3071300d..9f5bb3bcf8 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -253,7 +253,6 @@ my \$cmd = qq(\$Perl -e "sleep 3");
|
||||
my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
|
||||
close \$fh;
|
||||
PROG
|
||||
- print $prog;
|
||||
my $out = fresh_perl($prog, {});
|
||||
cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
# checks that that program did something rather than failing to
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,54 @@
|
||||
From fb5e77103dd443cc2112ba14dc665aa5ec072ce6 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 30 May 2018 14:03:04 +1000
|
||||
Subject: [PATCH] (perl #122112) test for signal handler death in pclose
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/io/pipe.t | 23 ++++++++++++++++++++++-
|
||||
1 file changed, 22 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index f9ee65afe8..1d01db6af6 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -10,7 +10,7 @@ if (!$Config{'d_fork'}) {
|
||||
skip_all("fork required to pipe");
|
||||
}
|
||||
else {
|
||||
- plan(tests => 25);
|
||||
+ plan(tests => 27);
|
||||
}
|
||||
|
||||
my $Perl = which_perl();
|
||||
@@ -241,3 +241,24 @@ SKIP: {
|
||||
|
||||
is($child, -1, 'child reaped if piped program cannot be executed');
|
||||
}
|
||||
+
|
||||
+{
|
||||
+ # [perl #122112] refcnt: fd -1 < 0 when a signal handler dies
|
||||
+ # while a pipe close is waiting on a child process
|
||||
+ my $prog = <<PROG;
|
||||
+\$SIG{ALRM}=sub{die};
|
||||
+alarm 1;
|
||||
+\$Perl = "$Perl";
|
||||
+my \$cmd = qq(\$Perl -e "sleep 3");
|
||||
+my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
|
||||
+close \$fh;
|
||||
+PROG
|
||||
+ print $prog;
|
||||
+ my $out = fresh_perl($prog, {});
|
||||
+ $::TODO = "not fixed yet";
|
||||
+ cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
||||
+ undef $::TODO;
|
||||
+ # checks that that program did something rather than failing to
|
||||
+ # compile
|
||||
+ cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
|
||||
+}
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,73 @@
|
||||
From 027471cf1095f75f273df40310e4647fe1e8a9df Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 20 Mar 2019 16:47:49 +1100
|
||||
Subject: [PATCH] (perl #133913) limit numeric format results to INT_MAX
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
The return value of v?snprintf() is int, and we pay attention to that
|
||||
return value, so limit the expected size of numeric formats to
|
||||
INT_MAX.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perldiag.pod | 6 ++++++
|
||||
sv.c | 7 +++++++
|
||||
t/op/sprintf2.t | 7 +++++++
|
||||
3 files changed, 20 insertions(+)
|
||||
|
||||
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
|
||||
index 1037215d44..166d29b4bb 100644
|
||||
--- a/pod/perldiag.pod
|
||||
+++ b/pod/perldiag.pod
|
||||
@@ -4354,6 +4354,12 @@ the meantime, try using scientific notation (e.g. "1e6" instead of
|
||||
a number. This happens, for example with C<\o{}>, with no number between
|
||||
the braces.
|
||||
|
||||
+=item Numeric format result too large
|
||||
+
|
||||
+(F) The length of the result of a numeric format supplied to sprintf()
|
||||
+or printf() would have been too large for the underlying C function to
|
||||
+report. This limit is typically 2GB.
|
||||
+
|
||||
=item Octal number > 037777777777 non-portable
|
||||
|
||||
(W portable) The octal number you specified is larger than 2**32-1
|
||||
diff --git a/sv.c b/sv.c
|
||||
index 8fbca52eb2..8bc0af0c16 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -13085,6 +13085,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
|
||||
if (float_need < width)
|
||||
float_need = width;
|
||||
|
||||
+ if (float_need > INT_MAX) {
|
||||
+ /* snprintf() returns an int, and we use that return value,
|
||||
+ so die horribly if the expected size is too large for int
|
||||
+ */
|
||||
+ Perl_croak(aTHX_ "Numeric format result too large");
|
||||
+ }
|
||||
+
|
||||
if (PL_efloatsize <= float_need) {
|
||||
/* PL_efloatbuf should be at least 1 greater than
|
||||
* float_need to allow a trailing \0 to be returned by
|
||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
||||
index 84259a4afd..5fee8efede 100644
|
||||
--- a/t/op/sprintf2.t
|
||||
+++ b/t/op/sprintf2.t
|
||||
@@ -1153,4 +1153,11 @@ foreach(
|
||||
is sprintf("%.0f", $_), sprintf("%-.0f", $_), "special-case %.0f on $_";
|
||||
}
|
||||
|
||||
+# large uvsize needed so the large width is parsed properly
|
||||
+# large sizesize needed so the STRLEN check doesn't
|
||||
+if ($Config{intsize} == 4 && $Config{uvsize} > 4 && $Config{sizesize} > 4) {
|
||||
+ eval { my $x = sprintf("%7000000000E", 0) };
|
||||
+ like($@, qr/^Numeric format result too large at /,
|
||||
+ "croak for very large numeric format results");
|
||||
+}
|
||||
done_testing();
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,78 @@
|
||||
From 1d9630e7857d6fbae6fddd261fbb80c9c9a8cfd6 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 18 Mar 2019 16:02:33 +1100
|
||||
Subject: [PATCH] (perl #133936) document differences between IO::Socket::* and
|
||||
builtin
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 43 +++++++++++++++++++++++++++++++++++++---
|
||||
1 file changed, 40 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index da9e8c94d0..345ffd475d 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -434,9 +434,6 @@ corresponding built-in functions:
|
||||
bind
|
||||
listen
|
||||
accept
|
||||
- send
|
||||
- recv
|
||||
- peername (getpeername)
|
||||
sockname (getsockname)
|
||||
shutdown
|
||||
|
||||
@@ -517,6 +514,46 @@ SO_LINGER enabled with a zero timeout, then the peer's close() will generate
|
||||
a RST segment, upon receipt of which the local TCP transitions immediately to
|
||||
B<CLOSED>, and in that state, connected() I<will> return undef.
|
||||
|
||||
+=item send(MSG, [, FLAGS [, TO ] ])
|
||||
+
|
||||
+Like the built-in L<send()|perlfunc/send>, except that:
|
||||
+
|
||||
+=over
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+C<FLAGS> is optional and defaults to C<0>, and
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+after a successful send with C<TO>, further calls to send() without
|
||||
+C<TO> will send to the same address, and C<TO> will be used as the
|
||||
+result of peername().
|
||||
+
|
||||
+=back
|
||||
+
|
||||
+=item recv(BUF, LEN, [,FLAGS])
|
||||
+
|
||||
+Like the built-in L<recv()|perlfunc/recv>, except that:
|
||||
+
|
||||
+=over
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+C<FLAGS> is optional and defaults to C<0>, and
|
||||
+
|
||||
+=item *
|
||||
+
|
||||
+the cached value returned by peername() is updated with the result of
|
||||
+recv().
|
||||
+
|
||||
+=back
|
||||
+
|
||||
+=item peername
|
||||
+
|
||||
+Returns the cached peername, possibly set by recv() or send() above.
|
||||
+If not otherwise set returns (and caches) the result of getpeername().
|
||||
+
|
||||
=item protocol
|
||||
|
||||
Returns the numerical number for the protocol being used on the socket, if
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,107 @@
|
||||
From f1000aa2d58fbed2741dbb2887b668f872ef0cb8 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 18 Mar 2019 15:05:32 +1100
|
||||
Subject: [PATCH] (perl #133936) ensure TO is honoured for UDP $sock->send()
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 7 ++++---
|
||||
dist/IO/t/io_udp.t | 31 +++++++++++++++++++++++++++----
|
||||
2 files changed, 31 insertions(+), 7 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index 1bf57ab826..a34a10b232 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -282,9 +282,10 @@ sub send {
|
||||
croak 'send: Cannot determine peer address'
|
||||
unless(defined $peer);
|
||||
|
||||
- my $r = defined(getpeername($sock))
|
||||
- ? send($sock, $_[1], $flags)
|
||||
- : send($sock, $_[1], $flags, $peer);
|
||||
+ my $type = $sock->socktype;
|
||||
+ my $r = $type == SOCK_DGRAM || $type == SOCK_RAW
|
||||
+ ? send($sock, $_[1], $flags, $peer)
|
||||
+ : send($sock, $_[1], $flags);
|
||||
|
||||
# remember who we send to, if it was successful
|
||||
${*$sock}{'io_socket_peername'} = $peer
|
||||
diff --git a/dist/IO/t/io_udp.t b/dist/IO/t/io_udp.t
|
||||
index d7e95a8829..571e4303bb 100644
|
||||
--- a/dist/IO/t/io_udp.t
|
||||
+++ b/dist/IO/t/io_udp.t
|
||||
@@ -15,6 +15,8 @@ BEGIN {
|
||||
skip_all($reason) if $reason;
|
||||
}
|
||||
|
||||
+use strict;
|
||||
+
|
||||
sub compare_addr {
|
||||
no utf8;
|
||||
my $a = shift;
|
||||
@@ -36,18 +38,18 @@ sub compare_addr {
|
||||
"$a[0]$a[1]" eq "$b[0]$b[1]";
|
||||
}
|
||||
|
||||
-plan(7);
|
||||
+plan(15);
|
||||
watchdog(15);
|
||||
|
||||
use Socket;
|
||||
use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
|
||||
|
||||
-$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+my $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
|| IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
ok(1);
|
||||
|
||||
-$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+my $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
|| IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
ok(1);
|
||||
@@ -56,6 +58,7 @@ $udpa->send('BORK', 0, $udpb->sockname);
|
||||
|
||||
ok(compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname'));
|
||||
|
||||
+my $buf;
|
||||
my $where = $udpb->recv($buf="", 4);
|
||||
is($buf, 'BORK');
|
||||
|
||||
@@ -69,7 +72,27 @@ $udpb->send('FOObar', @xtra);
|
||||
$udpa->recv($buf="", 6);
|
||||
is($buf, 'FOObar');
|
||||
|
||||
-ok(! $udpa->connected);
|
||||
+{
|
||||
+ # check the TO parameter passed to $sock->send() is honoured for UDP sockets
|
||||
+ # [perl #133936]
|
||||
+ my $udpc = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
|
||||
+ || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
|
||||
+ or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
|
||||
+ pass("created C socket");
|
||||
+
|
||||
+ ok($udpc->connect($udpa->sockname), "connect C to A");
|
||||
+
|
||||
+ ok($udpc->connected, "connected a UDP socket");
|
||||
+
|
||||
+ ok($udpc->send("fromctoa"), "send to a");
|
||||
+
|
||||
+ ok($udpa->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctoa", "check value received");
|
||||
+
|
||||
+ ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
+ ok($udpb->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctob", "check value received");
|
||||
+}
|
||||
|
||||
exit(0);
|
||||
|
||||
--
|
||||
2.20.1
|
||||
|
93
SOURCES/perl-5.31.0-perl-133936-make-send-a-bit-saner.patch
Normal file
93
SOURCES/perl-5.31.0-perl-133936-make-send-a-bit-saner.patch
Normal file
@ -0,0 +1,93 @@
|
||||
From bc26d2e6b287cc6693f41e1a2d48b0dd77d2e427 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 18 Jun 2019 14:59:00 +1000
|
||||
Subject: [PATCH] (perl #133936) make send() a bit saner
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
This undoes some of the effect of f1000aa2d in that TO will always
|
||||
be supplied to CORE::send() if it's supplied, otherwise whether
|
||||
TO is supplied to CORE::send() is based on whether the socket is
|
||||
connected.
|
||||
|
||||
On Linux you appear to be able to sendto() to a different address on
|
||||
a connected UDP socket, but this doesn't appear to be portable,
|
||||
failing on darwin, and presumably on other BSDs.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
dist/IO/lib/IO/Socket.pm | 25 +++++++++++++++++--------
|
||||
dist/IO/t/io_udp.t | 11 ++++++++---
|
||||
2 files changed, 25 insertions(+), 11 deletions(-)
|
||||
|
||||
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
|
||||
index 345ffd475d..28fa1ec149 100644
|
||||
--- a/dist/IO/lib/IO/Socket.pm
|
||||
+++ b/dist/IO/lib/IO/Socket.pm
|
||||
@@ -277,13 +277,22 @@ sub send {
|
||||
@_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
|
||||
my $sock = $_[0];
|
||||
my $flags = $_[2] || 0;
|
||||
- my $peer = $_[3] || $sock->peername;
|
||||
+ my $peer;
|
||||
|
||||
- croak 'send: Cannot determine peer address'
|
||||
- unless(defined $peer);
|
||||
+ if ($_[3]) {
|
||||
+ # the caller explicitly requested a TO, so use it
|
||||
+ # this is non-portable for "connected" UDP sockets
|
||||
+ $peer = $_[3];
|
||||
+ }
|
||||
+ elsif (!defined getpeername($sock)) {
|
||||
+ # we're not connected, so we require a peer from somewhere
|
||||
+ $peer = $sock->peername;
|
||||
+
|
||||
+ croak 'send: Cannot determine peer address'
|
||||
+ unless(defined $peer);
|
||||
+ }
|
||||
|
||||
- my $type = $sock->socktype;
|
||||
- my $r = $type == SOCK_DGRAM || $type == SOCK_RAW
|
||||
+ my $r = $peer
|
||||
? send($sock, $_[1], $flags, $peer)
|
||||
: send($sock, $_[1], $flags);
|
||||
|
||||
@@ -526,9 +535,9 @@ C<FLAGS> is optional and defaults to C<0>, and
|
||||
|
||||
=item *
|
||||
|
||||
-after a successful send with C<TO>, further calls to send() without
|
||||
-C<TO> will send to the same address, and C<TO> will be used as the
|
||||
-result of peername().
|
||||
+after a successful send with C<TO>, further calls to send() on an
|
||||
+unconnected socket without C<TO> will send to the same address, and
|
||||
+C<TO> will be used as the result of peername().
|
||||
|
||||
=back
|
||||
|
||||
diff --git a/dist/IO/t/io_udp.t b/dist/IO/t/io_udp.t
|
||||
index 571e4303bb..2adc6a4a69 100644
|
||||
--- a/dist/IO/t/io_udp.t
|
||||
+++ b/dist/IO/t/io_udp.t
|
||||
@@ -89,9 +89,14 @@ is($buf, 'FOObar');
|
||||
ok($udpa->recv($buf = "", 8), "recv it");
|
||||
is($buf, "fromctoa", "check value received");
|
||||
|
||||
- ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
- ok($udpb->recv($buf = "", 8), "recv it");
|
||||
- is($buf, "fromctob", "check value received");
|
||||
+ SKIP:
|
||||
+ {
|
||||
+ $^O eq "linux"
|
||||
+ or skip "This is non-portable, known to 'work' on Linux", 3;
|
||||
+ ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket");
|
||||
+ ok($udpb->recv($buf = "", 8), "recv it");
|
||||
+ is($buf, "fromctob", "check value received");
|
||||
+ }
|
||||
}
|
||||
|
||||
exit(0);
|
||||
--
|
||||
2.20.1
|
||||
|
28
SOURCES/perl-5.31.0-perl-134008-an-alternative-test.patch
Normal file
28
SOURCES/perl-5.31.0-perl-134008-an-alternative-test.patch
Normal file
@ -0,0 +1,28 @@
|
||||
From 9dfe0a3438ae69872b71b98e4fb4f4bef084983d Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 3 Jun 2019 14:34:17 +1000
|
||||
Subject: [PATCH 2/2] (perl #134008) an alternative test
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/sprintf2.t | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
|
||||
index 569bd8053d..84259a4afd 100644
|
||||
--- a/t/op/sprintf2.t
|
||||
+++ b/t/op/sprintf2.t
|
||||
@@ -840,6 +840,7 @@ SKIP: {
|
||||
|
||||
# [rt.perl.org #134008]
|
||||
is(sprintf("%.*a", -99999, 1.03125), "0x1.08p+0", "[rt.perl.org #134008]");
|
||||
+ is(sprintf("%.*a", -100000,0), "0x0p+0", "negative precision ignored by format_hexfp");
|
||||
|
||||
# [rt.perl.org #128890]
|
||||
is(sprintf("%a", 0x1.18p+0), "0x1.18p+0");
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,84 @@
|
||||
From 40258daf9899686d934c460ba3630431312d7694 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 15 May 2019 15:59:49 +1000
|
||||
Subject: [PATCH] (perl #134072) allow \&foo = \&bar to work in main::
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
subs in main:: are stored as a RV referring to a CV as a space
|
||||
optimization, but the pp_refassign code expected to find a glob,
|
||||
which made the assignment a no-op.
|
||||
|
||||
Fix this by upgrading the reference to a glob in the refassign check
|
||||
function.
|
||||
|
||||
Note that this would be an issue in other packages if 1e2cfe157ca
|
||||
was reverted (allowing the space savings in other packages too.)
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
op.c | 9 +++++++++
|
||||
t/op/lvref.t | 15 ++++++++++++++-
|
||||
2 files changed, 23 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/op.c b/op.c
|
||||
index f63eeadc36..6ad192307f 100644
|
||||
--- a/op.c
|
||||
+++ b/op.c
|
||||
@@ -12462,7 +12462,16 @@ Perl_ck_refassign(pTHX_ OP *o)
|
||||
OP * const kid = cUNOPx(kidparent)->op_first;
|
||||
o->op_private |= OPpLVREF_CV;
|
||||
if (kid->op_type == OP_GV) {
|
||||
+ SV *sv = (SV*)cGVOPx_gv(kid);
|
||||
varop = kidparent;
|
||||
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
|
||||
+ /* a CVREF here confuses pp_refassign, so make sure
|
||||
+ it gets a GV */
|
||||
+ CV *const cv = (CV*)SvRV(sv);
|
||||
+ SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
|
||||
+ (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
|
||||
+ assert(SvTYPE(sv) == SVt_PVGV);
|
||||
+ }
|
||||
goto detach_and_stack;
|
||||
}
|
||||
if (kid->op_type != OP_PADCV) goto bad;
|
||||
diff --git a/t/op/lvref.t b/t/op/lvref.t
|
||||
index 3d5e952fb0..3991a53780 100644
|
||||
--- a/t/op/lvref.t
|
||||
+++ b/t/op/lvref.t
|
||||
@@ -1,10 +1,11 @@
|
||||
+#!perl
|
||||
BEGIN {
|
||||
chdir 't';
|
||||
require './test.pl';
|
||||
set_up_inc("../lib");
|
||||
}
|
||||
|
||||
-plan 164;
|
||||
+plan 167;
|
||||
|
||||
eval '\$x = \$y';
|
||||
like $@, qr/^Experimental aliasing via reference not enabled/,
|
||||
@@ -291,6 +292,18 @@ package CodeTest {
|
||||
my sub bs;
|
||||
\(&cs) = expect_list_cx;
|
||||
is \&cs, \&ThatSub, '\(&statesub)';
|
||||
+
|
||||
+ package main {
|
||||
+ # this is only a problem in main:: due to 1e2cfe157ca
|
||||
+ sub sx { "x" }
|
||||
+ sub sy { "y" }
|
||||
+ is sx(), "x", "check original";
|
||||
+ my $temp = \&sx;
|
||||
+ \&sx = \&sy;
|
||||
+ is sx(), "y", "aliased";
|
||||
+ \&sx = $temp;
|
||||
+ is sx(), "x", "and restored";
|
||||
+ }
|
||||
}
|
||||
|
||||
# Mixed List Assignments
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,59 @@
|
||||
From 22f05786af0b7f963440e47908cd5f35cf074c12 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Thu, 13 Jun 2019 10:05:15 +1000
|
||||
Subject: [PATCH] (perl #134193) allow %{^CAPTURE} to work when @{^CAPTURE}
|
||||
comes first
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
gv_magicalize() is called when the GV is created, so when the array
|
||||
was mentioned first, the hash wouldn't reach this code and the magic
|
||||
wouldn't be added to the hash.
|
||||
|
||||
This also fixes a similar problem with (%|@){^CAPTURE_ALL}, though
|
||||
@{^CAPTURE_ALL} is unused at this point.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/Tie-Hash-NamedCapture/t/tiehash.t | 3 +++
|
||||
gv.c | 6 ++----
|
||||
2 files changed, 5 insertions(+), 4 deletions(-)
|
||||
|
||||
diff --git a/ext/Tie-Hash-NamedCapture/t/tiehash.t b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
index 962754085f..cca05278f4 100644
|
||||
--- a/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
+++ b/ext/Tie-Hash-NamedCapture/t/tiehash.t
|
||||
@@ -3,6 +3,9 @@ use strict;
|
||||
|
||||
use Test::More;
|
||||
|
||||
+# this would break the hash magic setup [perl #134193]
|
||||
+my ($ca, $c) = ( \@{^CAPTURE_ALL}, \@{^CAPTURE} );
|
||||
+
|
||||
my %hashes = (
|
||||
'+' => \%+,
|
||||
'-' => \%-,
|
||||
diff --git a/gv.c b/gv.c
|
||||
index 46a32dcc20..2b83680898 100644
|
||||
--- a/gv.c
|
||||
+++ b/gv.c
|
||||
@@ -2032,13 +2032,11 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
|
||||
sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
|
||||
SvREADONLY_on(av);
|
||||
|
||||
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
|
||||
- require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
|
||||
} else /* %{^CAPTURE_ALL} */
|
||||
if (memEQs(name, len, "\003APTURE_ALL")) {
|
||||
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
|
||||
- require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
}
|
||||
break;
|
||||
case '\005': /* $^ENCODING */
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,36 @@
|
||||
From d8422270033e0728e6a9cecb24cdbd123656e367 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 17 Jun 2019 11:46:00 +1000
|
||||
Subject: [PATCH] (perl #134193) make the varname match the %[+-] names
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
when loading Tie/Hash/NamedCapture.pm for the long name variants
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
gv.c | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/gv.c b/gv.c
|
||||
index 2b83680898..652f5e737d 100644
|
||||
--- a/gv.c
|
||||
+++ b/gv.c
|
||||
@@ -2032,11 +2032,11 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
|
||||
sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
|
||||
SvREADONLY_on(av);
|
||||
|
||||
- require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
|
||||
} else /* %{^CAPTURE_ALL} */
|
||||
if (memEQs(name, len, "\003APTURE_ALL")) {
|
||||
- require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
|
||||
+ require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
|
||||
}
|
||||
break;
|
||||
case '\005': /* $^ENCODING */
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,65 @@
|
||||
From 28eabf1185634216ca335b3a24e1131b0f392ca1 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Wed, 10 Jul 2019 12:59:06 +0100
|
||||
Subject: [PATCH] avoid SEGV with uninit warning with multideref
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
RT #134275
|
||||
|
||||
When the 'uninitialized warning' code in S_find_uninit_var() comes
|
||||
across an OP_MULTIDEREF node, it scans it to see if any part of that op
|
||||
(e.g. the indices or the returned value) could have been the source of
|
||||
the uninitialized value which triggered the warning. Unfortunately when
|
||||
getting an AV or HV from a GV, it wasn't checking whether gp_av/gp_hv
|
||||
contained a NULL value. If so, it would SEGV.
|
||||
|
||||
The test code is a bit contrived; you have to "pull the rug" from under
|
||||
the GV at just the right moment with *foo = *bar, then trigger an uninit
|
||||
warning on an op whose subtree includes an OP_MULTIDEREF.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
sv.c | 5 ++++-
|
||||
t/lib/warnings/9uninit | 10 ++++++++++
|
||||
2 files changed, 14 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/sv.c b/sv.c
|
||||
index 83de536ad7..4315fe9b64 100644
|
||||
--- a/sv.c
|
||||
+++ b/sv.c
|
||||
@@ -16662,8 +16662,11 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
|
||||
|
||||
if (agg_targ)
|
||||
sv = PAD_SV(agg_targ);
|
||||
- else if (agg_gv)
|
||||
+ else if (agg_gv) {
|
||||
sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
|
||||
+ if (!sv)
|
||||
+ break;
|
||||
+ }
|
||||
else
|
||||
break;
|
||||
|
||||
diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
|
||||
index 774c6ee432..5c173fdb2a 100644
|
||||
--- a/t/lib/warnings/9uninit
|
||||
+++ b/t/lib/warnings/9uninit
|
||||
@@ -2206,3 +2206,13 @@ use warnings 'uninitialized';
|
||||
undef $0;
|
||||
EXPECT
|
||||
Use of uninitialized value in undef operator at - line 5.
|
||||
+########
|
||||
+# RT #134275
|
||||
+# This was SEGVing due to the multideref code in S_find_uninit_var not
|
||||
+# handling a GV with a null gp_hv slot.
|
||||
+use warnings 'uninitialized';
|
||||
+"" =~ /$foo{a}${*foo=*bar}$x/;
|
||||
+EXPECT
|
||||
+Use of uninitialized value in regexp compilation at - line 5.
|
||||
+Use of uninitialized value in regexp compilation at - line 5.
|
||||
+Use of uninitialized value $x in regexp compilation at - line 5.
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,39 @@
|
||||
From 293a533c53d9c0fe939e23c439f4dfc47a5736dc Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 25 Jun 2019 15:47:57 +1000
|
||||
Subject: [PATCH] (perl #122112) make sure SIGPIPE is delivered if we test it
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/io/pipe.t | 12 ++++++++++++
|
||||
1 file changed, 12 insertions(+)
|
||||
|
||||
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
||||
index 9f5bb3bcf8..bdf743c26c 100644
|
||||
--- a/t/io/pipe.t
|
||||
+++ b/t/io/pipe.t
|
||||
@@ -125,6 +125,18 @@ wait; # Collect from $pid
|
||||
pipe(READER,WRITER) || die "Can't open pipe";
|
||||
close READER;
|
||||
|
||||
+eval {
|
||||
+ # one platform at least appears to block SIGPIPE by default (see #122112)
|
||||
+ # so make sure it's unblocked.
|
||||
+ # The eval wrapper should ensure this does nothing if these aren't
|
||||
+ # implemented.
|
||||
+ require POSIX;
|
||||
+ my $mask = POSIX::SigSet->new(POSIX::SIGPIPE());
|
||||
+ my $old = POSIX::SigSet->new();
|
||||
+ POSIX::sigprocmask(POSIX::SIG_UNBLOCK(), $mask, $old);
|
||||
+ note "Yes, SIGPIPE was blocked" if $old->ismember(POSIX::SIGPIPE());
|
||||
+};
|
||||
+
|
||||
$SIG{'PIPE'} = 'broken_pipe';
|
||||
|
||||
sub broken_pipe {
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,128 @@
|
||||
From 74b421cc877e412c4eda06757396a1e19fc756ba Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 15 Jul 2019 11:53:23 +1000
|
||||
Subject: [PATCH 3/3] (perl #134221) support O_APPEND for open ..., undef on
|
||||
VMS
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
VMS doesn't allow you to delete an open file like POSIXish systems
|
||||
do, but you can mark a file to be deleted once it's closed, but
|
||||
only when you open it.
|
||||
|
||||
Since VMS doesn't (yet) have mkostemp() we can add our own flag to
|
||||
our mkostemp() emulation to pass the necessary magic to open() call
|
||||
to delete the file on close.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perlio.c | 10 ++++++----
|
||||
util.c | 15 ++++++++++++++-
|
||||
util.h | 11 +++++++++++
|
||||
3 files changed, 31 insertions(+), 5 deletions(-)
|
||||
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index 81ebc156ad..805959f840 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -5062,7 +5062,7 @@ PerlIO_tmpfile_flags(int imode)
|
||||
const int fd = win32_tmpfd_mode(imode);
|
||||
if (fd >= 0)
|
||||
f = PerlIO_fdopen(fd, "w+b");
|
||||
-#elif ! defined(VMS) && ! defined(OS2)
|
||||
+#elif ! defined(OS2)
|
||||
int fd = -1;
|
||||
char tempname[] = "/tmp/PerlIO_XXXXXX";
|
||||
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
|
||||
@@ -5073,19 +5073,19 @@ PerlIO_tmpfile_flags(int imode)
|
||||
/* if TMPDIR is set and not empty, we try that first */
|
||||
sv = newSVpv(tmpdir, 0);
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
if (fd < 0) {
|
||||
SvREFCNT_dec(sv);
|
||||
sv = NULL;
|
||||
/* else we try /tmp */
|
||||
- fd = Perl_my_mkostemp_cloexec(tempname, imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
if (fd < 0) {
|
||||
/* Try cwd */
|
||||
sv = newSVpvs(".");
|
||||
sv_catpv(sv, tempname + 4);
|
||||
- fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode);
|
||||
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
|
||||
}
|
||||
umask(old_umask);
|
||||
if (fd >= 0) {
|
||||
@@ -5096,7 +5096,9 @@ PerlIO_tmpfile_flags(int imode)
|
||||
f = PerlIO_fdopen(fd, mode);
|
||||
if (f)
|
||||
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
|
||||
+# ifndef VMS
|
||||
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
|
||||
+# endif
|
||||
}
|
||||
SvREFCNT_dec(sv);
|
||||
#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
|
||||
diff --git a/util.c b/util.c
|
||||
index e6863f6dfe..165d13a39e 100644
|
||||
--- a/util.c
|
||||
+++ b/util.c
|
||||
@@ -5712,6 +5712,11 @@ S_my_mkostemp(char *templte, int flags) {
|
||||
STRLEN len = strlen(templte);
|
||||
int fd;
|
||||
int attempts = 0;
|
||||
+#ifdef VMS
|
||||
+ int delete_on_close = flags & O_VMS_DELETEONCLOSE;
|
||||
+
|
||||
+ flags &= ~O_VMS_DELETEONCLOSE;
|
||||
+#endif
|
||||
|
||||
if (len < 6 ||
|
||||
templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
|
||||
@@ -5725,7 +5730,15 @@ S_my_mkostemp(char *templte, int flags) {
|
||||
for (i = 1; i <= 6; ++i) {
|
||||
templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
|
||||
}
|
||||
- fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
|
||||
+#ifdef VMS
|
||||
+ if (delete_on_close) {
|
||||
+ fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt");
|
||||
+ }
|
||||
+ else
|
||||
+#endif
|
||||
+ {
|
||||
+ fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
|
||||
+ }
|
||||
} while (fd == -1 && errno == EEXIST && ++attempts <= 100);
|
||||
|
||||
return fd;
|
||||
diff --git a/util.h b/util.h
|
||||
index d8fa3e8396..d9df7b39c6 100644
|
||||
--- a/util.h
|
||||
+++ b/util.h
|
||||
@@ -248,6 +248,17 @@ means arg not present, 1 is empty string/null byte */
|
||||
int mkstemp(char*);
|
||||
#endif
|
||||
|
||||
+#ifdef PERL_CORE
|
||||
+# if defined(VMS)
|
||||
+/* only useful for calls to our mkostemp() emulation */
|
||||
+# define O_VMS_DELETEONCLOSE 0x40000000
|
||||
+# ifdef HAS_MKOSTEMP
|
||||
+# error 134221 will need a new solution for VMS
|
||||
+# endif
|
||||
+# else
|
||||
+# define O_VMS_DELETEONCLOSE 0
|
||||
+# endif
|
||||
+#endif
|
||||
#if defined(HAS_MKOSTEMP) && defined(PERL_CORE)
|
||||
# define Perl_my_mkostemp(templte, flags) mkostemp(templte, flags)
|
||||
#endif
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,76 @@
|
||||
From 0424723402ef153af8ee44222315d9b6a818d1ba Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 2 Jul 2019 15:22:26 +1000
|
||||
Subject: [PATCH 2/3] (perl #134221) support append mode temp files on Win32
|
||||
too
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
perlio.c | 2 +-
|
||||
win32/win32.c | 10 +++++++++-
|
||||
win32/win32iop.h | 1 +
|
||||
3 files changed, 11 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/perlio.c b/perlio.c
|
||||
index a737e79e02..81ebc156ad 100644
|
||||
--- a/perlio.c
|
||||
+++ b/perlio.c
|
||||
@@ -5059,7 +5059,7 @@ PerlIO_tmpfile_flags(int imode)
|
||||
#endif
|
||||
PerlIO *f = NULL;
|
||||
#ifdef WIN32
|
||||
- const int fd = win32_tmpfd();
|
||||
+ const int fd = win32_tmpfd_mode(imode);
|
||||
if (fd >= 0)
|
||||
f = PerlIO_fdopen(fd, "w+b");
|
||||
#elif ! defined(VMS) && ! defined(OS2)
|
||||
diff --git a/win32/win32.c b/win32/win32.c
|
||||
index 8104d864c2..91fdffe09b 100644
|
||||
--- a/win32/win32.c
|
||||
+++ b/win32/win32.c
|
||||
@@ -2907,10 +2907,18 @@ win32_rewind(FILE *pf)
|
||||
|
||||
DllExport int
|
||||
win32_tmpfd(void)
|
||||
+{
|
||||
+ return win32_tmpfd_mode(0);
|
||||
+}
|
||||
+
|
||||
+DllExport int
|
||||
+win32_tmpfd_mode(int mode)
|
||||
{
|
||||
char prefix[MAX_PATH+1];
|
||||
char filename[MAX_PATH+1];
|
||||
DWORD len = GetTempPath(MAX_PATH, prefix);
|
||||
+ mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
|
||||
+ mode |= O_RDWR;
|
||||
if (len && len < MAX_PATH) {
|
||||
if (GetTempFileName(prefix, "plx", 0, filename)) {
|
||||
HANDLE fh = CreateFile(filename,
|
||||
@@ -2922,7 +2930,7 @@ win32_tmpfd(void)
|
||||
| FILE_FLAG_DELETE_ON_CLOSE,
|
||||
NULL);
|
||||
if (fh != INVALID_HANDLE_VALUE) {
|
||||
- int fd = win32_open_osfhandle((intptr_t)fh, 0);
|
||||
+ int fd = win32_open_osfhandle((intptr_t)fh, mode);
|
||||
if (fd >= 0) {
|
||||
PERL_DEB(dTHX;)
|
||||
DEBUG_p(PerlIO_printf(Perl_debug_log,
|
||||
diff --git a/win32/win32iop.h b/win32/win32iop.h
|
||||
index 53330e5951..559e1f9cd2 100644
|
||||
--- a/win32/win32iop.h
|
||||
+++ b/win32/win32iop.h
|
||||
@@ -64,6 +64,7 @@ DllExport int win32_fgetpos(FILE *pf,fpos_t *p);
|
||||
DllExport int win32_fsetpos(FILE *pf,const fpos_t *p);
|
||||
DllExport void win32_rewind(FILE *pf);
|
||||
DllExport int win32_tmpfd(void);
|
||||
+DllExport int win32_tmpfd_mode(int mode);
|
||||
DllExport FILE* win32_tmpfile(void);
|
||||
DllExport void win32_abort(void);
|
||||
DllExport int win32_fstat(int fd,Stat_t *sbufptr);
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,38 @@
|
||||
From 12e1284a67e5e3404c704c3f864749fd9f04c7c4 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 7 Aug 2019 14:58:14 +1000
|
||||
Subject: [PATCH] PerlIO::Via: check arg is non-NULL before using it.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
I can't find any code in core that ends up calling the _pushed handler
|
||||
with arg == NULL, but PerlIO_push() is API, and there might be
|
||||
CPAN or DarkPAN code out there that does, escpecially since there's
|
||||
a check for arg being non-NULL further down.
|
||||
|
||||
CID 169261.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
ext/PerlIO-via/via.xs | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
|
||||
index d91c6855fc..8456242bc0 100644
|
||||
--- a/ext/PerlIO-via/via.xs
|
||||
+++ b/ext/PerlIO-via/via.xs
|
||||
@@ -134,8 +134,8 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
|
||||
{
|
||||
IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
|
||||
|
||||
- if (SvTYPE(arg) >= SVt_PVMG
|
||||
- && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
|
||||
+ if (arg && SvTYPE(arg) >= SVt_PVMG
|
||||
+ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
|
||||
return code;
|
||||
}
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,30 @@
|
||||
From 665ac6aded4b9694283d373a0f127f32a3e75b26 Mon Sep 17 00:00:00 2001
|
||||
From: James E Keenan <jkeenan@cpan.org>
|
||||
Date: Wed, 7 Aug 2019 09:39:56 -0400
|
||||
Subject: [PATCH] Run tests in ext/File-Find/t in series
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
For: RT # 133771
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/harness | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/t/harness b/t/harness
|
||||
index caa2a318b8..b9857fa022 100644
|
||||
--- a/t/harness
|
||||
+++ b/t/harness
|
||||
@@ -189,7 +189,7 @@ if (@ARGV) {
|
||||
# directory containing such files should be tested in serial order.
|
||||
#
|
||||
# Add exceptions to the above rule
|
||||
- for (qw(ext/Pod-Html/t cpan/IO-Zlib/t)) {
|
||||
+ for (qw(ext/Pod-Html/t cpan/IO-Zlib/t ext/File-Find/t)) {
|
||||
$serials{$_} = 1;
|
||||
}
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,37 @@
|
||||
From 1d84a25665013f389ffc6fad7dd133f1c6287a08 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Tue, 6 Aug 2019 14:36:45 +0100
|
||||
Subject: [PATCH] include a trailing \0 in SVs holding trie info
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
RT #13427
|
||||
|
||||
TRIE_STORE_REVCHAR() was creating SvPV()s with no trailing '\0'. This
|
||||
doesn't really matter given the specialised use these are put to, but
|
||||
it upset valgrind et al when perl was run with -Drv which printf("%s")'s
|
||||
the contents of the string.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 3 ++-
|
||||
1 file changed, 2 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 370221f72e..1117998fc8 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -2526,7 +2526,8 @@ is the recommended Unicode-aware way of saying
|
||||
if (UTF) { \
|
||||
SV *zlopp = newSV(UTF8_MAXBYTES); \
|
||||
unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \
|
||||
- unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
|
||||
+ unsigned char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
|
||||
+ *kapow = '\0'; \
|
||||
SvCUR_set(zlopp, kapow - flrbbbbb); \
|
||||
SvPOK_on(zlopp); \
|
||||
SvUTF8_on(zlopp); \
|
||||
--
|
||||
2.20.1
|
||||
|
48
SOURCES/perl-5.31.2-locale.c-Stop-Coverity-warning.patch
Normal file
48
SOURCES/perl-5.31.2-locale.c-Stop-Coverity-warning.patch
Normal file
@ -0,0 +1,48 @@
|
||||
From 21dce8f4eb9136875a886371016aa25788f5144f Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Tue, 6 Aug 2019 21:29:22 -0600
|
||||
Subject: [PATCH] locale.c: Stop Coverity warning
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Coverity is right, so re-order these clauses. This code is executed
|
||||
only if some very strange error occurs.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
locale.c | 11 ++++++-----
|
||||
1 file changed, 6 insertions(+), 5 deletions(-)
|
||||
|
||||
diff --git a/locale.c b/locale.c
|
||||
index db83d993de..af7af60038 100644
|
||||
--- a/locale.c
|
||||
+++ b/locale.c
|
||||
@@ -4349,11 +4349,6 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
|
||||
return xbuf;
|
||||
|
||||
bad:
|
||||
- Safefree(xbuf);
|
||||
- if (s != input_string) {
|
||||
- Safefree(s);
|
||||
- }
|
||||
- *xlen = 0;
|
||||
|
||||
# ifdef DEBUGGING
|
||||
|
||||
@@ -4363,6 +4358,12 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
|
||||
|
||||
# endif
|
||||
|
||||
+ Safefree(xbuf);
|
||||
+ if (s != input_string) {
|
||||
+ Safefree(s);
|
||||
+ }
|
||||
+ *xlen = 0;
|
||||
+
|
||||
return NULL;
|
||||
}
|
||||
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,54 @@
|
||||
From 85d4e0a35b2d44cf06a9343d23a2f84b8ebb9024 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Wed, 17 Jul 2019 11:32:50 +1000
|
||||
Subject: [PATCH] (perl #134291) propagate non-PVs in $@ in bare die()
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pp_sys.c | 2 +-
|
||||
t/op/die.t | 6 +++++-
|
||||
2 files changed, 6 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pp_sys.c b/pp_sys.c
|
||||
index 0214367ea6..251527785e 100644
|
||||
--- a/pp_sys.c
|
||||
+++ b/pp_sys.c
|
||||
@@ -498,7 +498,7 @@ PP(pp_die)
|
||||
}
|
||||
}
|
||||
}
|
||||
- else if (SvPOK(errsv) && SvCUR(errsv)) {
|
||||
+ else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) {
|
||||
exsv = sv_mortalcopy(errsv);
|
||||
sv_catpvs(exsv, "\t...propagated");
|
||||
}
|
||||
diff --git a/t/op/die.t b/t/op/die.t
|
||||
index ef2b85f8f5..d6d7daffa5 100644
|
||||
--- a/t/op/die.t
|
||||
+++ b/t/op/die.t
|
||||
@@ -6,7 +6,7 @@ BEGIN {
|
||||
set_up_inc('../lib');
|
||||
}
|
||||
|
||||
-plan tests => 20;
|
||||
+plan tests => 21;
|
||||
|
||||
eval {
|
||||
eval {
|
||||
@@ -94,6 +94,10 @@ like($@, qr/\.{3}propagated at/, '... and appends a phrase');
|
||||
local $SIG{__WARN__} = sub { $ok = 0 };
|
||||
eval { undef $@; die };
|
||||
is( $ok, 1, 'no warnings if $@ is undef' );
|
||||
+
|
||||
+ eval { $@ = 100; die };
|
||||
+ like($@."", qr/100\t\.{3}propagated at/,
|
||||
+ 'check non-PVs in $@ are propagated');
|
||||
}
|
||||
|
||||
TODO: {
|
||||
--
|
||||
2.20.1
|
||||
|
@ -0,0 +1,118 @@
|
||||
From 8b4b30c5d389983c3df51b7ff3b38e5608c7c2e2 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 3 Aug 2019 09:17:43 -0600
|
||||
Subject: [PATCH] perlapi: 5.30 promise not met; change to 5.32
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
We delayed this change, but I forgot to change this documentation
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
handy.h | 24 ++++++++++++------------
|
||||
1 file changed, 12 insertions(+), 12 deletions(-)
|
||||
|
||||
diff --git a/handy.h b/handy.h
|
||||
index 24c028a638..2dfbc86125 100644
|
||||
--- a/handy.h
|
||||
+++ b/handy.h
|
||||
@@ -609,13 +609,13 @@ future releases.
|
||||
Variant C<isI<FOO>_utf8> is like C<isI<FOO>_utf8_safe>, but takes just a single
|
||||
parameter, C<p>, which has the same meaning as the corresponding parameter does
|
||||
in C<isI<FOO>_utf8_safe>. The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take a second
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take a second
|
||||
parameter, becoming a synonym for C<isI<FOO>_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<isI<FOO>_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<isI<FOO>_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
Variant C<isI<FOO>_LC> is like the C<isI<FOO>_A> and C<isI<FOO>_L1> variants, but the
|
||||
@@ -649,13 +649,13 @@ future releases.
|
||||
Variant C<isI<FOO>_LC_utf8> is like C<isI<FOO>_LC_utf8_safe>, but takes just a single
|
||||
parameter, C<p>, which has the same meaning as the corresponding parameter does
|
||||
in C<isI<FOO>_LC_utf8_safe>. The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take a second
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take a second
|
||||
parameter, becoming a synonym for C<isI<FOO>_LC_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<isI<FOO>_LC_utf8> from each call point in
|
||||
the program will raise a deprecation warning, enabled by default. You can
|
||||
convert your program now to use C<isI<FOO>_LC_utf8_safe>, and avoid the warnings,
|
||||
-and get an extra measure of protection, or you can wait until v5.30, when
|
||||
+and get an extra measure of protection, or you can wait until v5.32, when
|
||||
you'll be forced to add the C<e> parameter.
|
||||
|
||||
=for apidoc Am|bool|isALPHA|char ch
|
||||
@@ -897,13 +897,13 @@ implementation, and subject to change in future releases.
|
||||
=for apidoc Am|UV|toUPPER_utf8|U8* p|U8* s|STRLEN* lenp
|
||||
This is like C<L</toUPPER_utf8_safe>>, but doesn't have the C<e>
|
||||
parameter The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take the C<e>
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take the C<e>
|
||||
parameter, becoming a synonym for C<toUPPER_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<toUPPER_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<toUPPER_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
=for apidoc Am|U8|toFOLD|U8 ch
|
||||
@@ -944,13 +944,13 @@ implementation, and subject to change in future releases.
|
||||
=for apidoc Am|UV|toFOLD_utf8|U8* p|U8* s|STRLEN* lenp
|
||||
This is like C<L</toFOLD_utf8_safe>>, but doesn't have the C<e>
|
||||
parameter The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take the C<e>
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take the C<e>
|
||||
parameter, becoming a synonym for C<toFOLD_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<toFOLD_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<toFOLD_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
=for apidoc Am|U8|toLOWER|U8 ch
|
||||
@@ -999,13 +999,13 @@ implementation, and subject to change in future releases.
|
||||
=for apidoc Am|UV|toLOWER_utf8|U8* p|U8* s|STRLEN* lenp
|
||||
This is like C<L</toLOWER_utf8_safe>>, but doesn't have the C<e>
|
||||
parameter The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take the C<e>
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take the C<e>
|
||||
parameter, becoming a synonym for C<toLOWER_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<toLOWER_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<toLOWER_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
=for apidoc Am|U8|toTITLE|U8 ch
|
||||
@@ -1047,13 +1047,13 @@ implementation, and subject to change in future releases.
|
||||
=for apidoc Am|UV|toTITLE_utf8|U8* p|U8* s|STRLEN* lenp
|
||||
This is like C<L</toLOWER_utf8_safe>>, but doesn't have the C<e>
|
||||
parameter The function therefore can't check if it is reading
|
||||
-beyond the end of the string. Starting in Perl v5.30, it will take the C<e>
|
||||
+beyond the end of the string. Starting in Perl v5.32, it will take the C<e>
|
||||
parameter, becoming a synonym for C<toTITLE_utf8_safe>. At that time every
|
||||
program that uses it will have to be changed to successfully compile. In the
|
||||
meantime, the first runtime call to C<toTITLE_utf8> from each call point in the
|
||||
program will raise a deprecation warning, enabled by default. You can convert
|
||||
your program now to use C<toTITLE_utf8_safe>, and avoid the warnings, and get an
|
||||
-extra measure of protection, or you can wait until v5.30, when you'll be forced
|
||||
+extra measure of protection, or you can wait until v5.32, when you'll be forced
|
||||
to add the C<e> parameter.
|
||||
|
||||
=cut
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,36 @@
|
||||
From 31532982b04c20a43aa9c3d26780e3591c524fbc Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Thu, 27 Jun 2019 15:39:11 -0600
|
||||
Subject: [PATCH] regcomp.c: Don't read off the end of buffer
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Until this commit, it was possible that \p{nv=3/} would cause the right
|
||||
brace to be considered part of the property name.
|
||||
|
||||
Spotted by Hugo van der Sanden
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 4 +++-
|
||||
1 file changed, 3 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 1117998fc8..cf9246473f 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -23092,7 +23092,9 @@ Perl_parse_uniprop_string(pTHX_
|
||||
}
|
||||
|
||||
/* Store the first real character in the denominator */
|
||||
- lookup_name[j++] = name[i];
|
||||
+ if (i < name_len) {
|
||||
+ lookup_name[j++] = name[i];
|
||||
+ }
|
||||
}
|
||||
}
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,30 @@
|
||||
From 425077e4b85509df2907be6c103d54c0687c7647 Mon Sep 17 00:00:00 2001
|
||||
From: Florian Weimer <fweimer@redhat.com>
|
||||
Date: Mon, 9 Sep 2019 19:35:47 +0200
|
||||
Subject: [PATCH 1/2] Configure: Include <stdlib.h> in futimes check
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Needed for the exit function.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
Configure | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/Configure b/Configure
|
||||
index 818deb8378..7aa03d6aed 100755
|
||||
--- a/Configure
|
||||
+++ b/Configure
|
||||
@@ -14091,6 +14091,7 @@ $cat >try.c <<EOCP
|
||||
#include <sys/time.h>
|
||||
#include <errno.h>
|
||||
#include <fcntl.h>
|
||||
+#include <stdlib.h>
|
||||
|
||||
int main ()
|
||||
{
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,28 @@
|
||||
From da006e4432402cea01c9018743467314377e3c1e Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 10 Sep 2019 10:44:10 +1000
|
||||
Subject: [PATCH 2/2] Florian Weimer is now a perl author
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
AUTHORS | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/AUTHORS b/AUTHORS
|
||||
index a2b6d8c15a..a554cfc045 100644
|
||||
--- a/AUTHORS
|
||||
+++ b/AUTHORS
|
||||
@@ -418,6 +418,7 @@ Fergal Daly <fergal@esatclear.ie>
|
||||
Fingle Nark <finglenark@gmail.com>
|
||||
Florent Guillaume
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
+Florian Weimer <fweimer@redhat.com>
|
||||
François Désarménien <desar@club-internet.fr>
|
||||
François Perrad <francois.perrad@gadz.org>
|
||||
Frank Crawford
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,31 @@
|
||||
From 7ea7c4bb61d23965a7ad7041fe9c58b5075aac85 Mon Sep 17 00:00:00 2001
|
||||
From: James E Keenan <jkeenan@cpan.org>
|
||||
Date: Sat, 31 Aug 2019 19:18:36 -0400
|
||||
Subject: [PATCH] Supply missing right brace in regex example
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
As suggested by Jim Avera in RT 134395.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perlrebackslash.pod | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/pod/perlrebackslash.pod b/pod/perlrebackslash.pod
|
||||
index cfd182a7e1..4a8717346d 100644
|
||||
--- a/pod/perlrebackslash.pod
|
||||
+++ b/pod/perlrebackslash.pod
|
||||
@@ -446,7 +446,7 @@ Mnemonic: I<g>roup.
|
||||
=head3 Relative referencing
|
||||
|
||||
C<\g-I<N>> (starting in Perl 5.10.0) is used for relative addressing. (It can
|
||||
-be written as C<\g{-I<N>>.) It refers to the I<N>th group before the
|
||||
+be written as C<\g{-I<N>}>.) It refers to the I<N>th group before the
|
||||
C<\g{-I<N>}>.
|
||||
|
||||
The big advantage of this form is that it makes it much easier to write
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,57 @@
|
||||
From 14d26b44a1d7eee67837ec0ea8fb0368ac6fe33e Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Tue, 20 Aug 2019 15:43:05 +1000
|
||||
Subject: [PATCH] (perl #134230) don't interpret 0x, 0b when numifying strings
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
numeric.c | 9 +++++++++
|
||||
t/op/int.t | 5 ++++-
|
||||
2 files changed, 13 insertions(+), 1 deletion(-)
|
||||
|
||||
diff --git a/numeric.c b/numeric.c
|
||||
index f5eadc8173..fae2eb3c6d 100644
|
||||
--- a/numeric.c
|
||||
+++ b/numeric.c
|
||||
@@ -1551,6 +1551,15 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
|
||||
if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
|
||||
return endp;
|
||||
|
||||
+ /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
|
||||
+ 0b-prefixed binary numbers, which is backward incompatible
|
||||
+ */
|
||||
+ if ((len == 0 || len >= 2) && *s == '0' &&
|
||||
+ (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
|
||||
+ *value = 0;
|
||||
+ return (char *)s+1;
|
||||
+ }
|
||||
+
|
||||
/* If the length is passed in, the input string isn't NUL-terminated,
|
||||
* and in it turns out the function below assumes it is; therefore we
|
||||
* create a copy and NUL-terminate that */
|
||||
diff --git a/t/op/int.t b/t/op/int.t
|
||||
index 7e936da68d..b730ab2672 100644
|
||||
--- a/t/op/int.t
|
||||
+++ b/t/op/int.t
|
||||
@@ -7,7 +7,7 @@ BEGIN {
|
||||
require Config;
|
||||
}
|
||||
|
||||
-plan 17;
|
||||
+plan 19;
|
||||
|
||||
# compile time evaluation
|
||||
|
||||
@@ -83,3 +83,6 @@ SKIP:
|
||||
cmp_ok($x, "==", int($x), "check $x == int($x)");
|
||||
}
|
||||
}
|
||||
+
|
||||
+is(1+"0x10", 1, "check string '0x' prefix not treated as hex");
|
||||
+is(1+"0b10", 1, "check string '0b' prefix not treated as binary");
|
||||
--
|
||||
2.21.0
|
||||
|
31
SOURCES/perl-5.31.3-regcomp.c-Fix-wrong-limit-test.patch
Normal file
31
SOURCES/perl-5.31.3-regcomp.c-Fix-wrong-limit-test.patch
Normal file
@ -0,0 +1,31 @@
|
||||
From 8d3e0237887e7149be56d17a9448cb465edc5f76 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Thu, 22 Aug 2019 10:16:14 -0600
|
||||
Subject: [PATCH] regcomp.c: Fix wrong limit test
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Spotted by Hugo van der Sanden in code reading.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index aba6648da5..d61fd434fe 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -23132,7 +23132,7 @@ Perl_parse_uniprop_string(pTHX_
|
||||
|
||||
/* If the original input began with 'In' or 'Is', it could be a subroutine
|
||||
* call to a user-defined property instead of a Unicode property name. */
|
||||
- if ( non_pkg_begin + name_len > 2
|
||||
+ if ( name_len - non_pkg_begin > 2
|
||||
&& name[non_pkg_begin+0] == 'I'
|
||||
&& (name[non_pkg_begin+1] == 'n' || name[non_pkg_begin+1] == 's'))
|
||||
{
|
||||
--
|
||||
2.21.0
|
||||
|
237
SOURCES/perl-5.31.4-Handle-undefined-values-correctly.patch
Normal file
237
SOURCES/perl-5.31.4-Handle-undefined-values-correctly.patch
Normal file
@ -0,0 +1,237 @@
|
||||
From 01aed385e6bdbdcfd13bb66e9d8b7c55d2cfc34a Mon Sep 17 00:00:00 2001
|
||||
From: James E Keenan <jkeenan@cpan.org>
|
||||
Date: Thu, 19 Sep 2019 23:02:54 -0400
|
||||
Subject: [PATCH] Handle undefined values correctly
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
As reported by Henrik Pauli in RT 134441, the documentation's claim that
|
||||
|
||||
$dv->dumpValue([$x, $y]);
|
||||
|
||||
and
|
||||
|
||||
$dv->dumpValues($x, $y);
|
||||
|
||||
was not being sustained in the case where one of the elements in the
|
||||
array (or array ref) was undefined. This was due to an insufficiently
|
||||
precise specification within the dumpValues() method for determining
|
||||
when the value "undef\n" should be printed.
|
||||
|
||||
Tests for previously untested cases have been provided in
|
||||
t/rt-134441-dumpvalue.t. They were not appended to t/Dumpvalue.t (as
|
||||
would normally have been the case) because the tests in that file have
|
||||
accreted over the years in a sub-optimal manner: changes in attributes
|
||||
of the Dumpvalue object are tested but those changes are not zeroed-out
|
||||
(by, e.g., use of 'local $self->{attribute} = undef')
|
||||
before additional attributes are modified and tested. As a consequence,
|
||||
it's difficult to determine the state of the Dumpvalue object at any
|
||||
particular point and interactions between attributes cannot be ruled
|
||||
out.
|
||||
|
||||
Package TieOut, used to capture STDOUT during testing, has been
|
||||
extracted to its own file so that it can be used by all test files.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
MANIFEST | 2 +
|
||||
dist/Dumpvalue/lib/Dumpvalue.pm | 4 +-
|
||||
dist/Dumpvalue/t/Dumpvalue.t | 20 +-----
|
||||
dist/Dumpvalue/t/lib/TieOut.pm | 20 ++++++
|
||||
dist/Dumpvalue/t/rt-134441-dumpvalue.t | 86 ++++++++++++++++++++++++++
|
||||
5 files changed, 112 insertions(+), 20 deletions(-)
|
||||
create mode 100644 dist/Dumpvalue/t/lib/TieOut.pm
|
||||
create mode 100644 dist/Dumpvalue/t/rt-134441-dumpvalue.t
|
||||
|
||||
diff --git a/MANIFEST b/MANIFEST
|
||||
index 7bf62d8479..8159ac8cc1 100644
|
||||
--- a/MANIFEST
|
||||
+++ b/MANIFEST
|
||||
@@ -3455,6 +3455,8 @@ dist/Devel-SelfStubber/lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
|
||||
dist/Devel-SelfStubber/t/Devel-SelfStubber.t See if Devel::SelfStubber works
|
||||
dist/Dumpvalue/lib/Dumpvalue.pm Screen dump of perl values
|
||||
dist/Dumpvalue/t/Dumpvalue.t See if Dumpvalue works
|
||||
+dist/Dumpvalue/t/lib/TieOut.pm Helper module for Dumpvalue tests
|
||||
+dist/Dumpvalue/t/rt-134441-dumpvalue.t See if Dumpvalue works
|
||||
dist/encoding-warnings/lib/encoding/warnings.pm warn on implicit encoding conversions
|
||||
dist/encoding-warnings/t/1-warning.t tests for encoding::warnings
|
||||
dist/encoding-warnings/t/2-fatal.t tests for encoding::warnings
|
||||
diff --git a/dist/Dumpvalue/lib/Dumpvalue.pm b/dist/Dumpvalue/lib/Dumpvalue.pm
|
||||
index eef9b27157..3faf829538 100644
|
||||
--- a/dist/Dumpvalue/lib/Dumpvalue.pm
|
||||
+++ b/dist/Dumpvalue/lib/Dumpvalue.pm
|
||||
@@ -1,7 +1,7 @@
|
||||
use 5.006_001; # for (defined ref) and $#$v and our
|
||||
package Dumpvalue;
|
||||
use strict;
|
||||
-our $VERSION = '1.18';
|
||||
+our $VERSION = '1.19';
|
||||
our(%address, $stab, @stab, %stab, %subs);
|
||||
|
||||
sub ASCII { return ord('A') == 65; }
|
||||
@@ -79,7 +79,7 @@ sub dumpValues {
|
||||
my $self = shift;
|
||||
local %address;
|
||||
local $^W=0;
|
||||
- (print "undef\n"), return unless defined $_[0];
|
||||
+ (print "undef\n"), return if (@_ == 1 and not defined $_[0]);
|
||||
$self->unwrap(\@_,0);
|
||||
}
|
||||
|
||||
diff --git a/dist/Dumpvalue/t/Dumpvalue.t b/dist/Dumpvalue/t/Dumpvalue.t
|
||||
index 7063dd984c..ba8775126e 100644
|
||||
--- a/dist/Dumpvalue/t/Dumpvalue.t
|
||||
+++ b/dist/Dumpvalue/t/Dumpvalue.t
|
||||
@@ -16,6 +16,8 @@ BEGIN {
|
||||
|
||||
our ( $foo, @bar, %baz );
|
||||
|
||||
+use lib ("./t/lib");
|
||||
+use TieOut;
|
||||
use Test::More tests => 88;
|
||||
|
||||
use_ok( 'Dumpvalue' );
|
||||
@@ -278,21 +280,3 @@ is( $out->read, "0 0..0 'two'\n", 'dumpValues worked on array ref' );
|
||||
$d->dumpValues('one', 'two');
|
||||
is( $out->read, "0..1 'one' 'two'\n", 'dumpValues worked on multiple values' );
|
||||
|
||||
-
|
||||
-package TieOut;
|
||||
-use overload '"' => sub { "overloaded!" };
|
||||
-
|
||||
-sub TIEHANDLE {
|
||||
- my $class = shift;
|
||||
- bless(\( my $ref), $class);
|
||||
-}
|
||||
-
|
||||
-sub PRINT {
|
||||
- my $self = shift;
|
||||
- $$self .= join('', @_);
|
||||
-}
|
||||
-
|
||||
-sub read {
|
||||
- my $self = shift;
|
||||
- return substr($$self, 0, length($$self), '');
|
||||
-}
|
||||
diff --git a/dist/Dumpvalue/t/lib/TieOut.pm b/dist/Dumpvalue/t/lib/TieOut.pm
|
||||
new file mode 100644
|
||||
index 0000000000..568caedf9c
|
||||
--- /dev/null
|
||||
+++ b/dist/Dumpvalue/t/lib/TieOut.pm
|
||||
@@ -0,0 +1,20 @@
|
||||
+package TieOut;
|
||||
+use overload '"' => sub { "overloaded!" };
|
||||
+
|
||||
+sub TIEHANDLE {
|
||||
+ my $class = shift;
|
||||
+ bless(\( my $ref), $class);
|
||||
+}
|
||||
+
|
||||
+sub PRINT {
|
||||
+ my $self = shift;
|
||||
+ $$self .= join('', @_);
|
||||
+}
|
||||
+
|
||||
+sub read {
|
||||
+ my $self = shift;
|
||||
+ return substr($$self, 0, length($$self), '');
|
||||
+}
|
||||
+
|
||||
+1;
|
||||
+
|
||||
diff --git a/dist/Dumpvalue/t/rt-134441-dumpvalue.t b/dist/Dumpvalue/t/rt-134441-dumpvalue.t
|
||||
new file mode 100644
|
||||
index 0000000000..cc9f270f5a
|
||||
--- /dev/null
|
||||
+++ b/dist/Dumpvalue/t/rt-134441-dumpvalue.t
|
||||
@@ -0,0 +1,86 @@
|
||||
+BEGIN {
|
||||
+ require Config;
|
||||
+ if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
|
||||
+ print "1..0 # Skip -- Perl configured without List::Util module\n";
|
||||
+ exit 0;
|
||||
+ }
|
||||
+
|
||||
+ # `make test` in the CPAN version of this module runs us with -w, but
|
||||
+ # Dumpvalue.pm relies on all sorts of things that can cause warnings. I
|
||||
+ # don't think that's worth fixing, so we just turn off all warnings
|
||||
+ # during testing.
|
||||
+ $^W = 0;
|
||||
+}
|
||||
+
|
||||
+use lib ("./t/lib");
|
||||
+use TieOut;
|
||||
+use Test::More tests => 17;
|
||||
+
|
||||
+use_ok( 'Dumpvalue' );
|
||||
+
|
||||
+my $d;
|
||||
+ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' );
|
||||
+
|
||||
+my $out = tie *OUT, 'TieOut';
|
||||
+select(OUT);
|
||||
+
|
||||
+my (@foobar, $x, $y);
|
||||
+
|
||||
+@foobar = ('foo', 'bar');
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 'foo'\n1 'bar'\n", 'dumpValue worked on array ref' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 'foo'\n1 'bar'\n", 'dumpValues worked on array' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref");
|
||||
+
|
||||
+@foobar = (undef, 'bar');
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 undef\n1 'bar'\n",
|
||||
+ 'dumpValue worked on array ref, first element undefined' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 undef\n1 'bar'\n",
|
||||
+ 'dumpValues worked on array, first element undefined' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref, first element undefined");
|
||||
+
|
||||
+@foobar = ('bar', undef);
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 'bar'\n1 undef\n",
|
||||
+ 'dumpValue worked on array ref, last element undefined' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 'bar'\n1 undef\n",
|
||||
+ 'dumpValues worked on array, last element undefined' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref, last element undefined");
|
||||
+
|
||||
+@foobar = ('', 'bar');
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 ''\n1 'bar'\n",
|
||||
+ 'dumpValue worked on array ref, first element empty string' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 ''\n1 'bar'\n",
|
||||
+ 'dumpValues worked on array, first element empty string' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref, first element empty string");
|
||||
+
|
||||
+@foobar = ('bar', '');
|
||||
+$d->dumpValue([@foobar]);
|
||||
+$x = $out->read;
|
||||
+is( $x, "0 'bar'\n1 ''\n",
|
||||
+ 'dumpValue worked on array ref, last element empty string' );
|
||||
+$d->dumpValues(@foobar);
|
||||
+$y = $out->read;
|
||||
+is( $y, "0 'bar'\n1 ''\n",
|
||||
+ 'dumpValues worked on array, last element empty string' );
|
||||
+is( $y, $x,
|
||||
+ "dumpValues called on array returns same as dumpValue on array ref, last element empty string");
|
||||
+
|
||||
--
|
||||
2.21.0
|
||||
|
109
SOURCES/perl-5.31.5-Adapt-Configure-to-GCC-version-10.patch
Normal file
109
SOURCES/perl-5.31.5-Adapt-Configure-to-GCC-version-10.patch
Normal file
@ -0,0 +1,109 @@
|
||||
From 913582217c96512015fd60f270f0e262824579b7 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Tue, 12 Nov 2019 09:19:18 +0100
|
||||
Subject: [PATCH] Adapt Configure to GCC version 10
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
I got a notice from Jeff Law <law@redhat.com>:
|
||||
|
||||
Your particular package fails its testsuite. This was ultimately
|
||||
tracked down to a Configure problem. The perl configure script treated
|
||||
gcc-10 as gcc-1 and turned on -fpcc-struct-return. This is an ABI
|
||||
changing flag and caused Perl to not be able to interact properly with
|
||||
the dbm libraries on the system leading to a segfault.
|
||||
|
||||
His proposed patch corrected only this one instance of the version
|
||||
mismatch. Reading the Configure script revealed more issues. This
|
||||
patch fixes all of them I found.
|
||||
|
||||
Please note I did not test it because I don't have GCC 10 available.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
Configure | 14 +++++++-------
|
||||
cflags.SH | 2 +-
|
||||
2 files changed, 8 insertions(+), 8 deletions(-)
|
||||
|
||||
diff --git a/Configure b/Configure
|
||||
index fad1c9f2b1..706c0b64ed 100755
|
||||
--- a/Configure
|
||||
+++ b/Configure
|
||||
@@ -4701,7 +4701,7 @@ else
|
||||
fi
|
||||
$rm -f try try.*
|
||||
case "$gccversion" in
|
||||
-1*) cpp=`./loc gcc-cpp $cpp $pth` ;;
|
||||
+1.*) cpp=`./loc gcc-cpp $cpp $pth` ;;
|
||||
esac
|
||||
case "$gccversion" in
|
||||
'') gccosandvers='' ;;
|
||||
@@ -4741,7 +4741,7 @@ esac
|
||||
# gcc 3.* complain about adding -Idirectories that they already know about,
|
||||
# so we will take those off from locincpth.
|
||||
case "$gccversion" in
|
||||
-3*)
|
||||
+3.*)
|
||||
echo "main(){}">try.c
|
||||
for incdir in $locincpth; do
|
||||
warn=`$cc $ccflags -I$incdir -c try.c 2>&1 | \
|
||||
@@ -5467,13 +5467,13 @@ fi
|
||||
case "$hint" in
|
||||
default|recommended)
|
||||
case "$gccversion" in
|
||||
- 1*) dflt="$dflt -fpcc-struct-return" ;;
|
||||
+ 1.*) dflt="$dflt -fpcc-struct-return" ;;
|
||||
esac
|
||||
case "$optimize:$DEBUGGING" in
|
||||
*-g*:old) dflt="$dflt -DDEBUGGING";;
|
||||
esac
|
||||
case "$gccversion" in
|
||||
- 2*) if $test -d /etc/conf/kconfig.d &&
|
||||
+ 2.*) if $test -d /etc/conf/kconfig.d &&
|
||||
$contains _POSIX_VERSION $usrinc/sys/unistd.h >/dev/null 2>&1
|
||||
then
|
||||
# Interactive Systems (ISC) POSIX mode.
|
||||
@@ -5482,7 +5482,7 @@ default|recommended)
|
||||
;;
|
||||
esac
|
||||
case "$gccversion" in
|
||||
- 1*) ;;
|
||||
+ 1.*) ;;
|
||||
2.[0-8]*) ;;
|
||||
?*) set strict-aliasing -fno-strict-aliasing
|
||||
eval $checkccflag
|
||||
@@ -5600,7 +5600,7 @@ case "$cppflags" in
|
||||
;;
|
||||
esac
|
||||
case "$gccversion" in
|
||||
-1*) cppflags="$cppflags -D__GNUC__"
|
||||
+1.*) cppflags="$cppflags -D__GNUC__"
|
||||
esac
|
||||
case "$mips_type" in
|
||||
'');;
|
||||
@@ -23103,7 +23103,7 @@ fi
|
||||
|
||||
: add -D_FORTIFY_SOURCE if feasible and not already there
|
||||
case "$gccversion" in
|
||||
-[456789].*) case "$optimize$ccflags" in
|
||||
+[456789].*|[1-9][0-9]*) case "$optimize$ccflags" in
|
||||
*-O*) case "$ccflags$cppsymbols" in
|
||||
*_FORTIFY_SOURCE=*) # Don't add it again.
|
||||
echo "You seem to have -D_FORTIFY_SOURCE already, not adding it." >&4
|
||||
diff --git a/cflags.SH b/cflags.SH
|
||||
index e60742fed1..f1bcd6c38e 100755
|
||||
--- a/cflags.SH
|
||||
+++ b/cflags.SH
|
||||
@@ -156,7 +156,7 @@ esac
|
||||
|
||||
case "$gccversion" in
|
||||
'') ;;
|
||||
-[12]*) ;; # gcc versions 1 (gasp!) and 2 are not good for this.
|
||||
+[12].*) ;; # gcc versions 1 (gasp!) and 2 are not good for this.
|
||||
Intel*) ;; # # Is that you, Intel C++?
|
||||
#
|
||||
# NOTE 1: the -std=c89 without -pedantic is a bit pointless.
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,32 @@
|
||||
From a1c1fa25b1b25efb11cc8f987e007d4dd20056bc Mon Sep 17 00:00:00 2001
|
||||
From: Dave Cross <dave@dave.org.uk>
|
||||
Date: Wed, 23 Oct 2019 12:50:01 +0100
|
||||
Subject: [PATCH] Be clearer about taint's effect on @INC.
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perlsec.pod | 5 +++--
|
||||
1 file changed, 3 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pod/perlsec.pod b/pod/perlsec.pod
|
||||
index 0682674143..a631981ba5 100644
|
||||
--- a/pod/perlsec.pod
|
||||
+++ b/pod/perlsec.pod
|
||||
@@ -269,8 +269,9 @@ problem will be reported:
|
||||
Insecure dependency in require while running with -T switch
|
||||
|
||||
On versions of Perl before 5.26, activating taint mode will also remove
|
||||
-the current directory (".") from C<@INC>. Since version 5.26, the
|
||||
-current directory isn't included in C<@INC>.
|
||||
+the current directory (".") from the default value of C<@INC>. Since
|
||||
+version 5.26, the current directory isn't included in C<@INC> by
|
||||
+default.
|
||||
|
||||
=head2 Cleaning Up Your Path
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
45
SOURCES/perl-5.31.5-Fix-taint-mode-INC-documentation.patch
Normal file
45
SOURCES/perl-5.31.5-Fix-taint-mode-INC-documentation.patch
Normal file
@ -0,0 +1,45 @@
|
||||
From f73351928dfa1d1d564d3f7b8e63c5281ed835ee Mon Sep 17 00:00:00 2001
|
||||
From: Dave Cross <dave@dave.org.uk>
|
||||
Date: Tue, 22 Oct 2019 14:24:13 +0100
|
||||
Subject: [PATCH] Fix taint mode @INC documentation
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Explain that -T no longer removes '.' from @INC because, since
|
||||
5.26, '.' isn't in @INC to start with.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
pod/perlsec.pod | 8 ++++++--
|
||||
1 file changed, 6 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/pod/perlsec.pod b/pod/perlsec.pod
|
||||
index b210445685..0682674143 100644
|
||||
--- a/pod/perlsec.pod
|
||||
+++ b/pod/perlsec.pod
|
||||
@@ -245,8 +245,8 @@ Unix-like environments that support #! and setuid or setgid scripts.)
|
||||
|
||||
=head2 Taint mode and @INC
|
||||
|
||||
-When the taint mode (C<-T>) is in effect, the "." directory is removed
|
||||
-from C<@INC>, and the environment variables C<PERL5LIB> and C<PERLLIB>
|
||||
+When the taint mode (C<-T>) is in effect, the environment variables
|
||||
+C<PERL5LIB> and C<PERLLIB>
|
||||
are ignored by Perl. You can still adjust C<@INC> from outside the
|
||||
program by using the C<-I> command line option as explained in
|
||||
L<perlrun>. The two environment variables are ignored because
|
||||
@@ -268,6 +268,10 @@ problem will be reported:
|
||||
|
||||
Insecure dependency in require while running with -T switch
|
||||
|
||||
+On versions of Perl before 5.26, activating taint mode will also remove
|
||||
+the current directory (".") from C<@INC>. Since version 5.26, the
|
||||
+current directory isn't included in C<@INC>.
|
||||
+
|
||||
=head2 Cleaning Up Your Path
|
||||
|
||||
For "Insecure C<$ENV{PATH}>" messages, you need to set C<$ENV{'PATH'}> to
|
||||
--
|
||||
2.21.0
|
||||
|
30
SOURCES/perl-5.31.5-PATCH-gh-17218-memory-leak.patch
Normal file
30
SOURCES/perl-5.31.5-PATCH-gh-17218-memory-leak.patch
Normal file
@ -0,0 +1,30 @@
|
||||
From 0463f3a19af7afac8b402655ad66e5b05c095bcc Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Fri, 15 Nov 2019 15:01:15 -0700
|
||||
Subject: [PATCH] PATCH: gh#17218 memory leak
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Indeed, a variable's ref count was not getting decremented.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
regcomp.c | 1 +
|
||||
1 file changed, 1 insertion(+)
|
||||
|
||||
diff --git a/regcomp.c b/regcomp.c
|
||||
index 076ea350b5..7b9bf6ba7d 100644
|
||||
--- a/regcomp.c
|
||||
+++ b/regcomp.c
|
||||
@@ -18180,6 +18180,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
|
||||
|
||||
/* Likewise for 'posixes' */
|
||||
_invlist_union(posixes, cp_list, &cp_list);
|
||||
+ SvREFCNT_dec(posixes);
|
||||
|
||||
/* Likewise for anything else in the range that matched only
|
||||
* under UTF-8 */
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,77 @@
|
||||
From a4e94e39cfa6852b1d57e61ee122c8083ab9d82e Mon Sep 17 00:00:00 2001
|
||||
From: Hauke D <haukex@zero-g.net>
|
||||
Date: Mon, 20 Nov 2017 15:31:57 +0100
|
||||
Subject: [PATCH] Tie::StdHandle::BINMODE: handle layer argument
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Fixes #16262
|
||||
|
||||
BINMODE was not handling the LAYER argument.
|
||||
Also bump the version number.
|
||||
|
||||
(cherry picked from commit 479d04b98e5b747e5c9ead7368d3e132f524a2b7)
|
||||
Signed-off-by: Nicolas R <atoomic@cpan.org>
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
lib/Tie/Handle/stdhandle.t | 13 ++++++++++++-
|
||||
lib/Tie/StdHandle.pm | 4 ++--
|
||||
2 files changed, 14 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/lib/Tie/Handle/stdhandle.t b/lib/Tie/Handle/stdhandle.t
|
||||
index d2f04bcc5c..6c20d90f2b 100644
|
||||
--- a/lib/Tie/Handle/stdhandle.t
|
||||
+++ b/lib/Tie/Handle/stdhandle.t
|
||||
@@ -5,7 +5,7 @@ BEGIN {
|
||||
@INC = '../lib';
|
||||
}
|
||||
|
||||
-use Test::More tests => 27;
|
||||
+use Test::More tests => 29;
|
||||
|
||||
use_ok('Tie::StdHandle');
|
||||
|
||||
@@ -72,6 +72,17 @@ is($b, "rhubarbX\n", "b eq rhubarbX");
|
||||
$b = <$f>;
|
||||
is($b, "89\n", "b eq 89");
|
||||
|
||||
+# binmode should pass through layer argument
|
||||
+
|
||||
+binmode $f, ':raw';
|
||||
+ok !grep( $_ eq 'utf8', PerlIO::get_layers(tied(*$f)) ),
|
||||
+ 'no utf8 in layers after binmode :raw';
|
||||
+binmode $f, ':utf8';
|
||||
+ok grep( $_ eq 'utf8', PerlIO::get_layers(tied(*$f)) ),
|
||||
+ 'utf8 is in layers after binmode :utf8';
|
||||
+
|
||||
+# finish up
|
||||
+
|
||||
ok(eof($f), "eof");
|
||||
ok(close($f), "close");
|
||||
|
||||
diff --git a/lib/Tie/StdHandle.pm b/lib/Tie/StdHandle.pm
|
||||
index dfb86634f0..fb79a986c6 100644
|
||||
--- a/lib/Tie/StdHandle.pm
|
||||
+++ b/lib/Tie/StdHandle.pm
|
||||
@@ -4,7 +4,7 @@ use strict;
|
||||
|
||||
use Tie::Handle;
|
||||
our @ISA = 'Tie::Handle';
|
||||
-our $VERSION = '4.5';
|
||||
+our $VERSION = '4.6';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
@@ -48,7 +48,7 @@ sub TELL { tell($_[0]) }
|
||||
sub FILENO { fileno($_[0]) }
|
||||
sub SEEK { seek($_[0],$_[1],$_[2]) }
|
||||
sub CLOSE { close($_[0]) }
|
||||
-sub BINMODE { binmode($_[0]) }
|
||||
+sub BINMODE { &CORE::binmode(shift, @_) }
|
||||
|
||||
sub OPEN
|
||||
{
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,48 @@
|
||||
From 7c3f362035dec9b7eaec388b1f7f1619c1bd96a3 Mon Sep 17 00:00:00 2001
|
||||
From: Tony Cook <tony@develop-help.com>
|
||||
Date: Mon, 4 Nov 2019 09:52:22 +1100
|
||||
Subject: [PATCH] prevent a race between name-based stat and an open modifying
|
||||
atime
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Most linux systems rarely update atime, so it's very unlikely
|
||||
for this issue to trigger there, but on a system with classic atime
|
||||
behaviour this was a race between open modifying atime and time()
|
||||
ticking over.
|
||||
|
||||
gh #17234
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
lib/File/stat.t | 6 ++++--
|
||||
1 file changed, 4 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/lib/File/stat.t b/lib/File/stat.t
|
||||
index c403fc4498..fc9bb12cef 100644
|
||||
--- a/lib/File/stat.t
|
||||
+++ b/lib/File/stat.t
|
||||
@@ -133,6 +133,9 @@ SKIP: {
|
||||
test_X_ops($^X, "for $^X", qr/A/);
|
||||
}
|
||||
|
||||
+# open early so atime is consistent with the name based call
|
||||
+local *STAT;
|
||||
+my $canopen = open(STAT, '<', $file);
|
||||
|
||||
my $stat = File::stat::stat($file);
|
||||
isa_ok($stat, 'File::stat', 'should build a stat object');
|
||||
@@ -143,8 +146,7 @@ for (split //, "tTB") {
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
- local *STAT;
|
||||
- skip("Could not open file: $!", 2) unless open(STAT, '<', $file);
|
||||
+ skip("Could not open file: $!", 2) unless $canopen;
|
||||
isa_ok(File::stat::stat('STAT'), 'File::stat',
|
||||
'... should be able to find filehandle');
|
||||
|
||||
--
|
||||
2.21.0
|
||||
|
@ -0,0 +1,78 @@
|
||||
From 0c311b7c345769239f38d0139ea7738feec5ca4d Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Sat, 2 Nov 2019 13:59:38 -0600
|
||||
Subject: [PATCH] toke.c: Fix bug tr/// upgrading to UTF-8 in middle
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Consider tr/\x{ff}-\x{100}/AB/.
|
||||
|
||||
While parsing, the code keeps an offset from the beginning of the output
|
||||
to the beginning of the second number in the range. This is purely for
|
||||
speed so that it wouldn't have to re-find the beginning of that value,
|
||||
when it already knew it.
|
||||
|
||||
But the example above shows the folly of this shortcut. The second
|
||||
number in the range causes the output to be upgraded to UTF-8, which
|
||||
makes that offset invalid in general. Change to re-find the beginning.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
t/op/tr.t | 12 +++++++++++-
|
||||
toke.c | 4 +++-
|
||||
2 files changed, 14 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/t/op/tr.t b/t/op/tr.t
|
||||
index 47d603d4fd..25125c5bc7 100644
|
||||
--- a/t/op/tr.t
|
||||
+++ b/t/op/tr.t
|
||||
@@ -13,7 +13,7 @@ BEGIN {
|
||||
|
||||
use utf8;
|
||||
|
||||
-plan tests => 301;
|
||||
+plan tests => 304;
|
||||
|
||||
# Test this first before we extend the stack with other operations.
|
||||
# This caused an asan failure due to a bad write past the end of the stack.
|
||||
@@ -1145,4 +1145,14 @@ for ("", nullrocow) {
|
||||
'RT #133880 illegal \N{}');
|
||||
}
|
||||
|
||||
+{
|
||||
+ my $c = "\xff";
|
||||
+ my $d = "\x{104}";
|
||||
+ eval '$c =~ tr/\x{ff}-\x{104}/\x{100}-\x{105}/';
|
||||
+ is($@, "", 'tr/\x{ff}-\x{104}/\x{100}-\x{105}/ compiled');
|
||||
+ is($c, "\x{100}", 'ff -> 100');
|
||||
+ eval '$d =~ tr/\x{ff}-\x{104}/\x{100}-\x{105}/';
|
||||
+ is($d, "\x{105}", '104 -> 105');
|
||||
+}
|
||||
+
|
||||
1;
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 2995737af2..28f305c62c 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -3044,7 +3044,7 @@ S_scan_const(pTHX_ char *start)
|
||||
* 'offset_to_max' is the offset in 'sv' at which the character
|
||||
* (the range's maximum end point) before 'd' begins.
|
||||
*/
|
||||
- char * max_ptr = SvPVX(sv) + offset_to_max;
|
||||
+ char * max_ptr;
|
||||
char * min_ptr;
|
||||
IV range_min;
|
||||
IV range_max; /* last character in range */
|
||||
@@ -3056,6 +3056,8 @@ S_scan_const(pTHX_ char *start)
|
||||
IV real_range_max = 0;
|
||||
#endif
|
||||
/* Get the code point values of the range ends. */
|
||||
+ max_ptr = (d_is_utf8) ? (char *) utf8_hop( (U8*) d, -1) : d - 1;
|
||||
+ offset_to_max = max_ptr - SvPVX_const(sv);
|
||||
if (d_is_utf8) {
|
||||
/* We know the utf8 is valid, because we just constructed
|
||||
* it ourselves in previous loop iterations */
|
||||
--
|
||||
2.21.0
|
||||
|
48
SOURCES/perl-5.31.5-toke.c-comment-changes.patch
Normal file
48
SOURCES/perl-5.31.5-toke.c-comment-changes.patch
Normal file
@ -0,0 +1,48 @@
|
||||
From d7f7b0e39a10a6e3e0bd81d15473ee522a064016 Mon Sep 17 00:00:00 2001
|
||||
From: Karl Williamson <khw@cpan.org>
|
||||
Date: Mon, 4 Nov 2019 21:55:53 -0700
|
||||
Subject: [PATCH] toke.c: comment changes
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
These should have been included in
|
||||
0c311b7c345769239f38d0139ea7738feec5ca4d
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
toke.c | 11 ++---------
|
||||
1 file changed, 2 insertions(+), 9 deletions(-)
|
||||
|
||||
diff --git a/toke.c b/toke.c
|
||||
index 3f376640ef..9c1e77f9db 100644
|
||||
--- a/toke.c
|
||||
+++ b/toke.c
|
||||
@@ -3032,13 +3032,8 @@ S_scan_const(pTHX_ char *start)
|
||||
s++; /* Skip past the hyphen */
|
||||
|
||||
/* d now points to where the end-range character will be
|
||||
- * placed. Save it so won't have to go finding it later,
|
||||
- * and drop down to get that character. (Actually we
|
||||
- * instead save the offset, to handle the case where a
|
||||
- * realloc in the meantime could change the actual
|
||||
- * pointer). We'll finish processing the range the next
|
||||
- * time through the loop */
|
||||
- offset_to_max = d - SvPVX_const(sv);
|
||||
+ * placed. Drop down to get that character. We'll finish
|
||||
+ * processing the range the next time through the loop */
|
||||
|
||||
if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
|
||||
has_above_latin1 = TRUE;
|
||||
@@ -3055,8 +3050,6 @@ S_scan_const(pTHX_ char *start)
|
||||
* are the range start and range end, in order.
|
||||
* 'd' points to just beyond the range end in the 'sv' string,
|
||||
* where we would next place something
|
||||
- * 'offset_to_max' is the offset in 'sv' at which the character
|
||||
- * (the range's maximum end point) before 'd' begins.
|
||||
*/
|
||||
char * max_ptr;
|
||||
char * min_ptr;
|
||||
--
|
||||
2.21.0
|
||||
|
47
SOURCES/perl-5.8.0-libdir64.patch
Normal file
47
SOURCES/perl-5.8.0-libdir64.patch
Normal file
@ -0,0 +1,47 @@
|
||||
diff -up perl-5.28.0-RC1/Configure.orig perl-5.28.0-RC1/Configure
|
||||
--- perl-5.28.0-RC1/Configure.orig 2018-05-21 12:44:04.000000000 +0200
|
||||
+++ perl-5.28.0-RC1/Configure 2018-05-22 12:21:53.908599933 +0200
|
||||
@@ -7269,8 +7269,8 @@ esac'
|
||||
: Reproduce behavior of 5.005 and earlier, maybe drop that in 5.7.
|
||||
case "$installstyle" in
|
||||
'') case "$prefix" in
|
||||
- *perl*) dflt='lib';;
|
||||
- *) dflt='lib/perl5' ;;
|
||||
+ *perl*) dflt='lib64';;
|
||||
+ *) dflt='lib64/perl5' ;;
|
||||
esac
|
||||
;;
|
||||
*) dflt="$installstyle" ;;
|
||||
@@ -7336,8 +7336,8 @@ esac
|
||||
: /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
|
||||
@@ -7584,8 +7584,8 @@ siteprefixexp="$ansexp"
|
||||
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"
|
||||
@@ -8001,8 +8001,8 @@ case "$vendorprefix" in
|
||||
'')
|
||||
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
Normal file
109
SOURCES/perl-USE_MM_LD_RUN_PATH.patch
Normal 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
|
||||
@@ -89,6 +89,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
|
||||
@@ -317,7 +317,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
|
||||
|
||||
@@ -501,7 +501,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){
|
||||
@@ -2821,6 +2841,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
|
||||
@@ -1045,7 +1045,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
Normal file
21
SOURCES/perl-example.stp
Normal 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
Normal file
21
SOURCES/perl-perlbug-tag.patch
Normal file
@ -0,0 +1,21 @@
|
||||
diff -up perl-5.28.0-RC1/utils/perlbug.PL.orig perl-5.28.0-RC1/utils/perlbug.PL
|
||||
--- perl-5.28.0-RC1/utils/perlbug.PL.orig 2018-05-21 12:44:04.000000000 +0200
|
||||
+++ perl-5.28.0-RC1/utils/perlbug.PL 2018-05-22 12:17:58.584993588 +0200
|
||||
@@ -288,17 +288,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
Normal file
71
SOURCES/perl.stp
Normal 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)
|
||||
}
|
7011
SPECS/perl.spec
Normal file
7011
SPECS/perl.spec
Normal file
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user