packages/perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

bump version to 5.32.0

Browse Source
This commit is contained in:
Yangyang Shen 2020-08-13 15:31:23 +08:00
parent ba10d81ee2
commit 4a3cf165c0
22 changed files with 60 additions and 1416 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
CVE-2018-18312-1.patch
View File

@ -1,10 +0,0 @@
--- a/regcomp.c 2018-05-21 20:29:23.000000000 +0800
+++ b/regcomp-change.c 2019-04-11 09:51:08.493000000 +0800
@@ -15591,7 +15591,6 @@ redo_curchar:
if (UCHARAT(RExC_parse) != ')')
vFAIL("Expecting close paren for wrapper for nested extended charclass");
- RExC_parse++;
RExC_flags = save_flags;
goto handle_operand;
}

11
CVE-2018-18312-2.patch
View File

@ -1,11 +0,0 @@
--- a/t/re/reg_mesg.t 2018-05-21 20:29:23.000000000 +0800
+++ b/t/re/reg_mesg-change.t 2019-04-11 09:54:59.622000000 +0800
@@ -122,6 +122,8 @@ my $tab_hex = sprintf "%02X", ord("\t");
#
# The first set are those that should be fatal errors.
+my $bug133423 = "(?[(?^:(?[\\\x00]))\\]\x00|2[^^]\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80])R.\\670";
+
my @death =
(
'/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions {#} m/[[=foo=]{#}]/',

10
CVE-2018-18312-3.patch
View File

@ -1,10 +0,0 @@
--- a/t/re/reg_mesg-change.t 2019-04-11 10:07:36.626000000 +0800
+++ b/t/re/reg_mesg.t 2019-04-11 10:08:20.032000000 +0800
@@ -309,6 +309,7 @@ my @death =
'/\A{/' => 'Unescaped left brace in regex is illegal here {#} m/\A{{#}/',
'/(?<=/' => 'Sequence (?... not terminated {#} m/(?<={#}/', # [perl #128170]
'/\p{vertical tab}/' => 'Can\'t find Unicode property definition "vertical tab" {#} m/\\p{vertical tab}{#}/', # [perl #132055]
+ "/$bug133423/" => "Operand with no preceding operator {#} m/(?[(?^:(?[\\\0]))\\{#}]\0|2[^^]\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80])R.\\670/",
);

93
Fix-script-run-bug-1-followed-by-Thai-digit.patch
View File

