In perl.git, the branch maint-5.24 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/13a293bb99c3c20bcedfb906dadb75543bf0a455?hp=b94bb58ebced3c5efc16addcc8f60c26ffd5cccb>
- Log ----------------------------------------------------------------- commit 13a293bb99c3c20bcedfb906dadb75543bf0a455 Author: David Mitchell <[email protected]> Date: Wed Feb 15 15:58:24 2017 +0000 avoid a leak in list assign from/to magic values RT #130766 A leak in list assignment was introduced by v5.23.6-89-gbeb08a1 and extended with v5.23.6-90-g5c1db56. Basically the code in S_aassign_copy_common() which does a mark-and-sweep looking for common vars by temporarily setting SVf_BREAK on LHS SVs then seeing if that flag was present on RHS vars, very temporarily removed that flag from the RHS SV while mortal copying it, then set it again. After those two commits, the "resetting" code could set SVf_BREAK on the RHS SV even when it hadn't been been present earlier. This meant that on exit from S_aassign_copy_common(), some SVs could be left with SVf_BREAK on. When that SV was freed, the SVf_BREAK flag meant that the SV head wasn't planted back in the arena (but PL_sv_count was still decremented). This could lead to slow growth of the SV HEAD arenas. The two circumstances that could trigger the leak were: 1) An SMG var on the LHS and a temporary on the RHS, e.g. use Tie::Scalar; my ($s, $t); tie $s, 'Tie::StdScalar'; # $s has set magic while (1) { ($s, $t) = ($t, map 1, 1, 2); # the map returns temporaries } 2) A temporary on the RHS which has GMG, e.g. my $s = "abc"; pos($s) = 1; local our ($x, $y); while (1) { my $pr = \pos($s); # creates a ref to a TEMP with get magic ($x, $y) = (1, $$pr); } Strictly speaking a TEMP isn't required for either case; just a situation where there's always a fresh SV on the RHS for each iteration that will soon get freed and thus leaked. This commit doesn't include any tests since I can't think of a way of testing it. svleak.t relies on PL_sv_count, which in this case doesn't show the leak. (cherry picked from commit 1050723fecc0e27677c39fadbb97cb892dfd27d2) M pp_hot.c commit 3e7de924526c40efdec87aeddf020b93041cb9d3 Author: Steven Humphrey <[email protected]> Date: Tue Sep 20 12:42:39 2016 +0100 Fix typo in perlrun.pod s/and/any/ perl -c documentation has a typo when talking about BEGIN blocks. Steven Humphrey is now a Perl author. For: RT #129313 (cherry picked from commit 2c4188f3fe3f46d4ebe3f23a094a7cf96ebe87f1) M AUTHORS M pod/perlrun.pod commit 49cc7193dce17db7dda6d396ee6a4ab22fb6a394 Author: Dave Cross <[email protected]> Date: Thu Sep 1 18:29:58 2016 -0400 Correct 'map' documentation to reflect operation on a list. Rather than on an array. For: RT #126169. Dave Cross is now a Perl Author. (cherry picked from commit 7c280bee056f2462f4b4aa2150a160fb9176601e) M AUTHORS M pod/perlfunc.pod commit 5f869718f8d9635142117ca99bbdfd46eda51e16 Author: James E Keenan <[email protected]> Date: Thu Sep 1 14:39:16 2016 -0400 Provide missing link for one instance of 'eval'. As originally reported by KES. See RT #129168. (cherry picked from commit 177f0db9b219c09ca9541c325f9309b8cca12ac4) M pod/perlfunc.pod commit ccd4868dabb84eee89314a23aca4e3064a290894 Author: Karl Williamson <[email protected]> Date: Fri Jul 28 08:30:32 2017 +0100 PATCH: [perl #129122] regex sets syntax error This was caused by two statements being in the wrong order. One should save something on the stack before changing it, not after. However fixing this led to the discovery of another bug in which an error case was failed to be detected. (cherry picked from commit c333712c4a550eeb3146b964d8508f772e294a49) M regcomp.c M t/re/reg_mesg.t M t/re/regex_sets.t commit 9873846f2684da0dd9a561af401157c290668234 Author: Jarkko Hietaniemi <[email protected]> Date: Tue Aug 16 19:06:31 2016 -0400 Revert "Check against negative uid/gid for fchown()." This reverts commit f95ba548a286b17c260cc168715a9d0d441b14a6. [rt.perl.org #128967] The negative arguments to fchown depend on the platform, so Coverity should not claim it knows what is acceptable. (cherry picked from commit dd1dbff095629118e73a48a2a6008f03418a07f6) M doio.c commit 45f3eff978e2858a6175daeb8ec7cb5ed8c5a954 Author: Father Chrysostomos <[email protected]> Date: Mon Aug 15 18:09:17 2016 -0700 [perl #126482] Fix assert fail âa_const a_constâ Mentioning a constant twice in a row results in an assertion failure: $ ./miniperl -e 'sub ub(){0} ub ub' Assertion failed: (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM), function Perl_cv_const_sv_or_av, file op.c, line 7926. Abort trap: 6 A bisect points to 2eaf799e7, but I donât understand why that commit introduced it. I suspect it was failing an assertion for a slightly different reason back then, but am too lazy to check. In any case, it fails now because, while âub ubâ is being compiled, when the sub is looked up initially (in toke.c:yylex), we call rv2cv_op_cv with the RV2GVOPCV_RETURN_STUB flag, which allows a bare constant ref to be returned. So the âcvâ variable contains an RV (\0): cv = lex ? isGV(gv) ? GvCV(gv) : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV ? (CV *)SvRV(gv) : ((CV *)gv) : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB); (âubâ here is a constant 0, which is stored in the symbol table as \0; i.e., âsub ub(){0}â is equivalent to âBEGIN { $::{ub} = \0 }â.) Then if we see a word immediately following it (the second âubâ) we check a little further down to see whether it might be a method call. That entails calling intuit_method, which does this: indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); if (indirgv && GvCVu(indirgv)) return 0; So we are looking to see whether the second word refers to a sub and deciding this is not an indirect method call if there is a sub. But calling gv_fetchpvn_flags like that has the effect of upgrading the symbol table entry to a full GV. Since the âcvâ variable in yylex points to that symbol table entry, it ends up pointing to a GV, which certain code later on does not expect to happen. So we should pass the GV_NOADD_NOINIT flag to gv_fetchpvn_flags to prevent lookup of the second bareword from upgrading the entry (we already do that earlier in intuit_method for the first bareword). We only check the GV to see whether it has a sub or io thingy in it any- way, so we donât actually need a full GV. (As a bonus, GvIO will already work on a non-GV and return NULL, so that part of the code remains unchanged.) (cherry picked from commit c82de78e3ba0184f85b5b49245e5da32d1cb3fcc) M t/op/method.t M toke.c commit 395aac6865f58827454238b1d3028a6f45b3b16a Author: Karl Williamson <[email protected]> Date: Sun Aug 14 09:59:11 2016 -0600 locale.c: Add missing '{' Spotted by bulk88, http://nntp.perl.org/group/perl.perl5.porters/238968 (cherry picked from commit 9f42613cff9529b84706745e7fee949fab7b9613) M locale.c commit 4c5c6c64c26b2af7953be76e2867fb2552ae6476 Author: Karl Williamson <[email protected]> Date: Mon Aug 8 10:03:32 2016 -0600 perlop: Fix important typo The text is saying don't mix case, and this typo was mixing case. (cherry picked from commit 8df98a270ad3d8791a954ebf97837b721b1c144a) M pod/perlop.pod commit 73e050e181031ca148ec5a48377c19e1fe8443bf Author: Father Chrysostomos <[email protected]> Date: Sun Jul 31 19:21:02 2016 -0700 [perl #128740] Check for null in pp_ghostent et al. Specifically in the S_space_join_names_mortal static function that several pp functions call. On some platforms (such as Gentoo Linux with torsocks), hent->h_aliases (where hent is a struct hostent *) may be null after a gethostent call. (cherry picked from commit d35c1b5e43e773f353239d9182ddccb41cdab3d6) M embed.fnc M pp_sys.c M proto.h commit 7e4f1950d493828a9ccdb25842eeed1823e71df8 Author: Karl Williamson <[email protected]> Date: Fri Jul 28 08:26:35 2017 +0100 PATCH: [perl #128734] tr/\N{...}/ failing for 128-255 The upper latin1 characters when expressed as \N{U+...} were failing. This was due to trying to convert them to UTF-8 when the result isn't UTF-8. I added a test for \N{name} as well, though these were not affected by this regression. (cherry picked from commit 3a34ca0bce7835211b45e070373cf653c253636a) M t/op/tr.t M toke.c commit c00934b73e0572477646e79eb4ff017452ae9d8e Author: David Mitchell <[email protected]> Date: Sun Jul 17 20:13:08 2016 +0100 fix build on clang plus -DPERL_GLOBAL_STRUCT The various PERL_TSA_* macros that utilise clang Thread Safety Analysis were failing on -DPERL_GLOBAL_STRUCT and -DPERL_GLOBAL_STRUCT_PRIVATE builds, due to lines like these: Perl_op_refcnt_lock(pTHX) PERL_TSA_ACQUIRE(PL_op_mutex) { ... } where under DPERL_GLOBAL_STRUCT globals vars aren't really global, so you can't pass PL_op_mutex as an arg to that function attribute. The simplest fix (since you can't just bung a dVAR in there) is to just disable TSA on PERL_GLOBAL_STRUCT builds. (cherry picked from commit ab0fe36e478f78846a1944a3e22e9cd26260c042) M perl.h commit 388afd1ceab1b90992954969d6b7d9ef0f210351 Author: Karl Williamson <[email protected]> Date: Fri Jul 28 08:24:41 2017 +0100 PATCH: [perl #128170] Assert fail in regcomp.c This fixes a regression in 5.24, bisected to commit commit cfbef7dc3bfb89e4ed2c00ea9c9e3bcfd0b170fd Author: Karl Williamson <[email protected]> Date: Wed Feb 10 16:27:13 2016 -0700 regcomp.c: Fix some parsing glitches (cherry picked from commit f2e32b2c677945ce6a36531a7cd5696dc1ca2cef) M regcomp.c M t/re/reg_mesg.t commit 54b1580f1e66d830eb0c466cd749dc1e29e25931 Author: Yves Orton <[email protected]> Date: Fri Jul 28 08:21:47 2017 +0100 [perl #128313] Fix leak in perl 5.24 with strict and regex posix char classes move warning text to RExC_state (via RExC_warn_text) This way we reuse the same AV each time, and avoid various refcount bookkeeping issues, all at a relatively modest cost (IMO) This patch is the result of detective work and inital patches by Dan Collins with additional coding to take advantage of the regexp engine internals by Yves Orton after feedback from Karl Williams. It is a squash of the following commits in blead: 222c4b0094b4145d06cb164bedd2a66a3141203b [perl #128313] test for memory leak in POSIX classes 0bf54b1ecaec8f6d80845d6cb77d62f8c9f4c415 fixup, guard av_top_index() for null RExC_warn_text 7eec73eb790f7c4982edfc28c17c011e8a072490 move warning text to RExC_state (via RExC_warn_text) ee072c898947f5fee316f1381b29ad692addcf05 [perl #128313] Fix leak in perl 5.24 with strict and regex posix char classes (cherry picked from commit dfd347fdcdbaf5a157586b05825005dc352b0e83) M regcomp.c M t/op/svleak.t commit 7ac00b6c199c704437d5f11445b1fbb2548ebca8 Author: Tony Cook <[email protected]> Date: Mon Apr 11 13:55:45 2016 +1000 make Configure abort if both -Duselongdouble and -Dusequadmath are requested See [perl #126203] (cherry picked from commit a2c061044c1e87ae8e777d6134191760235db0de) M Configure commit c053c1e495d2f2216ffdf92e6f5eb93ccb6e1ae7 Author: H.Merijn Brand <[email protected]> Date: Tue Jul 5 18:49:29 2016 +0200 [perl #128538] [PATCH] Fix copy/paste error in Configure Self-explanatory. The code in question adds -quadmath to archname, but only if it isn't already there. However, since this was copied from a few lines earlier, it checks for -ld instead of -quadmath. (cherry picked from commit d06c8f869698f7905df974ab8bafb703a5438fc1) M Configure commit be0ada6e96e67ddb6d3a8d150d05a501380bc2fe Author: Father Chrysostomos <[email protected]> Date: Sat Jul 2 00:08:48 2016 -0700 [perl #128508] Fix line numbers with perl -x When lex_start is invoked with an SV and a handle pointer, it expects the SV to contain the beginning of the code to be parsed. The handle will be read from for subsequent code. The -x command line option happens to invoke lex_start with two non- null pointers like this (a line and a handle), since, to find the #!perl line, it has to read that first line out of the file handle. There is a line of code in lex_start that adds "\n;" to the buffer goes back to 8990e30710 (perl 5.0 alpha 6) and string eval fails catastrophically without it. As of v5.19.1-485-g2179133 multiple lines are supported in the current parsing buffer (PL_linestr) when there is a file handle, and as of v5.19.3-63-gbf1b738 the line number is correctly incremented when the parser goes past a newline. So, for -x, "#!perl\n" turns into "#!perl\n\n" (the final ; is skipped as of v5.19.3-63-gbf1b738 if there is a handle). That throws line numbers off by one. In the case where we have a string to parse and a file handle, the extra "\n;" added to the end of the buffer turns out to be completely unnecessary. So this commit makes it conditional on rsfp. The existing tests for -x are quite exotic. I have made no effort to make them less so. (cherry picked from commit b3dd0aba3d2bf0b22280303ef6f068e976e31888) M t/run/switchx.aux M t/run/switchx.t M toke.c commit f2a117f170b84389d99a29cbff52b61fd2f36f69 Author: Father Chrysostomos <[email protected]> Date: Sun Jun 26 10:57:26 2016 -0700 perlunicode typo (cherry picked from commit c55dd03d1d6eb39244430d1cf2e0e94240d2b37a) M pod/perlunicode.pod commit 2bc753e48f6883cdeea350f9a5df1615ff80b958 Author: Karl Williamson <[email protected]> Date: Sat Jun 25 22:37:21 2016 -0600 perlunicode: Fix mistatement v5.24 reinstated the ability to compile any earlier version of the Unicode standard into Perl, but this pod did not get updated. (cherry picked from commit d2b457d752c03448e8006f00a3761b5f542000d6) M pod/perlunicode.pod commit 92337d93eaa52fc4eb8ea52b4fc206db597c029d Author: Tony Cook <[email protected]> Date: Thu Jun 16 14:08:18 2016 +1000 (perl #128316) preserve errno from failed system calls (cherry picked from commit 3f6b66c14467c0f8c7459e32c576618155ca89f3) M pp_sys.c M t/io/socket.t commit 6035f919de13f70b44763ca492202f747d2c2758 Author: Father Chrysostomos <[email protected]> Date: Fri Jul 28 08:13:06 2017 +0100 [perl #128182] Fix crash with require $nonstring If something other than a plain string (e.g. a reference or typeglob) whose stringified form contains a null character is passed to require() or do(), it crashes, as of v5.19.3-130-gc8028aa, because the code in question that handles the error tries to read fields of the scalar that are only valid if it is a string internally. (cherry picked from commit 08f800f8519574aea9e744ff83230fb93772652b) M pp_ctl.c M t/op/require_errors.t ----------------------------------------------------------------------- Summary of changes: AUTHORS | 2 ++ Configure | 16 +++++++++++++++- doio.c | 12 +----------- embed.fnc | 2 +- locale.c | 2 +- perl.h | 2 ++ pod/perlfunc.pod | 8 ++++---- pod/perlop.pod | 2 +- pod/perlrun.pod | 2 +- pod/perlunicode.pod | 2 +- pp_ctl.c | 4 ++-- pp_hot.c | 3 ++- pp_sys.c | 8 +++----- proto.h | 2 -- regcomp.c | 35 +++++++++++++++++++++-------------- t/io/socket.t | 22 ++++++++++++++++++++++ t/op/method.t | 6 +++++- t/op/require_errors.t | 10 +++++++++- t/op/svleak.t | 12 +++++++++++- t/op/tr.t | 11 ++++++++++- t/re/reg_mesg.t | 7 ++++--- t/re/regex_sets.t | 15 +++++++++++++++ t/run/switchx.aux | 7 ++++--- t/run/switchx.t | 4 ++-- toke.c | 12 ++++++++---- 25 files changed, 147 insertions(+), 61 deletions(-) diff --git a/AUTHORS b/AUTHORS index e77fc36902..ee02326762 100644 --- a/AUTHORS +++ b/AUTHORS @@ -298,6 +298,7 @@ Darrell Kindred <[email protected]> Darrell Schiebel <[email protected]> Darren/Torin/Who Ever... <[email protected]> Dave Bianchi +Dave Cross <[email protected]> Dave Hartnoll <[email protected]> Dave Liney <[email protected]> Dave Nelson <[email protected]> @@ -1147,6 +1148,7 @@ Steve Purkis <[email protected]> Steve Vinoski Stevan Little <[email protected]> Steven Hirsch <[email protected]> +Steven Humphrey <[email protected]> Steven Knight <[email protected]> Steven Morlock <[email protected]> Steven N. Hirsch <[email protected]> diff --git a/Configure b/Configure index 5a353d6de4..471771009f 100755 --- a/Configure +++ b/Configure @@ -5239,6 +5239,20 @@ case "$usequadmath" in *) usequadmath="$undef" ;; esac +: Fail if both uselongdouble and usequadmath are requested +case "$usequadmath:$uselongdouble" in +define:define) + $cat <<EOM >&4 + +*** You requested the use of the quadmath library and use +*** of long doubles. +*** +*** Please select one or the other. +EOM + exit 1 + ;; +esac + : Looking for optional libraries echo " " echo "Checking for optional libraries..." >&4 @@ -7185,7 +7199,7 @@ case "$usequadmath" in $define) echo "quadmath selected." >&4 case "$archname" in - *-ld*) echo "...and architecture name already has -quadmath." >&4 + *-quadmath*) echo "...and architecture name already has -quadmath." >&4 ;; *) archname="$archname-quadmath" echo "...setting architecture name to $archname." >&4 diff --git a/doio.c b/doio.c index 856b19a12a..67048627ac 100644 --- a/doio.c +++ b/doio.c @@ -1845,18 +1845,8 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); APPLY_TAINT_PROPER(); if (fd < 0) { - SETERRNO(EBADF,RMS_IFI); - tot--; -#if Uid_t_sign == 1 - } else if (val < 0) { - SETERRNO(EINVAL,LIB_INVARG); - tot--; -#endif -#if Gid_t_sign == 1 - } else if (val2 < 0) { - SETERRNO(EINVAL,LIB_INVARG); + SETERRNO(EBADF,RMS_IFI); tot--; -#endif } else if (fchown(fd, val, val2)) tot--; #else diff --git a/embed.fnc b/embed.fnc index d59eb35bc9..ab63e44e58 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2113,7 +2113,7 @@ s |OP* |doform |NN CV *cv|NN GV *gv|NULLOK OP *retop # if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) sR |int |dooneliner |NN const char *cmd|NN const char *filename # endif -s |SV * |space_join_names_mortal|NN char *const *array +s |SV * |space_join_names_mortal|NULLOK char *const *array #endif p |OP * |tied_method|NN SV *methname|NN SV **sp \ |NN SV *const sv|NN const MAGIC *const mg \ diff --git a/locale.c b/locale.c index bf8713a665..9c4ef80cbb 100644 --- a/locale.c +++ b/locale.c @@ -836,7 +836,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) : NULL; sl_result = my_setlocale(LC_MESSAGES, locale_param); DEBUG_LOCALE_INIT(LC_MESSAGES, locale_param, sl_result); - if (! sl_result) + if (! sl_result) { setlocale_failure = TRUE; } # endif /* USE_LOCALE_MESSAGES */ diff --git a/perl.h b/perl.h index f8f0069dfa..7080620489 100644 --- a/perl.h +++ b/perl.h @@ -3064,6 +3064,8 @@ freeing any remaining Perl interpreters. */ #if defined(USE_ITHREADS) && defined(I_PTHREAD) && \ defined(__clang__) && \ + !defined(PERL_GLOBAL_STRUCT) && \ + !defined(PERL_GLOBAL_STRUCT_PRIVATE) && \ !defined(SWIG) && \ ((!defined(__apple_build_version__) && \ ((__clang_major__ == 3 && __clang_minor__ >= 6) || \ diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index e9c7038a9c..b10b632360 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1703,8 +1703,8 @@ produce, respectively /etc/games is no good, stopped at canasta line 123. If the output is empty and L<C<$@>|perlvar/$@> already contains a value -(typically from a previous eval) that value is reused after appending -C<"\t...propagated">. This is useful for propagating exceptions: +(typically from a previous L<C<eval>|/eval EXPR>) that value is reused after +appending C<"\t...propagated">. This is useful for propagating exceptions: eval { ... }; die unless $@ =~ /Expected exception/; @@ -4006,8 +4006,8 @@ Note that L<C<$_>|perlvar/$_> is an alias to the list value, so it can be used to modify the elements of the LIST. While this is useful and supported, it can cause bizarre results if the elements of LIST are not variables. Using a regular C<foreach> loop for this purpose would be -clearer in most cases. See also L<C<grep>|/grep BLOCK LIST> for an -array composed of those items of the original list for which the BLOCK +clearer in most cases. See also L<C<grep>|/grep BLOCK LIST> for a +list composed of those items of the original list for which the BLOCK or EXPR evaluates to true. C<{> starts both hash references and blocks, so C<map { ...> could be either diff --git a/pod/perlop.pod b/pod/perlop.pod index 9b1319a7a6..9a43ce4dec 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -2423,7 +2423,7 @@ controls and characters which have no ASCII equivalents. But, even for portable ranges, it is not generally obvious what is included without having to look things up. A sound principle is to use only ranges that begin from and end at either ASCII alphabetics of equal -case (C<b-e>, C<b-E>), or digits (C<1-4>). Anything else is unclear +case (C<b-e>, C<B-E>), or digits (C<1-4>). Anything else is unclear (and unportable unless C<\N{...}> is used). If in doubt, spell out the character sets in full. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 349e91e3d6..25ec5e6648 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -345,7 +345,7 @@ You can also use binmode() to set the encoding of an I/O stream. X<-c> causes Perl to check the syntax of the program and then exit without -executing it. Actually, it I<will> execute and C<BEGIN>, C<UNITCHECK>, +executing it. Actually, it I<will> execute any C<BEGIN>, C<UNITCHECK>, or C<CHECK> blocks and any C<use> statements: these are considered as occurring outside the execution of your program. C<INIT> and C<END> blocks, however, will be skipped. diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod index 775a4307a4..4222c43e0d 100644 --- a/pod/perlunicode.pod +++ b/pod/perlunicode.pod @@ -1827,7 +1827,7 @@ the XS level, and L<perlapi/Unicode Support> for the API details. Perl by default comes with the latest supported Unicode version built-in, but the goal is to allow you to change to use any earlier one. In Perls v5.20 and v5.22, however, the earliest usable version is Unicode 5.1. -Perl v5.18 is able to handle all earlier versions. +Perl v5.18 and v5.24 are able to handle all earlier versions. Download the files in the desired version of Unicode from the Unicode web site L<http://www.unicode.org>). These should replace the existing files in diff --git a/pp_ctl.c b/pp_ctl.c index 99ff59a0f0..225b357519 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3678,8 +3678,8 @@ PP(pp_require) if (!IS_SAFE_PATHNAME(name, len, "require")) { DIE(aTHX_ "Can't locate %s: %s", - pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv), - SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0), + pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2, + NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0), Strerror(ENOENT)); } TAINT_PROPER("require"); diff --git a/pp_hot.c b/pp_hot.c index d6cb1aa091..243f43a972 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1181,6 +1181,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, assert(svr); if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) { + U32 brk = (SvFLAGS(svr) & SVf_BREAK); #ifdef DEBUGGING if (fake) { @@ -1216,7 +1217,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, /* ... but restore afterwards in case it's needed again, * e.g. ($a,$b,$c) = (1,$a,$a) */ - SvFLAGS(svr) |= SVf_BREAK; + SvFLAGS(svr) |= brk; } if (!lcount) diff --git a/pp_sys.c b/pp_sys.c index 33cba461ee..d16a0e5da1 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -2497,7 +2497,6 @@ PP(pp_socket) TAINT_PROPER("socket"); fd = PerlSock_socket(domain, type, protocol); if (fd < 0) { - SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ @@ -3531,8 +3530,9 @@ PP(pp_fttext) } PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); if (PL_laststatval < 0) { + dSAVE_ERRNO; (void)PerlIO_close(fp); - SETERRNO(EBADF,RMS_IFI); + RESTORE_ERRNO; FT_RETURNUNDEF; } PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); @@ -4934,9 +4934,7 @@ S_space_join_names_mortal(pTHX_ char *const *array) { SV *target; - PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL; - - if (*array) { + if (array && *array) { target = newSVpvs_flags("", SVs_TEMP); while (1) { sv_catpv(target, *array); diff --git a/proto.h b/proto.h index 8d4713b096..1494077ed5 100644 --- a/proto.h +++ b/proto.h @@ -4693,8 +4693,6 @@ STATIC OP* S_doform(pTHX_ CV *cv, GV *gv, OP *retop); #define PERL_ARGS_ASSERT_DOFORM \ assert(cv); assert(gv) STATIC SV * S_space_join_names_mortal(pTHX_ char *const *array); -#define PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL \ - assert(array) #endif #if defined(PERL_IN_REGCOMP_C) STATIC void S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end); diff --git a/regcomp.c b/regcomp.c index cbaad1e33a..ba571c23e3 100644 --- a/regcomp.c +++ b/regcomp.c @@ -199,6 +199,7 @@ struct RExC_state_t { scan_frame *frame_head; scan_frame *frame_last; U32 frame_count; + AV *warn_text; #ifdef ADD_TO_REGEXEC char *starttry; /* -Dr: where regtry was called. */ #define RExC_starttry (pRExC_state->starttry) @@ -290,6 +291,7 @@ struct RExC_state_t { #define RExC_frame_count (pRExC_state->frame_count) #define RExC_strict (pRExC_state->strict) #define RExC_study_started (pRExC_state->study_started) +#define RExC_warn_text (pRExC_state->warn_text) /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set * a flag to disable back-off on the fixed/floating substrings - if it's @@ -6764,6 +6766,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, #endif } + pRExC_state->warn_text = NULL; pRExC_state->code_blocks = NULL; pRExC_state->num_code_blocks = 0; @@ -10617,7 +10620,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) RExC_seen |= REG_LOOKBEHIND_SEEN; RExC_in_lookbehind++; RExC_parse++; - assert(RExC_parse < RExC_end); + if (RExC_parse >= RExC_end) { + vFAIL("Sequence (?... not terminated"); + } + /* FALLTHROUGH */ case '=': /* (?=...) */ RExC_seen_zerolen++; @@ -13702,8 +13708,8 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) * routine. q.v. */ #define ADD_POSIX_WARNING(p, text) STMT_START { \ if (posix_warnings) { \ - if (! warn_text) warn_text = newAV(); \ - av_push(warn_text, Perl_newSVpvf(aTHX_ \ + if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \ + av_push(RExC_warn_text, Perl_newSVpvf(aTHX_ \ WARNING_PREFIX \ text \ REPORT_LOCATION, \ @@ -13834,7 +13840,6 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state, bool has_opening_colon = FALSE; int class_number = OOB_NAMEDCLASS; /* Out-of-bounds until find valid class */ - AV* warn_text = NULL; /* any warning messages */ const char * possible_end = NULL; /* used for a 2nd parse pass */ const char* name_start; /* ptr to class name first char */ @@ -13850,6 +13855,9 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state, PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX; + if (posix_warnings && RExC_warn_text) + av_clear(RExC_warn_text); + if (p >= e) { return NOT_MEANT_TO_BE_A_POSIX_CLASS; } @@ -14467,14 +14475,8 @@ S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state, ADD_POSIX_WARNING(p, "there is no terminating ']'"); } - if (warn_text) { - if (posix_warnings) { - /* mortalize to avoid a leak with FATAL warnings */ - *posix_warnings = (AV *) sv_2mortal((SV *) warn_text); - } - else { - SvREFCNT_dec_NN(warn_text); - } + if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) { + *posix_warnings = RExC_warn_text; } } else if (class_number != OOB_NAMEDCLASS) { @@ -14880,8 +14882,8 @@ redo_curchar: } /* Stack the position of this undealt-with left paren */ - fence = top_index + 1; av_push(fence_stack, newSViv(fence)); + fence = top_index + 1; break; case '\\': @@ -14962,7 +14964,12 @@ redo_curchar: vFAIL("Unexpected ')'"); } - /* If at least two thing on the stack, treat this as an + /* If nothing after the fence, is missing an operand */ + if (top_index - fence < 0) { + RExC_parse++; + goto bad_syntax; + } + /* If at least two things on the stack, treat this as an * operator */ if (top_index - fence >= 1) { goto join_operators; diff --git a/t/io/socket.t b/t/io/socket.t index b51079a4a5..54e4438717 100644 --- a/t/io/socket.t +++ b/t/io/socket.t @@ -128,6 +128,28 @@ SKIP: { } } +SKIP: +{ + eval { require Errno; defined &Errno::EMFILE } + or skip "Can't load Errno or EMFILE not defined", 1; + my @socks; + my $sock_limit = 1000; # don't consume every file in the system + # Default limits on various systems I have: + # 65536 - Linux + # 256 - Solaris + # 128 - NetBSD + # 256 - Cygwin + # 256 - darwin + while (@socks < $sock_limit) { + socket my $work, PF_INET, SOCK_STREAM, $tcp + or last; + push @socks, $work; + } + @socks == $sock_limit + and skip "Didn't run out of open handles", 1; + is(0+$!, Errno::EMFILE(), "check correct errno for too many files"); +} + done_testing(); my @child_tests; diff --git a/t/op/method.t b/t/op/method.t index b915306b8e..1fc99cfdf9 100644 --- a/t/op/method.t +++ b/t/op/method.t @@ -13,7 +13,7 @@ BEGIN { use strict; no warnings 'once'; -plan(tests => 150); +plan(tests => 151); @A::ISA = 'B'; @B::ISA = 'C'; @@ -704,6 +704,10 @@ SKIP: { "check unknown import() methods don't corrupt the stack"); } +like runperl(prog => 'sub ub(){0} ub ub', stderr=>1), qr/Bareword found/, + '[perl #126482] Assert failure when mentioning a constant twice in a row'; + + __END__ #FF9900 #F78C08 diff --git a/t/op/require_errors.t b/t/op/require_errors.t index 3d3d0270f0..d57ee95700 100644 --- a/t/op/require_errors.t +++ b/t/op/require_errors.t @@ -8,7 +8,7 @@ BEGIN { use strict; use warnings; -plan(tests => 17); +plan(tests => 19); my $nonfile = tempfile(); @@ -134,3 +134,11 @@ like $@, qr/^Can't locate strict\.pm\\0invalid: /, 'do nul check'; eval "require strict\0::invalid;"; like $@, qr/^syntax error at \(eval \d+\) line 1/, 'parse error with \0 in barewords module names'; +# Refs and globs that stringify with embedded nulls +# These crashed from 5.20 to 5.24 [perl #128182]. +eval { no warnings 'syscalls'; require eval "qr/\0/" }; +like $@, qr/^Can't locate \(\?\^:\\0\):/, + 'require ref that stringifies with embedded null'; +eval { no strict; no warnings 'syscalls'; require *{"\0a"} }; +like $@, qr/^Can't locate \*main::\\0a:/, + 'require ref that stringifies with embedded null'; diff --git a/t/op/svleak.t b/t/op/svleak.t index 595bf3e85d..c18f498cbe 100644 --- a/t/op/svleak.t +++ b/t/op/svleak.t @@ -15,7 +15,7 @@ BEGIN { use Config; -plan tests => 131; +plan tests => 132; # 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 @@ -537,3 +537,13 @@ EOF ::leak(5, 0, \&f, q{goto shouldn't leak @_}); } + +# [perl #128313] POSIX warnings shouldn't leak +{ + no warnings 'experimental'; + use re 'strict'; + my $a = 'aaa'; + my $b = 'aa'; + sub f { $a =~ /[^.]+$b/; } + ::leak(2, 0, \&f, q{use re 'strict' shouldn't leak warning strings}); +} diff --git a/t/op/tr.t b/t/op/tr.t index 6783dad40d..d40187f5fc 100644 --- a/t/op/tr.t +++ b/t/op/tr.t @@ -9,7 +9,7 @@ BEGIN { set_up_inc('../lib'); } -plan tests => 164; +plan tests => 166; # Test this first before we extend the stack with other operations. # This caused an asan failure due to a bad write past the end of the stack. @@ -643,4 +643,13 @@ for ("", nullrocow) { ok(1, "tr///d on glob does not assert"); } +{ # [perl #128734 + my $string = "\x{00e0}"; + $string =~ tr/\N{U+00e0}/A/; + is($string, "A", 'tr// of \N{U+...} works for upper-Latin1'); + $string = "\x{00e1}"; + $string =~ tr/\N{LATIN SMALL LETTER A WITH ACUTE}/A/; + is($string, "A", 'tr// of \N{name} works for upper-Latin1'); +} + 1; diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t index 0fe4539695..08d90c5c40 100644 --- a/t/re/reg_mesg.t +++ b/t/re/reg_mesg.t @@ -220,8 +220,8 @@ my @death = '/(?[ \x{} ])/' => 'Number with no digits {#} m/(?[ \x{}{#} ])/', '/(?[ \cK + ) ])/' => 'Unexpected \')\' {#} m/(?[ \cK + ){#} ])/', '/(?[ \cK + ])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[ \cK + {#}])/', - '/(?[ ( ) ])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[ ( ) {#}])/', - '/(?[[0]+()+])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[[0]+()+{#}])/', + '/(?[ ( ) ])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[ ( ){#} ])/', + '/(?[[0]+()+])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[[0]+(){#}+])/', '/(?[ \p{foo} ])/' => 'Can\'t find Unicode property definition "foo" {#} m/(?[ \p{foo}{#} ])/', '/(?[ \p{ foo = bar } ])/' => 'Can\'t find Unicode property definition "foo = bar" {#} m/(?[ \p{ foo = bar }{#} ])/', '/(?[ \8 ])/' => 'Unrecognized escape \8 in character class {#} m/(?[ \8{#} ])/', @@ -266,8 +266,9 @@ my @death = '/(?[\ -!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[\ -!{#}])/', # [perl #126180] '/(?[\ ^!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[\ ^!{#}])/', # [perl #126180] '/(?[\ |!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[\ |!{#}])/', # [perl #126180] - '/(?[()-!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[()-!{#}])/', # [perl #126204] + '/(?[()-!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[(){#}-!])/', # [perl #126204] '/(?[!()])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[!(){#}])/', # [perl #126404] + '/(?<=/' => 'Sequence (?... not terminated {#} m/(?<={#}/', # [perl #128170] ); # These are messages that are warnings when not strict; death under 'use re diff --git a/t/re/regex_sets.t b/t/re/regex_sets.t index cd5df00ed0..92875677be 100644 --- a/t/re/regex_sets.t +++ b/t/re/regex_sets.t @@ -182,6 +182,21 @@ for my $char ("Ù ", "Ù¥", "Ù©") { 'qr/qr/(?[ ! ( ! (\w)])/'); } +{ # RT #129122 + my $pat = '(?[ ( [ABC] - [B] ) + ( [abc] - [b] ) + [def] ])'; + like("A", qr/$pat/, "'A' matches /$pat/"); + unlike("B", qr/$pat/, "'B' doesn't match /$pat/"); + like("C", qr/$pat/, "'C' matches /$pat/"); + unlike("D", qr/$pat/, "'D' doesn't match /$pat/"); + like("a", qr/$pat/, "'a' matches /$pat/"); + unlike("b", qr/$pat/, "'b' doesn't match /$pat/"); + like("c", qr/$pat/, "'c' matches /$pat/"); + like("d", qr/$pat/, "'d' matches /$pat/"); + like("e", qr/$pat/, "'e' matches /$pat/"); + like("f", qr/$pat/, "'f' matches /$pat/"); + unlike("g", qr/$pat/, "'g' doesn't match /$pat/"); +} + done_testing(); 1; diff --git a/t/run/switchx.aux b/t/run/switchx.aux index b59df4a0ed..106b2f79c6 100644 --- a/t/run/switchx.aux +++ b/t/run/switchx.aux @@ -17,11 +17,12 @@ still not perl #!/some/path/that/leads/to/perl -l -print "1..7"; +print "1..8"; +print "ok 1 - Correct line number" if __LINE__ == 4; if (-f 'run/switchx.aux') { - print "ok 1 - Test file exists"; + print "ok 2 - Test file exists"; } -print "ok 2 - Test file utilized"; +print "ok 3 - Test file utilized"; # other tests are in switchx2.aux __END__ diff --git a/t/run/switchx.t b/t/run/switchx.t index bcea3d0ab6..4e57d04497 100644 --- a/t/run/switchx.t +++ b/t/run/switchx.t @@ -15,9 +15,9 @@ print runperl( switches => ['-x'], # Test '-xdir' print runperl( switches => ['-x./run'], progfile => 'run/switchx2.aux', - args => [ 3 ] ); + args => [ 4 ] ); -curr_test(5); +curr_test(6); # Test the error message for not found like(runperl(switches => ['-x'], progfile => 'run/switchx3.aux', stderr => 1), diff --git a/toke.c b/toke.c index b493401673..aa814b991d 100644 --- a/toke.c +++ b/toke.c @@ -725,7 +725,8 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) parser->linestr = flags & LEX_START_COPIED ? SvREFCNT_inc_simple_NN(line) : newSVpvn_flags(s, len, SvUTF8(line)); - sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2); + if (!rsfp) + sv_catpvs(parser->linestr, "\n;"); } else { parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2); } @@ -3539,7 +3540,7 @@ S_scan_const(pTHX_ char *start) } /* Add the (Unicode) code point to the output. */ - if (OFFUNI_IS_INVARIANT(uv)) { + if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) { *d++ = (char) LATIN1_TO_NATIVE(uv); } else { @@ -4107,8 +4108,11 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) tmpbuf[len] = '\0'; goto bare_package; } - indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); - if (indirgv && GvCVu(indirgv)) + indirgv = gv_fetchpvn_flags(tmpbuf, len, + GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ), + SVt_PVCV); + if (indirgv && SvTYPE(indirgv) != SVt_NULL + && (!isGV(indirgv) || GvCVu(indirgv))) return 0; /* filehandle or package name makes it a method */ if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { -- Perl5 Master Repository
