X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8d1e72f0f234299a86ddd5ce728d7cff6b44a547..ee67f2540868d78287befae45cd503f1cf44911a:/toke.c diff --git a/toke.c b/toke.c index d54e79e..4fcc45a 100644 --- a/toke.c +++ b/toke.c @@ -38,7 +38,6 @@ Individual members of C have their own documentation. #include "EXTERN.h" #define PERL_IN_TOKE_C #include "perl.h" -#include "dquote_inline.h" #include "invlist_inline.h" #define new_constant(a,b,c,d,e,f,g, h) \ @@ -95,6 +94,7 @@ Individual members of C have their own documentation. && ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen) static const char* const ident_too_long = "Identifier too long"; +static const char* const ident_var_zero_multi_digit = "Numeric variables with more than one digit may not start with '0'"; # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke] @@ -147,6 +147,15 @@ static const char* const ident_too_long = "Identifier too long"; #define LEX_INTERPCONST 2 /* NOT USED */ #define LEX_FORMLINE 1 /* expecting a format line */ +/* returned to yyl_try() to request it to retry the parse loop, expected to only + be returned directly by yyl_fake_eof(), but functions that call yyl_fake_eof() + can also return it. + + yylex (aka Perl_yylex) returns 0 on EOF rather than returning -1, + other token values are 258 or higher (see perly.h), so -1 should be + a safe value here. +*/ +#define YYL_RETRY (-1) #ifdef DEBUGGING static const char* const lex_state_names[] = { @@ -196,8 +205,10 @@ static const char* const lex_state_names[] = { * Aop : addition-level operator * AopNOASSIGN : addition-level operator that is never part of .= * Mop : multiplication-level operator - * Eop : equality-testing operator - * Rop : relational operator <= != gt + * ChEop : chaining equality-testing operator + * NCEop : non-chaining comparison operator at equality precedence + * ChRop : chaining relational operator <= != gt + * NCRop : non-chaining relational operator isa * * Also see LOP and lop() below. */ @@ -227,15 +238,17 @@ static const char* const lex_state_names[] = { #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP)) #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP)) #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \ - REPORT('~') + REPORT(PERLY_TILDE) #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP)) #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP)) #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP)) #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP)) #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP)) -#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP)) -#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP)) +#define ChEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHEQOP)) +#define NCEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCEQOP)) +#define ChRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHRELOP)) +#define NCRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCRELOP)) /* This bit of chicanery makes a unary function followed by * a parenthesis into a function with one argument, highest precedence. @@ -303,7 +316,6 @@ struct code { static const struct code no_code = { NULL, NULL, NULL, NULL, NULL, 0, FALSE }; - #ifdef DEBUGGING /* how to interpret the pl_yylval associated with the token */ @@ -315,6 +327,9 @@ enum token_type { TOKENTYPE_OPVAL }; +#define DEBUG_TOKEN(Type, Name) \ + { Name, TOKENTYPE_##Type, #Name } + static struct debug_tokens { const int token; enum token_type type; @@ -330,6 +345,8 @@ static struct debug_tokens { { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" }, { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" }, { BITOROP, TOKENTYPE_OPNUM, "BITOROP" }, + { CHEQOP, TOKENTYPE_OPNUM, "CHEQOP" }, + { CHRELOP, TOKENTYPE_OPNUM, "CHRELOP" }, { COLONATTR, TOKENTYPE_NONE, "COLONATTR" }, { CONTINUE, TOKENTYPE_NONE, "CONTINUE" }, { DEFAULT, TOKENTYPE_NONE, "DEFAULT" }, @@ -340,7 +357,6 @@ static struct debug_tokens { { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" }, { ELSE, TOKENTYPE_NONE, "ELSE" }, { ELSIF, TOKENTYPE_IVAL, "ELSIF" }, - { EQOP, TOKENTYPE_OPNUM, "EQOP" }, { FOR, TOKENTYPE_IVAL, "FOR" }, { FORMAT, TOKENTYPE_NONE, "FORMAT" }, { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" }, @@ -363,11 +379,31 @@ static struct debug_tokens { { METHOD, TOKENTYPE_OPVAL, "METHOD" }, { MULOP, TOKENTYPE_OPNUM, "MULOP" }, { MY, TOKENTYPE_IVAL, "MY" }, + { NCEQOP, TOKENTYPE_OPNUM, "NCEQOP" }, + { NCRELOP, TOKENTYPE_OPNUM, "NCRELOP" }, { NOAMP, TOKENTYPE_NONE, "NOAMP" }, { NOTOP, TOKENTYPE_NONE, "NOTOP" }, { OROP, TOKENTYPE_IVAL, "OROP" }, { OROR, TOKENTYPE_NONE, "OROR" }, { PACKAGE, TOKENTYPE_NONE, "PACKAGE" }, + DEBUG_TOKEN (IVAL, PERLY_AMPERSAND), + DEBUG_TOKEN (IVAL, PERLY_BRACE_CLOSE), + DEBUG_TOKEN (IVAL, PERLY_BRACE_OPEN), + DEBUG_TOKEN (IVAL, PERLY_BRACKET_CLOSE), + DEBUG_TOKEN (IVAL, PERLY_BRACKET_OPEN), + DEBUG_TOKEN (IVAL, PERLY_COLON), + DEBUG_TOKEN (IVAL, PERLY_COMMA), + DEBUG_TOKEN (IVAL, PERLY_DOT), + DEBUG_TOKEN (IVAL, PERLY_EQUAL_SIGN), + DEBUG_TOKEN (IVAL, PERLY_EXCLAMATION_MARK), + DEBUG_TOKEN (IVAL, PERLY_MINUS), + DEBUG_TOKEN (IVAL, PERLY_PAREN_OPEN), + DEBUG_TOKEN (IVAL, PERLY_PERCENT_SIGN), + DEBUG_TOKEN (IVAL, PERLY_PLUS), + DEBUG_TOKEN (IVAL, PERLY_QUESTION_MARK), + DEBUG_TOKEN (IVAL, PERLY_SEMICOLON), + DEBUG_TOKEN (IVAL, PERLY_SNAIL), + DEBUG_TOKEN (IVAL, PERLY_TILDE), { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" }, { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" }, { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, @@ -380,7 +416,6 @@ static struct debug_tokens { { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" }, { QWLIST, TOKENTYPE_OPVAL, "QWLIST" }, { REFGEN, TOKENTYPE_NONE, "REFGEN" }, - { RELOP, TOKENTYPE_OPNUM, "RELOP" }, { REQUIRE, TOKENTYPE_NONE, "REQUIRE" }, { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" }, { SIGSUB, TOKENTYPE_NONE, "SIGSUB" }, @@ -401,6 +436,8 @@ static struct debug_tokens { { 0, TOKENTYPE_NONE, NULL } }; +#undef DEBUG_TOKEN + /* dump the returned token in rv, plus any optional arg in pl_yylval */ STATIC int @@ -1011,7 +1048,6 @@ function is more convenient. void Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags) { - dVAR; char *bufptr; PERL_ARGS_ASSERT_LEX_STUFF_PVN; if (flags & ~(LEX_STUFF_UTF8)) @@ -1443,7 +1479,6 @@ is encountered, an exception is generated. I32 Perl_lex_peek_unichar(pTHX_ U32 flags) { - dVAR; char *s, *bufend; if (flags & ~(LEX_KEEP_PREVIOUS)) Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar"); @@ -2015,20 +2050,25 @@ S_force_next(pTHX_ I32 type) static int S_postderef(pTHX_ int const funny, char const next) { - assert(funny == DOLSHARP || memCHRs("$@%&*", funny)); + assert(funny == DOLSHARP + || memCHRs("$@%&*", funny) + || funny == PERLY_SNAIL + || funny == PERLY_PERCENT_SIGN + || funny == PERLY_AMPERSAND + ); if (next == '*') { PL_expect = XOPERATOR; if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { - assert('@' == funny || '$' == funny || DOLSHARP == funny); + assert(PERLY_SNAIL == funny || '$' == funny || DOLSHARP == funny); PL_lex_state = LEX_INTERPEND; - if ('@' == funny) + if (PERLY_SNAIL == funny) force_next(POSTJOIN); } force_next(next); PL_bufptr+=2; } else { - if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL + if (PERLY_SNAIL == funny && PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) PL_lex_dojoin = 2; PL_expect = XOPERATOR; @@ -2044,11 +2084,11 @@ Perl_yyunlex(pTHX) if (yyc != YYEMPTY) { if (yyc) { NEXTVAL_NEXTTOKE = PL_parser->yylval; - if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) { + if (yyc == PERLY_BRACE_OPEN || yyc == HASHBRACK || yyc == PERLY_BRACKET_OPEN) { PL_lex_allbrackets--; PL_lex_brackets--; yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16); - } else if (yyc == '('/*)*/) { + } else if (yyc == PERLY_PAREN_OPEN) { PL_lex_allbrackets--; yyc |= (2<<24); } @@ -2156,8 +2196,8 @@ S_force_ident(pTHX_ const char *s, int kind) (PL_in_eval ? GV_ADDMULTI : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), kind == '$' ? SVt_PV : - kind == '@' ? SVt_PVAV : - kind == '%' ? SVt_PVHV : + kind == PERLY_SNAIL ? SVt_PVAV : + kind == PERLY_PERCENT_SIGN ? SVt_PVHV : SVt_PVGV ); } @@ -2586,6 +2626,64 @@ S_sublex_done(pTHX) } } +HV * +Perl_load_charnames(pTHX_ SV * char_name, const char * context, + const STRLEN context_len, const char ** error_msg) +{ + /* Load the official _charnames module if not already there. The + * parameters are just to give info for any error messages generated: + * char_name a name to look up which is the reason for loading this + * context 'char_name' in the context in the input in which it appears + * context_len how many bytes 'context' occupies + * error_msg *error_msg will be set to any error + * + * Returns the ^H table if success; otherwise NULL */ + + unsigned int i; + HV * table; + SV **cvp; + SV * res; + + PERL_ARGS_ASSERT_LOAD_CHARNAMES; + + /* This loop is executed 1 1/2 times. On the first time through, if it + * isn't already loaded, try loading it, and iterate just once to see if it + * worked. */ + for (i = 0; i < 2; i++) { + table = GvHV(PL_hintgv); /* ^H */ + + if ( table + && (PL_hints & HINT_LOCALIZE_HH) + && (cvp = hv_fetchs(table, "charnames", FALSE)) + && SvOK(*cvp)) + { + return table; /* Quit if already loaded */ + } + + if (i == 0) { + Perl_load_module(aTHX_ + 0, + newSVpvs("_charnames"), + + /* version parameter; no need to specify it, as if we get too early + * a version, will fail anyway, not being able to find 'charnames' + * */ + NULL, + newSVpvs(":full"), + newSVpvs(":short"), + NULL); + } + } + + /* Here, it failed; new_constant will give appropriate error messages */ + *error_msg = NULL; + res = new_constant( NULL, 0, "charnames", char_name, NULL, + context, context_len, error_msg); + SvREFCNT_dec(res); + + return NULL; +} + STATIC SV* S_get_and_check_backslash_N_name_wrapper(pTHX_ const char* s, const char* const e) { @@ -2624,41 +2722,54 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s, * 'is_utf8' is TRUE if we know we want the result to be UTF-8 even if it * doesn't have to be. */ + SV* char_name; SV* res; HV * table; SV **cvp; SV *cv; SV *rv; HV *stash; - const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */ - dVAR; + + /* Points to the beginning of the \N{... so that any messages include the + * context of what's failing*/ + const char* context = s - 3; + STRLEN context_len = e - context + 1; /* include all of \N{...} */ + PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME; assert(e >= s); assert(s > (char *) 3); - res = newSVpvn_flags(s, e - s, (is_utf8) ? SVf_UTF8 : 0); + char_name = newSVpvn_flags(s, e - s, (is_utf8) ? SVf_UTF8 : 0); - if (!SvCUR(res)) { - SvREFCNT_dec_NN(res); + if (!SvCUR(char_name)) { + SvREFCNT_dec_NN(char_name); /* diag_listed_as: Unknown charname '%s' */ *error_msg = Perl_form(aTHX_ "Unknown charname ''"); return NULL; } - res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr, - /* include the <}> */ - e - backslash_ptr + 1, error_msg); - if (! SvPOK(res)) { - SvREFCNT_dec_NN(res); + /* Autoload the charnames module */ + + table = load_charnames(char_name, context, context_len, error_msg); + if (table == NULL) { + return NULL; + } + + *error_msg = NULL; + res = new_constant( NULL, 0, "charnames", char_name, NULL, + context, context_len, error_msg); + if (*error_msg) { + *error_msg = Perl_form(aTHX_ "Unknown charname '%s'", SvPVX(char_name)); + + SvREFCNT_dec(res); return NULL; } /* See if the charnames handler is the Perl core's, and if so, we can skip * the validation needed for a user-supplied one, as Perl's does its own * validation. */ - table = GvHV(PL_hintgv); /* ^H */ cvp = hv_fetchs(table, "charnames", FALSE); if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv), SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL)) @@ -2755,7 +2866,7 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s, *error_msg = Perl_form(aTHX_ "charnames alias definitions may not contain trailing " "white-space; marked by <-- HERE in %.*s<-- HERE %.*s", - (int)(s - backslash_ptr + 1), backslash_ptr, + (int)(s - context + 1), context, (int)(e - s + 1), s + 1); return NULL; } @@ -2775,7 +2886,7 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s, immediately after '%s' */ *error_msg = Perl_form(aTHX_ "Malformed UTF-8 returned by %.*s immediately after '%.*s'", - (int) (e - backslash_ptr + 1), backslash_ptr, + (int) context_len, context, (int) ((char *) first_bad_char_loc - str), str); return NULL; } @@ -2791,7 +2902,7 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s, in \N{%s} */ *error_msg = Perl_form(aTHX_ "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s", - (int)(s - backslash_ptr + 1), backslash_ptr, + (int)(s - context + 1), context, (int)(e - s + 1), s + 1); return NULL; } @@ -2803,7 +2914,7 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s, *error_msg = Perl_form(aTHX_ "charnames alias definitions may not contain a sequence of " "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s", - (int)(s - backslash_ptr + 1), backslash_ptr, + (int)(s - context + 1), context, (int)(e - s + 1), s + 1); return NULL; } @@ -3534,15 +3645,18 @@ S_scan_const(pTHX_ char *start) case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': { - I32 flags = PERL_SCAN_SILENT_ILLDIGIT; + I32 flags = PERL_SCAN_SILENT_ILLDIGIT + | PERL_SCAN_NOTIFY_ILLDIGIT; STRLEN len = 3; - uv = grok_oct(s, &len, &flags, NULL); - s += len; - if (len < 3 && s < send && isDIGIT(*s) + uv = grok_oct(s, &len, &flags, NULL); + s += len; + if ( (flags & PERL_SCAN_NOTIFY_ILLDIGIT) + && s < send + && isDIGIT(*s) /* like \08, \178 */ && ckWARN(WARN_MISC)) { - Perl_warner(aTHX_ packWARN(WARN_MISC), - "%s", form_short_octal_warning(s, len)); + Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", + form_alien_digit_msg(8, len, s, send, UTF, FALSE)); } } goto NUM_ESCAPE_INSERT; @@ -3745,13 +3859,23 @@ S_scan_const(pTHX_ char *start) } else { /* Not a pattern: convert the hex to string */ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES - | PERL_SCAN_SILENT_ILLDIGIT - | PERL_SCAN_DISALLOW_PREFIX; + | PERL_SCAN_SILENT_ILLDIGIT + | PERL_SCAN_SILENT_OVERFLOW + | PERL_SCAN_DISALLOW_PREFIX; STRLEN len = e - s; + uv = grok_hex(s, &len, &flags, NULL); if (len == 0 || (len != (STRLEN)(e - s))) goto bad_NU; + if ( uv > MAX_LEGAL_CP + || (flags & PERL_SCAN_GREATER_THAN_UV_MAX)) + { + yyerror(form_cp_too_large_msg(16, s, len, 0)); + uv = 0; /* drop through to ensure range ends are + set */ + } + /* For non-tr///, if the destination is not in utf8, * unconditionally recode it to be so. This is * because \N{} implies Unicode semantics, and scalars @@ -4168,7 +4292,7 @@ S_scan_const(pTHX_ char *start) } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') { type = "q"; typelen = 1; - } else { + } else { type = "qq"; typelen = 2; } @@ -4379,6 +4503,9 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) PERL_ARGS_ASSERT_INTUIT_METHOD; + if (!FEATURE_INDIRECT_IS_ENABLED) + return 0; + if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv)) return 0; if (cv && SvPOK(cv)) { @@ -4879,7 +5006,12 @@ yyl_sigvar(pTHX_ char *s) break; } - TOKEN(sigil); + switch (sigil) { + case ',': TOKEN (PERLY_COMMA); + case '@': TOKEN (PERLY_SNAIL); + case '%': TOKEN (PERLY_PERCENT_SIGN); + default: TOKEN (sigil); + } } static int @@ -4945,13 +5077,40 @@ yyl_dollar(pTHX_ char *s) if (ckWARN(WARN_SYNTAX)) { char *t = s+1; - while ( isSPACE(*t) - || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) - || *t == '$') - { - t += UTF ? UTF8SKIP(t) : 1; + while ( t < PL_bufend ) { + if (isSPACE(*t)) { + do { t += UTF ? UTF8SKIP(t) : 1; } while (t < PL_bufend && isSPACE(*t)); + /* consumed one or more space chars */ + } else if (*t == '$' || *t == '@') { + /* could be more than one '$' like $$ref or @$ref */ + do { t++; } while (t < PL_bufend && *t == '$'); + + /* could be an abigail style identifier like $ foo */ + while (t < PL_bufend && *t == ' ') t++; + + /* strip off the name of the var */ + while (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) + t += UTF ? UTF8SKIP(t) : 1; + /* consumed a varname */ + } else if (isDIGIT(*t)) { + /* deal with hex constants like 0x11 */ + if (t[0] == '0' && t[1] == 'x') { + t += 2; + while (t < PL_bufend && isXDIGIT(*t)) t++; + } else { + /* deal with decimal/octal constants like 1 and 0123 */ + do { t++; } while (isDIGIT(*t)); + if (t ($a,uc(b.$c)) */ if (PL_lex_casemods == 1 && PL_lex_inpat) - TOKEN(','); + TOKEN(PERLY_COMMA); else AopNOASSIGN(OP_CONCAT); } @@ -5402,7 +5561,7 @@ yyl_hyphen(pTHX_ char *s) if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) { s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE); DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } ); - OPERATOR('-'); /* unary minus */ + OPERATOR(PERLY_MINUS); /* unary minus */ } switch (tmp) { case 'r': ftst = OP_FTEREAD; break; @@ -5503,7 +5662,7 @@ yyl_hyphen(pTHX_ char *s) else { if (isSPACE(*s) || !isSPACE(*PL_bufptr)) check_uni(); - OPERATOR('-'); /* unary minus */ + OPERATOR(PERLY_MINUS); /* unary minus */ } } } @@ -5532,7 +5691,7 @@ yyl_plus(pTHX_ char *s) else { if (isSPACE(*s) || !isSPACE(*PL_bufptr)) check_uni(); - OPERATOR('+'); + OPERATOR(PERLY_PLUS); } } @@ -5588,13 +5747,13 @@ yyl_percent(pTHX_ char *s) Mop(OP_MODULO); } else if (PL_expect == XPOSTDEREF) - POSTDEREF('%'); + POSTDEREF(PERLY_PERCENT_SIGN); PL_tokenbuf[0] = '%'; s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); pl_yylval.ival = 0; if (!PL_tokenbuf[1]) { - PREREF('%'); + PREREF(PERLY_PERCENT_SIGN); } if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s, PL_bufend)) { @@ -5603,7 +5762,7 @@ yyl_percent(pTHX_ char *s) } PL_expect = XOPERATOR; force_ident_maybe_lex('%'); - TERM('%'); + TERM(PERLY_PERCENT_SIGN); } static int @@ -5765,7 +5924,7 @@ yyl_colon(pTHX_ char *s) : "Unterminated attribute list" ) ); if (attrs) op_free(attrs); - OPERATOR(':'); + OPERATOR(PERLY_COLON); } got_attrs: @@ -5790,7 +5949,7 @@ yyl_colon(pTHX_ char *s) } PL_lex_allbrackets--; - OPERATOR(':'); + OPERATOR(PERLY_COLON); } static int @@ -5883,7 +6042,7 @@ yyl_leftcurly(pTHX_ char *s, const U8 formbrack) const char minus = (PL_tokenbuf[0] == '-'); s = force_word(s + minus, BAREWORD, FALSE, TRUE); if (minus) - force_next('-'); + force_next(PERLY_MINUS); } } /* FALLTHROUGH */ @@ -6049,7 +6208,7 @@ yyl_leftcurly(pTHX_ char *s, const U8 formbrack) pl_yylval.ival = CopLINE(PL_curcop); PL_copline = NOLINE; /* invalidate current command line number */ - TOKEN(formbrack ? '=' : '{'); + TOKEN(formbrack ? PERLY_EQUAL_SIGN : PERLY_BRACE_OPEN); } static int @@ -6090,21 +6249,21 @@ yyl_rightcurly(pTHX_ char *s, const U8 formbrack) return yylex(); /* ignore fake brackets */ } - force_next(formbrack ? '.' : '}'); + force_next(formbrack ? PERLY_DOT : PERLY_BRACE_CLOSE); if (formbrack) LEAVE_with_name("lex_format"); if (formbrack == 2) { /* means . where arguments were expected */ - force_next(';'); + force_next(PERLY_SEMICOLON); TOKEN(FORMRBRACK); } - TOKEN(';'); + TOKEN(PERLY_SEMICOLON); } static int yyl_ampersand(pTHX_ char *s) { if (PL_expect == XPOSTDEREF) - POSTDEREF('&'); + POSTDEREF(PERLY_AMPERSAND); s++; if (*s++ == '&') { @@ -6150,9 +6309,9 @@ yyl_ampersand(pTHX_ char *s) if (PL_tokenbuf[1]) force_ident_maybe_lex('&'); else - PREREF('&'); + PREREF(PERLY_AMPERSAND); - TERM('&'); + TERM(PERLY_AMPERSAND); } static int @@ -6212,21 +6371,21 @@ yyl_bang(pTHX_ char *s) TOKEN(0); } - Eop(OP_NE); + ChEop(OP_NE); } if (tmp == '~') PMop(OP_NOT); s--; - OPERATOR('!'); + OPERATOR(PERLY_EXCLAMATION_MARK); } static int yyl_snail(pTHX_ char *s) { if (PL_expect == XPOSTDEREF) - POSTDEREF('@'); + POSTDEREF(PERLY_SNAIL); PL_tokenbuf[0] = '@'; s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); if (PL_expect == XOPERATOR) { @@ -6239,7 +6398,7 @@ yyl_snail(pTHX_ char *s) } pl_yylval.ival = 0; if (!PL_tokenbuf[1]) { - PREREF('@'); + PREREF(PERLY_SNAIL); } if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) s = skipspace(s); @@ -6258,7 +6417,7 @@ yyl_snail(pTHX_ char *s) } PL_expect = XOPERATOR; force_ident_maybe_lex('@'); - TERM('@'); + TERM(PERLY_SNAIL); } static int @@ -6297,14 +6456,12 @@ yyl_slash(pTHX_ char *s) static int yyl_leftsquare(pTHX_ char *s) { - char tmp; - if (PL_lex_brackets > 100) Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); PL_lex_brackstack[PL_lex_brackets++] = 0; PL_lex_allbrackets++; - tmp = *s++; - OPERATOR(tmp); + s++; + OPERATOR(PERLY_BRACKET_OPEN); } static int @@ -6327,7 +6484,7 @@ yyl_rightsquare(pTHX_ char *s) PL_lex_state = LEX_INTERPEND; } } - TERM(']'); + TERM(PERLY_BRACKET_CLOSE); } static int @@ -6341,7 +6498,7 @@ yyl_tilde(pTHX_ char *s) Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SMARTMATCH), "Smartmatch is experimental"); - Eop(OP_SMARTMATCH); + NCEop(OP_SMARTMATCH); } s++; if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') { @@ -6360,7 +6517,7 @@ yyl_leftparen(pTHX_ char *s) PL_expect = XTERM; s = skipspace(s); PL_lex_allbrackets++; - TOKEN('('); + TOKEN(PERLY_PAREN_OPEN); } static int @@ -6409,14 +6566,14 @@ yyl_leftpointy(pTHX_ char *s) s -= 3; TOKEN(0); } - Eop(OP_NCMP); + NCEop(OP_NCMP); } s--; if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { s -= 2; TOKEN(0); } - Rop(OP_LE); + ChRop(OP_LE); } s--; @@ -6425,7 +6582,7 @@ yyl_leftpointy(pTHX_ char *s) TOKEN(0); } - Rop(OP_LT); + ChRop(OP_LT); } static int @@ -6445,7 +6602,7 @@ yyl_rightpointy(pTHX_ char *s) s -= 2; TOKEN(0); } - Rop(OP_GE); + ChRop(OP_GE); } s--; @@ -6454,7 +6611,7 @@ yyl_rightpointy(pTHX_ char *s) TOKEN(0); } - Rop(OP_GT); + ChRop(OP_GT); } static int @@ -6473,9 +6630,10 @@ yyl_sglquote(pTHX_ char *s) } static int -yyl_dblquote(pTHX_ char *s, STRLEN len) +yyl_dblquote(pTHX_ char *s) { char *d; + STRLEN len; s = scan_str(s,FALSE,FALSE,FALSE,NULL); DEBUG_T( { if (s) @@ -6769,7 +6927,7 @@ yyl_my(pTHX_ char *s, I32 my) OPERATOR(MY); } -static int yyl_try(pTHX_ char*, STRLEN); +static int yyl_try(pTHX_ char*); static bool yyl_eol_needs_semicolon(pTHX_ char **ps) @@ -6819,7 +6977,7 @@ yyl_eol_needs_semicolon(pTHX_ char **ps) } static int -yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s, STRLEN len) +yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s) { char *d; @@ -6835,7 +6993,7 @@ yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s, STRLEN len) if (!lex_next_chunk(fake_eof)) { CopLINE_dec(PL_curcop); s = PL_bufptr; - TOKEN(';'); /* not infinite loop because rsfp is NULL now */ + TOKEN(PERLY_SEMICOLON); /* not infinite loop because rsfp is NULL now */ } CopLINE_dec(PL_curcop); s = PL_bufptr; @@ -6994,7 +7152,6 @@ yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s, STRLEN len) && !instr(s,"indir") && instr(PL_origargv[0],"perl")) { - dVAR; char **newargv; *ipathend = '\0'; @@ -7061,13 +7218,13 @@ yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s, STRLEN len) we must not do it again */ { SvPVCLEAR(PL_linestr); - PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); + PL_bufptr = PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; PL_preambled = FALSE; if (PERLDB_LINE_OR_SAVESRC) (void)gv_fetchfile(PL_origfilename); - return yyl_try(aTHX_ s, len); + return YYL_RETRY; } } } @@ -7077,10 +7234,11 @@ yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s, STRLEN len) if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { PL_lex_state = LEX_FORMLINE; force_next(FORMRBRACK); - TOKEN(';'); + TOKEN(PERLY_SEMICOLON); } - return yyl_try(aTHX_ s, len); + PL_bufptr = s; + return YYL_RETRY; } static int @@ -7377,12 +7535,12 @@ yyl_just_a_word(pTHX_ char *s, STRLEN len, I32 orig_keyword, struct code c) op_free(pl_yylval.opval), force_next(PRIVATEREF); else op_free(c.rv2cv_op), force_next(BAREWORD); pl_yylval.ival = 0; - TOKEN('&'); + TOKEN(PERLY_AMPERSAND); } /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && !c.cv) { + if ((*s == '$' || *s == '{') && !c.cv && FEATURE_INDIRECT_IS_ENABLED) { op_free(c.rv2cv_op); PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_METHOD; @@ -7466,7 +7624,7 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct case KEY___END__: if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) yyl_data_handle(aTHX); - return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s, len); + return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s); case KEY___SUB__: FUN0OP(CvCLONE(PL_compcv) @@ -7542,18 +7700,13 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct case KEY_cmp: if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) return REPORT(0); - Eop(OP_SCMP); + NCEop(OP_SCMP); case KEY_caller: UNI(OP_CALLER); case KEY_crypt: -#ifdef FCRYPT - if (!PL_cryptseen) { - PL_cryptseen = TRUE; - init_des(); - } -#endif + LOP(OP_CRYPT,XTERM); case KEY_chmod: @@ -7616,7 +7769,7 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct case KEY_eq: if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) return REPORT(0); - Eop(OP_SEQ); + ChEop(OP_SEQ); case KEY_exists: UNI(OP_EXISTS); @@ -7694,12 +7847,12 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct case KEY_gt: if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) return REPORT(0); - Rop(OP_SGT); + ChRop(OP_SGT); case KEY_ge: if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) return REPORT(0); - Rop(OP_SGE); + ChRop(OP_SGE); case KEY_grep: LOP(OP_GREPSTART, XREF); @@ -7818,7 +7971,7 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct case KEY_isa: Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental"); - Rop(OP_ISA); + NCRop(OP_ISA); case KEY_join: LOP(OP_JOIN,XTERM); @@ -7847,12 +8000,12 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct case KEY_lt: if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) return REPORT(0); - Rop(OP_SLT); + ChRop(OP_SLT); case KEY_le: if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) return REPORT(0); - Rop(OP_SLE); + ChRop(OP_SLE); case KEY_localtime: UNI(OP_LOCALTIME); @@ -7905,7 +8058,7 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct case KEY_ne: if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) return REPORT(0); - Eop(OP_SNE); + ChEop(OP_SNE); case KEY_no: s = tokenize_use(0, s); @@ -8384,7 +8537,6 @@ yyl_key_core(pTHX_ char *s, STRLEN len, struct code c) static int yyl_keylookup(pTHX_ char *s, GV *gv) { - dVAR; STRLEN len; bool anydelim; I32 key; @@ -8513,22 +8665,30 @@ yyl_keylookup(pTHX_ char *s, GV *gv) } static int -yyl_try(pTHX_ char *s, STRLEN len) +yyl_try(pTHX_ char *s) { char *d; GV *gv = NULL; + int tok; retry: switch (*s) { default: - if (UTF ? isIDFIRST_utf8_safe(s, PL_bufend) : isALNUMC(*s)) - return yyl_keylookup(aTHX_ s, gv); + if (UTF ? isIDFIRST_utf8_safe(s, PL_bufend) : isALNUMC(*s)) { + if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) + return tok; + goto retry_bufptr; + } yyl_croak_unrecognised(aTHX_ s); case 4: case 26: /* emulate EOF on ^D or ^Z */ - return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s, len); + if ((tok = yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s)) != YYL_RETRY) + return tok; + retry_bufptr: + s = PL_bufptr; + goto retry; case 0: if ((!PL_rsfp || PL_lex_inwhat) @@ -8584,7 +8744,7 @@ yyl_try(pTHX_ char *s, STRLEN len) } if (PL_minus_E) sv_catpvs(PL_linestr, - "use feature ':5." STRINGIFY(PERL_VERSION) "';"); + "use feature ':" STRINGIFY(PERL_REVISION) "." STRINGIFY(PERL_VERSION) "';"); if (PL_minus_n || PL_minus_p) { sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/); if (PL_minus_l) @@ -8629,7 +8789,9 @@ yyl_try(pTHX_ char *s, STRLEN len) update_debugger_info(PL_linestr, NULL, 0); goto retry; } - return yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s, len); + if ((tok = yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s)) != YYL_RETRY) + return tok; + goto retry_bufptr; case '\r': #ifdef PERL_STRICT_CR @@ -8645,7 +8807,7 @@ yyl_try(pTHX_ char *s, STRLEN len) case '\n': { const bool needs_semicolon = yyl_eol_needs_semicolon(aTHX_ &s); if (needs_semicolon) - TOKEN(';'); + TOKEN(PERLY_SEMICOLON); else goto retry; } @@ -8675,7 +8837,7 @@ yyl_try(pTHX_ char *s, STRLEN len) if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) TOKEN(0); s++; - OPERATOR(','); + OPERATOR(PERLY_COMMA); case ':': if (s[1] == ':') return yyl_just_a_word(aTHX_ s, 0, 0, no_code); @@ -8690,7 +8852,7 @@ yyl_try(pTHX_ char *s, STRLEN len) CLINE; s++; PL_expect = XSTATE; - TOKEN(';'); + TOKEN(PERLY_SEMICOLON); case ')': return yyl_rightparen(aTHX_ s); @@ -8714,7 +8876,7 @@ yyl_try(pTHX_ char *s, STRLEN len) case '=': if (s[1] == '=' && (s == PL_linestart || s[-1] == '\n') - && memBEGINs(s + 2, (STRLEN) (PL_bufend - s + 2), "=====")) + && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), "=====")) { s = vcs_conflict_marker(s + 7); goto retry; @@ -8730,7 +8892,7 @@ yyl_try(pTHX_ char *s, STRLEN len) s -= 2; TOKEN(0); } - Eop(OP_EQ); + ChEop(OP_EQ); } if (tmp == '>') { if (!PL_lex_allbrackets @@ -8739,7 +8901,7 @@ yyl_try(pTHX_ char *s, STRLEN len) s -= 2; TOKEN(0); } - OPERATOR(','); + OPERATOR(PERLY_COMMA); } if (tmp == '~') PMop(OP_MATCH); @@ -8803,12 +8965,12 @@ yyl_try(pTHX_ char *s, STRLEN len) pl_yylval.ival = 0; OPERATOR(ASSIGNOP); - case '!': + case '!': return yyl_bang(aTHX_ s + 1); case '<': if (s[1] == '<' && (s == PL_linestart || s[-1] == '\n') - && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<")) + && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), "<<<<<")) { s = vcs_conflict_marker(s + 7); goto retry; @@ -8817,7 +8979,7 @@ yyl_try(pTHX_ char *s, STRLEN len) case '>': if (s[1] == '>' && (s == PL_linestart || s[-1] == '\n') - && memBEGINs(s + 2, (STRLEN) (PL_bufend - s + 2), ">>>>>")) + && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), ">>>>>")) { s = vcs_conflict_marker(s + 7); goto retry; @@ -8842,7 +9004,7 @@ yyl_try(pTHX_ char *s, STRLEN len) TOKEN(0); } PL_lex_allbrackets++; - OPERATOR('?'); + OPERATOR(PERLY_QUESTION_MARK); case '.': if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack @@ -8900,7 +9062,7 @@ yyl_try(pTHX_ char *s, STRLEN len) return yyl_sglquote(aTHX_ s); case '"': - return yyl_dblquote(aTHX_ s, len); + return yyl_dblquote(aTHX_ s); case '`': return yyl_backtick(aTHX_ s); @@ -8918,13 +9080,19 @@ yyl_try(pTHX_ char *s, STRLEN len) TERM(THING); } else if ((*start == ':' && start[1] == ':') - || (PL_expect == XSTATE && *start == ':')) - return yyl_keylookup(aTHX_ s, gv); + || (PL_expect == XSTATE && *start == ':')) { + if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) + return tok; + goto retry_bufptr; + } else if (PL_expect == XSTATE) { d = start; while (d < PL_bufend && isSPACE(*d)) d++; - if (*d == ':') - return yyl_keylookup(aTHX_ s, gv); + if (*d == ':') { + if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) + return tok; + goto retry_bufptr; + } } /* avoid v123abc() or $h{v1}, allow C */ if (!isALPHA(*start) && (PL_expect == XTERM @@ -8938,14 +9106,18 @@ yyl_try(pTHX_ char *s, STRLEN len) } } } - return yyl_keylookup(aTHX_ s, gv); + if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) + return tok; + goto retry_bufptr; case 'x': if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { s++; Mop(OP_REPEAT); } - return yyl_keylookup(aTHX_ s, gv); + if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) + return tok; + goto retry_bufptr; case '_': case 'a': case 'A': @@ -8974,7 +9146,9 @@ yyl_try(pTHX_ char *s, STRLEN len) case 'X': case 'y': case 'Y': case 'z': case 'Z': - return yyl_keylookup(aTHX_ s, gv); + if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) + return tok; + goto retry_bufptr; } } @@ -9033,7 +9207,6 @@ yyl_try(pTHX_ char *s, STRLEN len) int Perl_yylex(pTHX) { - dVAR; char *s = PL_bufptr; if (UNLIKELY(PL_parser->recheck_utf8_validity)) { @@ -9114,12 +9287,12 @@ Perl_yylex(pTHX) PL_lex_state = LEX_INTERPNORMAL; if (PL_lex_dojoin) { NEXTVAL_NEXTTOKE.ival = 0; - force_next(','); + force_next(PERLY_COMMA); force_ident("\"", '$'); NEXTVAL_NEXTTOKE.ival = 0; force_next('$'); NEXTVAL_NEXTTOKE.ival = 0; - force_next((2<<24)|'('); + force_next((2<<24)|PERLY_PAREN_OPEN); NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */ force_next(FUNC); } @@ -9137,7 +9310,7 @@ Perl_yylex(pTHX) s = PL_bufptr; /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ if (!PL_lex_casemods && PL_lex_inpat) - TOKEN(','); + TOKEN(PERLY_COMMA); else AopNOASSIGN(OP_CONCAT); } @@ -9192,7 +9365,7 @@ Perl_yylex(pTHX) force_next(THING); PL_parser->lex_shared->re_eval_start = NULL; PL_expect = XTERM; - return REPORT(','); + return REPORT(PERLY_COMMA); } /* FALLTHROUGH */ @@ -9236,7 +9409,7 @@ Perl_yylex(pTHX) if (PL_lex_starts++) { /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ if (!PL_lex_casemods && PL_lex_inpat) - TOKEN(','); + TOKEN(PERLY_COMMA); else AopNOASSIGN(OP_CONCAT); } @@ -9282,7 +9455,7 @@ Perl_yylex(pTHX) expecting an operator) have been a sigil. */ bool expected_operator = (PL_expect == XOPERATOR); - int ret = yyl_try(aTHX_ s, 0); + int ret = yyl_try(aTHX_ s); switch (pl_yylval.ival) { case OP_BIT_AND: case OP_MODULO: @@ -9552,75 +9725,31 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, SV **cvp; SV *cv, *typesv; const char *why1 = "", *why2 = "", *why3 = ""; + const char * optional_colon = ":"; /* Only some messages have a colon */ + char *msg; PERL_ARGS_ASSERT_NEW_CONSTANT; /* We assume that this is true: */ - if (*key == 'c') { assert (strEQ(key, "charnames")); } assert(type || s); sv_2mortal(sv); /* Parent created it permanently */ - if (!table - || ! (PL_hints & HINT_LOCALIZE_HH) - || ! (cvp = hv_fetch(table, key, keylen, FALSE)) - || ! SvOK(*cvp)) + + if ( ! table + || ! (PL_hints & HINT_LOCALIZE_HH)) { - char *msg; - - /* Here haven't found what we're looking for. If it is charnames, - * perhaps it needs to be loaded. Try doing that before giving up */ - if (*key == 'c') { - Perl_load_module(aTHX_ - 0, - newSVpvs("_charnames"), - /* version parameter; no need to specify it, as if - * we get too early a version, will fail anyway, - * not being able to find '_charnames' */ - NULL, - newSVpvs(":full"), - newSVpvs(":short"), - NULL); - assert(sp == PL_stack_sp); - table = GvHV(PL_hintgv); - if (table - && (PL_hints & HINT_LOCALIZE_HH) - && (cvp = hv_fetch(table, key, keylen, FALSE)) - && SvOK(*cvp)) - { - goto now_ok; - } - } - if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { - msg = Perl_form(aTHX_ - "Constant(%.*s) unknown", - (int)(type ? typelen : len), - (type ? type: s)); - } - else { - why1 = "$^H{"; - why2 = key; - why3 = "} is not defined"; - report: - if (*key == 'c') { - msg = Perl_form(aTHX_ - /* The +3 is for '\N{'; -4 for that, plus '}' */ - "Unknown charname '%.*s'", (int)typelen - 4, type + 3 - ); - } - else { - msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s", - (int)(type ? typelen : len), - (type ? type: s), why1, why2, why3); - } - } - if (error_msg) { - *error_msg = msg; - } - else { - yyerror_pv(msg, UTF ? SVf_UTF8 : 0); - } - return SvREFCNT_inc_simple_NN(sv); + why1 = "unknown"; + optional_colon = ""; + goto report; } - now_ok: + + cvp = hv_fetch(table, key, keylen, FALSE); + if (!cvp || !SvOK(*cvp)) { + why1 = "$^H{"; + why2 = key; + why3 = "} is not defined"; + goto report; + } + cv = *cvp; if (!pv && s) pv = newSVpvn_flags(s, len, SVs_TEMP); @@ -9665,16 +9794,31 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, LEAVE ; POPSTACK; - if (!SvOK(res)) { - why1 = "Call to &{$^H{"; - why2 = key; - why3 = "}} did not return a defined value"; - sv = res; - (void)sv_2mortal(sv); - goto report; + if (SvOK(res)) { + return res; } - return res; + sv = res; + (void)sv_2mortal(sv); + + why1 = "Call to &{$^H{"; + why2 = key; + why3 = "}} did not return a defined value"; + + report: + + msg = Perl_form(aTHX_ "Constant(%.*s)%s %s%s%s", + (int)(type ? typelen : len), + (type ? type: s), + optional_colon, + why1, why2, why3); + if (error_msg) { + *error_msg = msg; + } + else { + yyerror_pv(msg, UTF ? SVf_UTF8 : 0); + } + return SvREFCNT_inc_simple_NN(sv); } PERL_STATIC_INLINE void @@ -9809,12 +9953,17 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) if (isSPACE(*s) || !*s) s = skipspace(s); - if (isDIGIT(*s)) { - while (isDIGIT(*s)) { - if (d >= e) - Perl_croak(aTHX_ "%s", ident_too_long); - *d++ = *s++; - } + if (isDIGIT(*s)) { /* handle $0 and $1 $2 and $10 and etc */ + bool is_zero= *s == '0' ? TRUE : FALSE; + char *digit_start= d; + *d++ = *s++; + while (s < PL_bufend && isDIGIT(*s)) { + if (d >= e) + Perl_croak(aTHX_ "%s", ident_too_long); + *d++ = *s++; + } + if (is_zero && d - digit_start > 1) + Perl_croak(aTHX_ ident_var_zero_multi_digit); } else { /* See if it is a "normal" identifier */ parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE); @@ -9866,6 +10015,19 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) } else { *d = *s++; + /* special case to handle ${10}, ${11} the same way we handle ${1} etc */ + if (isDIGIT(*d)) { + bool is_zero= *d == '0' ? TRUE : FALSE; + char *digit_start= d; + while (s < PL_bufend && isDIGIT(*s)) { + d++; + if (d >= e) + Perl_croak(aTHX_ "%s", ident_too_long); + *d= *s++; + } + if (is_zero && d - digit_start > 1) + Perl_croak(aTHX_ ident_var_zero_multi_digit); + } d[1] = '\0'; } } @@ -11209,7 +11371,7 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int /* if we allocated too much space, give some back */ if (SvCUR(sv) + 5 < SvLEN(sv)) { SvLEN_set(sv, SvCUR(sv) + 1); - SvPV_renew(sv, SvLEN(sv)); + SvPV_shrink_to_cur(sv); } /* decide whether this is the first or second quoted string we've read @@ -11235,7 +11397,7 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12. \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34 0b[01](_?[01])* binary integers - 0[0-7](_?[0-7])* octal integers + 0o?[0-7](_?[0-7])* octal integers 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats @@ -11291,6 +11453,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) NV hexfp_mult = 1.0; UV high_non_zero = 0; /* highest digit */ int non_zero_integer_digits = 0; + bool new_octal = FALSE; /* octal with "0o" prefix */ PERL_ARGS_ASSERT_SCAN_NUM; @@ -11328,7 +11491,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) "", "037777777777", "0xffffffff" }; - const char *base, *Base, *max; /* check for hex */ if (isALPHA_FOLD_EQ(s[1], 'x')) { @@ -11347,6 +11509,11 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) else { shift = 3; s++; + if (isALPHA_FOLD_EQ(*s, 'o')) { + s++; + just_zero = FALSE; + new_octal = TRUE; + } } if (*s == '_') { @@ -11354,10 +11521,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) lastub = s++; } - base = bases[shift]; - Base = Bases[shift]; - max = maxima[shift]; - /* read the rest of the number */ for (;;) { /* x is used in the overflow test, @@ -11421,7 +11584,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) n = (NV) u; Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), "Integer overflow in %s number", - base); + bases[shift]); } else u = x | b; /* add the digit to the end */ } @@ -11624,8 +11787,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } } - if (shift != 3 && !has_digs) { - /* 0x or 0b with no digits, treat it as an error. + if (!just_zero && !has_digs) { + /* 0x, 0o or 0b with no digits, treat it as an error. Originally this backed up the parse before the b or x, but that has the potential for silent changes in behaviour, like for: "0x.3" and "0x+$foo". @@ -11635,7 +11798,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if (*d) ++d; /* so the user sees the bad non-digit */ PL_bufptr = (char *)d; /* so yyerror reports the context */ yyerror(Perl_form(aTHX_ "No digits found for %s literal", - shift == 4 ? "hexadecimal" : "binary")); + bases[shift])); PL_bufptr = oldbp; } @@ -11643,7 +11806,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if (n > 4294967295.0) Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", - Base, max); + Bases[shift], + new_octal ? "0o37777777777" : maxima[shift]); sv = newSVnv(n); } else { @@ -11651,7 +11815,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if (u > 0xffffffff) Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", - Base, max); + Bases[shift], + new_octal ? "0o37777777777" : maxima[shift]); #endif sv = newSVuv(u); } @@ -11683,6 +11848,11 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) s = start + 2; break; case 3: + if (new_octal) { + *d++ = 'o'; + s = start + 2; + break; + } s = start + 1; break; case 1: @@ -12120,7 +12290,7 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) * processing unconditionally */ if (s != NULL) { - if (!yychar || (yychar == ';' && !PL_rsfp)) + if (!yychar || (yychar == PERLY_SEMICOLON && !PL_rsfp)) sv_catpvs(where_sv, "at EOF"); else if ( PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr @@ -12625,7 +12795,7 @@ look something like this: static Perl_keyword_plugin_t next_keyword_plugin; static OP *my_keyword_plugin(pTHX_ - char *keyword_plugin, STRLEN keyword_len, OP **op_ptr) + char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { if (memEQs(keyword_ptr, keyword_len, "my_new_keyword")) { @@ -12648,7 +12818,6 @@ void Perl_wrap_keyword_plugin(pTHX_ Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p) { - dVAR; PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;