Toshaan Bharvani
2 years ago
commit
da91542796
58 changed files with 15433 additions and 0 deletions
@ -0,0 +1,41 @@
@@ -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 |
@ -0,0 +1,158 @@
@@ -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/ |
||||
|
@ -0,0 +1,12 @@
@@ -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. |
@ -0,0 +1,12 @@
@@ -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); |
@ -0,0 +1,17 @@
@@ -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 @@
@@ -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 @@
@@ -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 |
||||
|
@ -0,0 +1,57 @@
@@ -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 @@
@@ -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 @@
@@ -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 @@
@@ -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 @@
@@ -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 @@
@@ -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 |
||||
|
@ -0,0 +1,175 @@
@@ -0,0 +1,175 @@
|
||||
From bafffe7f2ca587960177ed03216e2d5692fe6143 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Wed, 19 Aug 2020 11:57:17 -0600 |
||||
Subject: [PATCH] Add av_count() |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
This returns the number of elements in an array in a clearly named |
||||
function. |
||||
|
||||
av_top_index(), av_tindex() are clearly named, but are less than ideal, |
||||
and came about because no one back then thought of this one, until now |
||||
Paul Evans did. |
||||
|
||||
Petr Písař: Port 87306e0674dfe3af29804b4641347cd5ac9b0521 to 5.32.0. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
av.c | 17 ++++++++++++++--- |
||||
av.h | 3 ++- |
||||
embed.fnc | 3 ++- |
||||
embed.h | 2 +- |
||||
inline.h | 16 ++++++++++++---- |
||||
proto.h | 11 ++++++++--- |
||||
6 files changed, 39 insertions(+), 13 deletions(-) |
||||
|
||||
diff --git a/av.c b/av.c |
||||
index 27b2f12..b5ddaca 100644 |
||||
--- a/av.c |
||||
+++ b/av.c |
||||
@@ -814,9 +814,10 @@ The Perl equivalent for this is C<$#myarray>. |
||||
=for apidoc av_len |
||||
|
||||
Same as L</av_top_index>. Note that, unlike what the name implies, it returns |
||||
-the highest index in the array, so to get the size of the array you need to use |
||||
-S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would |
||||
-expect. |
||||
+the highest index in the array. This is unlike L</sv_len>, which returns what |
||||
+you would expect. |
||||
+ |
||||
+B<To get the true number of elements in the array, instead use C<L</av_count>>>. |
||||
|
||||
=cut |
||||
*/ |
||||
@@ -1089,6 +1090,16 @@ Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) { |
||||
return sv; |
||||
} |
||||
|
||||
+SSize_t |
||||
+Perl_av_top_index(pTHX_ AV *av) |
||||
+{ |
||||
+ PERL_ARGS_ASSERT_AV_TOP_INDEX; |
||||
+ assert(SvTYPE(av) == SVt_PVAV); |
||||
+ |
||||
+ return AvFILL(av); |
||||
+} |
||||
+ |
||||
+ |
||||
/* |
||||
* ex: set ts=8 sts=4 sw=4 et: |
||||
*/ |
||||
diff --git a/av.h b/av.h |
||||
index 5e39c42..90ebfff 100644 |
||||
--- a/av.h |
||||
+++ b/av.h |
||||
@@ -81,7 +81,8 @@ Same as C<av_top_index()>. |
||||
|
||||
#define AvFILL(av) ((SvRMAGICAL((const SV *) (av))) \ |
||||
? mg_size(MUTABLE_SV(av)) : AvFILLp(av)) |
||||
-#define av_tindex(av) av_top_index(av) |
||||
+#define av_top_index(av) AvFILL(av) |
||||
+#define av_tindex(av) av_top_index(av) |
||||
|
||||
/* Note that it doesn't make sense to do this: |
||||
* SvGETMAGIC(av); IV x = av_tindex_nomg(av); |
||||
diff --git a/embed.fnc b/embed.fnc |
||||
index 589ab1a..789cd3c 100644 |
||||
--- a/embed.fnc |
||||
+++ b/embed.fnc |
||||
@@ -541,7 +541,8 @@ Apd |void |av_push |NN AV *av|NN SV *val |
||||
EXp |void |av_reify |NN AV *av |
||||
ApdR |SV* |av_shift |NN AV *av |
||||
Apd |SV** |av_store |NN AV *av|SSize_t key|NULLOK SV *val |
||||
-AidRp |SSize_t|av_top_index |NN AV *av |
||||
+AMdRp |SSize_t|av_top_index |NN AV *av |
||||
+AidRp |Size_t |av_count |NN AV *av |
||||
AmdR |SSize_t|av_tindex |NN AV *av |
||||
Apd |void |av_undef |NN AV *av |
||||
Apdoex |SV** |av_create_and_unshift_one|NN AV **const avp|NN SV *const val |
||||
diff --git a/embed.h b/embed.h |
||||
index 182b12a..329ac40 100644 |
||||
--- a/embed.h |
||||
+++ b/embed.h |
||||
@@ -48,6 +48,7 @@ |
||||
#define atfork_lock Perl_atfork_lock |
||||
#define atfork_unlock Perl_atfork_unlock |
||||
#define av_clear(a) Perl_av_clear(aTHX_ a) |
||||
+#define av_count(a) Perl_av_count(aTHX_ a) |
||||
#define av_delete(a,b,c) Perl_av_delete(aTHX_ a,b,c) |
||||
#define av_exists(a,b) Perl_av_exists(aTHX_ a,b) |
||||
#define av_extend(a,b) Perl_av_extend(aTHX_ a,b) |
||||
@@ -59,7 +60,6 @@ |
||||
#define av_push(a,b) Perl_av_push(aTHX_ a,b) |
||||
#define av_shift(a) Perl_av_shift(aTHX_ a) |
||||
#define av_store(a,b,c) Perl_av_store(aTHX_ a,b,c) |
||||
-#define av_top_index(a) Perl_av_top_index(aTHX_ a) |
||||
#define av_undef(a) Perl_av_undef(aTHX_ a) |
||||
#define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b) |
||||
#define block_end(a,b) Perl_block_end(aTHX_ a,b) |
||||
diff --git a/inline.h b/inline.h |
||||
index 27005d2..35af18a 100644 |
||||
--- a/inline.h |
||||
+++ b/inline.h |
||||
@@ -39,13 +39,21 @@ SOFTWARE. |
||||
|
||||
/* ------------------------------- av.h ------------------------------- */ |
||||
|
||||
-PERL_STATIC_INLINE SSize_t |
||||
-Perl_av_top_index(pTHX_ AV *av) |
||||
+/* |
||||
+=for apidoc av_count |
||||
+Returns the number of elements in the array C<av>. This is the true length of |
||||
+the array, including any undefined elements. It is always the same as |
||||
+S<C<av_top_index(av) + 1>>. |
||||
+ |
||||
+=cut |
||||
+*/ |
||||
+PERL_STATIC_INLINE Size_t |
||||
+Perl_av_count(pTHX_ AV *av) |
||||
{ |
||||
- PERL_ARGS_ASSERT_AV_TOP_INDEX; |
||||
+ PERL_ARGS_ASSERT_AV_COUNT; |
||||
assert(SvTYPE(av) == SVt_PVAV); |
||||
|
||||
- return AvFILL(av); |
||||
+ return AvFILL(av) + 1; |
||||
} |
||||
|
||||
/* ------------------------------- cv.h ------------------------------- */ |
||||
diff --git a/proto.h b/proto.h |
||||
index 02ef4ed..83ba098 100644 |
||||
--- a/proto.h |
||||
+++ b/proto.h |
||||
@@ -219,6 +219,13 @@ PERL_CALLCONV SV** Perl_av_arylen_p(pTHX_ AV *av); |
||||
PERL_CALLCONV void Perl_av_clear(pTHX_ AV *av); |
||||
#define PERL_ARGS_ASSERT_AV_CLEAR \ |
||||
assert(av) |
||||
+#ifndef PERL_NO_INLINE_FUNCTIONS |
||||
+PERL_STATIC_INLINE Size_t Perl_av_count(pTHX_ AV *av) |
||||
+ __attribute__warn_unused_result__; |
||||
+#define PERL_ARGS_ASSERT_AV_COUNT \ |
||||
+ assert(av) |
||||
+#endif |
||||
+ |
||||
PERL_CALLCONV void Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val); |
||||
#define PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH \ |
||||
assert(avp); assert(val) |
||||
@@ -284,12 +291,10 @@ PERL_CALLCONV SV** Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val); |
||||
__attribute__warn_unused_result__; */ |
||||
#define PERL_ARGS_ASSERT_AV_TINDEX |
||||
|
||||
-#ifndef PERL_NO_INLINE_FUNCTIONS |
||||
-PERL_STATIC_INLINE SSize_t Perl_av_top_index(pTHX_ AV *av) |
||||
+PERL_CALLCONV SSize_t Perl_av_top_index(pTHX_ AV *av) |
||||
__attribute__warn_unused_result__; |
||||
#define PERL_ARGS_ASSERT_AV_TOP_INDEX \ |
||||
assert(av) |
||||
-#endif |
||||
|
||||
PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av); |
||||
#define PERL_ARGS_ASSERT_AV_UNDEF \ |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,196 @@
@@ -0,0 +1,196 @@
|
||||
From d7504df2a5d8985f2a8b04f17acff5e324572c39 Mon Sep 17 00:00:00 2001 |
||||
From: Richard Leach <richardleach@users.noreply.github.com> |
||||
Date: Sun, 11 Oct 2020 12:26:27 +0100 |
||||
Subject: [PATCH] pp_split: no SWITCHSTACK in @ary = split(...) optimisation |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Petr Písař: 607eaf26a99ff76ab48877e68f1d7b005dc51575 ported to 5.32.0. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
pp.c | 89 +++++++++++++++++++++++++++++----------------------- |
||||
t/op/split.t | 23 +++++++++++++- |
||||
2 files changed, 72 insertions(+), 40 deletions(-) |
||||
|
||||
diff --git a/pp.c b/pp.c |
||||
index df80830..e4863d3 100644 |
||||
--- a/pp.c |
||||
+++ b/pp.c |
||||
@@ -5985,6 +5985,7 @@ PP(pp_split) |
||||
|
||||
/* handle @ary = split(...) optimisation */ |
||||
if (PL_op->op_private & OPpSPLIT_ASSIGN) { |
||||
+ realarray = 1; |
||||
if (!(PL_op->op_flags & OPf_STACKED)) { |
||||
if (PL_op->op_private & OPpSPLIT_LEX) { |
||||
if (PL_op->op_private & OPpLVAL_INTRO) |
||||
@@ -6007,26 +6008,10 @@ PP(pp_split) |
||||
oldsave = PL_savestack_ix; |
||||
} |
||||
|
||||
- realarray = 1; |
||||
- PUTBACK; |
||||
- av_extend(ary,0); |
||||
- (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv)); |
||||
- av_clear(ary); |
||||
- SPAGAIN; |
||||
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) { |
||||
PUSHMARK(SP); |
||||
XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg)); |
||||
- } |
||||
- else { |
||||
- if (!AvREAL(ary)) { |
||||
- I32 i; |
||||
- AvREAL_on(ary); |
||||
- AvREIFY_off(ary); |
||||
- for (i = AvFILLp(ary); i >= 0; i--) |
||||
- AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ |
||||
- } |
||||
- /* temporarily switch stacks */ |
||||
- SAVESWITCHSTACK(PL_curstack, ary); |
||||
+ } else { |
||||
make_mortal = 0; |
||||
} |
||||
} |
||||
@@ -6358,29 +6343,56 @@ PP(pp_split) |
||||
LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */ |
||||
SPAGAIN; |
||||
if (realarray) { |
||||
- if (!mg) { |
||||
- if (SvSMAGICAL(ary)) { |
||||
- PUTBACK; |
||||
+ if (!mg) { |
||||
+ PUTBACK; |
||||
+ if(AvREAL(ary)) { |
||||
+ if (av_count(ary) > 0) |
||||
+ av_clear(ary); |
||||
+ } else { |
||||
+ AvREAL_on(ary); |
||||
+ AvREIFY_off(ary); |
||||
+ |
||||
+ if (AvMAX(ary) > -1) { |
||||
+ /* don't free mere refs */ |
||||
+ Zero(AvARRAY(ary), AvMAX(ary), SV*); |
||||
+ } |
||||
+ } |
||||
+ if(AvMAX(ary) < iters) |
||||
+ av_extend(ary,iters); |
||||
+ SPAGAIN; |
||||
+ |
||||
+ /* Need to copy the SV*s from the stack into ary */ |
||||
+ Copy(SP + 1 - iters, AvARRAY(ary), iters, SV*); |
||||
+ AvFILLp(ary) = iters - 1; |
||||
+ |
||||
+ if (SvSMAGICAL(ary)) { |
||||
+ PUTBACK; |
||||
mg_set(MUTABLE_SV(ary)); |
||||
SPAGAIN; |
||||
- } |
||||
- if (gimme == G_ARRAY) { |
||||
- EXTEND(SP, iters); |
||||
- Copy(AvARRAY(ary), SP + 1, iters, SV*); |
||||
- SP += iters; |
||||
- RETURN; |
||||
- } |
||||
+ } |
||||
+ |
||||
+ if (gimme != G_ARRAY) { |
||||
+ /* SP points to the final SV* pushed to the stack. But the SV* */ |
||||
+ /* are not going to be used from the stack. Point SP to below */ |
||||
+ /* the first of these SV*. */ |
||||
+ SP -= iters; |
||||
+ PUTBACK; |
||||
+ } |
||||
} |
||||
else { |
||||
- PUTBACK; |
||||
- ENTER_with_name("call_PUSH"); |
||||
- call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); |
||||
- LEAVE_with_name("call_PUSH"); |
||||
- SPAGAIN; |
||||
+ PUTBACK; |
||||
+ av_extend(ary,iters); |
||||
+ av_clear(ary); |
||||
+ |
||||
+ ENTER_with_name("call_PUSH"); |
||||
+ call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); |
||||
+ LEAVE_with_name("call_PUSH"); |
||||
+ SPAGAIN; |
||||
+ |
||||
if (gimme == G_ARRAY) { |
||||
SSize_t i; |
||||
/* EXTEND should not be needed - we just popped them */ |
||||
- EXTEND(SP, iters); |
||||
+ EXTEND_SKIP(SP, iters); |
||||
for (i=0; i < iters; i++) { |
||||
SV **svp = av_fetch(ary, i, FALSE); |
||||
PUSHs((svp) ? *svp : &PL_sv_undef); |
||||
@@ -6389,13 +6401,12 @@ PP(pp_split) |
||||
} |
||||
} |
||||
} |
||||
- else { |
||||
- if (gimme == G_ARRAY) |
||||
- RETURN; |
||||
- } |
||||
|
||||
- GETTARGET; |
||||
- XPUSHi(iters); |
||||
+ if (gimme != G_ARRAY) { |
||||
+ GETTARGET; |
||||
+ XPUSHi(iters); |
||||
+ } |
||||
+ |
||||
RETURN; |
||||
} |
||||
|
||||
diff --git a/t/op/split.t b/t/op/split.t |
||||
index 14f9158..7f37512 100644 |
||||
--- a/t/op/split.t |
||||
+++ b/t/op/split.t |
||||
@@ -7,7 +7,7 @@ BEGIN { |
||||
set_up_inc('../lib'); |
||||
} |
||||
|
||||
-plan tests => 176; |
||||
+plan tests => 182; |
||||
|
||||
$FS = ':'; |
||||
|
||||
@@ -648,6 +648,19 @@ is "@a", '1 2 3', 'assignment to split-to-array (stacked)'; |
||||
is (+@a, 0, "empty utf8 string"); |
||||
} |
||||
|
||||
+# correct stack adjustments (gh#18232) |
||||
+{ |
||||
+ sub foo { return @_ } |
||||
+ my @a = foo(1, scalar split " ", "a b"); |
||||
+ is(join('', @a), "12", "Scalar split to a sub parameter"); |
||||
+} |
||||
+ |
||||
+{ |
||||
+ sub foo { return @_ } |
||||
+ my @a = foo(1, scalar(@x = split " ", "a b")); |
||||
+ is(join('', @a), "12", "Split to @x then use scalar result as a sub parameter"); |
||||
+} |
||||
+ |
||||
fresh_perl_is(<<'CODE', '', {}, "scalar split stack overflow"); |
||||
map{int"";split//.0>60for"0000000000000000"}split// for"00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" |
||||
CODE |
||||
@@ -667,3 +680,11 @@ CODE |
||||
ok(eq_array(\@result,['a','b']), "Resulting in ('a','b')"); |
||||
} |
||||
} |
||||
+ |
||||
+# check that the (@ary = split) optimisation survives @ary being modified |
||||
+ |
||||
+fresh_perl_is('my @ary; @ary = split(/\w(?{ @ary[1000] = 1 })/, "abc");', |
||||
+ '',{},'(@ary = split ...) survives @ary being Renew()ed'); |
||||
+fresh_perl_is('my @ary; @ary = split(/\w(?{ undef @ary })/, "abc");', |
||||
+ '',{},'(@ary = split ...) survives an (undef @ary)'); |
||||
+ |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,34 @@
@@ -0,0 +1,34 @@
|
||||
From ab72b7bd043df0f0ad6090a4c95f378624fad9fc Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Sat, 7 Mar 2020 12:54:19 -0700 |
||||
Subject: [PATCH] DynaLoader: use PerlEnv_getenv() |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Doing so invokes thread-safe guards |
||||
|
||||
Petr Písař: Ported from b0312014d6c1804920d2b687a5fa5645b445ce9f to |
||||
5.32.1. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
ext/DynaLoader/dlutils.c | 2 +- |
||||
1 file changed, 1 insertion(+), 1 deletion(-) |
||||
|
||||
diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c |
||||
index 8584f89..1a27fbd 100644 |
||||
--- a/ext/DynaLoader/dlutils.c |
||||
+++ b/ext/DynaLoader/dlutils.c |
||||
@@ -115,7 +115,7 @@ dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */ |
||||
#endif |
||||
|
||||
#if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) |
||||
- if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL |
||||
+ if ( (perl_dl_nonlazy = PerlEnv_getenv("PERL_DL_NONLAZY")) != NULL |
||||
&& grok_atoUV(perl_dl_nonlazy, &uv, NULL) |
||||
&& uv <= INT_MAX |
||||
) { |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,44 @@
@@ -0,0 +1,44 @@
|
||||
From 2ce7bf1ad5fd7aee21975b3dd1c8dceef3aab7e4 Mon Sep 17 00:00:00 2001 |
||||
From: David Mitchell <davem@iabyn.com> |
||||
Date: Tue, 9 Mar 2021 16:42:11 +0000 |
||||
Subject: [PATCH] Perl_do_sv_dump(): handle PL_strtab |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
When dumping this special hash, the values in the HE entry are refcounts |
||||
rather than SV pointers. sv_dump() used to crash here. |
||||
|
||||
Petr Písař: Ported to 5.32.1 from upstream |
||||
a9bb6a62ae45bb372a5cca98a76d1a79edd89ccb. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
dump.c | 11 +++++++++-- |
||||
1 file changed, 9 insertions(+), 2 deletions(-) |
||||
|
||||
diff --git a/dump.c b/dump.c |
||||
index f03c3f6..0f15d77 100644 |
||||
--- a/dump.c |
||||
+++ b/dump.c |
||||
@@ -2224,8 +2224,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo |
||||
PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ)); |
||||
if (HvEITER_get(hv) == he) |
||||
PerlIO_printf(file, "[CURRENT] "); |
||||
- PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash); |
||||
- do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); |
||||
+ PerlIO_printf(file, "HASH = 0x%" UVxf, (UV) hash); |
||||
+ |
||||
+ if (sv == (SV*)PL_strtab) |
||||
+ PerlIO_printf(file, " REFCNT = 0x%" UVxf "\n", |
||||
+ (UV)he->he_valu.hent_refcount ); |
||||
+ else { |
||||
+ (void)PerlIO_putc(file, '\n'); |
||||
+ do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); |
||||
+ } |
||||
} |
||||
} |
||||
DONEHV:; |
||||
-- |
||||
2.26.3 |
||||
|
@ -0,0 +1,53 @@
@@ -0,0 +1,53 @@
|
||||
From c5eed6e541fe27d9e9dfd31f42c43f4dfa1f486b Mon Sep 17 00:00:00 2001 |
||||
From: Yves Orton <demerphq@gmail.com> |
||||
Date: Sat, 11 Jul 2020 09:26:21 +0200 |
||||
Subject: [PATCH] hv.c: add a guard clause to prevent the number of buckets in |
||||
a hash from getting too large |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
This caps it at 1<<28 buckets, eg, ~268M. In theory without a guard clause like |
||||
this we could grow to the point of possibly wrapping around in terms of size, |
||||
not to mention being ridiculously wasteful of memory at larger sizes. |
||||
Even this cap is probably too high. It should probably be something like 1<<24. |
||||
|
||||
Petr Písař: Ported to 5.32.1 from |
||||
aae087f7cec022be14a17deb95cb2208e16b7891. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
hv.c | 10 +++++++++- |
||||
1 file changed, 9 insertions(+), 1 deletion(-) |
||||
|
||||
diff --git a/hv.c b/hv.c |
||||
index eccae62..32dbd19 100644 |
||||
--- a/hv.c |
||||
+++ b/hv.c |
||||
@@ -38,7 +38,13 @@ holds the key and hash value. |
||||
* NOTE if you change this formula so we split earlier than previously |
||||
* you MUST change the logic in hv_ksplit() |
||||
*/ |
||||
-#define DO_HSPLIT(xhv) ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1)) > (xhv)->xhv_max ) |
||||
+ |
||||
+/* MAX_BUCKET_MAX is the maximum max bucket index, at which point we stop growing the |
||||
+ * number of buckets, |
||||
+ */ |
||||
+#define MAX_BUCKET_MAX ((1<<26)-1) |
||||
+#define DO_HSPLIT(xhv) ( ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1)) > (xhv)->xhv_max ) && \ |
||||
+ ((xhv)->xhv_max < MAX_BUCKET_MAX) ) |
||||
#define HV_FILL_THRESHOLD 31 |
||||
|
||||
static const char S_strtab_error[] |
||||
@@ -1426,6 +1432,8 @@ S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize) |
||||
); |
||||
|
||||
PERL_ARGS_ASSERT_HSPLIT; |
||||
+ if (newsize > MAX_BUCKET_MAX+1) |
||||
+ return; |
||||
|
||||
PL_nomemok = TRUE; |
||||
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,30 @@
@@ -0,0 +1,30 @@
|
||||
From 3c53c6179afbdbef748c110abdb849cb463c2727 Mon Sep 17 00:00:00 2001 |
||||
From: Todd Rinaldo <toddr@cpan.org> |
||||
Date: Thu, 30 Jul 2020 17:42:47 -0500 |
||||
Subject: [PATCH] Add missing MANIFEST entry from fix for debugger |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Add on fix to #17901 |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
MANIFEST | 1 + |
||||
1 file changed, 1 insertion(+) |
||||
|
||||
diff --git a/MANIFEST b/MANIFEST |
||||
index 990a75ad52..12601e46b4 100644 |
||||
--- a/MANIFEST |
||||
+++ b/MANIFEST |
||||
@@ -4826,6 +4826,7 @@ lib/perl5db/t/symbol-table-bug Tests for the Perl debugger |
||||
lib/perl5db/t/taint Tests for the Perl debugger |
||||
lib/perl5db/t/test-a-statement-1 Tests for the Perl debugger |
||||
lib/perl5db/t/test-a-statement-2 Tests for the Perl debugger |
||||
+lib/perl5db/t/test-a-statement-3 Tests for the Perl debugger |
||||
lib/perl5db/t/test-dieLevel-option-1 Tests for the Perl debugger |
||||
lib/perl5db/t/test-frame-option-1 Tests for the Perl debugger |
||||
lib/perl5db/t/test-l-statement-1 Tests for the Perl debugger |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,90 @@
@@ -0,0 +1,90 @@
|
||||
From b248789b64d6bd277c52bfe608ed3192023af1bd Mon Sep 17 00:00:00 2001 |
||||
From: "E. Choroba" <choroba@matfyz.cz> |
||||
Date: Fri, 26 Jun 2020 21:19:24 +0200 |
||||
Subject: [PATCH] After running an action in the debugger, turn it off |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
When running with "c", there was no problem, but when running with "n" |
||||
or "s", once the action was executed, it kept executing on the |
||||
following lines, which wasn't expected. Clearing $action here prevents |
||||
this unwanted behaviour. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
lib/perl5db.pl | 3 ++- |
||||
lib/perl5db.t | 22 ++++++++++++++++++++++ |
||||
lib/perl5db/t/test-a-statement-3 | 6 ++++++ |
||||
3 files changed, 30 insertions(+), 1 deletion(-) |
||||
create mode 100644 lib/perl5db/t/test-a-statement-3 |
||||
|
||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl |
||||
index 69a9bb6e64..e04a0e17fa 100644 |
||||
--- a/lib/perl5db.pl |
||||
+++ b/lib/perl5db.pl |
||||
@@ -529,7 +529,7 @@ BEGIN { |
||||
use vars qw($VERSION $header); |
||||
|
||||
# bump to X.XX in blead, only use X.XX_XX in maint |
||||
-$VERSION = '1.57'; |
||||
+$VERSION = '1.58'; |
||||
|
||||
$header = "perl5db.pl version $VERSION"; |
||||
|
||||
@@ -2708,6 +2708,7 @@ If there are any preprompt actions, execute those as well. |
||||
# The &-call is here to ascertain the mutability of @_. |
||||
&DB::eval; |
||||
} |
||||
+ undef $action; |
||||
|
||||
# Are we nested another level (e.g., did we evaluate a function |
||||
# that had a breakpoint in it at the debugger prompt)? |
||||
diff --git a/lib/perl5db.t b/lib/perl5db.t |
||||
index 421229a54a..913a301d98 100644 |
||||
--- a/lib/perl5db.t |
||||
+++ b/lib/perl5db.t |
||||
@@ -2799,6 +2799,28 @@ SKIP: |
||||
); |
||||
} |
||||
|
||||
+{ |
||||
+ # GitHub #17901 |
||||
+ my $wrapper = DebugWrap->new( |
||||
+ { |
||||
+ cmds => |
||||
+ [ |
||||
+ 'a 4 $s++', |
||||
+ ('s') x 5, |
||||
+ 'x $s', |
||||
+ 'q' |
||||
+ ], |
||||
+ prog => '../lib/perl5db/t/test-a-statement-3', |
||||
+ switches => [ '-d' ], |
||||
+ stderr => 0, |
||||
+ } |
||||
+ ); |
||||
+ $wrapper->contents_like( |
||||
+ qr/^0 +2$/m, |
||||
+ 'Test that the a command runs only on the given lines.', |
||||
+ ); |
||||
+} |
||||
+ |
||||
{ |
||||
# perl 5 RT #126735 regression bug. |
||||
local $ENV{PERLDB_OPTS} = "NonStop=0 RemotePort=non-existent-host.tld:9001"; |
||||
diff --git a/lib/perl5db/t/test-a-statement-3 b/lib/perl5db/t/test-a-statement-3 |
||||
new file mode 100644 |
||||
index 0000000000..b188c1c5c5 |
||||
--- /dev/null |
||||
+++ b/lib/perl5db/t/test-a-statement-3 |
||||
@@ -0,0 +1,6 @@ |
||||
+use strict; use warnings; |
||||
+ |
||||
+for my $x (1 .. 2) { |
||||
+ my $y = $x + 1; |
||||
+ my $x = $x - 1; |
||||
+} |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,33 @@
@@ -0,0 +1,33 @@
|
||||
From 589464a875768e4b4a609d972488e3b592103097 Mon Sep 17 00:00:00 2001 |
||||
From: "E. Choroba" <choroba@matfyz.cz> |
||||
Date: Mon, 27 Jul 2020 11:32:51 +0200 |
||||
Subject: [PATCH] Clearing DB::action at the end is no longer needed |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
as it's cleared right after it's been run. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
lib/perl5db.pl | 4 ---- |
||||
1 file changed, 4 deletions(-) |
||||
|
||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl |
||||
index e04a0e17fa..af3b972da0 100644 |
||||
--- a/lib/perl5db.pl |
||||
+++ b/lib/perl5db.pl |
||||
@@ -3347,10 +3347,6 @@ use B<o> I<inhibit_exit> to avoid stopping after program termination, |
||||
B<h q>, B<h R> or B<h o> to get additional info. |
||||
EOP |
||||
|
||||
- # Set the DB::eval context appropriately. |
||||
- # At program termination disable any user actions. |
||||
- $DB::action = undef; |
||||
- |
||||
$DB::package = 'main'; |
||||
$DB::usercontext = DB::_calc_usercontext($DB::package); |
||||
} ## end elsif ($package eq 'DB::fake') |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,74 @@
@@ -0,0 +1,74 @@
|
||||
From 8a2562bec7cd9f8eff6812f340f99dddd028bb33 Mon Sep 17 00:00:00 2001 |
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com> |
||||
Date: Thu, 6 Aug 2020 10:51:56 +0200 |
||||
Subject: [PATCH] IO::Handle: Fix a spurious error reported for regular file |
||||
handles |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
89341f87 fix for GH #6799 introduced a regression when calling error() |
||||
on an IO::Handle object that was opened for reading a regular file: |
||||
|
||||
$ perl -e 'open my $f, q{<}, q{/etc/hosts} or die; print qq{error\n} if $f->error' |
||||
error |
||||
|
||||
In case of a regular file opened for reading, IoOFP() returns NULL and |
||||
PerlIO_error(NULL) reports -1. Compare to the case of a file opened |
||||
for writing when both IoIFP() and IoOFP() return non-NULL, equaled |
||||
pointer. |
||||
|
||||
This patch fixes handling the case of the NULL output stream. |
||||
|
||||
GH #18019 |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
dist/IO/IO.xs | 4 ++-- |
||||
dist/IO/t/io_xs.t | 10 +++++++++- |
||||
2 files changed, 11 insertions(+), 3 deletions(-) |
||||
|
||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs |
||||
index 9158106416..fb009774c4 100644 |
||||
--- a/dist/IO/IO.xs |
||||
+++ b/dist/IO/IO.xs |
||||
@@ -397,9 +397,9 @@ ferror(handle) |
||||
CODE: |
||||
if (in) |
||||
#ifdef PerlIO |
||||
- RETVAL = PerlIO_error(in) || (in != out && PerlIO_error(out)); |
||||
+ RETVAL = PerlIO_error(in) || (out && in != out && PerlIO_error(out)); |
||||
#else |
||||
- RETVAL = ferror(in) || (in != out && ferror(out)); |
||||
+ RETVAL = ferror(in) || (out && in != out && ferror(out)); |
||||
#endif |
||||
else { |
||||
RETVAL = -1; |
||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t |
||||
index a8833b0651..4657088629 100644 |
||||
--- a/dist/IO/t/io_xs.t |
||||
+++ b/dist/IO/t/io_xs.t |
||||
@@ -11,7 +11,7 @@ BEGIN { |
||||
} |
||||
} |
||||
|
||||
-use Test::More tests => 8; |
||||
+use Test::More tests => 10; |
||||
use IO::File; |
||||
use IO::Seekable; |
||||
|
||||
@@ -69,3 +69,11 @@ SKIP: { |
||||
ok(!$fh->error, "check clearerr removed the error"); |
||||
close $fh; # silently ignore the error |
||||
} |
||||
+ |
||||
+{ |
||||
+ # [GH #18019] IO::Handle->error misreported an error after successully |
||||
+ # opening a regular file for reading. It was a regression in GH #6799 fix. |
||||
+ ok(open(my $fh, '<', __FILE__), "a regular file opened for reading"); |
||||
+ ok(!$fh->error, "no spurious error reported by error()"); |
||||
+ close $fh; |
||||
+} |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,80 @@
@@ -0,0 +1,80 @@
|
||||
From fc5f3468dcbee38eb202cfd552a5b8dbff990c7b Mon Sep 17 00:00:00 2001 |
||||
From: Tony Cook <tony@develop-help.com> |
||||
Date: Tue, 12 May 2020 10:59:08 +1000 |
||||
Subject: [PATCH 2/2] IO::Handle: clear the error on both input and output |
||||
streams |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Similarly to GH #6799 clearerr() only cleared the error status |
||||
of the input stream, so clear both. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
dist/IO/IO.xs | 14 +++++++++++--- |
||||
dist/IO/t/io_xs.t | 8 +++++--- |
||||
2 files changed, 16 insertions(+), 6 deletions(-) |
||||
|
||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs |
||||
index 99d523d2c1..9158106416 100644 |
||||
--- a/dist/IO/IO.xs |
||||
+++ b/dist/IO/IO.xs |
||||
@@ -410,13 +410,21 @@ ferror(handle) |
||||
|
||||
int |
||||
clearerr(handle) |
||||
- InputStream handle |
||||
+ SV * handle |
||||
+ PREINIT: |
||||
+ IO *io = sv_2io(handle); |
||||
+ InputStream in = IoIFP(io); |
||||
+ OutputStream out = IoOFP(io); |
||||
CODE: |
||||
if (handle) { |
||||
#ifdef PerlIO |
||||
- PerlIO_clearerr(handle); |
||||
+ PerlIO_clearerr(in); |
||||
+ if (in != out) |
||||
+ PerlIO_clearerr(out); |
||||
#else |
||||
- clearerr(handle); |
||||
+ clearerr(in); |
||||
+ if (in != out) |
||||
+ clearerr(out); |
||||
#endif |
||||
RETVAL = 0; |
||||
} |
||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t |
||||
index f890e92558..a8833b0651 100644 |
||||
--- a/dist/IO/t/io_xs.t |
||||
+++ b/dist/IO/t/io_xs.t |
||||
@@ -11,7 +11,7 @@ BEGIN { |
||||
} |
||||
} |
||||
|
||||
-use Test::More tests => 7; |
||||
+use Test::More tests => 8; |
||||
use IO::File; |
||||
use IO::Seekable; |
||||
|
||||
@@ -58,12 +58,14 @@ SKIP: { |
||||
# This isn't really a Linux/BSD specific test, but /dev/full is (I |
||||
# hope) reasonably well defined on these. Patches welcome if your platform |
||||
# also supports it (or something like it) |
||||
- skip "no /dev/full or not a /dev/full platform", 2 |
||||
+ skip "no /dev/full or not a /dev/full platform", 3 |
||||
unless $^O =~ /^(linux|netbsd|freebsd)$/ && -c "/dev/full"; |
||||
open my $fh, ">", "/dev/full" |
||||
- or skip "Could not open /dev/full: $!", 2; |
||||
+ or skip "Could not open /dev/full: $!", 3; |
||||
$fh->print("a" x 1024); |
||||
ok(!$fh->flush, "should fail to flush"); |
||||
ok($fh->error, "stream should be in error"); |
||||
+ $fh->clearerr; |
||||
+ ok(!$fh->error, "check clearerr removed the error"); |
||||
close $fh; # silently ignore the error |
||||
} |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,61 @@
@@ -0,0 +1,61 @@
|
||||
From c6439962c995d4d7052af9fb3f92da93c1584b84 Mon Sep 17 00:00:00 2001 |
||||
From: vividsnow <vividsnow@gmail.com> |
||||
Date: Fri, 31 Jul 2020 00:37:58 +0300 |
||||
Subject: [PATCH] IO::Socket::UNIX: synchronize behavior with module |
||||
documentation (#17787) |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
* synchronize behavior with module documentation |
||||
|
||||
IO::Socket docs states that passing Blocking => 0 will be set socket to non-blocking mode |
||||
|
||||
* Update AUTHORS |
||||
* bump version |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
AUTHORS | 1 + |
||||
dist/IO/lib/IO/Socket/UNIX.pm | 6 +++++- |
||||
2 files changed, 6 insertions(+), 1 deletion(-) |
||||
|
||||
diff --git a/AUTHORS b/AUTHORS |
||||
index 577ba7d0ee..299fdec8a8 100644 |
||||
--- a/AUTHORS |
||||
+++ b/AUTHORS |
||||
@@ -1293,6 +1293,7 @@ Ville Skyttä <scop@cs132170.pp.htv.fi> |
||||
Vincent Pit <perl@profvince.com> |
||||
Vishal Bhatia <vishal@deja.com> |
||||
Vitali Peil <vitali.peil@uni-bielefeld.de> |
||||
+vividsnow <vividsnow@gmail.com> |
||||
Vlad Harchev <hvv@hippo.ru> |
||||
Vladimir Alexiev <vladimir@cs.ualberta.ca> |
||||
Vladimir Marek <vlmarek@volny.cz> |
||||
diff --git a/dist/IO/lib/IO/Socket/UNIX.pm b/dist/IO/lib/IO/Socket/UNIX.pm |
||||
index 04b36eaf74..14d0b27a8c 100644 |
||||
--- a/dist/IO/lib/IO/Socket/UNIX.pm |
||||
+++ b/dist/IO/lib/IO/Socket/UNIX.pm |
||||
@@ -11,7 +11,7 @@ use IO::Socket; |
||||
use Carp; |
||||
|
||||
our @ISA = qw(IO::Socket); |
||||
-our $VERSION = "1.41"; |
||||
+our $VERSION = "1.42"; |
||||
|
||||
IO::Socket::UNIX->register_domain( AF_UNIX ); |
||||
|
||||
@@ -30,6 +30,10 @@ sub configure { |
||||
$sock->socket(AF_UNIX, $type, 0) or |
||||
return undef; |
||||
|
||||
+ if(exists $arg->{Blocking}) { |
||||
+ $sock->blocking($arg->{Blocking}) or |
||||
+ return undef; |
||||
+ } |
||||
if(exists $arg->{Local}) { |
||||
my $addr = sockaddr_un($arg->{Local}); |
||||
$sock->bind($addr) or |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,32 @@
@@ -0,0 +1,32 @@
|
||||
From 6c2255e0e80e0dc00c7fd96e073f1f524bbaa3e0 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Mon, 29 Jun 2020 09:21:24 -0600 |
||||
Subject: [PATCH] MUTABLE_PTR() Rmv non-standard syntax |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Variables in C are beginning with an underscore are reserved for use by |
||||
the C implementation. Change this non-conformant usage. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
handy.h | 2 +- |
||||
1 file changed, 1 insertion(+), 1 deletion(-) |
||||
|
||||
diff --git a/handy.h b/handy.h |
||||
index 287e2e206d..890b2b11a2 100644 |
||||
--- a/handy.h |
||||
+++ b/handy.h |
||||
@@ -54,7 +54,7 @@ Null SV pointer. (No longer available when C<PERL_CORE> is defined.) |
||||
*/ |
||||
|
||||
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) |
||||
-# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) |
||||
+# define MUTABLE_PTR(p) ({ void *p_ = (p); p_; }) |
||||
#else |
||||
# define MUTABLE_PTR(p) ((void *) (p)) |
||||
#endif |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,33 @@
@@ -0,0 +1,33 @@
|
||||
From b26a606d84ae1a6da560c7cd71d1a33c0dc7178e Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Sun, 14 Jun 2020 12:26:02 -0600 |
||||
Subject: [PATCH] Update pod for SvTRUE, to indicate single param evaluation |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
5.32 changed this macro into an inline function so that 'sv' only gets |
||||
evaluated once, but didn't update the documentation to reflect that. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
sv.h | 3 ++- |
||||
1 file changed, 2 insertions(+), 1 deletion(-) |
||||
|
||||
diff --git a/sv.h b/sv.h |
||||
index 3721b2fb1b..ad8accbf1a 100644 |
||||
--- a/sv.h |
||||
+++ b/sv.h |
||||
@@ -1607,7 +1607,8 @@ false. See C<L</SvOK>> for a defined/undefined test. Handles 'get' magic |
||||
unless the scalar is already C<SvPOK>, C<SvIOK> or C<SvNOK> (the public, not the |
||||
private flags). |
||||
|
||||
-See C<L</SvTRUEx>> for a version which guarantees to evaluate C<sv> only once. |
||||
+As of Perl 5.32, this is guaranteed to evaluate C<sv> only once. Prior to that |
||||
+release, use C<L</SvTRUEx>> for single evaluation. |
||||
|
||||
=for apidoc Am|bool|SvTRUE_nomg|SV* sv |
||||
Returns a boolean indicating whether Perl would evaluate the SV as true or |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,45 @@
@@ -0,0 +1,45 @@
|
||||
From 313464947382fab07299af0061f419a55540356a Mon Sep 17 00:00:00 2001 |
||||
From: Tomasz Konojacki <me@xenu.pl> |
||||
Date: Mon, 27 Apr 2020 08:31:47 +0200 |
||||
Subject: [PATCH] XSUB.h: fix MARK and items variables inside BOOT XSUBs |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
ax was incremented by Perl_xs_handshake() and because of that |
||||
MARK and items were off by one inside BOOT XSUBs. |
||||
|
||||
fixes #17755 |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
XSUB.h | 6 +++--- |
||||
1 file changed, 3 insertions(+), 3 deletions(-) |
||||
|
||||
diff --git a/XSUB.h b/XSUB.h |
||||
index e3147ce9fb..5f17a5acde 100644 |
||||
--- a/XSUB.h |
||||
+++ b/XSUB.h |
||||
@@ -160,16 +160,16 @@ is a lexical C<$_> in scope. |
||||
PL_xsubfilename. */ |
||||
#define dXSBOOTARGSXSAPIVERCHK \ |
||||
I32 ax = XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \ |
||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS |
||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS |
||||
#define dXSBOOTARGSAPIVERCHK \ |
||||
I32 ax = XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \ |
||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS |
||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS |
||||
/* dXSBOOTARGSNOVERCHK has no API in xsubpp to choose it so do |
||||
#undef dXSBOOTARGSXSAPIVERCHK |
||||
#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK */ |
||||
#define dXSBOOTARGSNOVERCHK \ |
||||
I32 ax = XS_SETXSUBFN_POPMARK; \ |
||||
- SV **mark = PL_stack_base + ax; dSP; dITEMS |
||||
+ SV **mark = PL_stack_base + ax - 1; dSP; dITEMS |
||||
|
||||
#define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \ |
||||
? PAD_SV(PL_op->op_targ) : sv_newmortal()) |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,38 @@
@@ -0,0 +1,38 @@
|
||||
From 73b535d23d98bd3bdc31a27da26222e2e56166ac Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Tue, 30 Jun 2020 13:58:50 -0600 |
||||
Subject: [PATCH] ext/XS-APItest/t/utf8_warn_base.pl: Fix a couple tests |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
These had invalid values, which didn't show up execpt on EBCDIC |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
ext/XS-APItest/t/utf8_warn_base.pl | 2 -- |
||||
1 file changed, 2 deletions(-) |
||||
|
||||
diff --git a/ext/XS-APItest/t/utf8_warn_base.pl b/ext/XS-APItest/t/utf8_warn_base.pl |
||||
index d86871cd0f..a0f732282e 100644 |
||||
--- a/ext/XS-APItest/t/utf8_warn_base.pl |
||||
+++ b/ext/XS-APItest/t/utf8_warn_base.pl |
||||
@@ -486,7 +486,6 @@ my @tests; |
||||
: I8_to_native( |
||||
"\xff\xa7\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"), |
||||
0x7FFFFFFFFFFFFFFF, |
||||
- (isASCII) ? 1 : 2, |
||||
], |
||||
[ "first 64 bit code point", |
||||
(isASCII) |
||||
@@ -525,7 +524,6 @@ my @tests; |
||||
I8_to_native( |
||||
"\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"), |
||||
0x800000000, |
||||
- 40000000 |
||||
], |
||||
[ "requires at least 32 bits", |
||||
I8_to_native( |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,193 @@
@@ -0,0 +1,193 @@
|
||||
From b334474a337421c6643b872388245fb2c11bf995 Mon Sep 17 00:00:00 2001 |
||||
From: Tony Cook <tony@develop-help.com> |
||||
Date: Mon, 30 Mar 2020 16:32:46 +1100 |
||||
Subject: [PATCH] fix C<i $obj> where $obj is a lexical |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
the DB::eval function depends on the special behaviour of eval "" |
||||
within the DB package, which evaluates the string within the context |
||||
of the first non-DB sub or eval scope, working up the call stack. |
||||
|
||||
The debugger refactor moved handling for the 'i' command from the |
||||
DB package to the DB::Obj package, so the eval in DB::eval was |
||||
working in the context of the DB::Obj::cmd_i function, not in the |
||||
calling scope. |
||||
|
||||
Fixed by moving the handling for the i command back to DB. |
||||
|
||||
Fixes #17661. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
MANIFEST | 1 + |
||||
lib/perl5db.pl | 65 +++++++++++++++++++++--------------------- |
||||
lib/perl5db.t | 20 +++++++++++++ |
||||
lib/perl5db/t/gh-17661 | 14 +++++++++ |
||||
4 files changed, 68 insertions(+), 32 deletions(-) |
||||
create mode 100644 lib/perl5db/t/gh-17661 |
||||
|
||||
diff --git a/MANIFEST b/MANIFEST |
||||
index 8c71995174..96af3618bd 100644 |
||||
--- a/MANIFEST |
||||
+++ b/MANIFEST |
||||
@@ -4808,6 +4808,7 @@ lib/perl5db/t/eval-line-bug Tests for the Perl debugger |
||||
lib/perl5db/t/fact Tests for the Perl debugger |
||||
lib/perl5db/t/filename-line-breakpoint Tests for the Perl debugger |
||||
lib/perl5db/t/gh-17660 Tests for the Perl debugger |
||||
+lib/perl5db/t/gh-17661 Tests for the Perl debugger |
||||
lib/perl5db/t/load-modules Tests for the Perl debugger |
||||
lib/perl5db/t/lsub-n Test script used by perl5db.t |
||||
lib/perl5db/t/lvalue-bug Tests for the Perl debugger |
||||
diff --git a/lib/perl5db.pl b/lib/perl5db.pl |
||||
index 96e56d559f..b647d24fb8 100644 |
||||
--- a/lib/perl5db.pl |
||||
+++ b/lib/perl5db.pl |
||||
@@ -2512,6 +2512,37 @@ EOP |
||||
return; |
||||
} |
||||
|
||||
+=head3 C<_DB__handle_i_command> - inheritance display |
||||
+ |
||||
+Display the (nested) parentage of the module or object given. |
||||
+ |
||||
+=cut |
||||
+ |
||||
+sub _DB__handle_i_command { |
||||
+ my $self = shift; |
||||
+ |
||||
+ my $line = $self->cmd_args; |
||||
+ require mro; |
||||
+ foreach my $isa ( split( /\s+/, $line ) ) { |
||||
+ $evalarg = "$isa"; |
||||
+ # The &-call is here to ascertain the mutability of @_. |
||||
+ ($isa) = &DB::eval; |
||||
+ no strict 'refs'; |
||||
+ print join( |
||||
+ ', ', |
||||
+ map { |
||||
+ "$_" |
||||
+ . ( |
||||
+ defined( ${"$_\::VERSION"} ) |
||||
+ ? ' ' . ${"$_\::VERSION"} |
||||
+ : undef ) |
||||
+ } @{mro::get_linear_isa(ref($isa) || $isa)} |
||||
+ ); |
||||
+ print "\n"; |
||||
+ } |
||||
+ next CMD; |
||||
+} |
||||
+ |
||||
# 't' is type. |
||||
# 'm' is method. |
||||
# 'v' is the value (i.e: method name or subroutine ref). |
||||
@@ -2531,6 +2562,7 @@ BEGIN |
||||
'W' => { t => 'm', v => '_handle_W_command', }, |
||||
'c' => { t => 's', v => \&_DB__handle_c_command, }, |
||||
'f' => { t => 's', v => \&_DB__handle_f_command, }, |
||||
+ 'i' => { t => 's', v => \&_DB__handle_i_command, }, |
||||
'm' => { t => 's', v => \&_DB__handle_m_command, }, |
||||
'n' => { t => 'm', v => '_handle_n_command', }, |
||||
'p' => { t => 'm', v => '_handle_p_command', }, |
||||
@@ -2551,7 +2583,7 @@ BEGIN |
||||
{ t => 's', v => \&_DB__handle_restart_and_rerun_commands, }, |
||||
} qw(R rerun)), |
||||
(map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, } |
||||
- qw(a A b B e E h i l L M o O v w W)), |
||||
+ qw(a A b B e E h l L M o O v w W)), |
||||
); |
||||
}; |
||||
|
||||
@@ -5468,37 +5500,6 @@ sub cmd_h { |
||||
} |
||||
} ## end sub cmd_h |
||||
|
||||
-=head3 C<cmd_i> - inheritance display |
||||
- |
||||
-Display the (nested) parentage of the module or object given. |
||||
- |
||||
-=cut |
||||
- |
||||
-sub cmd_i { |
||||
- my $cmd = shift; |
||||
- my $line = shift; |
||||
- |
||||
- require mro; |
||||
- |
||||
- foreach my $isa ( split( /\s+/, $line ) ) { |
||||
- $evalarg = $isa; |
||||
- # The &-call is here to ascertain the mutability of @_. |
||||
- ($isa) = &DB::eval; |
||||
- no strict 'refs'; |
||||
- print join( |
||||
- ', ', |
||||
- map { |
||||
- "$_" |
||||
- . ( |
||||
- defined( ${"$_\::VERSION"} ) |
||||
- ? ' ' . ${"$_\::VERSION"} |
||||
- : undef ) |
||||
- } @{mro::get_linear_isa(ref($isa) || $isa)} |
||||
- ); |
||||
- print "\n"; |
||||
- } |
||||
-} ## end sub cmd_i |
||||
- |
||||
=head3 C<cmd_l> - list lines (command) |
||||
|
||||
Most of the command is taken up with transforming all the different line |
||||
diff --git a/lib/perl5db.t b/lib/perl5db.t |
||||
index 913a301d98..ffa659a215 100644 |
||||
--- a/lib/perl5db.t |
||||
+++ b/lib/perl5db.t |
||||
@@ -2946,6 +2946,26 @@ SKIP: |
||||
); |
||||
} |
||||
|
||||
+{ |
||||
+ # gh #17661 |
||||
+ my $wrapper = DebugWrap->new( |
||||
+ { |
||||
+ cmds => |
||||
+ [ |
||||
+ 'c', |
||||
+ 'i $obj', |
||||
+ 'q', |
||||
+ ], |
||||
+ prog => '../lib/perl5db/t/gh-17661', |
||||
+ } |
||||
+ ); |
||||
+ |
||||
+ $wrapper->output_like( |
||||
+ qr/C5, C1, C2, C3, C4/, |
||||
+ q/check for reasonable result/, |
||||
+ ); |
||||
+} |
||||
+ |
||||
SKIP: |
||||
{ |
||||
$Config{usethreads} |
||||
diff --git a/lib/perl5db/t/gh-17661 b/lib/perl5db/t/gh-17661 |
||||
new file mode 100644 |
||||
index 0000000000..0d85977b35 |
||||
--- /dev/null |
||||
+++ b/lib/perl5db/t/gh-17661 |
||||
@@ -0,0 +1,14 @@ |
||||
+use v5.10.0; |
||||
+ |
||||
+{ package C1; sub c1 { } our @ISA = qw(C2) } |
||||
+{ package C2; sub c2 { } our @ISA = qw(C3) } |
||||
+{ package C3; sub c3 { } our @ISA = qw( ) } |
||||
+{ package C4; sub c4 { } our @ISA = qw( ) } |
||||
+{ package C5; sub c5 { } our @ISA = qw(C1 C4) } |
||||
+ |
||||
+my $obj = bless {}, 'C5'; |
||||
+$main::global = bless {}, 'C5'; |
||||
+ |
||||
+$DB::single = 1; |
||||
+ |
||||
+say "Done."; |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,87 @@
@@ -0,0 +1,87 @@
|
||||
From 89341f87f9fc65c4d7133e497bb04586e86b8052 Mon Sep 17 00:00:00 2001 |
||||
From: Tony Cook <tony@develop-help.com> |
||||
Date: Tue, 12 May 2020 10:29:17 +1000 |
||||
Subject: [PATCH 1/2] make $fh->error report errors from both input and output |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
For character devices and sockets perl uses separate PerlIO objects |
||||
for input and output so they can be buffered separately. |
||||
|
||||
The IO::Handle::error() method only checked the input stream, so |
||||
if a write error occurs error() would still returned false. |
||||
|
||||
Change this so both the input and output streams are checked. |
||||
|
||||
fixes #6799 |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
dist/IO/IO.xs | 12 ++++++++---- |
||||
dist/IO/t/io_xs.t | 19 ++++++++++++++++++- |
||||
2 files changed, 26 insertions(+), 5 deletions(-) |
||||
|
||||
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs |
||||
index 68b7352c38..99d523d2c1 100644 |
||||
--- a/dist/IO/IO.xs |
||||
+++ b/dist/IO/IO.xs |
||||
@@ -389,13 +389,17 @@ ungetc(handle, c) |
||||
|
||||
int |
||||
ferror(handle) |
||||
- InputStream handle |
||||
+ SV * handle |
||||
+ PREINIT: |
||||
+ IO *io = sv_2io(handle); |
||||
+ InputStream in = IoIFP(io); |
||||
+ OutputStream out = IoOFP(io); |
||||
CODE: |
||||
- if (handle) |
||||
+ if (in) |
||||
#ifdef PerlIO |
||||
- RETVAL = PerlIO_error(handle); |
||||
+ RETVAL = PerlIO_error(in) || (in != out && PerlIO_error(out)); |
||||
#else |
||||
- RETVAL = ferror(handle); |
||||
+ RETVAL = ferror(in) || (in != out && ferror(out)); |
||||
#endif |
||||
else { |
||||
RETVAL = -1; |
||||
diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t |
||||
index 1e3c49a4a7..f890e92558 100644 |
||||
--- a/dist/IO/t/io_xs.t |
||||
+++ b/dist/IO/t/io_xs.t |
||||
@@ -11,7 +11,7 @@ BEGIN { |
||||
} |
||||
} |
||||
|
||||
-use Test::More tests => 5; |
||||
+use Test::More tests => 7; |
||||
use IO::File; |
||||
use IO::Seekable; |
||||
|
||||
@@ -50,3 +50,20 @@ SKIP: |
||||
ok($fh->sync, "sync to a read only handle") |
||||
or diag "sync(): ", $!; |
||||
} |
||||
+ |
||||
+ |
||||
+SKIP: { |
||||
+ # gh 6799 |
||||
+ # |
||||
+ # This isn't really a Linux/BSD specific test, but /dev/full is (I |
||||
+ # hope) reasonably well defined on these. Patches welcome if your platform |
||||
+ # also supports it (or something like it) |
||||
+ skip "no /dev/full or not a /dev/full platform", 2 |
||||
+ unless $^O =~ /^(linux|netbsd|freebsd)$/ && -c "/dev/full"; |
||||
+ open my $fh, ">", "/dev/full" |
||||
+ or skip "Could not open /dev/full: $!", 2; |
||||
+ $fh->print("a" x 1024); |
||||
+ ok(!$fh->flush, "should fail to flush"); |
||||
+ ok($fh->error, "stream should be in error"); |
||||
+ close $fh; # silently ignore the error |
||||
+} |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,58 @@
@@ -0,0 +1,58 @@
|
||||
From 81169c06a76f62ff987ed990ac910c2ae08b3f91 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Tue, 10 Mar 2020 15:19:57 -0600 |
||||
Subject: [PATCH] reentr.c: Buffer sizes for asctime_r,ctime_r are small |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
The needed sizes of these are stated in the man pages, and are much |
||||
smaller than were being allocated. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
reentr.c | 4 ++-- |
||||
regen/reentr.pl | 5 ++++- |
||||
2 files changed, 6 insertions(+), 3 deletions(-) |
||||
|
||||
diff --git a/reentr.c b/reentr.c |
||||
index 8ddda7bfc0..8438c8f90f 100644 |
||||
--- a/reentr.c |
||||
+++ b/reentr.c |
||||
@@ -52,14 +52,14 @@ Perl_reentrant_size(pTHX) { |
||||
# define REENTRANTUSUALSIZE 4096 /* Make something up. */ |
||||
|
||||
# ifdef HAS_ASCTIME_R |
||||
- PL_reentrant_buffer->_asctime_size = REENTRANTSMALLSIZE; |
||||
+ PL_reentrant_buffer->_asctime_size = 26; |
||||
# endif /* HAS_ASCTIME_R */ |
||||
|
||||
# ifdef HAS_CRYPT_R |
||||
# endif /* HAS_CRYPT_R */ |
||||
|
||||
# ifdef HAS_CTIME_R |
||||
- PL_reentrant_buffer->_ctime_size = REENTRANTSMALLSIZE; |
||||
+ PL_reentrant_buffer->_ctime_size = 26; |
||||
# endif /* HAS_CTIME_R */ |
||||
|
||||
# ifdef HAS_GETGRNAM_R |
||||
diff --git a/regen/reentr.pl b/regen/reentr.pl |
||||
index f5788c7ad9..94721e9dec 100644 |
||||
--- a/regen/reentr.pl |
||||
+++ b/regen/reentr.pl |
||||
@@ -495,8 +495,11 @@ for my $func (@seenf) { |
||||
char* _${func}_buffer; |
||||
size_t _${func}_size; |
||||
EOF |
||||
+ my $size = ($func =~ /^(asctime|ctime)$/) |
||||
+ ? 26 |
||||
+ : "REENTRANTSMALLSIZE"; |
||||
push @size, <<EOF; |
||||
- PL_reentrant_buffer->_${func}_size = REENTRANTSMALLSIZE; |
||||
+ PL_reentrant_buffer->_${func}_size = $size; |
||||
EOF |
||||
pushinitfree $func; |
||||
pushssif $endif; |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,46 @@
@@ -0,0 +1,46 @@
|
||||
From 981fbfc16220a15e72457d8ece4e014988746946 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Thu, 12 Mar 2020 12:48:47 -0600 |
||||
Subject: [PATCH] reentr.c: Prevent infinite looping |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
This is an easy, though paranoid hedge to prevent something that should |
||||
never happen from causing an infinite loop if it were to happen. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
reentr.c | 2 +- |
||||
regen/reentr.pl | 2 +- |
||||
2 files changed, 2 insertions(+), 2 deletions(-) |
||||
|
||||
diff --git a/reentr.c b/reentr.c |
||||
index 8438c8f90f..2429aa2f5d 100644 |
||||
--- a/reentr.c |
||||
+++ b/reentr.c |
||||
@@ -36,7 +36,7 @@ |
||||
|
||||
#define RenewDouble(data_pointer, size_pointer, type) \ |
||||
STMT_START { \ |
||||
- const size_t size = *(size_pointer) * 2; \ |
||||
+ const size_t size = MAX(*(size_pointer), 1) * 2; \ |
||||
Renew((data_pointer), (size), type); \ |
||||
*(size_pointer) = size; \ |
||||
} STMT_END |
||||
diff --git a/regen/reentr.pl b/regen/reentr.pl |
||||
index 94721e9dec..ba2e1c8fa6 100644 |
||||
--- a/regen/reentr.pl |
||||
+++ b/regen/reentr.pl |
||||
@@ -818,7 +818,7 @@ print $c <<"EOF"; |
||||
|
||||
#define RenewDouble(data_pointer, size_pointer, type) \\ |
||||
STMT_START { \\ |
||||
- const size_t size = *(size_pointer) * 2; \\ |
||||
+ const size_t size = MAX(*(size_pointer), 1) * 2; \\ |
||||
Renew((data_pointer), (size), type); \\ |
||||
*(size_pointer) = size; \\ |
||||
} STMT_END |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,31 @@
@@ -0,0 +1,31 @@
|
||||
From 530e9296a21b673d7e4c2b42f18d0d52d00f35c4 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Sun, 28 Jun 2020 12:03:54 -0600 |
||||
Subject: [PATCH] sv.h: Wanted UOK, but said IOK |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
I don't know the consequences of this bug |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
sv.h | 2 +- |
||||
1 file changed, 1 insertion(+), 1 deletion(-) |
||||
|
||||
diff --git a/sv.h b/sv.h |
||||
index 2f6431a826..3721b2fb1b 100644 |
||||
--- a/sv.h |
||||
+++ b/sv.h |
||||
@@ -1711,7 +1711,7 @@ Like C<sv_catsv> but doesn't process magic. |
||||
#define SvNV(sv) (SvNOK_nog(sv) ? SvNVX(sv) : sv_2nv(sv)) |
||||
|
||||
#define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0)) |
||||
-#define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0)) |
||||
+#define SvUV_nomg(sv) (SvUOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0)) |
||||
#define SvNV_nomg(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv_flags(sv, 0)) |
||||
|
||||
/* ----*/ |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,77 @@
@@ -0,0 +1,77 @@
|
||||
From 390fe0c0d09aadc66f644e9eee4aa1245221188c Mon Sep 17 00:00:00 2001 |
||||
From: David Mitchell <davem@iabyn.com> |
||||
Date: Tue, 25 Aug 2020 13:15:25 +0100 |
||||
Subject: [PATCH] sort { return foo() } ... |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
GH #18081 |
||||
|
||||
A sub call via return in a sort block was called in void rather than |
||||
scalar context, causing the comparison result to be discarded. |
||||
|
||||
This because when a sort block is called it is not a real function |
||||
call, even though a sort block can be returned from. Instead, a |
||||
CXt_NULL is pushed on the context stack. Because this isn't a sub-ish |
||||
context type (unlike CXt_SUB, CXt_EVAL etc) there is no 'caller sub' |
||||
on the context stack to be found to retrieve the caller's context |
||||
(i.e. cx->cx_gimme). |
||||
|
||||
This commit fixes it by special-casing Perl_gimme_V(). |
||||
|
||||
Ideally at some future point, a new context type, CXt_SORT, should be |
||||
added. This would be used instead of CXt_NULL when a sort BLOCK is |
||||
called. Like other sub-ish context types, it would have an old_cxsubix |
||||
field and PL_curstackinfo->si_cxsubix would point to it. This would |
||||
eliminate needing special-case handling in places like Perl_gimme_V(). |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
inline.h | 2 +- |
||||
t/op/sort.t | 12 +++++++++++- |
||||
2 files changed, 12 insertions(+), 2 deletions(-) |
||||
|
||||
diff --git a/inline.h b/inline.h |
||||
index a8240efb9c..6fbd5abfea 100644 |
||||
--- a/inline.h |
||||
+++ b/inline.h |
||||
@@ -2086,7 +2086,7 @@ Perl_gimme_V(pTHX) |
||||
return gimme; |
||||
cxix = PL_curstackinfo->si_cxsubix; |
||||
if (cxix < 0) |
||||
- return G_VOID; |
||||
+ return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID; |
||||
assert(cxstack[cxix].blk_gimme & G_WANT); |
||||
return (cxstack[cxix].blk_gimme & G_WANT); |
||||
} |
||||
diff --git a/t/op/sort.t b/t/op/sort.t |
||||
index f2e139dff0..8e387fb90d 100644 |
||||
--- a/t/op/sort.t |
||||
+++ b/t/op/sort.t |
||||
@@ -7,7 +7,7 @@ BEGIN { |
||||
set_up_inc('../lib'); |
||||
} |
||||
use warnings; |
||||
-plan(tests => 203); |
||||
+plan(tests => 204); |
||||
use Tie::Array; # we need to test sorting tied arrays |
||||
|
||||
# these shouldn't hang |
||||
@@ -1202,3 +1202,13 @@ SKIP: |
||||
$fillb = undef; |
||||
is $act, "01[sortb]2[fillb]"; |
||||
} |
||||
+ |
||||
+# GH #18081 |
||||
+# sub call via return in sort block was called in void rather than scalar |
||||
+# context |
||||
+ |
||||
+{ |
||||
+ sub sort18081 { $a + 1 <=> $b + 1 } |
||||
+ my @a = sort { return &sort18081 } 6,1,2; |
||||
+ is "@a", "1 2 6", "GH #18081"; |
||||
+} |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,77 @@
@@ -0,0 +1,77 @@
|
||||
From bd5fa06648085e8c17efd55abeb6424aeeb1018e Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Tue, 29 Sep 2020 00:48:19 -0600 |
||||
Subject: [PATCH] Remove Perl_av_top_index |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
I created this in 87306e0674dfe3af29804b4641347cd5ac9b0521, thinking it |
||||
was needed to preserve backward compatibility if someone were using this |
||||
instead of the macro. But it turned out that there never was such a |
||||
function, it was inlined, and the name was S_av_top_index, so there is |
||||
no reason to create a new function that no one has ever been able to |
||||
call. So just remove it, and let all accesses go through the macro |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
av.c | 10 ---------- |
||||
embed.fnc | 2 +- |
||||
proto.h | 7 +++---- |
||||
3 files changed, 4 insertions(+), 15 deletions(-) |
||||
|
||||
diff --git a/av.c b/av.c |
||||
index ada09cde9a..ad2429f90d 100644 |
||||
--- a/av.c |
||||
+++ b/av.c |
||||
@@ -1095,16 +1095,6 @@ Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) { |
||||
return sv; |
||||
} |
||||
|
||||
-SSize_t |
||||
-Perl_av_top_index(pTHX_ AV *av) |
||||
-{ |
||||
- PERL_ARGS_ASSERT_AV_TOP_INDEX; |
||||
- assert(SvTYPE(av) == SVt_PVAV); |
||||
- |
||||
- return AvFILL(av); |
||||
-} |
||||
- |
||||
- |
||||
/* |
||||
* ex: set ts=8 sts=4 sw=4 et: |
||||
*/ |
||||
diff --git a/embed.fnc b/embed.fnc |
||||
index a6b4d0350f..f5c5b29c2d 100644 |
||||
--- a/embed.fnc |
||||
+++ b/embed.fnc |
||||
@@ -637,7 +637,7 @@ Apd |void |av_push |NN AV *av|NN SV *val |
||||
EXp |void |av_reify |NN AV *av |
||||
ApdR |SV* |av_shift |NN AV *av |
||||
Apd |SV** |av_store |NN AV *av|SSize_t key|NULLOK SV *val |
||||
-AMdRp |SSize_t|av_top_index |NN AV *av |
||||
+AmdR |SSize_t|av_top_index |NN AV *av |
||||
AidRp |Size_t |av_count |NN AV *av |
||||
AmdR |SSize_t|av_tindex |NN AV *av |
||||
Apd |void |av_undef |NN AV *av |
||||
diff --git a/proto.h b/proto.h |
||||
index c4490fc46e..2da1a07761 100644 |
||||
--- a/proto.h |
||||
+++ b/proto.h |
||||
@@ -291,10 +291,9 @@ PERL_CALLCONV SV** Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val); |
||||
__attribute__warn_unused_result__; */ |
||||
#define PERL_ARGS_ASSERT_AV_TINDEX |
||||
|
||||
-PERL_CALLCONV SSize_t Perl_av_top_index(pTHX_ AV *av) |
||||
- __attribute__warn_unused_result__; |
||||
-#define PERL_ARGS_ASSERT_AV_TOP_INDEX \ |
||||
- assert(av) |
||||
+/* PERL_CALLCONV SSize_t av_top_index(pTHX_ AV *av) |
||||
+ __attribute__warn_unused_result__; */ |
||||
+#define PERL_ARGS_ASSERT_AV_TOP_INDEX |
||||
|
||||
PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av); |
||||
#define PERL_ARGS_ASSERT_AV_UNDEF \ |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,31 @@
@@ -0,0 +1,31 @@
|
||||
From fa353c3d2833fc326233e0eb583753b4d7887a63 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Sun, 4 Oct 2020 11:07:19 -0600 |
||||
Subject: [PATCH] mro.xs: Fix compiler warning |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Fixes GH #18155 |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
ext/mro/mro.xs | 2 +- |
||||
1 file changed, 1 insertion(+), 1 deletion(-) |
||||
|
||||
diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs |
||||
index f21216af6e..8ce5844904 100644 |
||||
--- a/ext/mro/mro.xs |
||||
+++ b/ext/mro/mro.xs |
||||
@@ -253,7 +253,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) |
||||
hierarchy is not C3-incompatible */ |
||||
if(!winner) { |
||||
SV *errmsg; |
||||
- I32 i; |
||||
+ Size_t i; |
||||
|
||||
errmsg = newSVpvf( |
||||
"Inconsistent hierarchy during C3 merge of class '%" HEKf "':\n\t" |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,32 @@
@@ -0,0 +1,32 @@
|
||||
From 5777cf812c2812ea45eeb45e48979bab544d71af Mon Sep 17 00:00:00 2001 |
||||
From: TAKAI Kousuke <62541129+t-a-k@users.noreply.github.com> |
||||
Date: Thu, 8 Oct 2020 19:02:10 +0900 |
||||
Subject: [PATCH] sv.c: Added missing braces in Perl_sv_inc_nomg(). |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
sv.c | 3 ++- |
||||
1 file changed, 2 insertions(+), 1 deletion(-) |
||||
|
||||
diff --git a/sv.c b/sv.c |
||||
index 82248e3b1f..57fd65a5b8 100644 |
||||
--- a/sv.c |
||||
+++ b/sv.c |
||||
@@ -8944,9 +8944,10 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) |
||||
if (SvIsUV(sv)) { |
||||
if (SvUVX(sv) == UV_MAX) |
||||
sv_setnv(sv, UV_MAX_P1); |
||||
- else |
||||
+ else { |
||||
(void)SvIOK_only_UV(sv); |
||||
SvUV_set(sv, SvUVX(sv) + 1); |
||||
+ } |
||||
} else { |
||||
if (SvIVX(sv) == IV_MAX) |
||||
sv_setuv(sv, (UV)IV_MAX + 1); |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,36 @@
@@ -0,0 +1,36 @@
|
||||
From e17dadf36f7b4348e59076240c880d0c78b33fa9 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Tue, 22 Sep 2020 08:47:52 -0600 |
||||
Subject: [PATCH] sv.h: sv_collxfrm didn't work properly |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
It is supposed to be a wrapper for sv_collxfrm_flags, but it was just |
||||
calling sv_cmp_flags instead. The consequences are none except under |
||||
'use locale' in which case you always got the C locale. I did not add |
||||
tests, because it is really a pain to write portable locale tests, and |
||||
this doesn't seem to be much used. In core the '_flags' form was always |
||||
used. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
sv.h | 2 +- |
||||
1 file changed, 1 insertion(+), 1 deletion(-) |
||||
|
||||
diff --git a/sv.h b/sv.h |
||||
index 19ce718ac3..44414b35a9 100644 |
||||
--- a/sv.h |
||||
+++ b/sv.h |
||||
@@ -2045,7 +2045,7 @@ Like C<sv_catsv> but doesn't process magic. |
||||
#define sv_eq(sv1, sv2) sv_eq_flags(sv1, sv2, SV_GMAGIC) |
||||
#define sv_cmp(sv1, sv2) sv_cmp_flags(sv1, sv2, SV_GMAGIC) |
||||
#define sv_cmp_locale(sv1, sv2) sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC) |
||||
-#define sv_collxfrm(sv, nxp) sv_cmp_flags(sv, nxp, SV_GMAGIC) |
||||
+#define sv_collxfrm(sv, nxp) sv_collxfrm_flags(sv, nxp, SV_GMAGIC) |
||||
#define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC) |
||||
#define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0) |
||||
#define sv_insert(bigstr, offset, len, little, littlelen) \ |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,76 @@
@@ -0,0 +1,76 @@
|
||||
From e050064b67c501e9fdc7bc3f513ba2b8b9e795f8 Mon Sep 17 00:00:00 2001 |
||||
From: David Mitchell <davem@iabyn.com> |
||||
Date: Fri, 30 Oct 2020 20:50:58 +0000 |
||||
Subject: [PATCH] Perl_custom_op_get_field(): remove undef behaviour |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Thus function has a couple a switches with |
||||
|
||||
default: |
||||
NOT_REACHED; /* NOTREACHED */ |
||||
|
||||
but clang is complaining that the value returned by the function is |
||||
undefined if those default branches are taken, since the 'any' variable |
||||
doesn't get set in that path. |
||||
|
||||
Replace the NOTREACHED with a croak("panic: ..."). It's possible (albeit |
||||
not intended) for Perl_custom_op_get_field() to be called with a 'field' |
||||
arg which triggers the default case. So if this ever happens, make it |
||||
clear that something has gone wrong, rather than just silently |
||||
continuing on non-debugging builds. |
||||
|
||||
In any case, this shuts up clang. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
op.c | 14 ++++++-------- |
||||
1 file changed, 6 insertions(+), 8 deletions(-) |
||||
|
||||
diff --git a/op.c b/op.c |
||||
index c30c6b7c8f..2933e2ed7d 100644 |
||||
--- a/op.c |
||||
+++ b/op.c |
||||
@@ -18100,6 +18100,7 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) |
||||
else |
||||
xop = INT2PTR(XOP *, SvIV(HeVAL(he))); |
||||
} |
||||
+ |
||||
{ |
||||
XOPRETANY any; |
||||
if(field == XOPe_xop_ptr) { |
||||
@@ -18121,7 +18122,10 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) |
||||
any.xop_peep = xop->xop_peep; |
||||
break; |
||||
default: |
||||
- NOT_REACHED; /* NOTREACHED */ |
||||
+ field_panic: |
||||
+ Perl_croak(aTHX_ |
||||
+ "panic: custom_op_get_field(): invalid field %d\n", |
||||
+ (int)field); |
||||
break; |
||||
} |
||||
} else { |
||||
@@ -18139,17 +18143,11 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) |
||||
any.xop_peep = XOPd_xop_peep; |
||||
break; |
||||
default: |
||||
- NOT_REACHED; /* NOTREACHED */ |
||||
+ goto field_panic; |
||||
break; |
||||
} |
||||
} |
||||
} |
||||
- /* On some platforms (HP-UX, IA64) gcc emits a warning for this function: |
||||
- * op.c: In function 'Perl_custom_op_get_field': |
||||
- * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized] |
||||
- * This is because on those platforms (with -DEBUGGING) NOT_REACHED |
||||
- * expands to assert(0), which expands to ((0) ? (void)0 : |
||||
- * __assert(...)), and gcc doesn't know that __assert can never return. */ |
||||
return any; |
||||
} |
||||
} |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,57 @@
@@ -0,0 +1,57 @@
|
||||
From f877e124a20d4f94c82c36e6b7a99b4e9663e204 Mon Sep 17 00:00:00 2001 |
||||
From: Tony Cook <tony@develop-help.com> |
||||
Date: Tue, 10 Nov 2020 15:50:27 +1100 |
||||
Subject: [PATCH] fetch magic on the first stacked filetest, not the last |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
fixes #18293 |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
pp_sys.c | 2 +- |
||||
t/op/filetest.t | 10 +++++++++- |
||||
2 files changed, 10 insertions(+), 2 deletions(-) |
||||
|
||||
diff --git a/pp_sys.c b/pp_sys.c |
||||
index 66c5d9aade..5c9f768eaf 100644 |
||||
--- a/pp_sys.c |
||||
+++ b/pp_sys.c |
||||
@@ -3067,7 +3067,7 @@ S_try_amagic_ftest(pTHX_ char chr) { |
||||
SV *const arg = *PL_stack_sp; |
||||
|
||||
assert(chr != '?'); |
||||
- if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg); |
||||
+ if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg); |
||||
|
||||
if (SvAMAGIC(arg)) |
||||
{ |
||||
diff --git a/t/op/filetest.t b/t/op/filetest.t |
||||
index fe9724c59a..7c471c050c 100644 |
||||
--- a/t/op/filetest.t |
||||
+++ b/t/op/filetest.t |
||||
@@ -9,7 +9,7 @@ BEGIN { |
||||
set_up_inc(qw '../lib ../cpan/Perl-OSType/lib'); |
||||
} |
||||
|
||||
-plan(tests => 57 + 27*14); |
||||
+plan(tests => 58 + 27*14); |
||||
|
||||
if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) { |
||||
require Win32; # for IsAdminUser() |
||||
@@ -385,3 +385,11 @@ SKIP: { |
||||
ok(!-f "TEST\0-", '-f on name with \0'); |
||||
ok(!-r "TEST\0-", '-r on name with \0'); |
||||
} |
||||
+ |
||||
+{ |
||||
+ # github #18293 |
||||
+ "" =~ /(.*)/; |
||||
+ my $x = $1; # call magic on $1, setting the pv to "" |
||||
+ "test.pl" =~ /(.*)/; |
||||
+ ok(-f -r $1, "stacked handles on a name with magic"); |
||||
+} |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,54 @@
@@ -0,0 +1,54 @@
|
||||
From ab307de390c3459badcc89b3d77542b5b871b2e8 Mon Sep 17 00:00:00 2001 |
||||
From: Richard Leach <richardleach@users.noreply.github.com> |
||||
Date: Tue, 20 Oct 2020 18:16:38 +0100 |
||||
Subject: [PATCH 2/2] pp_split: add TonyC's stack-not-refcounted-suggestion and |
||||
tests |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
pp.c | 5 ++++- |
||||
t/op/split.t | 5 +++++ |
||||
2 files changed, 9 insertions(+), 1 deletion(-) |
||||
|
||||
diff --git a/pp.c b/pp.c |
||||
index ce16c56e63..5b5e163011 100644 |
||||
--- a/pp.c |
||||
+++ b/pp.c |
||||
@@ -6034,6 +6034,9 @@ PP(pp_split) |
||||
oldsave = PL_savestack_ix; |
||||
} |
||||
|
||||
+ /* Some defence against stack-not-refcounted bugs */ |
||||
+ (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary)); |
||||
+ |
||||
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) { |
||||
PUSHMARK(SP); |
||||
XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg)); |
||||
@@ -6356,7 +6359,7 @@ PP(pp_split) |
||||
} |
||||
|
||||
PUTBACK; |
||||
- LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */ |
||||
+ LEAVE_SCOPE(oldsave); |
||||
SPAGAIN; |
||||
if (realarray) { |
||||
if (!mg) { |
||||
diff --git a/t/op/split.t b/t/op/split.t |
||||
index 1d78a45bde..7a321645ac 100644 |
||||
--- a/t/op/split.t |
||||
+++ b/t/op/split.t |
||||
@@ -703,3 +703,8 @@ fresh_perl_is('my @ary; @ary = split(/\w(?{ @ary[1000] = 1 })/, "abc");', |
||||
fresh_perl_is('my @ary; @ary = split(/\w(?{ undef @ary })/, "abc");', |
||||
'',{},'(@ary = split ...) survives an (undef @ary)'); |
||||
|
||||
+# check the (@ary = split) optimisation survives stack-not-refcounted bugs |
||||
+fresh_perl_is('our @ary; @ary = split(/\w(?{ *ary = 0 })/, "abc");', |
||||
+ '',{},'(@ary = split ...) survives @ary destruction via typeglob'); |
||||
+fresh_perl_is('my $ary = []; @$ary = split(/\w(?{ $ary = [] })/, "abc");', |
||||
+ '',{},'(@ary = split ...) survives @ary destruction via reassignment'); |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,71 @@
@@ -0,0 +1,71 @@
|
||||
From b52b6c4029b51818442d64c6104d26e12e140f09 Mon Sep 17 00:00:00 2001 |
||||
From: TAKAI Kousuke <62541129+t-a-k@users.noreply.github.com> |
||||
Date: Thu, 5 Nov 2020 22:06:16 +0900 |
||||
Subject: [PATCH] t/op/inc.t, t/op/hexfp.t, t/op/sprintf2.t: Add missing d_ |
||||
prefixes for Config variable names. |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
t/op/hexfp.t | 2 +- |
||||
t/op/inc.t | 4 ++-- |
||||
t/op/sprintf2.t | 4 ++-- |
||||
3 files changed, 5 insertions(+), 5 deletions(-) |
||||
|
||||
diff --git a/t/op/hexfp.t b/t/op/hexfp.t |
||||
index b0c85cfdc6..5fb80d3d74 100644 |
||||
--- a/t/op/hexfp.t |
||||
+++ b/t/op/hexfp.t |
||||
@@ -246,7 +246,7 @@ SKIP: { |
||||
skip("non-80-bit-long-double", 4) |
||||
unless ($Config{uselongdouble} && |
||||
($Config{nvsize} == 16 || $Config{nvsize} == 12) && |
||||
- ($Config{long_double_style_ieee_extended})); |
||||
+ ($Config{d_long_double_style_ieee_extended})); |
||||
is(0x1p-1074, 4.94065645841246544e-324); |
||||
is(0x1p-1075, 2.47032822920623272e-324, '[perl #128919]'); |
||||
is(0x1p-1076, 1.23516411460311636e-324); |
||||
diff --git a/t/op/inc.t b/t/op/inc.t |
||||
index 0bb8b85b13..3d5cc024d3 100644 |
||||
--- a/t/op/inc.t |
||||
+++ b/t/op/inc.t |
||||
@@ -188,10 +188,10 @@ cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double"); |
||||
|
||||
SKIP: { |
||||
if ($Config{uselongdouble} && |
||||
- ($Config{long_double_style_ieee_doubledouble})) { |
||||
+ ($Config{d_long_double_style_ieee_doubledouble})) { |
||||
skip "the double-double format is weird", 1; |
||||
} |
||||
- unless ($Config{double_style_ieee}) { |
||||
+ unless ($Config{d_double_style_ieee}) { |
||||
skip "the doublekind $Config{doublekind} is not IEEE", 1; |
||||
} |
||||
|
||||
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t |
||||
index bbc12ccd0a..38a550c281 100644 |
||||
--- a/t/op/sprintf2.t |
||||
+++ b/t/op/sprintf2.t |
||||
@@ -701,7 +701,7 @@ SKIP: { |
||||
skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef') |
||||
. " longdblkind=$Config{longdblkind} os=$^O", 6) |
||||
unless ($Config{uselongdouble} && |
||||
- ($Config{long_double_style_ieee_doubledouble}) |
||||
+ ($Config{d_long_double_style_ieee_doubledouble}) |
||||
# Gating on 'linux' (ppc) here is due to the differing |
||||
# double-double implementations: other (also big-endian) |
||||
# double-double platforms (e.g. AIX on ppc or IRIX on mips) |
||||
@@ -892,7 +892,7 @@ SKIP: { |
||||
skip("non-80-bit-long-double", 17) |
||||
unless ($Config{uselongdouble} && |
||||
($Config{nvsize} == 16 || $Config{nvsize} == 12) && |
||||
- ($Config{long_double_style_ieee_extended})); |
||||
+ ($Config{d_long_double_style_ieee_extended})); |
||||
|
||||
{ |
||||
# The last normal for this format. |
||||
-- |
||||
2.25.4 |
||||
|
@ -0,0 +1,32 @@
@@ -0,0 +1,32 @@
|
||||
From 9289d4dc7a3d24b20c6e25045e687321ee3e8faf Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Mon, 30 Nov 2020 09:25:52 -0700 |
||||
Subject: [PATCH] locale.c: Fix typo in #ifdef |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
This misspelling led to the code assuming that the platform didn't have |
||||
a feature that, if used, would result in faster execution. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
locale.c | 2 +- |
||||
1 file changed, 1 insertion(+), 1 deletion(-) |
||||
|
||||
diff --git a/locale.c b/locale.c |
||||
index 9500ab7960..5970423404 100644 |
||||
--- a/locale.c |
||||
+++ b/locale.c |
||||
@@ -2621,7 +2621,7 @@ S_my_nl_langinfo(const int item, bool toggle) |
||||
#if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */ |
||||
# if ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \ |
||||
|| ! defined(HAS_POSIX_2008_LOCALE) \ |
||||
- || ! defined(DUPLOCALE) |
||||
+ || ! defined(HAS_DUPLOCALE) |
||||
|
||||
/* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC |
||||
* for those items dependent on it. This must be copied to a buffer before |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,140 @@
@@ -0,0 +1,140 @@
|
||||
From 4cfbe5474a5c5f852a6dbf0138dc796c2800be93 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Wed, 30 Dec 2020 05:55:08 -0700 |
||||
Subject: [PATCH] Fix buggy fc() in Turkish locale |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
When Turkish handling was added, fc() wasn't properly updated |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
pp.c | 12 +++++++++--- |
||||
t/op/lc.t | 23 ++++++++++++++++------- |
||||
2 files changed, 25 insertions(+), 10 deletions(-) |
||||
|
||||
diff --git a/pp.c b/pp.c |
||||
index 5e1706346d..23cc6c8adb 100644 |
||||
--- a/pp.c |
||||
+++ b/pp.c |
||||
@@ -4813,7 +4813,7 @@ PP(pp_fc) |
||||
do { |
||||
extra++; |
||||
|
||||
- s_peek = (U8 *) memchr(s_peek + 1, 'i', |
||||
+ s_peek = (U8 *) memchr(s_peek + 1, 'I', |
||||
send - (s_peek + 1)); |
||||
} while (s_peek != NULL); |
||||
} |
||||
@@ -4828,8 +4828,14 @@ PP(pp_fc) |
||||
+ 1 /* Trailing NUL */ ); |
||||
d = (U8*)SvPVX(dest) + len; |
||||
|
||||
- *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU); |
||||
- *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU); |
||||
+ if (*s == 'I') { |
||||
+ *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I); |
||||
+ *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I); |
||||
+ } |
||||
+ else { |
||||
+ *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU); |
||||
+ *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU); |
||||
+ } |
||||
s++; |
||||
|
||||
for (; s < send; s++) { |
||||
diff --git a/t/op/lc.t b/t/op/lc.t |
||||
index fce77f3d34..812c41d6b6 100644 |
||||
--- a/t/op/lc.t |
||||
+++ b/t/op/lc.t |
||||
@@ -17,7 +17,7 @@ BEGIN { |
||||
|
||||
use feature qw( fc ); |
||||
|
||||
-plan tests => 139 + 2 * (4 * 256) + 15; |
||||
+plan tests => 139 + 2 * (5 * 256) + 17; |
||||
|
||||
is(lc(undef), "", "lc(undef) is ''"); |
||||
is(lcfirst(undef), "", "lcfirst(undef) is ''"); |
||||
@@ -352,13 +352,14 @@ foreach my $turkic (0 .. 1) { |
||||
my $locale = ($turkic) ? $turkic_locale : $non_turkic_locale; |
||||
|
||||
SKIP: { |
||||
- skip "Can't find a $type UTF-8 locale", 4*256 unless defined $locale; |
||||
+ skip "Can't find a $type UTF-8 locale", 5*256 unless defined $locale; |
||||
|
||||
use feature qw( unicode_strings ); |
||||
|
||||
no locale; |
||||
|
||||
my @unicode_lc; |
||||
+ my @unicode_fc; |
||||
my @unicode_uc; |
||||
my @unicode_lcfirst; |
||||
my @unicode_ucfirst; |
||||
@@ -366,6 +367,7 @@ foreach my $turkic (0 .. 1) { |
||||
# Get all the values outside of 'locale' |
||||
for my $i (0 .. 255) { |
||||
push @unicode_lc, lc(chr $i); |
||||
+ push @unicode_fc, fc(chr $i); |
||||
push @unicode_uc, uc(chr $i); |
||||
push @unicode_lcfirst, lcfirst(chr $i); |
||||
push @unicode_ucfirst, ucfirst(chr $i); |
||||
@@ -373,6 +375,7 @@ foreach my $turkic (0 .. 1) { |
||||
|
||||
if ($turkic) { |
||||
$unicode_lc[ord 'I'] = chr 0x131; |
||||
+ $unicode_fc[ord 'I'] = chr 0x131; |
||||
$unicode_lcfirst[ord 'I'] = chr 0x131; |
||||
$unicode_uc[ord 'i'] = chr 0x130; |
||||
$unicode_ucfirst[ord 'i'] = chr 0x130; |
||||
@@ -384,6 +387,7 @@ foreach my $turkic (0 .. 1) { |
||||
for my $i (0 .. 255) { |
||||
is(lc(chr $i), $unicode_lc[$i], "In a $type UTF-8 locale, lc(chr $i) is the same as official Unicode"); |
||||
is(uc(chr $i), $unicode_uc[$i], "In a $type UTF-8 locale, uc(chr $i) is the same as official Unicode"); |
||||
+ is(fc(chr $i), $unicode_fc[$i], "In a $type UTF-8 locale, fc(chr $i) is the same as official Unicode"); |
||||
is(lcfirst(chr $i), $unicode_lcfirst[$i], "In a $type UTF-8 locale, lcfirst(chr $i) is the same as official Unicode"); |
||||
is(ucfirst(chr $i), $unicode_ucfirst[$i], "In a $type UTF-8 locale, ucfirst(chr $i) is the same as official Unicode"); |
||||
} |
||||
@@ -391,27 +395,32 @@ foreach my $turkic (0 .. 1) { |
||||
} |
||||
|
||||
SKIP: { |
||||
- skip "Can't find a turkic UTF-8 locale", 15 unless defined $turkic_locale; |
||||
+ skip "Can't find a turkic UTF-8 locale", 17 unless defined $turkic_locale; |
||||
|
||||
# These are designed to stress the calculation of space needed for the |
||||
# strings. $filler contains a variety of characters that have special |
||||
# handling in the casing functions, and some regular chars as well. |
||||
+ # (0x49 = 'I') |
||||
my $filler_length = 10000; |
||||
- my $filler = uni_to_native("\x{df}\x{b5}\x{e0}\x{c1}\x{b6}\x{ff}") x $filler_length; |
||||
+ my $filler = uni_to_native("\x{df}\x{49}\x{69}\x{b5}\x{e0}\x{c1}\x{b6}\x{ff}") x $filler_length; |
||||
|
||||
# These are the correct answers to what should happen when the given |
||||
# casing function is called on $filler; |
||||
- my $filler_lc = uni_to_native("\x{df}\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}") x $filler_length; |
||||
- my $filler_fc = ("ss" . uni_to_native("\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}")) x $filler_length; |
||||
- my $filler_uc = ("SS" . uni_to_native("\x{39c}\x{c0}\x{c1}\x{b6}\x{178}")) x $filler_length; |
||||
+ my $filler_lc = uni_to_native("\x{df}\x{131}\x{69}\x{b5}\x{e0}\x{e1}\x{b6}\x{ff}") x $filler_length; |
||||
+ my $filler_fc = ("ss" . uni_to_native("\x{131}\x{69}\x{3bc}\x{e0}\x{e1}\x{b6}\x{ff}")) x $filler_length; |
||||
+ my $filler_uc = ("SS" . uni_to_native("\x{49}\x{130}\x{39c}\x{c0}\x{c1}\x{b6}\x{178}")) x $filler_length; |
||||
|
||||
use locale; |
||||
setlocale(&POSIX::LC_CTYPE, $turkic_locale); |
||||
|
||||
is (lc "IIIIIII$filler", "\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc", |
||||
"lc non-UTF-8, in Turkic locale, beginning with a bunch of I's"); |
||||
+ is (fc "IIIIIII$filler", "\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_fc", |
||||
+ "fc non-UTF-8, in Turkic locale, beginning with a bunch of I's"); |
||||
is (lc "${filler}IIIIIII$filler", "$filler_lc\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc", |
||||
"lc non-UTF-8, in Turkic locale, a bunch of I's, but not at the beginning"); |
||||
+ is (fc "${filler}IIIIIII$filler", "$filler_fc\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_fc", |
||||
+ "fc non-UTF-8, in Turkic locale, a bunch of I's, but not at the beginning"); |
||||
is (lc "${filler}I\x{307}$filler", "${filler_lc}i$filler_lc", |
||||
"lc in Turkic locale with DOT ABOVE immediately following I"); |
||||
is (lc "${filler}I\x{307}IIIIII$filler", "${filler_lc}i\x{131}\x{131}\x{131}\x{131}\x{131}\x{131}$filler_lc", |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,43 @@
@@ -0,0 +1,43 @@
|
||||
From 036189b0a003875df7bf09c7f7fd702267f549e5 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Sat, 26 Dec 2020 08:44:08 -0700 |
||||
Subject: [PATCH] Use perl.h versions of PERL_UNUSED_foo in XSUB.h |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
This commit was applied to perl.h, but not to XSUB.h: |
||||
|
||||
commit a730e3f230f364cffe49370f816f975ae7c9c403 |
||||
Author: Jarkko Hietaniemi <jhi@iki.fi> |
||||
Date: Thu Sep 4 09:08:33 2014 -0400 |
||||
|
||||
Use sizeof() in UNUSED_ARG and UNUSED_VAR to avoid accessing the values. |
||||
|
||||
The values might even be uninitialized in the case of PERL_UNUSED_VAR. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
XSUB.h | 4 ++-- |
||||
1 file changed, 2 insertions(+), 2 deletions(-) |
||||
|
||||
diff --git a/XSUB.h b/XSUB.h |
||||
index 616d813840..c1e3959885 100644 |
||||
--- a/XSUB.h |
||||
+++ b/XSUB.h |
||||
@@ -108,10 +108,10 @@ is a lexical C<$_> in scope. |
||||
*/ |
||||
|
||||
#ifndef PERL_UNUSED_ARG |
||||
-# define PERL_UNUSED_ARG(x) ((void)x) |
||||
+# define PERL_UNUSED_ARG(x) ((void)sizeof(x)) |
||||
#endif |
||||
#ifndef PERL_UNUSED_VAR |
||||
-# define PERL_UNUSED_VAR(x) ((void)x) |
||||
+# define PERL_UNUSED_VAR(x) ((void)sizeof(x)) |
||||
#endif |
||||
|
||||
#define ST(off) PL_stack_base[ax + (off)] |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,78 @@
@@ -0,0 +1,78 @@
|
||||
From 07319fdbb283f93cb655c3106b5237cbc7272038 Mon Sep 17 00:00:00 2001 |
||||
From: Tomasz Konojacki <me@xenu.pl> |
||||
Date: Wed, 30 Dec 2020 14:03:02 +0100 |
||||
Subject: [PATCH] op.c: croak on "my $_" when "use utf8" is in effect |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
Fixes #18449 |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
op.c | 16 +++++++++------- |
||||
t/op/mydef.t | 11 +++++++++-- |
||||
2 files changed, 18 insertions(+), 9 deletions(-) |
||||
|
||||
diff --git a/op.c b/op.c |
||||
index b2e12dd0c0..dce844d297 100644 |
||||
--- a/op.c |
||||
+++ b/op.c |
||||
@@ -730,6 +730,7 @@ PADOFFSET |
||||
Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) |
||||
{ |
||||
PADOFFSET off; |
||||
+ bool is_idfirst, is_default; |
||||
const bool is_our = (PL_parser->in_my == KEY_our); |
||||
|
||||
PERL_ARGS_ASSERT_ALLOCMY; |
||||
@@ -738,14 +739,15 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) |
||||
Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, |
||||
(UV)flags); |
||||
|
||||
+ is_idfirst = flags & SVf_UTF8 |
||||
+ ? isIDFIRST_utf8_safe((U8*)name + 1, name + len) |
||||
+ : isIDFIRST_A(name[1]); |
||||
+ |
||||
+ /* $_, @_, etc. */ |
||||
+ is_default = len == 2 && name[1] == '_'; |
||||
+ |
||||
/* complain about "my $<special_var>" etc etc */ |
||||
- if ( len |
||||
- && !( is_our |
||||
- || isALPHA(name[1]) |
||||
- || ( (flags & SVf_UTF8) |
||||
- && isIDFIRST_utf8_safe((U8 *)name+1, name + len)) |
||||
- || (name[1] == '_' && len > 2))) |
||||
- { |
||||
+ if (!is_our && (!is_idfirst || is_default)) { |
||||
const char * const type = |
||||
PL_parser->in_my == KEY_sigvar ? "subroutine signature" : |
||||
PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\""; |
||||
diff --git a/t/op/mydef.t b/t/op/mydef.t |
||||
index 42a81d9ab0..225ce98e51 100644 |
||||
--- a/t/op/mydef.t |
||||
+++ b/t/op/mydef.t |
||||
@@ -6,10 +6,17 @@ BEGIN { |
||||
set_up_inc('../lib'); |
||||
} |
||||
|
||||
-plan tests => 1; |
||||
- |
||||
use strict; |
||||
|
||||
eval 'my $_'; |
||||
like $@, qr/^Can't use global \$_ in "my" at /; |
||||
|
||||
+{ |
||||
+ # using utf8 allows $_ to be declared with 'my' |
||||
+ # GH #18449 |
||||
+ use utf8; |
||||
+ eval 'my $_;'; |
||||
+ like $@, qr/^Can't use global \$_ in "my" at /; |
||||
+} |
||||
+ |
||||
+done_testing; |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,100 @@
@@ -0,0 +1,100 @@
|
||||
From cac138107138a9814b32c4de74426225628f1646 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Sun, 17 Jan 2021 21:45:20 -0700 |
||||
Subject: [PATCH] Add missing entries to perldiag; GH #18276 |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
The ticket mentions yet another message, not addressed in this |
||||
commit, "Insecure private-use override". That message is part of a |
||||
hook for a so-far unimplemented module, so it actually doesn't ever get |
||||
raised. |
||||
|
||||
Committer: One correction per Grinnz comment in |
||||
https://github.com/Perl/perl5/pull/18491 |
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
pod/perldiag.pod | 45 +++++++++++++++++++++++++++++++++++++++++++++ |
||||
1 file changed, 45 insertions(+) |
||||
|
||||
diff --git a/pod/perldiag.pod b/pod/perldiag.pod |
||||
index 9c91630d39..63f57f220e 100644 |
||||
--- a/pod/perldiag.pod |
||||
+++ b/pod/perldiag.pod |
||||
@@ -2195,6 +2195,20 @@ single form when it must operate on them directly. Either you've passed |
||||
an invalid file specification to Perl, or you've found a case the |
||||
conversion routines don't handle. Drat. |
||||
|
||||
+=item Error %s in expansion of %s |
||||
+ |
||||
+(F) An error was encountered in handling a user-defined property |
||||
+(L<perlunicode/User-Defined Character Properties>). These are |
||||
+programmer written subroutines, hence subject to errors that may |
||||
+prevent them from compiling or running. The calls to these subs are |
||||
+C<eval>'d, and if there is a failure, this message is raised, using the |
||||
+contents of C<$@> from the failed C<eval>. |
||||
+ |
||||
+Another possibility is that tainted data was encountered somewhere in |
||||
+the chain of expanding the property. If so, the message wording will |
||||
+indicate that this is the problem. See L</Insecure user-defined |
||||
+property %s>. |
||||
+ |
||||
=item Eval-group in insecure regular expression |
||||
|
||||
(F) Perl detected tainted data when trying to compile a regular |
||||
@@ -2836,6 +2850,16 @@ not match 8 spaces. |
||||
text. You should check the pattern to ensure that recursive patterns |
||||
either consume text or fail. |
||||
|
||||
+=item Infinite recursion in user-defined property |
||||
+ |
||||
+(F) A user-defined property (L<perlunicode/User-Defined Character |
||||
+Properties>) can depend on the definitions of other user-defined |
||||
+properties. If the chain of dependencies leads back to this property, |
||||
+infinite recursion would occur, were it not for the check that raised |
||||
+this error. |
||||
+ |
||||
+Restructure your property definitions to avoid this. |
||||
+ |
||||
=item Infinite recursion via empty pattern |
||||
|
||||
(F) You tried to use the empty pattern inside of a regex code block, |
||||
@@ -6273,6 +6297,20 @@ lexicals that are initialized only once (see L<feature>): |
||||
This use of C<my()> in a false conditional was deprecated beginning in |
||||
Perl 5.10 and became a fatal error in Perl 5.30. |
||||
|
||||
+=item Timeout waiting for another thread to define \p{%s} |
||||
+ |
||||
+(F) The first time a user-defined property |
||||
+(L<perlunicode/User-Defined Character Properties>) is used, its |
||||
+definition is looked up and converted into an internal form for more |
||||
+efficient handling in subsequent uses. There could be a race if two or |
||||
+more threads tried to do this processing nearly simultaneously. |
||||
+Instead, a critical section is created around this task, locking out all |
||||
+but one thread from doing it. This message indicates that the thread |
||||
+that is doing the conversion is taking an unexpectedly long time. The |
||||
+timeout exists solely to prevent deadlock; it's long enough that the |
||||
+system was likely thrashing and about to crash. There is no real remedy but |
||||
+rebooting. |
||||
+ |
||||
=item times not implemented |
||||
|
||||
(F) Your version of the C library apparently doesn't do times(). I |
||||
@@ -6846,6 +6884,13 @@ for the list of known options. |
||||
L<perlrun|perlrun/-C [numberE<sol>list]> documentation of the C<-C> switch |
||||
for the list of known options. |
||||
|
||||
+=item Unknown user-defined property name \p{%s} |
||||
+ |
||||
+(F) You specified to use a property within the C<\p{...}> which was a |
||||
+syntactically valid user-defined property, but no definition was found |
||||
+for it by the time one was required to proceed. Check your spelling. |
||||
+See L<perlunicode/User-Defined Character Properties>. |
||||
+ |
||||
=item Unknown verb pattern '%s' in regex; marked by S<<-- HERE> in m/%s/ |
||||
|
||||
(F) You either made a typo or have incorrectly put a C<*> quantifier |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,32 @@
@@ -0,0 +1,32 @@
|
||||
From a2f57b06b018b254bee93e1a1265cfc09833366f Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Tue, 9 Feb 2021 11:32:15 -0700 |
||||
Subject: [PATCH] t/run/locale.t: Rmv LANGUAGE from environment |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
This could cause interference with our tests on some platforms that have |
||||
this environment variable. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
t/run/locale.t | 2 +- |
||||
1 file changed, 1 insertion(+), 1 deletion(-) |
||||
|
||||
diff --git a/t/run/locale.t b/t/run/locale.t |
||||
index 8a04d1aea6..0f2a2ba457 100644 |
||||
--- a/t/run/locale.t |
||||
+++ b/t/run/locale.t |
||||
@@ -38,7 +38,7 @@ if (defined $ARGV[0] && $ARGV[0] ne "") { |
||||
} |
||||
|
||||
# reset the locale environment |
||||
-delete local @ENV{'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)}; |
||||
+delete local @ENV{'LANGUAGE', 'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)}; |
||||
|
||||
# If user wants this to happen, they set the environment variable AND use |
||||
# 'debug' |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,74 @@
@@ -0,0 +1,74 @@
|
||||
From 5f41fa466a67b5535aa8bcf4b814f242545ac7bd Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Sat, 27 Feb 2021 11:43:41 -0700 |
||||
Subject: [PATCH] regcomp.c: Remove memory leak |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
This fixes GH #18604. There was a path through the code where a |
||||
particular SV did not get its reference count decremented. |
||||
|
||||
I did an audit of the function and came up with several other |
||||
possiblities that are included in this commit. |
||||
|
||||
Further, there would be leaks for some instances of finding syntax |
||||
errors in the input pattern, or when warnings are fatalized. Those |
||||
would require mortalizing some SVs, but that is beyond the scope of this |
||||
commit. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
regcomp.c | 7 +++++++ |
||||
t/op/svleak.t | 3 ++- |
||||
2 files changed, 9 insertions(+), 1 deletion(-) |
||||
|
||||
diff --git a/regcomp.c b/regcomp.c |
||||
index e44c7a37e5..f5e5f581dc 100644 |
||||
--- a/regcomp.c |
||||
+++ b/regcomp.c |
||||
@@ -18765,6 +18765,12 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, |
||||
RExC_end = save_end; |
||||
RExC_in_multi_char_class = 0; |
||||
SvREFCNT_dec_NN(multi_char_matches); |
||||
+ SvREFCNT_dec(properties); |
||||
+ SvREFCNT_dec(cp_list); |
||||
+ SvREFCNT_dec(simple_posixes); |
||||
+ SvREFCNT_dec(posixes); |
||||
+ SvREFCNT_dec(nposixes); |
||||
+ SvREFCNT_dec(cp_foldable_list); |
||||
return ret; |
||||
} |
||||
|
||||
@@ -20122,6 +20128,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, |
||||
RExC_parse - orig_parse);; |
||||
SvREFCNT_dec(cp_list);; |
||||
SvREFCNT_dec(only_utf8_locale_list); |
||||
+ SvREFCNT_dec(upper_latin1_only_utf8_matches); |
||||
return ret; |
||||
} |
||||
|
||||
diff --git a/t/op/svleak.t b/t/op/svleak.t |
||||
index 6acc298c3d..3df4838be8 100644 |
||||
--- a/t/op/svleak.t |
||||
+++ b/t/op/svleak.t |
||||
@@ -15,7 +15,7 @@ BEGIN { |
||||
|
||||
use Config; |
||||
|
||||
-plan tests => 150; |
||||
+plan tests => 151; |
||||
|
||||
# run some code N times. If the number of SVs at the end of loop N is |
||||
# greater than (N-1)*delta at the end of loop 1, we've got a leak |
||||
@@ -278,6 +278,7 @@ eleak(2,0,'/[[:ascii:]]/'); |
||||
eleak(2,0,'/[[.zog.]]/'); |
||||
eleak(2,0,'/[.zog.]/'); |
||||
eleak(2,0,'/|\W/', '/|\W/ [perl #123198]'); |
||||
+eleak(2,0,'/a\sb/', '/a\sb/ [GH #18604]'); |
||||
eleak(2,0,'no warnings; /(?[])/'); |
||||
eleak(2,0,'no warnings; /(?[[a]+[b]])/'); |
||||
eleak(2,0,'no warnings; /(?[[a]-[b]])/'); |
||||
-- |
||||
2.26.2 |
||||
|
@ -0,0 +1,62 @@
@@ -0,0 +1,62 @@
|
||||
From 4e82c85b1c9c9b30253b8624470da6f20a6c0604 Mon Sep 17 00:00:00 2001 |
||||
From: Karl Williamson <khw@cpan.org> |
||||
Date: Mon, 15 Mar 2021 21:01:47 -0600 |
||||
Subject: [PATCH] Fix broken left shift of IV_MIN under 'use integer' |
||||
MIME-Version: 1.0 |
||||
Content-Type: text/plain; charset=UTF-8 |
||||
Content-Transfer-Encoding: 8bit |
||||
|
||||
This fixes GH 18639 |
||||
|
||||
When I wrote this code, I conflated casting and complementing. |
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com> |
||||
--- |
||||
pp.c | 3 --- |
||||
t/op/bop.t | 9 ++++++++- |
||||
2 files changed, 8 insertions(+), 4 deletions(-) |
||||
|
||||
diff --git a/pp.c b/pp.c |
||||
index d365afea4c..baf0777a47 100644 |
||||
--- a/pp.c |
||||
+++ b/pp.c |
||||
@@ -2007,9 +2007,6 @@ static IV S_iv_shift(IV iv, int shift, bool left) |
||||
* 18446744073709551552 |
||||
* */ |
||||
if (left) { |
||||
- if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */ |
||||
- return 0; |
||||
- } |
||||
return (IV) (((UV) iv) << shift); |
||||
} |
||||
|
||||
diff --git a/t/op/bop.t b/t/op/bop.t |
||||
index 07f057d0a9..31b6531a03 100644 |
||||
--- a/t/op/bop.t |
||||
+++ b/t/op/bop.t |
||||
@@ -18,7 +18,7 @@ BEGIN { |
||||
# If you find tests are failing, please try adding names to tests to track |
||||
# down where the failure is, and supply your new names as a patch. |
||||
# (Just-in-time test naming) |
||||
-plan tests => 502; |
||||
+plan tests => 503; |
||||
|
||||
# numerics |
||||
ok ((0xdead & 0xbeef) == 0x9ead); |
||||
@@ -33,6 +33,13 @@ ok ((33023 >> 7) == 257); |
||||
# signed vs. unsigned |
||||
ok ((~0 > 0 && do { use integer; ~0 } == -1)); |
||||
|
||||
+{ # GH #18639 |
||||
+ my $iv_min = -(~0 >> 1) - 1; |
||||
+ my $shifted; |
||||
+ { use integer; $shifted = $iv_min << 0 }; |
||||
+ is($shifted, $iv_min, "IV_MIN << 0 yields IV_MIN under 'use integer'"); |
||||
+} |
||||
+ |
||||
my $bits = 0; |
||||
for (my $i = ~0; $i; $i >>= 1) { ++$bits; } |
||||
my $cusp = 1 << ($bits - 1); |
||||
-- |
||||
2.26.3 |
||||
|
@ -0,0 +1,47 @@
@@ -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" |
@ -0,0 +1,109 @@
@@ -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 PUREPERL_ONLY |
||||
- 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)" '; |
||||
} |
||||
|
@ -0,0 +1,21 @@
@@ -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) |
||||
} |
@ -0,0 +1,21 @@
@@ -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 |
@ -0,0 +1,71 @@
@@ -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) |
||||
} |
Loading…
Reference in new issue