@ -1,93 +0,0 @@
From 7da8e27b9d7d2be4e770d074405ddb9941e6c8b7 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Thu, 16 Aug 2018 16:14:01 -0600
Subject: [PATCH] Fix script run bug '1' followed by Thai digit
This does not have a ticket, but was pointed out in
http://nntp.perl.org/group/perl.perl5.porters/251870
The logic for deciding if it was needed to check if a character is a
digit was flawed.
---
regexec.c | 46 +++++++++++++++++++++++++++++++---------------
t/re/script_run.t | 5 +++++
2 files changed, 36 insertions(+), 15 deletions(-)
diff --git a/regexec.c b/regexec.c
index 6f39670c4a..c927abc611 100644
--- a/regexec.c
+++ b/regexec.c
@@ -10626,23 +10626,39 @@ Perl_isSCRIPT_RUN(pTHX_ const U8 * s, const U8 * send, const bool utf8_target)
scripts_match:
/* Here, the script of the character is compatible with that of the
- * run. Either they match exactly, or one or both can be any of
- * several scripts, and the intersection is not empty. If the
- * character is not a decimal digit, we are done with it. Otherwise,
- * it could still fail if it is from a different set of 10 than seen
- * already (or we may not have seen any, and we need to set the
- * sequence). If we have determined a single script and that script
- * only has one set of digits (almost all scripts are like that), then
- * this isn't a problem, as any digit must come from the same sequence.
- * The only scripts that have multiple sequences have been constructed
- * to be 0 in 'script_zeros[]'.
+ * run. That means that in most cases, it continues the script run.
+ * Either it and the run match exactly, or one or both can be in any of
+ * several scripts, and the intersection is not empty. But if the
+ * character is a decimal digit, we need further handling. If we
+ * haven't seen a digit before, it would establish what set of 10 all
+ * must come from; and if we have established a set, we need to check
+ * that this is in it.
*
- * Here we check if it is a digit. */
+ * But there are cases we can rule out without having to look up if
+ * this is a digit:
+ * a. All instances of [0-9] have been dealt with earlier.
+ * b. The next digit encoded by Unicode is 1600 code points further
+ * on, so if the code point in this loop iteration is less than
+ * that, it isn't a digit.
+ * c. Most scripts that have digits have a single set of 10. If
+ * we've encountered a digit in such a script, 'zero_of_run' is
+ * set to the code point (call it z) whose numeric value is 0.
+ * If the code point in this loop iteration is in the range
+ * z..z+9, it is in the script's set of 10, and we've actually
+ * handled it earlier in this function and won't reach this
+ * point. But, code points in that script that aren't in that
+ * range can't be digits, so we don't have to look any such up.
+ * We can tell if this script is such a one by looking at
+ * 'script_zeros[]' for it. It is non-zero iff it has a single
+ * set of digits. This rule doesn't apply if we haven't narrowed
+ * down the possible scripts to a single one yet. Nor if the
+ * zero of the run is '0', as that also hasn't narrowed things
+ * down completely */
if ( cp >= FIRST_NON_ASCII_DECIMAL_DIGIT
- && ( ( zero_of_run == 0
- || ( ( script_of_char >= 0
- && script_zeros[script_of_char] == 0)
- || intersection))))
+ && ( intersection
+ || script_of_char < 0 /* Also implies an intersection */
+ || zero_of_run == '0'
+ || script_zeros[script_of_char] == 0))
{
SSize_t range_zero_index;
range_zero_index = _invlist_search(decimals_invlist, cp);
diff --git a/t/re/script_run.t b/t/re/script_run.t
index ca234d9d4e..10c71034c4 100644
--- a/t/re/script_run.t
+++ b/t/re/script_run.t
@@ -84,6 +84,11 @@ foreach my $type ('script_run', 'sr', 'atomic_script_run', 'asr') {
# From UTS 39
like("写真だけの結婚式", $script_run, "Mixed Hiragana and Han");
+
+ unlike "\N{THAI DIGIT FIVE}1", $script_run, "Thai digit followed by '1'";
+ unlike "1\N{THAI DIGIT FIVE}", $script_run, "'1' followed by Thai digit ";
+ unlike "\N{BENGALI DIGIT ZERO}\N{CHAKMA DIGIT SEVEN}", $script_run,
+ "Two digits in same extended script but from different sets of 10";
}
# Until fixed, this was skipping the '['
--
2.19.1

66
Fix-time-local-tests-in-2020.patch
View File

@ -1,66 +0,0 @@
From 836390962709d5856816807f13a3edfd4aff1fe1 Mon Sep 17 00:00:00 2001
From: openEuler Buildteam <buildteam@openeuler.org>
Date: Fri, 3 Jan 2020 15:31:48 +0800
Subject: [PATCH] Fix time local tests in 2020
See details at here:https://rt.cpan.org/Public/Bug/Display.html?id=124787
---
cpan/Time-Local/t/Local.t | 11 +++++------
1 file changed, 5 insertions(+), 6 deletions(-)
diff --git a/cpan/Time-Local/t/Local.t b/cpan/Time-Local/t/Local.t
index 6341396..e28c6d2 100644
--- a/cpan/Time-Local/t/Local.t
+++ b/cpan/Time-Local/t/Local.t
@@ -96,7 +96,7 @@ SKIP: {
# Test timelocal()
{
- my $year_in = $year < 70 ? $year + 1900 : $year;
+ my $year_in = $year + 1900;
my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year_in );
my ( $s, $m, $h, $D, $M, $Y ) = localtime($time);
@@ -111,7 +111,7 @@ SKIP: {
# Test timegm()
{
- my $year_in = $year < 70 ? $year + 1900 : $year;
+ my $year_in = $year + 1900;
my $time = timegm( $sec, $min, $hour, $mday, $mon, $year_in );
my ( $s, $m, $h, $D, $M, $Y ) = gmtime($time);
@@ -128,7 +128,6 @@ SKIP: {
for (@bad_time) {
my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
- $year -= 1900;
$mon--;
eval { timegm( $sec, $min, $hour, $mday, $mon, $year ) };
@@ -138,19 +137,19 @@ for (@bad_time) {
{
is(
- timelocal( 0, 0, 1, 1, 0, 90 ) - timelocal( 0, 0, 0, 1, 0, 90 ), 3600,
+ timelocal( 0, 0, 1, 1, 0, 1990 ) - timelocal( 0, 0, 0, 1, 0, 1990 ), 3600,
'one hour difference between two calls to timelocal'
);
is(
- timelocal( 1, 2, 3, 1, 0, 100 ) - timelocal( 1, 2, 3, 31, 11, 99 ),
+ timelocal( 1, 2, 3, 1, 0, 2000 ) - timelocal( 1, 2, 3, 31, 11, 1999 ),
24 * 3600,
'one day difference between two calls to timelocal'
);
# Diff beween Jan 1, 1980 and Mar 1, 1980 = (31 + 29 = 60 days)
is(
- timegm( 0, 0, 0, 1, 2, 80 ) - timegm( 0, 0, 0, 1, 0, 80 ),
+ timegm( 0, 0, 0, 1, 2, 1980 ) - timegm( 0, 0, 0, 1, 0, 1980 ),
60 * 24 * 3600,
'60 day difference between two calls to timegm'
);
--
1.8.3.1

175
Perl_my_setenv-handle-integer-wrap.patch
View File

@ -1,175 +0,0 @@
From 34716e2a6ee2af96078d62b065b7785c001194be Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Fri, 29 Jun 2018 13:37:03 +0100
Subject: [PATCH] Perl_my_setenv(); handle integer wrap
RT #133204
Wean this function off int/I32 and onto UV/Size_t.
Also, replace all malloc-ish calls with a wrapper that does
overflow checks,
In particular, it was doing (nlen + vlen + 2) which could wrap when
the combined length of the environment variable name and value
exceeded around 0x7fffffff.
The wrapper check function is probably overkill, but belt and braces...
NB this function has several variant parts, #ifdef'ed by platform
type; I have blindly changed the parts that aren't compiled under linux.
---
util.c | 76 ++++++++++++++++++++++++++++++++++++++++------------------
1 file changed, 53 insertions(+), 23 deletions(-)
diff --git a/util.c b/util.c
index 7282dd9cfe..c5c7becc0f 100644
--- a/util.c
+++ b/util.c
@@ -2061,8 +2061,40 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
*(s+(nlen+1+vlen)) = '\0'
#ifdef USE_ENVIRON_ARRAY
- /* VMS' my_setenv() is in vms.c */
+
+/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
+ * 'current' is non-null, with up to three sizes that are added together.
+ * It handles integer overflow.
+ */
+static char *
+S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
+{
+ void *p;
+ Size_t sl, l = l1 + l2;
+
+ if (l < l2)
+ goto panic;
+ l += l3;
+ if (l < l3)
+ goto panic;
+ sl = l * size;
+ if (sl < l)
+ goto panic;
+
+ p = current
+ ? safesysrealloc(current, sl)
+ : safesysmalloc(sl);
+ if (p)
+ return (char*)p;
+
+ panic:
+ croak_memory_wrap();
+}
+
+
+/* VMS' my_setenv() is in vms.c */
#if !defined(WIN32) && !defined(NETWARE)
+
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
@@ -2078,28 +2110,27 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
#ifndef PERL_USE_SAFE_PUTENV
if (!PL_use_safe_putenv) {
/* most putenv()s leak, so we manipulate environ directly */
- I32 i;
- const I32 len = strlen(nam);
- int nlen, vlen;
+ UV i;
+ Size_t vlen, nlen = strlen(nam);
/* where does it go? */
for (i = 0; environ[i]; i++) {
- if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+ if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
break;
}
if (environ == PL_origenviron) { /* need we copy environment? */
- I32 j;
- I32 max;
+ UV j, max;
char **tmpenv;
max = i;
while (environ[max])
max++;
- tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+ /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
+ tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
for (j=0; j<max; j++) { /* copy environment */
- const int len = strlen(environ[j]);
- tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ const Size_t len = strlen(environ[j]);
+ tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
Copy(environ[j], tmpenv[j], len+1, char);
}
tmpenv[max] = NULL;
@@ -2118,15 +2149,15 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
#endif
}
if (!environ[i]) { /* does not exist yet */
- environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+ environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
environ[i+1] = NULL; /* make sure it's null terminated */
}
else
safesysfree(environ[i]);
- nlen = strlen(nam);
+
vlen = strlen(val);
- environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
/* all that work just for this */
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
@@ -2150,22 +2181,21 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
if (environ) /* old glibc can crash with null environ */
(void)unsetenv(nam);
} else {
- const int nlen = strlen(nam);
- const int vlen = strlen(val);
- char * const new_env =
- (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ const Size_t nlen = strlen(nam);
+ const Size_t vlen = strlen(val);
+ char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
}
# else /* ! HAS_UNSETENV */
char *new_env;
- const int nlen = strlen(nam);
- int vlen;
+ const Size_t nlen = strlen(nam);
+ Size_t vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
/* all that work just for this */
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
@@ -2187,14 +2217,14 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
char *envstr;
- const int nlen = strlen(nam);
- int vlen;
+ const Size_t nlen = strlen(nam);
+ Size_t vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- Newx(envstr, nlen+vlen+2, char);
+ envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
--
2.19.1

49
Time-HiRes-t-itimer.t-avoid-race-condition.patch
View File

@ -1,49 +0,0 @@
From ecbf46993f6ffbdc255f6ded3c6c05a8266a71e8 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Tue, 7 Aug 2018 12:26:31 +0100
Subject: [PATCH] Time-HiRes/t/itimer.t: avoid race condition.
This test script sets a repeating interval timer going, and after 4
'ticks' (SIGVTALRM), disables the timer (by setting it to zero).
The main loop which does CPU burning, does a getitmer() every now and
again, and when the value is zero, assumes the signal handler has
disabled the timer, and so finishes.
The trouble was that it was checking the 'time left', which can reach
zero because the interval timer has counted down to zero, and the signal
handler is about to be called, but the interval hasn't been reset back
to 0.4s yet.
i.e. the code doesn't distinguish between "timer disabled" and "timer
just reached zero".
In that scenario, the cleanup code in the test script disables the
SIGVTALRM handler while the timer is still active, and so the process
gets killed if another signal is raised.
This commit changes the test to check the second value returned by
getitmer() for being zero rather than the first - the second being the
repeat interval, whichb is always 0.4 until the timer is disabled.
---
dist/Time-HiRes/t/itimer.t | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/dist/Time-HiRes/t/itimer.t b/dist/Time-HiRes/t/itimer.t
index e196b1648c..432b224488 100644
--- a/dist/Time-HiRes/t/itimer.t
+++ b/dist/Time-HiRes/t/itimer.t
@@ -51,7 +51,9 @@ ok(defined $virt && abs($virt / 0.5) - 1 < $limit,
printf("# getitimer: %s\n", join(" ",
Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)));
-while (Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)) {
+# burn CPU until the VTALRM signal handler sets the repeat interval to
+# zero, indicating that the timer has fired 4 times.
+while ((Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL))[1]) {
my $j;
for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer().
}
--
2.19.1

184
Update-Time-Piece-to-CPAN-version-1.33.patch
View File

@ -1,184 +0,0 @@
From 9d890beed61e079102335ef5859d652b4e2c32ac Mon Sep 17 00:00:00 2001
From: Chris 'BinGOs' Williams <chris@bingosnet.co.uk>
Date: Mon, 20 Aug 2018 11:15:20 +0100
Subject: [PATCH] Update Time-Piece to CPAN version 1.33
[DELTA]
1.33 2018-08-18
- Allow objects in overloaded methods
---
Porting/Maintainers.pl | 2 +-
cpan/Time-Piece/Piece.pm | 40 ++++++++++++++++++++--------------
cpan/Time-Piece/Seconds.pm | 2 +-
cpan/Time-Piece/t/06subclass.t | 15 +++++++++++++
4 files changed, 41 insertions(+), 18 deletions(-)
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index eaf9ed3262..a137ee9483 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -1208,7 +1208,7 @@ use File::Glob qw(:case);
},
'Time::Piece' => {
- 'DISTRIBUTION' => 'ESAYM/Time-Piece-1.3204.tar.gz',
+ 'DISTRIBUTION' => 'ESAYM/Time-Piece-1.33.tar.gz',
'FILES' => q[cpan/Time-Piece],
'EXCLUDED' => [ qw[reverse_deps.txt] ],
},
diff --git a/cpan/Time-Piece/Piece.pm b/cpan/Time-Piece/Piece.pm
index 8acba86e76..d5624636c6 100644
--- a/cpan/Time-Piece/Piece.pm
+++ b/cpan/Time-Piece/Piece.pm
@@ -6,6 +6,7 @@ use XSLoader ();
use Time::Seconds;
use Carp;
use Time::Local;
+use Scalar::Util qw/ blessed /;
use Exporter ();
@@ -18,7 +19,7 @@ our %EXPORT_TAGS = (
':override' => 'internal',
);
-our $VERSION = '1.3204';
+our $VERSION = '1.33';
XSLoader::load( 'Time::Piece', $VERSION );
@@ -63,13 +64,27 @@ sub gmtime {
$class->_mktime($time, 0);
}
+
+# Check if the supplied param is either a normal array (as returned from
+# localtime in list context) or a Time::Piece-like wrapper around one.
+#
+# We need to differentiate between an array ref that we can interrogate and
+# other blessed objects (like overloaded values).
+sub _is_time_struct {
+ return 1 if ref($_[1]) eq 'ARRAY';
+ return 1 if blessed($_[1]) && $_[1]->isa('Time::Piece');
+
+ return 0;
+}
+
+
sub new {
my $class = shift;
my ($time) = @_;
my $self;
- if (ref($time)) {
+ if ($class->_is_time_struct($time)) {
$self = $time->[c_islocal] ? $class->localtime($time) : $class->gmtime($time);
}
elsif (defined($time)) {
@@ -106,10 +121,9 @@ sub parse {
sub _mktime {
my ($class, $time, $islocal) = @_;
- $class = eval { (ref $class) && (ref $class)->isa('Time::Piece') }
- ? ref $class
- : $class;
- if (ref($time)) {
+ $class = blessed($class) || $class;
+
+ if ($class->_is_time_struct($time)) {
my @new_time = @$time;
my @tm_parts = (@new_time[c_sec .. c_mon], $new_time[c_year]+1900);
$new_time[c_epoch] = $islocal ? timelocal(@tm_parts) : timegm(@tm_parts);
@@ -639,7 +653,8 @@ sub cdate {
sub str_compare {
my ($lhs, $rhs, $reverse) = @_;
- if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
+
+ if (blessed($rhs) && $rhs->isa('Time::Piece')) {
$rhs = "$rhs";
}
return $reverse ? $rhs cmp $lhs->cdate : $lhs->cdate cmp $rhs;
@@ -652,9 +667,6 @@ use overload
sub subtract {
my $time = shift;
my $rhs = shift;
- if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
- $rhs = $rhs->seconds;
- }
if (shift)
{
@@ -667,7 +679,7 @@ sub subtract {
return $rhs - "$time";
}
- if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ if (blessed($rhs) && $rhs->isa('Time::Piece')) {
return Time::Seconds->new($time->epoch - $rhs->epoch);
}
else {
@@ -679,10 +691,6 @@ sub subtract {
sub add {
my $time = shift;
my $rhs = shift;
- if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
- $rhs = $rhs->seconds;
- }
- croak "Invalid rhs of addition: $rhs" if ref($rhs);
return $time->_mktime(($time->epoch + $rhs), $time->[c_islocal]);
}
@@ -692,7 +700,7 @@ use overload
sub get_epochs {
my ($lhs, $rhs, $reverse) = @_;
- if (!UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ unless (blessed($rhs) && $rhs->isa('Time::Piece')) {
$rhs = $lhs->new($rhs);
}
if ($reverse) {
diff --git a/cpan/Time-Piece/Seconds.pm b/cpan/Time-Piece/Seconds.pm
index 3a56b74485..71a4bd27f2 100644
--- a/cpan/Time-Piece/Seconds.pm
+++ b/cpan/Time-Piece/Seconds.pm
@@ -1,7 +1,7 @@
package Time::Seconds;
use strict;
-our $VERSION = '1.3204';
+our $VERSION = '1.33';
use Exporter 5.57 'import';
diff --git a/cpan/Time-Piece/t/06subclass.t b/cpan/Time-Piece/t/06subclass.t
index d6e4315c8f..a72cfb89ac 100644
--- a/cpan/Time-Piece/t/06subclass.t
+++ b/cpan/Time-Piece/t/06subclass.t
@@ -35,6 +35,21 @@ for my $method (qw(new localtime gmtime)) {
isa_ok($diff, $class, "yesterday via subtraction operator");
}
+{
+ my $g = $class->gmtime;
+ my $l = $class->localtime;
+
+ #via clone
+ my $l_clone = $class->new($l);
+ isa_ok($l_clone, $class, 'custom localtime via clone');
+ cmp_ok("$l_clone", 'eq', "$l", 'Clones match');
+
+ #via clone with gmtime
+ my $g_clone = $class->new($g);
+ isa_ok($g_clone, $class, 'custom gmtime via clone');
+ cmp_ok("$g_clone", 'eq', "$g", 'Clones match');
+}
+
{
# let's verify that we can use gmtime from T::P without the export magic
my $piece = Time::Piece::gmtime;
--
2.19.1

57
create-libperl-soname.patch
View File

@ -1,54 +1,57 @@
From fe7ae3db489775f409b9284c5e81ce91ab8578da Mon Sep 17 00:00:00 2001 From fa2f0dd5a7767223df10149d3f16d7ed7013e16f Mon Sep 17 00:00:00 2001
From: Torsten Veller <tove@gentoo.org> From: Torsten Veller <tove@gentoo.org>
Date: Mon, 30 Dec 2019 15:10:30 +0800 Date: Sat, 14 Apr 2012 13:49:18 +0200
Subject: [PATCH] create libperl soname Subject: Set libperl soname
See details: https://bugs.gentoo.org/286840 Bug-Gentoo: https://bugs.gentoo.org/286840
Patch-Name: gentoo/create_libperl_soname.diff
--- ---
Makefile.SH | 8 +++++++- Makefile.SH | 9 +++++++--
1 file changed, 7 insertions(+), 1 deletion(-) 1 file changed, 7 insertions(+), 2 deletions(-)
diff --git a/Makefile.SH b/Makefile.SH diff --git a/Makefile.SH b/Makefile.SH
index 123903d..e73f0ec 100755 index d1da0a0..7733a32 100755
--- a/Makefile.SH --- a/Makefile.SH
+++ b/Makefile.SH +++ b/Makefile.SH
@@ -68,7 +68,7 @@ true) @@ -70,11 +70,11 @@ true)
${api_revision}.${api_version}.${api_subversion} \ ${revision}.${patchlevel}.${subversion}"
-current_version \ case "$osvers" in
${revision}.${patchlevel}.${subversion} \ 1[5-9]*|[2-9]*)
- -install_name \$(shrpdir)/\$@" - shrpldflags="$shrpldflags -install_name `pwd`/\$@ -Xlinker -headerpad_max_install_names"
+ -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib" + shrpldflags="$shrpldflags -install_name `pwd`/libperl.${revision}.${patchlevel}.dylib -Xlinker -headerpad_max_install_names"
exeldflags="-Xlinker -headerpad_max_install_names"
;;
*)
- shrpldflags="$shrpldflags -install_name \$(shrpdir)/\$@"
+ shrpldflags="$shrpldflags -install_name \$(shrpdir)/libperl.${revision}.${patchlevel}.dylib"
;;
esac
;; ;;
cygwin*) @@ -76,13 +76,15 @@ true)
shrpldflags="$shrpldflags -Wl,--out-implib=libperl.dll.a -Wl,--image-base,0x52000000"
@@ -76,13 +76,16 @@ true)
;; ;;
sunos*) sunos*)
linklibperl="-lperl" linklibperl="-lperl"
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}" + shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;; ;;
netbsd*|freebsd[234]*|openbsd*|dragonfly*|bitrig*) netbsd*|freebsd[234]*|openbsd*|dragonfly*|bitrig*)
linklibperl="-L. -lperl" linklibperl="-L. -lperl"
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}" + shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;; ;;
interix*) interix*)
linklibperl="-L. -lperl" linklibperl="-L. -lperl"
shrpldflags="$shrpldflags -Wl,--image-base,0x57000000" - shrpldflags="$shrpldflags -Wl,--image-base,0x57000000"
+ shrpldflags="$shrpldflags -Wl,--image-base,0x57000000 -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}" + shrpldflags="$shrpldflags -Wl,--image-base,0x57000000 -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
;; ;;
aix*) aix*)
case "$cc" in case "$cc" in
@@ -120,6 +123,9 @@ true) @@ -120,6 +122,9 @@ true)
linklibperl='libperl.x' linklibperl='libperl.x'
DPERL_EXTERNAL_GLOB='' DPERL_EXTERNAL_GLOB=''
;; ;;
+ linux*) + linux*)
+ shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}" + shrpldflags="$shrpldflags -Wl,-soname -Wl,libperl.so.${revision}.${patchlevel}"
+ ;; + ;;
esac esac
case "$ldlibpthname" in case "$ldlibpthname" in
'') ;; '') ;;
--
1.8.3.1

