X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8405109152b060e3419c0cddc875535421bcc7ca..919ec23b10e41ed5c6aaf77a8ae3d2f7ef279f1b:/toke.c diff --git a/toke.c b/toke.c index 968d30e..b146cdc 100644 --- a/toke.c +++ b/toke.c @@ -182,17 +182,10 @@ static const char* const lex_state_names[] = { }; #endif -#ifdef ff_next -#undef ff_next -#endif - #include "keywords.h" /* CLINE is a macro that ensures PL_copline has a sane value */ -#ifdef CLINE -#undef CLINE -#endif #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) #ifdef PERL_MAD @@ -218,6 +211,7 @@ static const char* const lex_state_names[] = { * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref) * PREREF : *EXPR where EXPR is not a simple identifier * TERM : expression term + * POSTDEREF : postfix dereference (->$* ->@[...] etc.) * LOOPX : loop exiting command (goto, last, dump, etc) * FTST : file test operator * FUN0 : zero-argument function @@ -249,6 +243,7 @@ static const char* const lex_state_names[] = { #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval)) #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval)) #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval)) +#define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1])) #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX)) #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP)) #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) @@ -384,6 +379,7 @@ static struct debug_tokens { { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" }, { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" }, { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, + { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" }, { POSTDEC, TOKENTYPE_NONE, "POSTDEC" }, { POSTINC, TOKENTYPE_NONE, "POSTINC" }, { POWOP, TOKENTYPE_OPNUM, "POWOP" }, @@ -486,7 +482,9 @@ S_printbuf(pTHX_ const char *const fmt, const char *const s) PERL_ARGS_ASSERT_PRINTBUF; + GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); + GCC_DIAG_RESTORE; SvREFCNT_dec(tmp); } @@ -771,8 +769,11 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) parser->linestart = SvPVX(parser->linestr); parser->bufend = parser->bufptr + SvCUR(parser->linestr); parser->last_lop = parser->last_uni = NULL; - parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES - |LEX_DONT_CLOSE_RSFP); + + assert(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES + |LEX_DONT_CLOSE_RSFP)); + parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES + |LEX_DONT_CLOSE_RSFP)); parser->in_pod = parser->filtered = 0; } @@ -2162,6 +2163,43 @@ S_force_next(pTHX_ I32 type) #endif } +/* + * S_postderef + * + * This subroutine handles postfix deref syntax after the arrow has already + * been emitted. @* $* etc. are emitted as two separate token right here. + * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits + * only the first, leaving yylex to find the next. + */ + +static int +S_postderef(pTHX_ int const funny, char const next) +{ + dVAR; + assert(funny == DOLSHARP || strchr("$@%&*", funny)); + assert(strchr("*[{", next)); + if (next == '*') { + PL_expect = XOPERATOR; + if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { + assert('@' == funny || '$' == funny || DOLSHARP == funny); + PL_lex_state = LEX_INTERPEND; + start_force(PL_curforce); + force_next(POSTJOIN); + } + start_force(PL_curforce); + force_next(next); + PL_bufptr+=2; + } + else { + if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL + && !PL_lex_brackets) + PL_lex_dojoin = 2; + PL_expect = XOPERATOR; + PL_bufptr++; + } + return funny; +} + void Perl_yyunlex(pTHX) { @@ -2477,18 +2515,17 @@ S_tokeq(pTHX_ SV *sv) char *s; char *send; char *d; - STRLEN len = 0; SV *pv = sv; PERL_ARGS_ASSERT_TOKEQ; - if (!SvLEN(sv)) + assert (SvPOK(sv)); + assert (SvLEN(sv)); + assert (!SvIsCOW(sv)); + if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */ goto finish; - - s = SvPV_force(sv, len); - if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) - goto finish; - send = s + len; + s = SvPVX(sv); + send = SvEND(sv); /* This is relying on the SV being "well formed" with a trailing '\0' */ while (s < send && !(*s == '\\' && s[1] == '\\')) s++; @@ -2496,7 +2533,8 @@ S_tokeq(pTHX_ SV *sv) goto finish; d = s; if ( PL_hints & HINT_NEW_STRING ) { - pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv)); + pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv), + SVs_TEMP | SvUTF8(sv)); } while (s < send) { if (*s == '\\') { @@ -2552,7 +2590,7 @@ S_sublex_start(pTHX) PL_lex_op = NULL; return THING; } - if (op_type == OP_CONST || op_type == OP_READLINE) { + if (op_type == OP_CONST) { SV *sv = tokeq(PL_lex_stuff); if (SvTYPE(sv) == SVt_PVIV) { @@ -2565,17 +2603,6 @@ S_sublex_start(pTHX) } pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv); PL_lex_stuff = NULL; - /* Allow // "foo" */ - if (op_type == OP_READLINE) - PL_expect = XTERMORDORDOR; - return THING; - } - else if (op_type == OP_BACKTICK && PL_lex_op) { - /* readpipe() was overridden */ - cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff); - pl_yylval.opval = PL_lex_op; - PL_lex_op = NULL; - PL_lex_stuff = NULL; return THING; } @@ -2611,7 +2638,7 @@ S_sublex_push(pTHX) ENTER; PL_lex_state = PL_sublex_info.super_state; - SAVEBOOL(PL_lex_dojoin); + SAVEI8(PL_lex_dojoin); SAVEI32(PL_lex_brackets); SAVEI32(PL_lex_allbrackets); SAVEI32(PL_lex_formbrack); @@ -2830,11 +2857,12 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) * validation. */ table = GvHV(PL_hintgv); /* ^H */ cvp = hv_fetchs(table, "charnames", FALSE); - if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL) - && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL)) + if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv), + SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL)) { const char * const name = HvNAME(stash); - if strEQ(name, "_charnames") { + if (HvNAMELEN(stash) == sizeof("_charnames")-1 + && strEQ(name, "_charnames")) { return res; } } @@ -3353,6 +3381,7 @@ S_scan_const(pTHX_ char *start) if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { + /* diag_listed_as: \%d better written as $%d */ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); *--s = '$'; break; @@ -3463,7 +3492,7 @@ S_scan_const(pTHX_ char *start) * to recode the rest of the string into utf8 */ /* Here uv is the ordinal of the next character being added */ - if (!NATIVE_IS_INVARIANT(uv)) { + if (!UVCHR_IS_INVARIANT(uv)) { if (!has_utf8 && uv > 255) { /* Might need to recode whatever we have accumulated so * far if it contains any chars variant in utf8 or @@ -3540,7 +3569,7 @@ S_scan_const(pTHX_ char *start) if (! PL_lex_inpat) { yyerror("Missing right brace on \\N{}"); } else { - yyerror("Missing right brace on \\N{} or unescaped left brace after \\N."); + yyerror("Missing right brace on \\N{} or unescaped left brace after \\N"); } continue; } @@ -3797,7 +3826,7 @@ S_scan_const(pTHX_ char *start) default_action: /* If we started with encoded form, or already know we want it, then encode the next character */ - if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) { + if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) { STRLEN len = 1; @@ -3914,6 +3943,7 @@ S_scan_const(pTHX_ char *start) * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/ * * ->[ and ->{ return TRUE + * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled * { and [ outside a pattern are always subscripts, so return TRUE * if we're outside a pattern and it's not { or [, then return FALSE * if we're in a pattern and the first char is a { @@ -3939,6 +3969,11 @@ S_intuit_more(pTHX_ char *s) return TRUE; if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{')) return TRUE; + if (*s == '-' && s[1] == '>' + && FEATURE_POSTDEREF_QQ_IS_ENABLED + && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*'))) + ||(s[2] == '@' && strchr("*[{",s[3])) )) + return TRUE; if (*s != '{' && *s != '[') return FALSE; if (!PL_lex_inpat) @@ -3991,7 +4026,10 @@ S_intuit_more(pTHX_ char *s) weight -= seen[un_char] * 10; if (isWORDCHAR_lazy_if(s+1,UTF)) { int len; - scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE); + char *tmp = PL_bufend; + PL_bufend = (char*)send; + scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE); + PL_bufend = tmp; len = (int)strlen(tmpbuf); if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0, SVt_PV)) @@ -4427,32 +4465,6 @@ S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0); } -/* - * S_readpipe_override - * Check whether readpipe() is overridden, and generates the appropriate - * optree, provided sublex_start() is called afterwards. - */ -STATIC void -S_readpipe_override(pTHX) -{ - GV **gvp; - GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV); - pl_yylval.ival = OP_BACKTICK; - if ((gv_readpipe - && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)) - || - ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE)) - && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe) - && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))) - { - COPLINE_SET_FROM_MULTI_END; - PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, - newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */ - newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe)))); - } -} - #ifdef PERL_MAD /* * Perl_madlex @@ -4668,7 +4680,7 @@ S_tokenize_use(pTHX_ int is_use, char *s) { #ifdef DEBUGGING static const char* const exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", - "ATTRTERM", "TERMBLOCK", "TERMORDORDOR" + "ATTRTERM", "TERMBLOCK", "POSTDEREF", "TERMORDORDOR" }; #endif @@ -4682,6 +4694,20 @@ S_word_takes_any_delimeter(char *p, STRLEN len) (p[0] == 'q' && strchr("qwxr", p[1])))); } +static void +S_check_scalar_slice(pTHX_ char *s) +{ + s++; + while (*s == ' ' || *s == '\t') s++; + if (*s == 'q' && s[1] == 'w' + && !isWORDCHAR_lazy_if(s+2,UTF)) + return; + while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s))) + s += UTF ? UTF8SKIP(s) : 1; + if (*s == '}' || *s == ']') + pl_yylval.ival = OPpSLICEWARNING; +} + /* yylex @@ -4727,9 +4753,6 @@ S_word_takes_any_delimeter(char *p, STRLEN len) */ -#ifdef __SC__ -#pragma segment Perl_yylex -#endif int Perl_yylex(pTHX) { @@ -4738,7 +4761,7 @@ Perl_yylex(pTHX) char *d; STRLEN len; bool bof = FALSE; - const bool saw_infix_sigil = PL_parser->saw_infix_sigil; + const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil); U8 formbrack = 0; U32 fake_eof = 0; @@ -4760,11 +4783,9 @@ Perl_yylex(pTHX) } ); switch (PL_lex_state) { -#ifdef COMMENTARY - case LEX_NORMAL: /* Some compilers will produce faster */ - case LEX_INTERPNORMAL: /* code if we comment these out. */ + case LEX_NORMAL: + case LEX_INTERPNORMAL: break; -#endif /* when we've already built the next token, just pull it out of the queue */ case LEX_KNOWNEXT: @@ -5022,6 +5043,7 @@ Perl_yylex(pTHX) case LEX_INTERPEND: if (PL_lex_dojoin) { + const U8 dojoin_was = PL_lex_dojoin; PL_lex_dojoin = FALSE; PL_lex_state = LEX_INTERPCONCAT; #ifdef PERL_MAD @@ -5032,7 +5054,7 @@ Perl_yylex(pTHX) } #endif PL_lex_allbrackets--; - return REPORT(')'); + return REPORT(dojoin_was == 1 ? ')' : POSTJOIN); } if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl && SvEVALED(PL_lex_repl)) @@ -5656,7 +5678,6 @@ Perl_yylex(pTHX) DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } ); OPERATOR('-'); /* unary minus */ } - PL_last_uni = PL_oldbufptr; switch (tmp) { case 'r': ftst = OP_FTEREAD; break; case 'w': ftst = OP_FTEWRITE; break; @@ -5695,6 +5716,7 @@ Perl_yylex(pTHX) break; } if (ftst) { + PL_last_uni = PL_oldbufptr; PL_last_lop_op = (OPCODE)ftst; DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw file test %c\n", (int)tmp); @@ -5723,6 +5745,20 @@ Perl_yylex(pTHX) else if (*s == '>') { s++; s = SKIPSPACE1(s); + if (FEATURE_POSTDEREF_IS_ENABLED && ( + ((*s == '$' || *s == '&') && s[1] == '*') + ||(*s == '$' && s[1] == '#' && s[2] == '*') + ||((*s == '@' || *s == '%') && strchr("*[{", s[1])) + ||(*s == '*' && (s[1] == '*' || s[1] == '{')) + )) + { + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__POSTDEREF), + "Postfix dereference is experimental" + ); + PL_expect = XPOSTDEREF; + TOKEN(ARROW); + } if (isIDFIRST_lazy_if(s,UTF)) { s = force_word(s,METHOD,FALSE,TRUE); TOKEN(ARROW); @@ -5773,8 +5809,9 @@ Perl_yylex(pTHX) } case '*': + if (PL_expect == XPOSTDEREF) POSTDEREF('*'); if (PL_expect != XOPERATOR) { - s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); + s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); PL_expect = XOPERATOR; force_ident(PL_tokenbuf, '*'); if (!*PL_tokenbuf) @@ -5800,6 +5837,7 @@ Perl_yylex(pTHX) Mop(OP_MULTIPLY); case '%': + { if (PL_expect == XOPERATOR) { if (s[1] == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) @@ -5808,16 +5846,22 @@ Perl_yylex(pTHX) PL_parser->saw_infix_sigil = 1; Mop(OP_MODULO); } + else if (PL_expect == XPOSTDEREF) POSTDEREF('%'); PL_tokenbuf[0] = '%'; - s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, + s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); + pl_yylval.ival = 0; if (!PL_tokenbuf[1]) { PREREF('%'); } + if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { + if (*s == '[') + PL_tokenbuf[0] = '@'; + } PL_expect = XOPERATOR; force_ident_maybe_lex('%'); TERM('%'); - + } case '^': if (!PL_lex_allbrackets && PL_lex_fakeeof >= (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) @@ -5905,7 +5949,7 @@ Perl_yylex(pTHX) } sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0); if (*d == '(') { - d = scan_str(d,TRUE,TRUE,FALSE, FALSE); + d = scan_str(d,TRUE,TRUE,FALSE,FALSE,NULL); COPLINE_SET_FROM_MULTI_END; if (!d) { /* MUST advance bufptr here to avoid bogus @@ -6048,6 +6092,7 @@ Perl_yylex(pTHX) TOKEN(0); s++; if (PL_lex_brackets <= 0) + /* diag_listed_as: Unmatched right %s bracket */ yyerror("Unmatched right square bracket"); else --PL_lex_brackets; @@ -6226,6 +6271,7 @@ Perl_yylex(pTHX) rightbracket: s++; if (PL_lex_brackets <= 0) + /* diag_listed_as: Unmatched right %s bracket */ yyerror("Unmatched right curly bracket"); else PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; @@ -6277,6 +6323,7 @@ Perl_yylex(pTHX) } TOKEN(';'); case '&': + if (PL_expect == XPOSTDEREF) POSTDEREF('&'); s++; if (*s++ == '&') { if (!PL_lex_allbrackets && PL_lex_fakeeof >= @@ -6305,7 +6352,7 @@ Perl_yylex(pTHX) } PL_tokenbuf[0] = '&'; - s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1, + s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE); if (PL_tokenbuf[1]) { PL_expect = XOPERATOR; @@ -6535,10 +6582,17 @@ Perl_yylex(pTHX) return deprecate_commaless_var_list(); } } + else if (PL_expect == XPOSTDEREF) { + if (s[1] == '#') { + s++; + POSTDEREF(DOLSHARP); + } + POSTDEREF('$'); + } if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) { PL_tokenbuf[0] = '@'; - s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, + s = scan_ident(s + 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); if (PL_expect == XOPERATOR) no_op("Array length", s); @@ -6550,7 +6604,7 @@ Perl_yylex(pTHX) } PL_tokenbuf[0] = '$'; - s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, + s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); if (PL_expect == XOPERATOR) no_op("Scalar", s); @@ -6668,8 +6722,10 @@ Perl_yylex(pTHX) case '@': if (PL_expect == XOPERATOR) no_op("Array", s); + else if (PL_expect == XPOSTDEREF) POSTDEREF('@'); PL_tokenbuf[0] = '@'; - s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); + s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); + pl_yylval.ival = 0; if (!PL_tokenbuf[1]) { PREREF('@'); } @@ -6682,18 +6738,7 @@ Perl_yylex(pTHX) /* Warn about @ where they meant $. */ if (*s == '[' || *s == '{') { if (ckWARN(WARN_SYNTAX)) { - const char *t = s + 1; - while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t))) - t += UTF ? UTF8SKIP(t) : 1; - if (*t == '}' || *t == ']') { - t++; - PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ - /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Scalar value %"UTF8f" better written as $%"UTF8f, - UTF8fARG(UTF, t-PL_bufptr, PL_bufptr), - UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1)); - } + S_check_scalar_slice(aTHX_ s); } } } @@ -6809,7 +6854,7 @@ Perl_yylex(pTHX) TERM(THING); case '\'': - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); COPLINE_SET_FROM_MULTI_END; DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { @@ -6825,7 +6870,7 @@ Perl_yylex(pTHX) TERM(sublex_start()); case '"': - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); DEBUG_T( { if (s) printbuf("### Saw string before %s\n", s); @@ -6856,18 +6901,19 @@ Perl_yylex(pTHX) TERM(sublex_start()); case '`': - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) missingterm(NULL); - readpipe_override(); + pl_yylval.ival = OP_BACKTICK; TERM(sublex_start()); case '\\': s++; - if (PL_lex_inwhat && isDIGIT(*s)) + if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr + && isDIGIT(*s)) Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", *s, *s); if (PL_expect == XOPERATOR) @@ -6964,8 +7010,10 @@ Perl_yylex(pTHX) anydelim = word_takes_any_delimeter(PL_tokenbuf, len); /* x::* is just a word, unless x is "CORE" */ - if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) + if (!anydelim && *s == ':' && s[1] == ':') { + if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE; goto just_a_word; + } d = s; while (d < PL_bufend && isSPACE(*d)) @@ -7064,7 +7112,8 @@ Perl_yylex(pTHX) if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) { CV *cv; if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, - UTF ? SVf_UTF8 : 0, SVt_PVCV)) && + (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL, + SVt_PVCV)) && (cv = GvCVu(gv))) { if (GvIMPORTED_CV(gv)) @@ -7074,9 +7123,14 @@ Perl_yylex(pTHX) } if (!ogv && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf, - UTF ? -(I32)len : (I32)len, FALSE)) && - (gv = *gvp) && isGV_with_GP(gv) && - GvCVu(gv) && GvIMPORTED_CV(gv)) + len, FALSE)) && + (gv = *gvp) && ( + isGV_with_GP(gv) + ? GvCVu(gv) && GvIMPORTED_CV(gv) + : SvPCS_IMPORTED(gv) + && (gv_init(gv, PL_globalstash, PL_tokenbuf, + len, 0), 1) + )) { ogv = gv; } @@ -7099,7 +7153,7 @@ Perl_yylex(pTHX) } gv = NULL; gvp = 0; - if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ + if (hgv && tmp != KEY_x) /* never ambiguous */ Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous call resolved as CORE::%s(), " "qualify as such or use &", @@ -7395,7 +7449,7 @@ Perl_yylex(pTHX) pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS, pl_yylval.opval); else { - pl_yylval.opval->op_private = OPpCONST_FOLDED; + pl_yylval.opval->op_private = 0; pl_yylval.opval->op_folded = 1; pl_yylval.opval->op_flags |= OPf_SPECIAL; } @@ -7555,8 +7609,13 @@ Perl_yylex(pTHX) while (isLOWER(*d)) d++; if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0)) + { + /* PL_warn_reserved is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, PL_tokenbuf); + GCC_DIAG_RESTORE; + } } } } @@ -7705,8 +7764,8 @@ Perl_yylex(pTHX) } goto just_a_word; - case KEY_CORE: - if (*s == ':' && s[1] == ':') { + case_KEY_CORE: + { STRLEN olen = len; d = s; s += 2; @@ -7730,7 +7789,6 @@ Perl_yylex(pTHX) orig_keyword = tmp; goto reserved_word; } - goto just_a_word; case KEY_abs: UNI(OP_ABS); @@ -7961,9 +8019,9 @@ Perl_yylex(pTHX) strnEQ(p, "our", 3) && isSPACE(*(p + 3))) p += 3; p = PEEKSPACE(p); + /* skip optional package name, as in "for my abc $x (..)" */ if (isIDFIRST_lazy_if(p,UTF)) { - p = scan_ident(p, PL_bufend, - PL_tokenbuf, sizeof PL_tokenbuf, TRUE); + p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); p = PEEKSPACE(p); } if (*p != '$') @@ -8100,7 +8158,7 @@ Perl_yylex(pTHX) case KEY_glob: LOP( - orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB, + orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB, XTERM ); @@ -8333,7 +8391,7 @@ Perl_yylex(pTHX) LOP(OP_PIPE_OP,XTERM); case KEY_q: - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); COPLINE_SET_FROM_MULTI_END; if (!s) missingterm(NULL); @@ -8345,7 +8403,7 @@ Perl_yylex(pTHX) case KEY_qw: { OP *words = NULL; - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); COPLINE_SET_FROM_MULTI_END; if (!s) missingterm(NULL); @@ -8396,7 +8454,7 @@ Perl_yylex(pTHX) } case KEY_qq: - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); if (!s) missingterm(NULL); pl_yylval.ival = OP_STRINGIFY; @@ -8409,10 +8467,10 @@ Perl_yylex(pTHX) TERM(sublex_start()); case KEY_qx: - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); if (!s) missingterm(NULL); - readpipe_override(); + pl_yylval.ival = OP_BACKTICK; TERM(sublex_start()); case KEY_return: @@ -8726,7 +8784,7 @@ Perl_yylex(pTHX) /* Look for a prototype */ if (*s == '(') { - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); COPLINE_SET_FROM_MULTI_END; if (!s) Perl_croak(aTHX_ "Prototype not terminated"); @@ -8941,9 +8999,6 @@ Perl_yylex(pTHX) } }} } -#ifdef __SC__ -#pragma segment Main -#endif /* S_pending_ident @@ -8993,10 +9048,14 @@ S_pending_ident(pTHX) tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0); } else { - if (has_colon) + if (has_colon) { + /* PL_no_myglob is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); yyerror_pv(Perl_form(aTHX_ PL_no_myglob, PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf), UTF ? SVf_UTF8 : 0); + GCC_DIAG_RESTORE; + } pl_yylval.opval = newOP(OP_PADANY, 0); pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, @@ -9188,7 +9247,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, newSVpvs(":full"), newSVpvs(":short"), NULL); - SPAGAIN; + assert(sp == PL_stack_sp); table = GvHV(PL_hintgv); if (table && (PL_hints & HINT_LOCALIZE_HH) @@ -9349,14 +9408,16 @@ S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN } STATIC char * -S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni) +S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) { dVAR; - char *bracket = NULL; + I32 herelines = PL_parser->herelines; + SSize_t bracket = -1; char funny = *s++; char *d = dest; char * const e = d + destlen - 3; /* two-character token, ending NUL */ bool is_utf8 = cBOOL(UTF); + I32 orig_copline = 0, tmp_copline = 0; PERL_ARGS_ASSERT_SCAN_IDENT; @@ -9395,10 +9456,12 @@ S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck } /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */ if (*s == '{') { - bracket = s; + bracket = s - SvPVX(PL_linestr); s++; - while (s < send && SPACE_OR_TAB(*s)) - s++; + orig_copline = CopLINE(PL_curcop); + if (s < PL_bufend && isSPACE(*s)) { + s = PEEKSPACE(s); + } } /* Is the byte 'd' a legal single character identifier name? 'u' is true @@ -9417,9 +9480,13 @@ S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck || (((U8)(d)) <= 8 && (d) != 0) \ || (((U8)(d)) == 13)))) \ || (((U8)(d)) == toCTRL('?'))) - if (s < send + if (s < PL_bufend && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8))) { + if ( isCNTRL_A((U8)*s) ) { + deprecate("literal control characters in variable names"); + } + if (is_utf8) { const STRLEN skip = UTF8SKIP(s); STRLEN i; @@ -9440,9 +9507,9 @@ S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck /* Warn about ambiguous code after unary operators if {...} notation isn't used. There's no difference in ambiguity; it's merely a heuristic about when not to warn. */ - else if (ck_uni && !bracket) + else if (ck_uni && bracket == -1) check_uni(); - if (bracket) { + if (bracket != -1) { /* If we were processing {...} notation then... */ if (isIDFIRST_lazy_if(d,is_utf8)) { /* if it starts as a valid identifier, assume that it is one. @@ -9451,18 +9518,23 @@ S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck d += is_utf8 ? UTF8SKIP(d) : 1; parse_ident(&s, &d, e, 1, is_utf8); *d = '\0'; - while (s < send && SPACE_OR_TAB(*s)) - s++; + tmp_copline = CopLINE(PL_curcop); + if (s < PL_bufend && isSPACE(*s)) { + s = PEEKSPACE(s); + } if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { /* ${foo[0]} and ${foo{bar}} notation. */ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) { const char * const brack = (const char *) ((*s == '[') ? "[...]" : "{...}"); + orig_copline = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, tmp_copline); /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); + CopLINE_set(PL_curcop, orig_copline); } bracket++; PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); @@ -9484,9 +9556,12 @@ S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck *d = '\0'; } - while (s < send && SPACE_OR_TAB(*s)) - s++; - + if ( !tmp_copline ) + tmp_copline = CopLINE(PL_curcop); + if (s < PL_bufend && isSPACE(*s)) { + s = PEEKSPACE(s); + } + /* Expect to find a closing } after consuming any trailing whitespace. */ if (*s == '}') { @@ -9504,16 +9579,21 @@ S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) ); if (funny == '#') funny = '@'; + orig_copline = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, tmp_copline); Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf, funny, tmp, funny, tmp); + CopLINE_set(PL_curcop, orig_copline); } } } else { /* Didn't find the closing } at the point we expected, so restore state such that the next thing to process is the opening { and */ - s = bracket; /* let the parser handle it */ + s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */ + CopLINE_set(PL_curcop, orig_copline); + PL_parser->herelines = herelines; *dest = '\0'; } } @@ -9607,6 +9687,7 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c)); } else if (c == 'a') { + /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */ yyerror("Regexp modifier \"/a\" may appear a maximum of twice"); } else { @@ -9634,7 +9715,7 @@ S_scan_pat(pTHX_ char *start, I32 type) PERL_ARGS_ASSERT_SCAN_PAT; s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING), - TRUE /* look for escaped bracketed metas */ ); + TRUE /* look for escaped bracketed metas */, NULL); if (!s) { const char * const delimiter = skipspace(start); @@ -9722,19 +9803,19 @@ S_scan_subst(pTHX_ char *start) #ifdef PERL_MAD char *modstart; #endif + char *t; PERL_ARGS_ASSERT_SCAN_SUBST; pl_yylval.ival = OP_NULL; s = scan_str(start,!!PL_madskills,FALSE,FALSE, - TRUE /* look for escaped bracketed metas */ ); + TRUE /* look for escaped bracketed metas */, &t); if (!s) Perl_croak(aTHX_ "Substitution pattern not terminated"); - if (s[-1] == PL_multi_open) - s--; + s = t; #ifdef PERL_MAD if (PL_madskills) { CURMAD('q', PL_thisopen); @@ -9747,7 +9828,7 @@ S_scan_subst(pTHX_ char *start) first_start = PL_multi_start; first_line = CopLINE(PL_curcop); - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); if (!s) { if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); @@ -9834,17 +9915,17 @@ S_scan_trans(pTHX_ char *start) #ifdef PERL_MAD char *modstart; #endif + char *t; PERL_ARGS_ASSERT_SCAN_TRANS; pl_yylval.ival = OP_NULL; - s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,&t); if (!s) Perl_croak(aTHX_ "Transliteration pattern not terminated"); - if (s[-1] == PL_multi_open) - s--; + s = t; #ifdef PERL_MAD if (PL_madskills) { CURMAD('q', PL_thisopen); @@ -9855,7 +9936,7 @@ S_scan_trans(pTHX_ char *start) } #endif - s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); if (!s) { if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); @@ -10308,7 +10389,7 @@ S_scan_inputsymbol(pTHX_ char *start) if (d - PL_tokenbuf != len) { pl_yylval.ival = OP_GLOB; - s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE); + s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,NULL); if (!s) Perl_croak(aTHX_ "Glob not terminated"); return s; @@ -10316,7 +10397,6 @@ S_scan_inputsymbol(pTHX_ char *start) else { bool readline_overriden = FALSE; GV *gv_readline; - GV **gvp; /* we're in a filehandle read situation */ d = PL_tokenbuf; @@ -10326,12 +10406,7 @@ S_scan_inputsymbol(pTHX_ char *start) /* Check whether readline() is overriden */ gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV); - if ((gv_readline - && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) - || - ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE)) - && (gv_readline = *gvp) && isGV_with_GP(gv_readline) - && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))) + if ((gv_readline = gv_override("readline",8))) readline_overriden = TRUE; /* if <$fh>, create the ops to turn the variable into a @@ -10414,6 +10489,11 @@ intro_sym: deprecate_escaped_meta issue a deprecation warning for cer- tain paired metacharacters that appear escaped within it + delimp if non-null, this is set to the position of + the closing delimiter, or just after it if + the closing and opening delimiters differ + (i.e., the opening delimiter of a substitu- + tion replacement) returns: position to continue reading from buffer side-effects: multi_start, multi_close, lex_repl or lex_stuff, and updates the read buffer. @@ -10455,7 +10535,7 @@ intro_sym: STATIC char * S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, - bool deprecate_escaped_meta + bool deprecate_escaped_meta, char **delimp ) { dVAR; @@ -10882,6 +10962,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, PL_sublex_info.repl = sv; else PL_lex_stuff = sv; + if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s; return s; } @@ -11433,9 +11514,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) return oldsavestack_ix; } -#ifdef __SC__ -#pragma segment Perl_yylex -#endif static int S_yywarn(pTHX_ const char *const s, U32 flags) { @@ -11567,9 +11645,6 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) PL_in_my_stash = NULL; return 0; } -#ifdef __SC__ -#pragma segment Main -#endif STATIC char* S_swallow_bom(pTHX_ U8 *s) @@ -11886,7 +11961,7 @@ Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv) /* Append native character for the rev point */ tmpend = uvchr_to_utf8(tmpbuf, rev); sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - if (!NATIVE_IS_INVARIANT(rev)) + if (!UVCHR_IS_INVARIANT(rev)) SvUTF8_on(sv); if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1])) s = ++pos;