X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e850844c70e877ddb73171e20c9e78f2673117a2..f3b02925aeacaac5636cac62dc3bf78525fdbe3d:/toke.c diff --git a/toke.c b/toke.c index a2fba3c..2dbe7f7 100644 --- a/toke.c +++ b/toke.c @@ -1511,6 +1511,7 @@ S_incline(pTHX_ const char *s) const char *t; const char *n; const char *e; + line_t line_num; PERL_ARGS_ASSERT_INCLINE; @@ -1554,9 +1555,10 @@ S_incline(pTHX_ const char *s) if (*e != '\n' && *e != '\0') return; /* false alarm */ + line_num = atoi(n)-1; + if (t - s > 0) { const STRLEN len = t - s; -#ifndef USE_ITHREADS SV *const temp_sv = CopFILESV(PL_curcop); const char *cf; STRLEN tmplen; @@ -1611,19 +1613,35 @@ S_incline(pTHX_ const char *s) gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE); /* adjust ${"::_ 0) { + AV * const av2 = GvAVn(gv2); + SV **svp = AvARRAY(av) + start; + I32 l = (I32)line_num+1; + while (items--) + av_store(av2, l++, SvREFCNT_inc(*svp++)); + } + } } if (tmpbuf2 != smallbuf) Safefree(tmpbuf2); } if (tmpbuf != smallbuf) Safefree(tmpbuf); } -#endif CopFILE_free(PL_curcop); CopFILE_setn(PL_curcop, s, len); } - CopLINE_set(PL_curcop, atoi(n)-1); + CopLINE_set(PL_curcop, line_num); } #ifdef PERL_MAD @@ -4328,7 +4346,7 @@ Perl_yylex(pTHX) if (PL_lex_brackets > 100) Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); PL_lex_brackstack[PL_lex_brackets++] = - (next_type >> 16) & 0xff; + (char) ((next_type >> 16) & 0xff); } if (next_type & (2<<24)) PL_lex_allbrackets++; @@ -8755,17 +8773,131 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL return s; } -static U32 -S_pmflag(U32 pmfl, const char ch) { - switch (ch) { - CASE_STD_PMMOD_FLAGS_PARSE_SET(&pmfl); - case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break; - case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break; - case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break; - case KEEPCOPY_PAT_MOD: pmfl |= RXf_PMf_KEEPCOPY; break; - case NONDESTRUCT_PAT_MOD: pmfl |= PMf_NONDESTRUCT; break; - } - return pmfl; +static bool +S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) { + + /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in + * the parse starting at 's', based on the subset that are valid in this + * context input to this routine in 'valid_flags'. Advances s. Returns + * TRUE if the input was a valid flag, so the next char may be as well; + * otherwise FALSE. 'charset' should point to a NUL upon first call on the + * current regex. This routine will set it to any charset modifier found. + * The caller shouldn't change it. This way, another charset modifier + * encountered in the parse can be detected as an error, as we have decided + * allow only one */ + + const char c = **s; + + if (! strchr(valid_flags, c)) { + if (isALNUM(c)) { + goto deprecate; + } + return FALSE; + } + + switch (c) { + + CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl); + case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break; + case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break; + case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break; + case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break; + case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break; + case LOCALE_PAT_MOD: + + /* In 5.14, qr//lt is legal but deprecated; the 't' means they + * can't be regex modifiers. + * In 5.14, s///le is legal and ambiguous. Try to disambiguate as + * much as easily done. s///lei, for example, has to mean regex + * modifiers if it's not an error (as does any word character + * following the 'e'). Otherwise, we resolve to the backwards- + * compatible, but less likely 's/// le ...', i.e. as meaning + * less-than-or-equal. The reason it's not likely is that s// + * returns a number for code in the field (/r returns a string, but + * that wasn't added until the 5.13 series), and so '<=' should be + * used for comparing, not 'le'. */ + if (*((*s) + 1) == 't') { + goto deprecate; + } + else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) { + + /* 'e' is valid only for substitutes, s///e. If it is not + * valid in the current context, then 'm//le' must mean the + * comparison operator, so use the regular deprecation message. + */ + if (! strchr(valid_flags, 'e')) { + goto deprecate; + } + Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), + "Ambiguous use of 's//le...' resolved as 's// le...'; Rewrite as 's//el' if you meant 'use locale rules and evaluate rhs as an expression'. In Perl 5.16, it will be resolved the other way"); + return FALSE; + } + if (*charset) { + goto multiple_charsets; + } + set_regex_charset(pmfl, REGEX_LOCALE_CHARSET); + *charset = c; + break; + case UNICODE_PAT_MOD: + /* In 5.14, qr//unless and qr//until are legal but deprecated; the + * 'n' means they can't be regex modifiers */ + if (*((*s) + 1) == 'n') { + goto deprecate; + } + if (*charset) { + goto multiple_charsets; + } + set_regex_charset(pmfl, REGEX_UNICODE_CHARSET); + *charset = c; + break; + case ASCII_RESTRICT_PAT_MOD: + /* In 5.14, qr//and is legal but deprecated; the 'n' means they + * can't be regex modifiers */ + if (*((*s) + 1) == 'n') { + goto deprecate; + } + if (*((*s) + 1) == ASCII_RESTRICT_PAT_MOD) { + /* Doubled modifier implies more restricted */ + set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET); + (*s)++; + } + else { + set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET); + } + if (*charset) { /* Do this after the increment of *s in /aa, so + the return advances the ptr correctly */ + goto multiple_charsets; + } + *charset = c; + break; + case DEPENDS_PAT_MOD: + if (*charset) { + goto multiple_charsets; + } + set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET); + *charset = c; + break; + } + + (*s)++; + return TRUE; + + deprecate: + Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), + "Having no space between pattern and following word is deprecated"); + return FALSE; + + multiple_charsets: + if (*charset != c) { + yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c)); + } + else { + yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c)); + } + + /* Pretend that it worked, so will continue processing before dieing */ + (*s)++; + return TRUE; } STATIC char * @@ -8776,6 +8908,7 @@ S_scan_pat(pTHX_ char *start, I32 type) char *s = scan_str(start,!!PL_madskills,FALSE); const char * const valid_flags = (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS); + char charset = '\0'; /* character set modifier */ #ifdef PERL_MAD char *modstart; #endif @@ -8817,14 +8950,7 @@ S_scan_pat(pTHX_ char *start, I32 type) #ifdef PERL_MAD modstart = s; #endif - while (*s && strchr(valid_flags, *s)) - pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++); - - if (isALNUM(*s)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), - "Having no space between pattern and following word is deprecated"); - - } + while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {}; #ifdef PERL_MAD if (PL_madskills && modstart != s) { SV* tmptoken = newSVpvn(modstart, s - modstart); @@ -8847,10 +8973,11 @@ STATIC char * S_scan_subst(pTHX_ char *start) { dVAR; - register char *s; + char *s; register PMOP *pm; I32 first_start; I32 es = 0; + char charset = '\0'; /* character set modifier */ #ifdef PERL_MAD char *modstart; #endif @@ -8903,14 +9030,8 @@ S_scan_subst(pTHX_ char *start) s++; es++; } - else if (strchr(S_PAT_MODS, *s)) - pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++); - else { - if (isALNUM(*s)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), - "Having no space between pattern and following word is deprecated"); - - } + else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset)) + { break; } }