81
delete-ext-GDBM_File-t-fatal.t.patch
View File

@ -1,81 +0,0 @@
From 4f712a7338a4aa692c118460f734a2c4a6710550 Mon Sep 17 00:00:00 2001
From: openEuler Buildteam <buildteam@openeuler.org>
Date: Mon, 30 Dec 2019 15:20:40 +0800
Subject: [PATCH] delete ext GDBM_File t fatal.t
---
MANIFEST | 1 -
ext/GDBM_File/t/fatal.t | 49 -------------------------------------------------
2 files changed, 50 deletions(-)
delete mode 100644 ext/GDBM_File/t/fatal.t
diff --git a/MANIFEST b/MANIFEST
index 2005f54..f778051 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4089,7 +4089,6 @@ ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
ext/GDBM_File/Makefile.PL GDBM extension makefile writer
-ext/GDBM_File/t/fatal.t Test the fatal_func argument to gdbm_open
ext/GDBM_File/t/gdbm.t See if GDBM_File works
ext/GDBM_File/typemap GDBM extension interface types
ext/Hash-Util/Changes Change history of Hash::Util
diff --git a/ext/GDBM_File/t/fatal.t b/ext/GDBM_File/t/fatal.t
deleted file mode 100644
index 0e426d4..0000000
--- a/ext/GDBM_File/t/fatal.t
+++ /dev/null
@@ -1,49 +0,0 @@
-#!./perl -w
-use strict;
-
-use Test::More;
-use Config;
-
-BEGIN {
- plan(skip_all => "GDBM_File was not built")
- unless $Config{extensions} =~ /\bGDBM_File\b/;
-
- # https://rt.perl.org/Public/Bug/Display.html?id=117967
- plan(skip_all => "GDBM_File is flaky in $^O")
- if $^O =~ /darwin/;
-
- plan(tests => 8);
- use_ok('GDBM_File');
-}
-
-unlink <Op_dbmx*>;
-
-open my $fh, '<', $^X or die "Can't open $^X: $!";
-my $fileno = fileno $fh;
-isnt($fileno, undef, "Can find next available file descriptor");
-close $fh or die $!;
-
-is((open $fh, "<&=$fileno"), undef,
- "Check that we cannot open fileno $fileno. \$! is $!");
-
-umask(0);
-my %h;
-isa_ok(tie(%h, 'GDBM_File', 'Op_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
-
-isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno")
- or diag("\$! = $!");
-isnt(close $fh, undef,
- "close fileno $fileno, out from underneath the GDBM_File");
-is(eval {
- $h{Perl} = 'Rules';
- untie %h;
- 1;
-}, undef, 'Trapped error when attempting to write to knobbled GDBM_File');
-
-# Observed "File write error" and "lseek error" from two different systems.
-# So there might be more variants. Important part was that we trapped the error
-# via croak.
-like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/,
- 'expected error message from GDBM_File');
-
-unlink <Op_dbmx*>;
--
1.8.3.1

52
locale.c-Fix-conditional-compilation.patch
View File

@ -1,52 +0,0 @@
From 17dd77cd74f0a69332c091f816162e34abff30c5 Mon Sep 17 00:00:00 2001
From: Francois Perrad <francois.perrad@gadz.org>
Date: Mon, 2 Jul 2018 00:17:44 +0200
Subject: [PATCH] locale.c: Fix conditional compilation
With Perl 5.28.0, there are some mismatches between blocks
and conditional compilation in the Perl__is_cur_LC_category_utf8() function.
The compilation of miniperl could fails like this:
```
locale.c: In function `Perl__is_cur_LC_category_utf8`:
locale.c:5481:1: error: expected declaration or statement at end of input
}
^
```
Signed-off-by: Francois Perrad <francois.perrad@gadz.org>
---
locale.c | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/locale.c b/locale.c
index f8f77fb3d0..f2731846ad 100644
--- a/locale.c
+++ b/locale.c
@@ -4649,11 +4649,12 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
&& wc == (wchar_t) UNICODE_REPLACEMENT);
}
+# endif
+
restore_switched_locale(LC_CTYPE, original_ctype_locale);
goto finish_and_return;
}
-# endif
# else
/* Here, we must have a C89 compiler that doesn't have mbtowc(). Next
@@ -4885,9 +4886,9 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
is_utf8 = TRUE;
goto finish_and_return;
}
- }
# endif
+ }
# endif
/* Other common encodings are the ISO 8859 series, which aren't UTF-8. But
--
2.19.1

106
multiconcat-mutator-not-seen-in-lex.patch
View File

@ -1,106 +0,0 @@
From 0fe04e1dc741a43190e79a985fb0cec0493ebfe9 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Wed, 29 Aug 2018 14:32:24 +0100
Subject: [PATCH] multiconcat: mutator not seen in (lex = ...) .= ...
RT #133441
TL;DR:
(($lex = expr1.expr2) .= expr3) was being misinterpreted as
(expr1 . expr2 . expr3) when the ($lex = expr1) subtree had had the
assign op optimised away by the OPpTARGET_MY optimisation.
Full details.
S_maybe_multiconcat() looks for suitable chains of OP_CONCAT to convert
into a single OP_MULTICONCAT.
Part of the code needs to distinguish between (expr . expr) and
(expr .= expr). This didn't used to be easy, as both are just OP_CONCAT
ops, but with the OPf_STACKED set on the second one. But...
perl also used to optimise ($a . $b . $c) into ($a . $b) .= $c, to
reuse the padtmp returned by the $a.$b concat. This meant that an
OP_CONCAT could have the OPf_STACKED flag on even when it was a '.'
rather than a '.='.
I disambiguated these cases by seeing whether the top op in the LHS
expression had the OPf_MOD flag set too - if so, it implies '.='.
This fails in the specific case where the LHS expression is a
sub-expression which is assigned to a lexical variable, e.g.
($lex = $a+$b) .= $c.
Initially the top node in the LHS expression above is OP_SASSIGN, with
OPf_MOD set due to the enclosing '.='. Then the OPpTARGET_MY
optimisation kicks in, and the ($lex = $a + $b) part of the optree is
converted from
sassign sKPRMS
add[t4] sK
padsv[a$] s
padsv[$b] s
padsv[$lex] s
to
add[$lex] sK/TARGMY
padsv[a$] s
padsv[$b] s
which is all fine and dandy, except that the top node of that optree no
longer has the OPf_MOD flag set, which trips up S_maybe_multiconcat into
no longer spotting that the outer concat is a '.=' rather than a '.'.
Whether the OPpTARGET_MY optimising code should copy the OPf_MOD from
the being-removed sassign op to its successor is an issue I won't
address here. But in the meantime, the good news is that for 5.28.0
I added the OPpCONCAT_NESTED private flag, which is set whenever
($a . $b . $c) is optimised into ($a . $b) .= $c. This means that it's
no longer necessary to inspect the OPf_MOD flag of the first child to
disambiguate the two cases. So the fix is trivial.
---
op.c | 1 -
t/opbasic/concat.t | 10 +++++++++-
2 files changed, 9 insertions(+), 2 deletions(-)
diff --git a/op.c b/op.c
index ddeb484b64..d0dcffbecb 100644
--- a/op.c
+++ b/op.c
@@ -2722,7 +2722,6 @@ S_maybe_multiconcat(pTHX_ OP *o)
}
else if ( topop->op_type == OP_CONCAT
&& (topop->op_flags & OPf_STACKED)
- && (cUNOPo->op_first->op_flags & OPf_MOD)
&& (!(topop->op_private & OPpCONCAT_NESTED))
)
{
diff --git a/t/opbasic/concat.t b/t/opbasic/concat.t
index 9ce9722f5c..4b73b22c1c 100644
--- a/t/opbasic/concat.t
+++ b/t/opbasic/concat.t
@@ -39,7 +39,7 @@ sub is {
return $ok;
}
-print "1..253\n";
+print "1..254\n";
($a, $b, $c) = qw(foo bar);
@@ -853,3 +853,11 @@ package RT132595 {
my $res = $a.$t.$a.$t;
::is($res, "b1c1b1c2", "RT #132595");
}
+
+# RT #133441
+# multiconcat wasn't seeing a mutator as a mutator
+{
+ my ($a, $b) = qw(a b);
+ ($a = 'A'.$b) .= 'c';
+ is($a, "Abc", "RT #133441");
+}
--
2.19.1

56
perl-132655-nul-terminate-result-of-unpack-u-of-inva.patch
View File

@ -1,56 +0,0 @@
From 12cad9bd99725bba72029e2651b2b7f0cab2e0b0 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 20 Aug 2018 16:31:45 +1000
Subject: [PATCH] (perl #132655) nul terminate result of unpack "u" of invalid
data
In the given test case, Perl_atof2() would run off the end of the PV,
producing an error from ASAN.
---
pp_pack.c | 5 ++++-
t/op/pack.t | 9 ++++++++-
2 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/pp_pack.c b/pp_pack.c
index 5e9cc64301..f8be9d48ae 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -1727,7 +1727,10 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
if (!checksum) {
const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
sv = sv_2mortal(newSV(l));
- if (l) SvPOK_on(sv);
+ if (l) {
+ SvPOK_on(sv);
+ *SvEND(sv) = '\0';
+ }
}
/* Note that all legal uuencoded strings are ASCII printables, so
diff --git a/t/op/pack.t b/t/op/pack.t
index cf0e286509..bb9f865091 100644
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -12,7 +12,7 @@ my $no_endianness = $] > 5.009 ? '' :
my $no_signedness = $] > 5.009 ? '' :
"Signed/unsigned pack modifiers not available on this perl";
-plan tests => 14717;
+plan tests => 14718;
use strict;
use warnings qw(FATAL all);
@@ -2081,3 +2081,10 @@ SKIP:
fresh_perl_like('pack "c10f1073741824"', qr/Out of memory during pack/, { stderr => 1 },
"integer overflow calculating allocation (multiply)");
}
+
+{
+ # [perl #132655] heap-buffer-overflow READ of size 11
+ # only expect failure under ASAN (and maybe valgrind)
+ fresh_perl_is('0.0 + unpack("u", "ab")', "", { stderr => 1 },
+ "ensure unpack u of invalid data nul terminates result");
+}
--
2.19.1

74
perl-132683-don-t-try-to-convert-PL_sv_placeholder-i.patch
View File

@ -1,74 +0,0 @@
From 2460a4968c375f226973ba7e7e5fe6cf5a997ddb Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 21 Feb 2018 16:24:08 +1100
Subject: [PATCH] (perl #132683) don't try to convert PL_sv_placeholder into a
CV
Constant folding sets PL_warnhook to PERL_WARNHOOK_FATAL, which is
&PL_sv_placeholder, an undef SV.
If warn() is called while constant folding, invoke_exception_hook()
attempts to use the value of a non-NULL PL_warnhook as a CV, which
caused an undefined value warning.
invoke_exception_hook() now treats a PL_warnhook of PERL_WARNHOOK_FATAL
the same as NULL, falling back to the normal warning handling which
throws an exception to abort constant folding.
---
t/lib/warnings/util | 29 +++++++++++++++++++++++++++++
util.c | 2 +-
2 files changed, 30 insertions(+), 1 deletion(-)
diff --git a/t/lib/warnings/util b/t/lib/warnings/util
index e82d6a6617..92be6efa73 100644
--- a/t/lib/warnings/util
+++ b/t/lib/warnings/util
@@ -106,3 +106,32 @@ no warnings 'portable' ;
$a = oct "0047777777777" ;
EXPECT
Octal number > 037777777777 non-portable at - line 5.
+########
+# util.c
+# NAME 132683: Use of uninitialized value" in warn() with constant folding and overloaded numbers
+use strict;
+use warnings;
+
+package Foo;
+
+use overload log => sub {
+ warn "here\n"; # Use of uninitialized value in warn
+ CORE::log($_[0]->{value});
+};
+
+sub import {
+ overload::constant
+ integer => sub { __PACKAGE__->new($_[0]) };
+}
+
+sub new {
+ my ($class, $value) = @_;
+ bless {value => $value}, $class;
+}
+
+package main;
+
+BEGIN { Foo->import }
+my $x = log(2);
+EXPECT
+here
diff --git a/util.c b/util.c
index 37a71a1a81..ff88a54bf6 100644
--- a/util.c
+++ b/util.c
@@ -1534,7 +1534,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
/* sv_2cv might call Perl_croak() or Perl_warner() */
SV * const oldhook = *hook;
- if (!oldhook)
+ if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
return FALSE;
ENTER;
--
2.19.1

