In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/1b5aaca661f906a9b324afb51b7af8727497f276?hp=61984ee1c56aaa8a989b7eed4cbc2effd74177c5>
- Log ----------------------------------------------------------------- commit 1b5aaca661f906a9b324afb51b7af8727497f276 Author: Father Chrysostomos <[email protected]> Date: Fri Jun 29 22:16:22 2012 -0700 pad.c: Update comments M pad.c commit 1c2b3fd6f10f07e101845ead8e14f613c1b487de Author: Father Chrysostomos <[email protected]> Date: Fri Jun 29 17:34:38 2012 -0700 [perl #113012] String negation under âuse integerâ This makes the negation operator under the integer pragma (i_int) use the same logic for determining whether to do string negation as the regular negation operator. Before, this did not happen at all under the integer pragma, except for barewords, resulting in strange inconsistencies: $ perl -le 'use integer; print -foo' -foo $ perl -le 'use integer; print -"foo"' 0 The code for string negation is now in a static routine in pp.c and is used by both types of negation. M pp.c M t/op/negate.t commit f87fa3355a3a1f41c9bc2160d98d7e7e16bdd9ea Author: Father Chrysostomos <[email protected]> Date: Fri Jun 29 14:49:53 2012 -0700 [perl #113006] perllocale: change Spanish to traditional Spanish Nowadays, Spanish collation does not treat ch as a separate letter. M pod/perllocale.pod commit 9963ffa20596275dc70831862ce25471cf69f9ed Author: Father Chrysostomos <[email protected]> Date: Fri Jun 29 13:18:06 2012 -0700 op.c: Remove unnecessary variable This is left over from when I had the partially-filled slab at the end of the chain, instead of second (which was never committed). M op.c commit 4a273b91c8e47ab37c6dd310072403d4fe2d0fb9 Author: Father Chrysostomos <[email protected]> Date: Fri Jun 29 12:41:21 2012 -0700 Donât crash with formats in special blocks Commit 421f30ed1e9 didnât go far enough. If a special block happens to replace a stub, then a format trying to close over variables in the special block will be pointing to the wrong outer sub. Such stubs shouldnât usually happen, but perl shouldnât crash. M perly.act M perly.h M perly.tab M perly.y M t/comp/form_scope.t ----------------------------------------------------------------------- Summary of changes: op.c | 8 +++----- pad.c | 8 +++++--- perly.act | 7 +++++-- perly.h | 45 ++++++++++++++++++++------------------------- perly.tab | 6 +++--- perly.y | 2 +- pod/perllocale.pod | 2 +- pp.c | 42 ++++++++++++++++++++++++++---------------- t/comp/form_scope.t | 16 +++++++++++++++- t/op/negate.t | 47 ++++++++++++++++++++++++++++++++++++++++++++++- 10 files changed, 125 insertions(+), 58 deletions(-) diff --git a/op.c b/op.c index 2281ddf..e708a99 100644 --- a/op.c +++ b/op.c @@ -378,8 +378,6 @@ Perl_Slab_Alloc(pTHX_ size_t sz) if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) { /* Remaining space is too small. */ - OPSLAB *newslab; - /* If we can fit a BASEOP, add it to the free chain, so as not to waste it. */ if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) { @@ -393,9 +391,9 @@ Perl_Slab_Alloc(pTHX_ size_t sz) /* Create a new slab. Make this one twice as big. */ slot = slab2->opslab_first; while (slot->opslot_next) slot = slot->opslot_next; - newslab = S_new_slab(aTHX_ DIFF(slab2, slot)*2); - newslab->opslab_next = slab->opslab_next; - slab->opslab_next = slab2 = newslab; + slab2 = S_new_slab(aTHX_ DIFF(slab2, slot)*2); + slab2->opslab_next = slab->opslab_next; + slab->opslab_next = slab2; } assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz); diff --git a/pad.c b/pad.c index 1870ab6..c569e18 100644 --- a/pad.c +++ b/pad.c @@ -1923,10 +1923,12 @@ Perl_cv_clone(pTHX_ CV *proto) assert(!CvUNIQUE(proto)); - /* Since cloneable anon subs can be nested, CvOUTSIDE may point + /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not + * reliable. The currently-running sub is always the one we need to + * close over. + * Note that in general for formats, CvOUTSIDE != find_runcv. + * Since formats may be nested inside closures, CvOUTSIDE may point * to a prototype; we instead want the cloned parent who called us. - * Note that in general for formats, CvOUTSIDE != find_runcv; formats - * inside closures, however, only work if CvOUTSIDE == find_runcv. */ if (SvTYPE(proto) == SVt_PVCV) diff --git a/perly.act b/perly.act index ce830e3..6516b02 100644 --- a/perly.act +++ b/perly.act @@ -214,7 +214,7 @@ case 2: newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval)); (yyval.opval) = (OP*)NULL; #endif - if (CvOUTSIDE(fmtcv) && !CvUNIQUE(CvOUTSIDE(fmtcv))) { + if (CvOUTSIDE(fmtcv) && !CvEVAL(CvOUTSIDE(fmtcv))) { SvREFCNT_inc_simple_void(fmtcv); pad_add_anon(fmtcv, OP_NULL); } @@ -1717,10 +1717,13 @@ case 2: { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; + +/* Line 1267 of yacc.c. */ + default: break; /* Generated from: - * 27cce68ad4844f1b8053bfc11206fb9f559e08be6cefd4a986aaa606c0e5fb38 perly.y + * efdb10e4176c622005697eec1ff496d913ef986c5297086baa5088bbd3aedaf2 perly.y * 38f866dcd8341ad3c0810347587113eb2c6ac7d4f33bdab75b020efce92865be regen_perly.pl * ex: set ro: */ diff --git a/perly.h b/perly.h index d185ee9..8925a2e 100644 --- a/perly.h +++ b/perly.h @@ -5,25 +5,27 @@ */ #ifdef PERL_CORE -/* A Bison parser, made by GNU Bison 2.4.3. */ +/* A Bison parser, made by GNU Bison 2.3. */ /* Skeleton interface for Bison's Yacc-like parsers in C - - Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - 2009, 2010 Free Software Foundation, Inc. - - This program is free software: you can redistribute it and/or modify + + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - + the Free Software Foundation; either version 2, or (at your option) + any later version. + This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. - + You should have received a copy of the GNU General Public License - along with this program. If not, see <http://www.gnu.org/licenses/>. */ + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work @@ -34,11 +36,10 @@ special exception, which will cause the skeleton and the resulting Bison output files to be licensed under the GNU General Public License without this special exception. - + This special exception was added by the Free Software Foundation in version 2.2 of Bison. */ - /* Tokens. */ #ifndef YYTOKENTYPE # define YYTOKENTYPE @@ -126,7 +127,6 @@ PEG = 336 }; #endif - /* Tokens. */ #define GRAMPROG 258 #define GRAMEXPR 259 @@ -210,13 +210,11 @@ + #endif /* PERL_CORE */ #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED typedef union YYSTYPE { - -/* Line 1685 of yacc.c */ - I32 ival; /* __DEFAULT__ (marker for regen_perly.pl; must always be 1st union member) */ char *pval; @@ -232,21 +230,18 @@ typedef union YYSTYPE #ifdef PERL_MAD TOKEN* tkval; #endif - - - -/* Line 1685 of yacc.c */ -} YYSTYPE; -# define YYSTYPE_IS_TRIVIAL 1 +} +/* Line 1529 of yacc.c. */ + YYSTYPE; # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 +# define YYSTYPE_IS_TRIVIAL 1 #endif - /* Generated from: - * 27cce68ad4844f1b8053bfc11206fb9f559e08be6cefd4a986aaa606c0e5fb38 perly.y + * efdb10e4176c622005697eec1ff496d913ef986c5297086baa5088bbd3aedaf2 perly.y * 38f866dcd8341ad3c0810347587113eb2c6ac7d4f33bdab75b020efce92865be regen_perly.pl * ex: set ro: */ diff --git a/perly.tab b/perly.tab index 86cc024..309d5d9 100644 --- a/perly.tab +++ b/perly.tab @@ -223,9 +223,9 @@ static const char *const yytname[] = "':'", "DORDOR", "OROR", "ANDAND", "BITOROP", "BITANDOP", "SHIFTOP", "MATCHOP", "'!'", "'~'", "REFGEN", "UMINUS", "POWOP", "POSTDEC", "POSTINC", "PREDEC", "PREINC", "ARROW", "')'", "'('", "PEG", "$accept", - "grammar", "$@1", "$@2", "$@3", "$@4", "$@5", "$@6", "block", "remember", + "grammar", "@1", "@2", "@3", "@4", "@5", "@6", "block", "remember", "mydefsv", "mblock", "mremember", "stmtseq", "fullstmt", "labfullstmt", - "barestmt", "$@7", "$@8", "sideff", "else", "cont", "mintro", "nexpr", + "barestmt", "@7", "@8", "sideff", "else", "cont", "mintro", "nexpr", "texpr", "iexpr", "mexpr", "mnexpr", "miexpr", "formname", "startsub", "startanonsub", "startformsub", "subname", "proto", "subattrlist", "myattrlist", "subbody", "expr", "listexpr", "listop", "@9", "method", @@ -1089,6 +1089,6 @@ static const toketypes yy_type_tab[] = }; /* Generated from: - * 27cce68ad4844f1b8053bfc11206fb9f559e08be6cefd4a986aaa606c0e5fb38 perly.y + * efdb10e4176c622005697eec1ff496d913ef986c5297086baa5088bbd3aedaf2 perly.y * 38f866dcd8341ad3c0810347587113eb2c6ac7d4f33bdab75b020efce92865be regen_perly.pl * ex: set ro: */ diff --git a/perly.y b/perly.y index e103db4..c819b5b 100644 --- a/perly.y +++ b/perly.y @@ -292,7 +292,7 @@ barestmt: PLUGSTMT newFORM($2, $3, $4); $$ = (OP*)NULL; #endif - if (CvOUTSIDE(fmtcv) && !CvUNIQUE(CvOUTSIDE(fmtcv))) { + if (CvOUTSIDE(fmtcv) && !CvEVAL(CvOUTSIDE(fmtcv))) { SvREFCNT_inc_simple_void(fmtcv); pad_add_anon(fmtcv, OP_NULL); } diff --git a/pod/perllocale.pod b/pod/perllocale.pod index 9217eec..c14120a 100644 --- a/pod/perllocale.pod +++ b/pod/perllocale.pod @@ -577,7 +577,7 @@ C<use locale ':not_characters'>), Perl looks to the C<LC_COLLATE> environment variable to determine the application's notions on collation (ordering) of characters. For example, "b" follows "a" in Latin alphabets, but where do "E<aacute>" and "E<aring>" belong? And while -"color" follows "chocolate" in English, what about in Spanish? +"color" follows "chocolate" in English, what about in traditional Spanish? The following collations all make sense and you may meet any of them if you "use locale". diff --git a/pp.c b/pp.c index 1742baa..0324c19 100644 --- a/pp.c +++ b/pp.c @@ -2149,10 +2149,34 @@ PP(pp_bit_or) } } +PERL_STATIC_INLINE bool +S_negate_string(pTHX) +{ + dTARGET; dSP; + STRLEN len; + const char *s; + SV * const sv = TOPs; + if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv))) + return FALSE; + s = SvPV_nomg_const(sv, len); + if (isIDFIRST(*s)) { + sv_setpvs(TARG, "-"); + sv_catsv(TARG, sv); + } + else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) { + sv_setsv_nomg(TARG, sv); + *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; + } + else return FALSE; + SETTARG; PUTBACK; + return TRUE; +} + PP(pp_negate) { dVAR; dSP; dTARGET; tryAMAGICun_MG(neg_amg, AMGf_numeric); + if (S_negate_string(aTHX)) return NORMAL; { SV * const sv = TOPs; @@ -2183,23 +2207,8 @@ PP(pp_negate) } if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv))) SETn(-SvNV_nomg(sv)); - else if (SvPOKp(sv)) { - STRLEN len; - const char * const s = SvPV_nomg_const(sv, len); - if (isIDFIRST(*s)) { - sv_setpvs(TARG, "-"); - sv_catsv(TARG, sv); - } - else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) { - sv_setsv_nomg(TARG, sv); - *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; - } - else if (SvIV_please_nomg(sv)) + else if (SvPOKp(sv) && SvIV_please_nomg(sv)) goto oops_its_an_int; - else - sv_setnv(TARG, -SvNV_nomg(sv)); - SETTARG; - } else SETn(-SvNV_nomg(sv)); } @@ -2550,6 +2559,7 @@ PP(pp_i_negate) { dVAR; dSP; dTARGET; tryAMAGICun_MG(neg_amg, 0); + if (S_negate_string(aTHX)) return NORMAL; { SV * const sv = TOPs; IV const i = SvIV_nomg(sv); diff --git a/t/comp/form_scope.t b/t/comp/form_scope.t index d805ffa..6344652 100644 --- a/t/comp/form_scope.t +++ b/t/comp/form_scope.t @@ -1,6 +1,6 @@ #!./perl -print "1..7\n"; +print "1..8\n"; # Tests bug #22977. Test case from Dave Mitchell. sub f ($); @@ -97,3 +97,17 @@ $next = $clo1; &$clo2(0); $next = $clo2; &$clo1(0); + +# This is a variation of bug #22977, which crashes or fails an assertion +# up to 5.16. +# Keep this test last if you want test numbers to be sane. +BEGIN { \&END } +END { + my $test = "ok 8"; + *STDOUT = *STDOUT5{FORMAT}; + write; + format STDOUT5 = +@<<<<<<< +$test +. +} diff --git a/t/op/negate.t b/t/op/negate.t index 6c355c7..033beb5 100644 --- a/t/op/negate.t +++ b/t/op/negate.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 24; +plan tests => 45; # Some of these will cause warnings if left on. Here we're checking the # functionality, not the warnings. @@ -57,3 +57,48 @@ $a = "97656250000000000"; () = 0+$a; $t = $a; is -$t, -97656250000000000, 'magic str+int dualvar'; + +{ # Repeat most of the tests under use integer + use integer; + is(- 10, -10, "Simple numeric negation to negative"); + is(- -10, 10, "Simple numeric negation to positive"); + is(-"10", -10, "Negation of a positive string to negative"); + is(-"10.0", -10, "Negation of a positive decimal sting to negative"); + is(-"10foo", -10, + "Negation of a numeric-lead string returns negation of numeric"); + is(-"-10", 10, + 'Negation of string starting with "-" returns a positive number -' + .' integer'); + "-10" =~ /(.*)/; + is(-$1, 10, 'Negation of magical string starting with "-" - integer'); + is(-"-10.0", 10, + 'Negation of string starting with "-" returns a positive number - ' + .'decimal'); + "-10.0" =~ /(.*)/; + is(-$1, 10, 'Negation of magical string starting with "-" - decimal'); + is(-"-10foo", "+10foo", + 'Negation of string starting with "-" returns a string starting ' + .'with "+" - non-numeric'); + is(-"xyz", "-xyz", + 'Negation of a negative string adds "-" to the front'); + is(-"-xyz", "+xyz", "Negation of a negative string to positive"); + is(-"+xyz", "-xyz", "Negation of a positive string to negative"); + is(-bareword, "-bareword", + "Negation of bareword treated like a string"); + is(- -bareword, "+bareword", + "Negation of -bareword returns string +bareword"); + is(-" -10", 10, "Negation of a whitespace-lead numeric string"); + is(-" -10.0", 10, "Negation of a whitespace-lead decimal string"); + is(-" -10foo", 10, + "Negation of a whitespace-lead sting starting with a numeric"); + + $x = "dogs"; + ()=0+$x; + is -$x, '-dogs', + 'cached numeric value does not sabotage string negation'; + + $a = "%apples"; + chop($au = "%apples\x{100}"); + is(-$au, -$a, 'utf8 flag makes no difference for string negation'); + is -"\x{100}", 0, '-(non-ASCII) is equivalent to -(punct)'; +} -- Perl5 Master Repository