97
perl-133314-always-close-the-directory-handle-on-cle.patch
View File

@ -1,97 +0,0 @@
From 3d5e9c119db6b727684fe75dfcfe5831c4351bec Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 2 Jul 2018 10:43:19 +1000
Subject: [PATCH] (perl #133314) always close the directory handle on clean up
Previously the directory handle was only closed if the rest of the
magic free clean up is done, but in most success cases that code
doesn't run, leaking the directory handle.
So always close the directory if our AV is available.
---
doio.c | 56 +++++++++++++++++++++++++++++++-------------------------
1 file changed, 31 insertions(+), 25 deletions(-)
diff --git a/doio.c b/doio.c
index 4b8923f77c..16daf9fd11 100644
--- a/doio.c
+++ b/doio.c
@@ -1163,44 +1163,50 @@ S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
/* mg_obj can be NULL if a thread is created with the handle open, in which
case we leave any clean up to the parent thread */
- if (mg->mg_obj && IoIFP(io)) {
- SV **pid_psv;
+ if (mg->mg_obj) {
#ifdef ARGV_USE_ATFUNCTIONS
SV **dir_psv;
DIR *dir;
+
+ dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
+ assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
+ dir = INT2PTR(DIR *, SvIV(*dir_psv));
#endif
- PerlIO *iop = IoIFP(io);
+ if (IoIFP(io)) {
+ SV **pid_psv;
+ PerlIO *iop = IoIFP(io);
- assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
+ assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
- pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
+ pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
- assert(pid_psv && *pid_psv);
+ assert(pid_psv && *pid_psv);
- if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
- /* if we get here the file hasn't been closed explicitly by the
- user and hadn't been closed implicitly by nextargv(), so
- abandon the edit */
- SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
- const char *temp_pv = SvPVX(*temp_psv);
+ if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
+ /* if we get here the file hasn't been closed explicitly by the
+ user and hadn't been closed implicitly by nextargv(), so
+ abandon the edit */
+ SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
+ const char *temp_pv = SvPVX(*temp_psv);
- assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
- (void)PerlIO_close(iop);
- IoIFP(io) = IoOFP(io) = NULL;
+ assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
+ (void)PerlIO_close(iop);
+ IoIFP(io) = IoOFP(io) = NULL;
#ifdef ARGV_USE_ATFUNCTIONS
- dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
- assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
- dir = INT2PTR(DIR *, SvIV(*dir_psv));
- if (dir) {
- if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
- NotSupported(errno))
- (void)UNLINK(temp_pv);
- closedir(dir);
- }
+ if (dir) {
+ if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
+ NotSupported(errno))
+ (void)UNLINK(temp_pv);
+ }
#else
- (void)UNLINK(temp_pv);
+ (void)UNLINK(temp_pv);
#endif
+ }
}
+#ifdef ARGV_USE_ATFUNCTIONS
+ if (dir)
+ closedir(dir);
+#endif
}
return 0;
--
2.19.1

76
perl-133314-test-for-handle-leaks-from-in-place-edit.patch
View File

@ -1,76 +0,0 @@
From 028f02e7e97a6026ba9ef084c3803ea08d36aa5b Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 1 Aug 2018 11:55:22 +1000
Subject: [PATCH] (perl #133314) test for handle leaks from in-place editing
---
t/io/nargv.t | 46 +++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 45 insertions(+), 1 deletion(-)
diff --git a/t/io/nargv.t b/t/io/nargv.t
index 598ceed617..4482572aeb 100644
--- a/t/io/nargv.t
+++ b/t/io/nargv.t
@@ -6,7 +6,7 @@ BEGIN {
set_up_inc('../lib');
}
-print "1..6\n";
+print "1..7\n";
my $j = 1;
for $i ( 1,2,5,4,3 ) {
@@ -84,6 +84,50 @@ sub other {
}
}
+{
+ # (perl #133314) directory handle leak
+ #
+ # We process a significant number of files here to make sure any
+ # leaks are significant
+ @ARGV = mkfiles(1 .. 10);
+ for my $file (@ARGV) {
+ open my $f, ">", $file;
+ print $f "\n";
+ close $f;
+ }
+ local $^I = ".bak";
+ local $_;
+ while (<>) {
+ s/^/foo/;
+ }
+}
+
+{
+ # (perl #133314) directory handle leak
+ # We open three handles here because the file processing opened:
+ # - the original file
+ # - the output file, and finally
+ # - the directory
+ # so we need to open the first two to use up the slots used for the original
+ # and output files.
+ # This test assumes fd are allocated in the typical *nix way - lowest
+ # available, which I believe is the case for the Win32 CRTs too.
+ # If this turns out not to be the case this test will need to skip on
+ # such platforms or only run on a small set of known-good platforms.
+ my $tfile = mkfiles(1);
+ open my $f, "<", $tfile
+ or die "Cannot open temp: $!";
+ open my $f2, "<", $tfile
+ or die "Cannot open temp: $!";
+ open my $f3, "<", $tfile
+ or die "Cannot open temp: $!";
+ print +(fileno($f3) < 20 ? "ok" : "not ok"), " 7 check fd leak\n";
+ close $f;
+ close $f2;
+ close $f3;
+}
+
+
my @files;
sub mkfiles {
foreach (@_) {
--
2.19.1

BIN
perl-5.28.0.tar.xz → perl-5.32.0.tar.xz
View File

Binary file not shown.

28
perl.h-Add-parens-around-macro-arguments.patch
View File

@ -1,28 +0,0 @@
From ff58ca57f8442a7e2e74ab4a79a9e542f9a180e7 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Mon, 11 Jun 2018 13:26:24 -0600
Subject: [PATCH] perl.h: Add parens around macro arguments
Arguments used within macros need to be parenthesized in case they are
called with an expression. This commit changes
_CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG() to do that.
---
perl.h | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/perl.h b/perl.h
index 6f04c6facd..3e1f6cd571 100644
--- a/perl.h
+++ b/perl.h
@@ -5632,7 +5632,7 @@ typedef struct am_table_short AMTS;
# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \
STMT_START { /* Check if to warn before doing the conversion work */\
if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \
- UV cp = utf8_to_uvchr_buf((U8 *) s, (U8 *) send, NULL); \
+ UV cp = utf8_to_uvchr_buf((U8 *) (s), (U8 *) (send), NULL); \
Perl_warner(aTHX_ packWARN(WARN_LOCALE), \
"Wide character (U+%" UVXf ") in %s", \
(cp == 0) \
--
2.19.1

82
perl.spec
View File

@ -14,11 +14,15 @@
#provides module without verion, no need to provide #provides module without verion, no need to provide
%global __provides_exclude %{?__provides_exclude:%__provides_exclude|}^perl\\((charnames|DynaLoader|DB)\\)$ %global __provides_exclude %{?__provides_exclude:%__provides_exclude|}^perl\\((charnames|DynaLoader|DB)\\)$
%global perl_version 5.32.0
%global perl_compat perl(:MODULE_COMPAT_5.32.0)
Name: perl Name: perl
License: (GPL+ or Artistic) and (GPLv2+ or Artistic) and MIT and UCD and Public Domain and BSD License: (GPL+ or Artistic) and (GPLv2+ or Artistic) and MIT and UCD and Public Domain and BSD
Epoch: 4 Epoch: 4
Version: 5.28.0 Version: %{perl_version}
Release: 434 Release: 1
Summary: A highly capable, feature-rich programming language Summary: A highly capable, feature-rich programming language
Url: https://www.perl.org/ Url: https://www.perl.org/
Source0: https://www.cpan.org/src/5.0/%{name}-%{version}.tar.xz Source0: https://www.cpan.org/src/5.0/%{name}-%{version}.tar.xz
@ -26,53 +30,17 @@ Source0: https://www.cpan.org/src/5.0/%{name}-%{version}.tar.xz
# PATCH-FEATURE-OPENEULER # PATCH-FEATURE-OPENEULER
Patch1: change-lib-to-lib64.patch Patch1: change-lib-to-lib64.patch
# PATCH-FEATURE-OPENEULER # PATCH-FEATURE-OPENEULER
Patch3: disable-rpath-by-default.patch Patch2: disable-rpath-by-default.patch
# PATCH-FIX-OPENEULER # PATCH-FIX-OPENEULER
Patch5: create-libperl-soname.patch Patch3: create-libperl-soname.patch
# PATCH-FIX-OPENEULER--rh#1107543, RT#61912 # PATCH-FIX-OPENEULER--rh#1107543, RT#61912
Patch8: perl-5.18.2-Destroy-GDBM-NDBM-ODBM-SDBM-_File-objects-only-from-.patch Patch4: perl-5.18.2-Destroy-GDBM-NDBM-ODBM-SDBM-_File-objects-only-from-.patch
# PATCH-FIX-OPENEULER--RT#133295
Patch12: delete-ext-GDBM_File-t-fatal.t.patch
# PATCH-FIX-UPSTREAM--RT#133204, upstream 5.29.0
Patch13: Perl_my_setenv-handle-integer-wrap.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.0
Patch14: regexec.c-Call-macro-with-correct-args.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.0
Patch15: perl.h-Add-parens-around-macro-arguments.patch
# PATCH-FIX-UPSTREAM--RT#133368, upstream 5.29.0
Patch16: treat-when-index-1-as-a-boolean-expression.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.0
Patch17: locale.c-Fix-conditional-compilation.patch
# PATCH-FIX-UPSTREAM--RT#133314, upstream 5.29.1
Patch18: perl-133314-test-for-handle-leaks-from-in-place-edit.patch
Patch19: perl-133314-always-close-the-directory-handle-on-cle.patch
# PATCH-FIX-UPSTREAM--Fix buffer overrun, upstream 5.29.1
Patch20: utf8.c-Make-safer-a-deprecated-function.patch
# PATCH-FIX-UPSTREAM--Fix time race, upstream 5.29.1
Patch21: Time-HiRes-t-itimer.t-avoid-race-condition.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.1
Patch22: Fix-script-run-bug-1-followed-by-Thai-digit.patch
# PATCH-FIX-UPSTREAM-- upstream 5.29.1
Patch23: Update-Time-Piece-to-CPAN-version-1.33.patch
# PATCH-FIX-UPSTREAM-- RT#133441, upstream 5.29.2
Patch24: multiconcat-mutator-not-seen-in-lex.patch
# PATCH-FIX-UPSTREAM-- RT#132683, upstream 5.29.2
Patch25: perl-132683-don-t-try-to-convert-PL_sv_placeholder-i.patch
# PATCH-FIX-UPSTREAM-- RT#132655, upstream 5.29.2
Patch26: perl-132655-nul-terminate-result-of-unpack-u-of-inva.patch
# PATCH-FIX-OPENEULER
# In 2020, a year of 70 starts to mean 2070. So cpan/Time-Local/t/Local.t test
Patch27: Fix-time-local-tests-in-2020.patch
Patch6000: CVE-2018-18312-1.patch
Patch6001: CVE-2018-18312-2.patch
Patch6002: CVE-2018-18312-3.patch
BuildRequires: gcc bash findutils coreutils make tar procps bzip2-devel gdbm-devel BuildRequires: gcc bash findutils coreutils make tar procps bzip2-devel gdbm-devel
BuildRequires: zlib-devel systemtap-sdt-devel perl-interpreter perl-generators gdb BuildRequires: zlib-devel systemtap-sdt-devel perl-interpreter perl-generators gdb
Requires: perl-libs = %{epoch}:%{version}-%{release} Requires: perl-libs = %{epoch}:%{version}-%{release}
Requires: perl(:MODULE_COMPAT_5.28.0) perl-version perl-threads perl-threads-shared perl-parent Requires: perl-version perl-threads perl-threads-shared perl-parent
Requires: perl-devel = %{epoch}:%{version}-%{release} system-rpm-config Requires: perl-devel = %{epoch}:%{version}-%{release} system-rpm-config
Requires: perl-Unicode-Collate perl-Unicode-Normalize perl-Time-Local perl-Time-HiRes Requires: perl-Unicode-Collate perl-Unicode-Normalize perl-Time-Local perl-Time-HiRes
Requires: perl-Thread-Queue perl-Text-Tabs+Wrap perl-Test-Simple perl-Test-Harness perl-devel Requires: perl-Thread-Queue perl-Text-Tabs+Wrap perl-Test-Simple perl-Test-Harness perl-devel
@ -94,9 +62,9 @@ Requires: perl-Module-Metadata perl-Sys-Syslog perl-PerlIO-via-QuotedPrint
Provides: perl-Attribute-Handlers perl-interpreter perl(bytes_heavy.pl) perl(dumpvar.pl) perl(perl5db.pl) Provides: perl-Attribute-Handlers perl-interpreter perl(bytes_heavy.pl) perl(dumpvar.pl) perl(perl5db.pl)
Provides: perl-ExtUtils-Embed perl-ExtUtils-Miniperl perl-IO perl-IO-Zlib perl-Locale-Maketext-Simple perl-Math-Complex Provides: perl-ExtUtils-Embed perl-ExtUtils-Miniperl perl-IO perl-IO-Zlib perl-Locale-Maketext-Simple perl-Math-Complex
Provides: perl-Module-Loaded perl-Net-Ping perl-Pod-Html perl-SelfLoader perl-Test perl-Time-Piece perl-libnetcfg perl-open perl-utils Provides: perl-Module-Loaded perl-Net-Ping perl-Pod-Html perl-SelfLoader perl-Test perl-Time-Piece perl-libnetcfg perl-open perl-utils
Provides: perl-Errno perl-macros perl-Memoize Provides: perl-Errno perl-Memoize
Obsoletes: perl-Attribute-Handlers perl-interpreter perl-macros perl-Errno perl-ExtUtils-Embed perl-Net-Ping Obsoletes: perl-Attribute-Handlers perl-interpreter perl-Errno perl-ExtUtils-Embed perl-Net-Ping
Obsoletes: perl-ExtUtils-Miniperl perl-IO perl-IO-Zlib perl-Locale-Maketext-Simple perl-Math-Complex perl-Memoize perl-Module-Loaded Obsoletes: perl-ExtUtils-Miniperl perl-IO perl-IO-Zlib perl-Locale-Maketext-Simple perl-Math-Complex perl-Memoize perl-Module-Loaded
Obsoletes: perl-Pod-Html perl-SelfLoader perl-Test perl-Time-Piece perl-libnetcfg perl-open perl-utils Obsoletes: perl-Pod-Html perl-SelfLoader perl-Test perl-Time-Piece perl-libnetcfg perl-open perl-utils
@ -110,6 +78,8 @@ prototyping and large scale development projects.
Summary: The libraries for the perl Summary: The libraries for the perl
License: (GPL+ or Artistic) and HSRL and MIT and UCD License: (GPL+ or Artistic) and HSRL and MIT and UCD
Provides: perl(:MODULE_COMPAT_5.28.0) perl(:VERSION) = 5.28.0 Provides: perl(:MODULE_COMPAT_5.28.0) perl(:VERSION) = 5.28.0
Provides: %perl_compat
Provides: perl(:VERSION) = %{perl_version} libperl.so.5.28()(64bit)
Provides: perl(:WITH_64BIT) perl(:WITH_ITHREADS) perl(:WITH_THREADS) Provides: perl(:WITH_64BIT) perl(:WITH_ITHREADS) perl(:WITH_THREADS)
Provides: perl(:WITH_LARGEFILES) perl(:WITH_PERLIO) perl(unicore::Name) Provides: perl(:WITH_LARGEFILES) perl(:WITH_PERLIO) perl(unicore::Name)
Provides: perl(utf8_heavy.pl) Provides: perl(utf8_heavy.pl)
@ -135,7 +105,9 @@ This package contains the development files and test files for %{name}.
%package_help %package_help
%prep %prep
%autosetup -n %{name}-%{version} -p1 %autosetup -n %{name}-%{perl_version} -p1
%global perl_abi %(echo '%{perl_version}' | sed 's/^\\([^.]*\\.[^.]*\\).*/\\1/')
echo %{perl_abi}
# Configure Compress::Zlib to use system zlib # Configure Compress::Zlib to use system zlib
sed -i 's|BUILD_ZLIB = True|BUILD_ZLIB = False| sed -i 's|BUILD_ZLIB = True|BUILD_ZLIB = False|
@ -154,8 +126,8 @@ sed -i '/\(bzip2\|zlib\)-src/d' MANIFEST
-DDEBUGGING=-g -Dversion=%{version} -Dmyhostname=localhost \ -DDEBUGGING=-g -Dversion=%{version} -Dmyhostname=localhost \
-Dperladmin=root@localhost -Dcc='%{__cc}' -Dprefix=%{_prefix} \ -Dperladmin=root@localhost -Dcc='%{__cc}' -Dprefix=%{_prefix} \
-Dvendorprefix=%{_prefix} -Dsiteprefix=%{_prefix}/local \ -Dvendorprefix=%{_prefix} -Dsiteprefix=%{_prefix}/local \
-Dsitelib="%{_prefix}/local/share/perl5" -Dprivlib="%{perl_datadir}" \ -Dsitelib="%{_prefix}/local/share/perl5/%{perl_abi}" -Dprivlib="%{perl_datadir}" \
-Dsitearch="%{_prefix}/local/%{_lib}/perl5" \ -Dsitearch="%{_prefix}/local/%{_lib}/perl5/%{perl_abi}" \
-Dvendorlib="%{perl_vendor_datadir}" -Darchlib="%{perl_libdir}" \ -Dvendorlib="%{perl_vendor_datadir}" -Darchlib="%{perl_libdir}" \
-Dvendorarch="%{perl_vendor_libdir}" -Darchname="%{_arch}-%{_os}-thread-multi" \ -Dvendorarch="%{perl_vendor_libdir}" -Darchname="%{_arch}-%{_os}-thread-multi" \
-Dlibpth="/usr/local/lib64 /lib64 %{_prefix}/lib64" \ -Dlibpth="/usr/local/lib64 /lib64 %{_prefix}/lib64" \
@ -173,7 +145,7 @@ BZIP2_LIB=%{_libdir}
export BUILD_BZIP2 BZIP2_LIB export BUILD_BZIP2 BZIP2_LIB
# for new perl can be executed from make. # for new perl can be executed from make.
%global soname libperl.so.%(echo '%{version}' | sed 's/^\\([^.]*\\.[^.]*\\).*/\\1/') %global soname libperl.so.%{perl_abi}
test -L %{soname} || ln -s libperl.so %{soname} test -L %{soname} || ln -s libperl.so %{soname}
make %{?_smp_mflags} make %{?_smp_mflags}
@ -191,7 +163,7 @@ rm -f "%{buildroot}%{perl_libdir}/CORE/%{soname}"
install -p -m 755 utils/pl2pm %{buildroot}%{_bindir}/pl2pm install -p -m 755 utils/pl2pm %{buildroot}%{_bindir}/pl2pm
for h_file in asm/termios.h syscall.h syslimits.h syslog.h sys/ioctl.h sys/socket.h sys/time.h wait.h for h_file in sys/ioctl.h sys/syscall.h syscall.h
do do
%{perl_new} %{buildroot}%{_bindir}/h2ph -a -d %{buildroot}%{perl_libdir} $h_file || true %{perl_new} %{buildroot}%{_bindir}/h2ph -a -d %{buildroot}%{perl_libdir} $h_file || true
done done
@ -221,7 +193,7 @@ done
# fix shell bangs in tests. # fix shell bangs in tests.
%{perl_new} -MConfig -i -pn \ %{perl_new} -MConfig -i -pn \
-e 's"\A#!(?:perl|\./perl|/usr/bin/perl|/usr/bin/env perl)\b"$Config{startperl}"' \ -e 's"\A#!(?:perl|\./perl|/perl|/usr/bin/perl|/usr/bin/env perl)\b"$Config{startperl}"' \
$(find %{buildroot}%{_libexecdir}/perl5-tests/perl-tests -type f) $(find %{buildroot}%{_libexecdir}/perl5-tests/perl-tests -type f)
%check %check
@ -237,7 +209,7 @@ make test_harness
%files %files
# there are many files do not need to be packaged # there are many files do not need to be packaged
# in this main package # in this main package
%exclude %{_bindir}/{h2xs,perlivp,corelist,prove,cpan,enc2xs} %exclude %{_bindir}/{h2xs,perlivp,corelist,prove,cpan,enc2xs,streamzip}
%exclude %{_bindir}/{ptar,ptargrep,ptardiff,shasum,json_pp} %exclude %{_bindir}/{ptar,ptargrep,ptardiff,shasum,json_pp}
%exclude %{_bindir}/{encguess,piconv,instmodsh,xsubpp,pod2text} %exclude %{_bindir}/{encguess,piconv,instmodsh,xsubpp,pod2text}
%exclude %{_bindir}/{podchecker,podselect,perldoc,pod2usage,pod2man} %exclude %{_bindir}/{podchecker,podselect,perldoc,pod2usage,pod2man}
@ -475,7 +447,7 @@ make test_harness
# there are many man docs don not need to be packaged # there are many man docs don not need to be packaged
%exclude %{_mandir}/man1/{ptar.1*,ptardiff.1*,ptargrep.1*,cpan.1*,shasum.1*,perlfilter.*} %exclude %{_mandir}/man1/{ptar.1*,ptardiff.1*,ptargrep.1*,cpan.1*,shasum.1*,perlfilter.*}
%exclude %{_mandir}/man1/{encguess.1*,piconv.1*,enc2xs.1*,instmodsh.1*,xsubpp*,podchecker.*} %exclude %{_mandir}/man1/{encguess.1*,piconv.1*,enc2xs.1*,instmodsh.1*,xsubpp*,podchecker.*}
%exclude %{_mandir}/man1/{zipdetails.*,json_pp.1*,corelist*,perlfaq*,perlglossary.*} %exclude %{_mandir}/man1/{zipdetails.*,json_pp.1*,corelist*,perlfaq*,perlglossary.*,streamzip.*}
%exclude %{_mandir}/man1/{podselect.1*,perldoc.1*,pod2usage.*,pod2man.1*,pod2text.1*} %exclude %{_mandir}/man1/{podselect.1*,perldoc.1*,pod2usage.*,pod2man.1*,pod2text.1*}
%exclude %{_mandir}/man1/{perlpodstyle.1*,prove.1*} %exclude %{_mandir}/man1/{perlpodstyle.1*,prove.1*}
%exclude %{_mandir}/man3/{Archive::Tar*,autodie*,Fatal.3*,B::Debug.3*,Pod::Find.*} %exclude %{_mandir}/man3/{Archive::Tar*,autodie*,Fatal.3*,B::Debug.3*,Pod::Find.*}
@ -511,6 +483,12 @@ make test_harness
%{_mandir}/man3/* %{_mandir}/man3/*
%changelog %changelog
* Thu Aug 13 2020 openEuler Buildteam <buildteam@openeuler.org> - 4:5.32.0-1
- Type:enhancement
- ID:NA
- SUG:NA
- DESC:bump version to 5.32.0
* Sat Mar 21 2020 openEuler Buildteam <buildteam@openeuler.org> - 4:5.28.0-434 * Sat Mar 21 2020 openEuler Buildteam <buildteam@openeuler.org> - 4:5.28.0-434
- Type:NA - Type:NA
- ID:NA - ID:NA

27
regexec.c-Call-macro-with-correct-args.patch
View File

@ -1,27 +0,0 @@
From e1a2878a55b1a7f11f19b384c4ea5235c29866b2 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Mon, 11 Jun 2018 13:28:53 -0600
Subject: [PATCH] regexec.c: Call macro with correct args.
The second argument to this macro is a pointer to the end, as opposed to
a length.
---
regexec.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/regexec.c b/regexec.c
index 7ed8f4fabc..ba52ae97c7 100644
--- a/regexec.c
+++ b/regexec.c
@@ -1808,7 +1808,7 @@ STMT_START {
case trie_flu8: \
_CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
if (UTF8_IS_ABOVE_LATIN1(*uc)) { \
- _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end - uc); \
+ _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end); \
} \
goto do_trie_utf8_fold; \
case trie_utf8_exactfa_fold: \
--
2.19.1

98
treat-when-index-1-as-a-boolean-expression.patch
View File

@ -1,98 +0,0 @@
From 6b877bbd2c071b3e0659fab552a74dc2ff7e08fb Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Sat, 14 Jul 2018 10:47:04 +0100
Subject: [PATCH] treat when(index() > -1) as a boolean expression
RT #133368
when(X) is normally compiled as when($_ ~~ X) *except* when X appears to
be a boolean expression, in which case it's used directly.
5.28.0 introduced an optimisation whereby comparisons involving index
like
index(...) != -1
eliminated the comparison, and pp_index() returned a boolean value
directly. This defeated the 'look for a boolean op' mechanism, and so
when(index(...) != -1)
and similar were being incorrectly compiled as
when($_ ~~ (index(...) != -1))
---
op.c | 8 +++++++-
t/op/switch.t | 23 ++++++++++++++++++++++-
2 files changed, 29 insertions(+), 2 deletions(-)
diff --git a/op.c b/op.c
index a05a1319d4..ddeb484b64 100644
--- a/op.c
+++ b/op.c
@@ -9072,6 +9072,13 @@ S_looks_like_bool(pTHX_ const OP *o)
case OP_FLOP:
return TRUE;
+
+ case OP_INDEX:
+ case OP_RINDEX:
+ /* optimised-away (index() != -1) or similar comparison */
+ if (o->op_private & OPpTRUEBOOL)
+ return TRUE;
+ return FALSE;
case OP_CONST:
/* Detect comparisons that have been optimized away */
@@ -9081,7 +9088,6 @@ S_looks_like_bool(pTHX_ const OP *o)
return TRUE;
else
return FALSE;
-
/* FALLTHROUGH */
default:
return FALSE;
diff --git a/t/op/switch.t b/t/op/switch.t
index e5385df0b4..6ff69e0bce 100644
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -10,7 +10,7 @@ use strict;
use warnings;
no warnings 'experimental::smartmatch';
-plan tests => 195;
+plan tests => 197;
# The behaviour of the feature pragma should be tested by lib/feature.t
# using the tests in t/lib/feature/*. This file tests the behaviour of
@@ -1358,6 +1358,27 @@ given("xyz") {
"scalar value of false when";
}
+# RT #133368
+# index() and rindex() comparisons such as '> -1' are optimised away. Make
+# sure that they're still treated as a direct boolean expression rather
+# than when(X) being implicitly converted to when($_ ~~ X)
+
+{
+ my $s = "abc";
+ my $ok = 0;
+ given("xyz") {
+ when (index($s, 'a') > -1) { $ok = 1; }
+ }
+ ok($ok, "RT #133368 index");
+
+ $ok = 0;
+ given("xyz") {
+ when (rindex($s, 'a') > -1) { $ok = 1; }
+ }
+ ok($ok, "RT #133368 rindex");
+}
+
+
# Okay, that'll do for now. The intricacies of the smartmatch
# semantics are tested in t/op/smartmatch.t. Taintedness of
# returned values is checked in t/op/taint.t.
--
2.19.1

44
utf8.c-Make-safer-a-deprecated-function.patch
View File

@ -1,44 +0,0 @@
From 016c8ffcc6c9d41d145035ef5df607568880e3b3 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Tue, 24 Jul 2018 17:20:08 -0600
Subject: [PATCH] utf8.c: Make safer a deprecated function
This function is only called from deprecated functions, but they may be
moved to ppport.h. It is lacking a length parameter, so malformed UTF-8
may cause it to read beyond the buffer. This commit causes it to not
read beyond a NUL character, which makes it safe for the common case
that the input is a C string.
---
utf8.c | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/utf8.c b/utf8.c
index 8471fb8093..3062f58338 100644
--- a/utf8.c
+++ b/utf8.c
@@ -3100,7 +3100,9 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
* Note that it is assumed that the buffer length of <p> is enough to
* contain all the bytes that comprise the character. Thus, <*p> should
* have been checked before this call for mal-formedness enough to assure
- * that. */
+ * that. This function, does make sure to not look past any NUL, so it is
+ * safe to use on C, NUL-terminated, strings */
+ STRLEN len = my_strnlen((char *) p, UTF8SKIP(p));
PERL_ARGS_ASSERT_IS_UTF8_COMMON;
@@ -3109,9 +3111,8 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
* as far as there being enough bytes available in it to accommodate the
* character without reading beyond the end, and pass that number on to the
* validating routine */
- if (! isUTF8_CHAR(p, p + UTF8SKIP(p))) {
- _force_out_malformed_utf8_message(p, p + UTF8SKIP(p),
- _UTF8_NO_CONFIDENCE_IN_CURLEN,
+ if (! isUTF8_CHAR(p, p + len)) {
+ _force_out_malformed_utf8_message(p, p + len, _UTF8_NO_CONFIDENCE_IN_CURLEN,
1 /* Die */ );
NOT_REACHED; /* NOTREACHED */
}
--
2.19.1