X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=6f5441622ae49e80714cd2eb38adc39278e0b70f;hb=6d7fb585cd8ad83f4523191641999603aa48eb76;hp=a50f625f9516189cdc9f00bc20b62a8d7647261f;hpb=672994ceae26eaea7b543577cbf4ae1bf28d2934;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index a50f625..6f54416 100644 --- a/toke.c +++ b/toke.c @@ -26,12 +26,8 @@ #define yychar (*PL_yycharp) #define yylval (*PL_yylvalp) -static const char ident_too_long[] = - "Identifier too long"; -static const char c_without_g[] = - "Use of /c modifier is meaningless without /g"; -static const char c_in_subst[] = - "Use of /c modifier is meaningless in s///"; +static const char ident_too_long[] = "Identifier too long"; +static const char commaless_variable_list[] = "comma-less variable list"; static void restore_rsfp(pTHX_ void *f); #ifndef PERL_NO_UTF16_FILTER @@ -66,17 +62,22 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); /* #define LEX_NOTPARSING 11 is done in perl.h. */ -#define LEX_NORMAL 10 -#define LEX_INTERPNORMAL 9 -#define LEX_INTERPCASEMOD 8 -#define LEX_INTERPPUSH 7 -#define LEX_INTERPSTART 6 -#define LEX_INTERPEND 5 -#define LEX_INTERPENDMAYBE 4 -#define LEX_INTERPCONCAT 3 -#define LEX_INTERPCONST 2 -#define LEX_FORMLINE 1 -#define LEX_KNOWNEXT 0 +#define LEX_NORMAL 10 /* normal code (ie not within "...") */ +#define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */ +#define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */ +#define LEX_INTERPPUSH 7 /* starting a new sublex parse level */ +#define LEX_INTERPSTART 6 /* expecting the start of a $var */ + + /* at end of code, eg "$x" followed by: */ +#define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */ +#define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */ + +#define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of + string or after \E, $foo, etc */ +#define LEX_INTERPCONST 2 /* NOT USED */ +#define LEX_FORMLINE 1 /* expecting a format line */ +#define LEX_KNOWNEXT 0 /* next token known; just return it */ + #ifdef DEBUGGING static const char* const lex_state_names[] = { @@ -136,7 +137,7 @@ static const char* const lex_state_names[] = { */ #ifdef DEBUGGING /* Serve -DT. */ -# define REPORT(retval) tokereport(s,(int)retval) +# define REPORT(retval) tokereport((I32)retval) #else # define REPORT(retval) (retval) #endif @@ -167,25 +168,29 @@ static const char* const lex_state_names[] = { * The UNIDOR macro is for unary functions that can be followed by the // * operator (such as C). */ -#define UNI2(f,x) return ( \ - yylval.ival = f, \ - PL_expect = x, \ - PL_bufptr = s, \ - PL_last_uni = PL_oldbufptr, \ - PL_last_lop_op = f, \ - REPORT( \ - (*s == '(' || (s = skipspace(s), *s == '(') \ - ? (int)FUNC1 : (int)UNIOP))) +#define UNI2(f,x) { \ + yylval.ival = f; \ + PL_expect = x; \ + PL_bufptr = s; \ + PL_last_uni = PL_oldbufptr; \ + PL_last_lop_op = f; \ + if (*s == '(') \ + return REPORT( (int)FUNC1 ); \ + s = skipspace(s); \ + return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ + } #define UNI(f) UNI2(f,XTERM) #define UNIDOR(f) UNI2(f,XTERMORDORDOR) -#define UNIBRACK(f) return ( \ - yylval.ival = f, \ - PL_bufptr = s, \ - PL_last_uni = PL_oldbufptr, \ - REPORT( \ - (*s == '(' || (s = skipspace(s), *s == '(') \ - ? (int)FUNC1 : (int)UNIOP))) +#define UNIBRACK(f) { \ + yylval.ival = f; \ + PL_bufptr = s; \ + PL_last_uni = PL_oldbufptr; \ + if (*s == '(') \ + return REPORT( (int)FUNC1 ); \ + s = skipspace(s); \ + return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \ + } /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) @@ -215,6 +220,7 @@ static struct debug_tokens { const int token, type; const char *name; } { BITOROP, TOKENTYPE_OPNUM, "BITOROP" }, { COLONATTR, TOKENTYPE_NONE, "COLONATTR" }, { CONTINUE, TOKENTYPE_NONE, "CONTINUE" }, + { DEFAULT, TOKENTYPE_NONE, "DEFAULT" }, { DO, TOKENTYPE_NONE, "DO" }, { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" }, { DORDOR, TOKENTYPE_NONE, "DORDOR" }, @@ -230,6 +236,7 @@ static struct debug_tokens { const int token, type; const char *name; } { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" }, { FUNC1, TOKENTYPE_OPNUM, "FUNC1" }, { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" }, + { GIVEN, TOKENTYPE_IVAL, "GIVEN" }, { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" }, { IF, TOKENTYPE_IVAL, "IF" }, { LABEL, TOKENTYPE_PVAL, "LABEL" }, @@ -265,6 +272,7 @@ static struct debug_tokens { const int token, type; const char *name; } { UNLESS, TOKENTYPE_IVAL, "UNLESS" }, { UNTIL, TOKENTYPE_IVAL, "UNTIL" }, { USE, TOKENTYPE_IVAL, "USE" }, + { WHEN, TOKENTYPE_IVAL, "WHEN" }, { WHILE, TOKENTYPE_IVAL, "WHILE" }, { WORD, TOKENTYPE_OPVAL, "WORD" }, { 0, TOKENTYPE_NONE, 0 } @@ -273,15 +281,15 @@ static struct debug_tokens { const int token, type; const char *name; } /* dump the returned token in rv, plus any optional arg in yylval */ STATIC int -S_tokereport(pTHX_ const char* s, I32 rv) +S_tokereport(pTHX_ I32 rv) { if (DEBUG_T_TEST) { const char *name = Nullch; enum token_type type = TOKENTYPE_NONE; - struct debug_tokens *p; - SV* report = newSVpvn("<== ", 4); + const struct debug_tokens *p; + SV* const report = newSVpvn("<== ", 4); - for (p = (struct debug_tokens *)debug_tokens; p->token; p++) { + for (p = debug_tokens; p->token; p++) { if (p->token == (int)rv) { name = p->name; type = p->type; @@ -311,25 +319,35 @@ S_tokereport(pTHX_ const char* s, I32 rv) Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval); break; case TOKENTYPE_OPVAL: - if (yylval.opval) + if (yylval.opval) { Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)", PL_op_name[yylval.opval->op_type]); + if (yylval.opval->op_type == OP_CONST) { + Perl_sv_catpvf(aTHX_ report, " %s", + SvPEEK(cSVOPx_sv(yylval.opval))); + } + + } else Perl_sv_catpv(aTHX_ report, "(opval=null)"); break; } - Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop)); - if (s - PL_bufptr > 0) - sv_catpvn(report, PL_bufptr, s - PL_bufptr); - else { - if (PL_oldbufptr && *PL_oldbufptr) - sv_catpv(report, PL_tokenbuf); - } - PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen(report)); + PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report)); }; return (int)rv; } + +/* print the buffer with suitable escapes */ + +STATIC void +S_printbuf(pTHX_ const char* fmt, const char* s) +{ + SV* const tmp = newSVpvn("", 0); + PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); + SvREFCNT_dec(tmp); +} + #endif /* @@ -371,8 +389,8 @@ S_ao(pTHX_ int toketype) STATIC void S_no_op(pTHX_ const char *what, char *s) { - char *oldbp = PL_bufptr; - bool is_first = (PL_oldbufptr == PL_linestart); + char * const oldbp = PL_bufptr; + const bool is_first = (PL_oldbufptr == PL_linestart); if (!s) s = oldbp; @@ -384,17 +402,17 @@ S_no_op(pTHX_ const char *what, char *s) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\t(Missing semicolon on previous line?)\n"); else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { - char *t; + const char *t; for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; if (t < PL_bufptr && isSPACE(*t)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\t(Do you need to predeclare %.*s?)\n", - t - PL_oldoldbufptr, PL_oldoldbufptr); + (int)(t - PL_oldoldbufptr), PL_oldoldbufptr); } else { assert(s >= oldbp); Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); + "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp); } } PL_bufptr = oldbp; @@ -415,7 +433,7 @@ S_missingterm(pTHX_ char *s) char tmpbuf[3]; char q; if (s) { - char *nl = strrchr(s,'\n'); + char * const nl = strrchr(s,'\n'); if (nl) *nl = '\0'; } @@ -427,7 +445,7 @@ S_missingterm(pTHX_ char *s) #endif ) { *tmpbuf = '^'; - tmpbuf[1] = toCTRL(PL_multi_close); + tmpbuf[1] = (char)toCTRL(PL_multi_close); tmpbuf[2] = '\0'; s = tmpbuf; } @@ -440,6 +458,23 @@ S_missingterm(pTHX_ char *s) Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q); } +#define FEATURE_IS_ENABLED(name, namelen) \ + ((0 != (PL_hints & HINT_LOCALIZE_HH)) \ + && feature_is_enabled(name, namelen) ) +/* + * S_feature_is_enabled + * Check whether the named feature is enabled. + */ +STATIC bool +S_feature_is_enabled(pTHX_ char *name, STRLEN namelen) +{ + HV * const hinthv = GvHV(PL_hintgv); + char he_name[32] = "feature_"; + (void) strncpy(&he_name[8], name, 24); + + return (hinthv && hv_exists(hinthv, he_name, 8 + namelen)); +} + /* * Perl_deprecate */ @@ -468,17 +503,6 @@ Perl_deprecate_old(pTHX_ const char *s) } /* - * depcom - * Deprecate a comma-less variable list. - */ - -STATIC void -S_depcom(pTHX) -{ - deprecate_old("comma-less variable list"); -} - -/* * experimental text filters for win32 carriage-returns, utf16-to-utf8 and * utf16-to-utf8-reversed. */ @@ -487,8 +511,8 @@ S_depcom(pTHX) static void strip_return(SV *sv) { - register char *s = SvPVX(sv); - register char *e = s + SvCUR(sv); + register const char *s = SvPVX_const(sv); + register const char * const e = s + SvCUR(sv); /* outer loop optimized to do nothing if there are no CR-LFs */ while (s < e) { if (*s++ == '\r' && *s == '\n') { @@ -509,7 +533,7 @@ strip_return(SV *sv) STATIC I32 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) { - I32 count = FILTER_READ(idx+1, sv, maxlen); + const I32 count = FILTER_READ(idx+1, sv, maxlen); if (count > 0 && !maxlen) strip_return(sv); return count; @@ -525,7 +549,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { - char *s; + const char *s; STRLEN len; SAVEI32(PL_lex_dojoin); @@ -566,8 +590,8 @@ Perl_lex_start(pTHX_ SV *line) PL_lex_defer = 0; PL_expect = XSTATE; PL_lex_brackets = 0; - New(899, PL_lex_brackstack, 120, char); - New(899, PL_lex_casestack, 12, char); + Newx(PL_lex_brackstack, 120, char); + Newx(PL_lex_casestack, 12, char); PL_lex_casemods = 0; *PL_lex_casestack = '\0'; PL_lex_dojoin = 0; @@ -581,7 +605,7 @@ Perl_lex_start(pTHX_ SV *line) PL_linestr = line; if (SvREADONLY(PL_linestr)) PL_linestr = sv_2mortal(newSVsv(PL_linestr)); - s = SvPV(PL_linestr, len); + s = SvPV_const(PL_linestr, len); if (!len || s[len-1] != ';') { if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) PL_linestr = sv_2mortal(newSVsv(PL_linestr)); @@ -660,6 +684,43 @@ S_incline(pTHX_ char *s) ch = *t; *t = '\0'; if (t - s > 0) { +#ifndef USE_ITHREADS + const char * const cf = CopFILE(PL_curcop); + STRLEN tmplen = cf ? strlen(cf) : 0; + if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) { + /* must copy *{"::_<(eval N)[oldfilename:L]"} + * to *{"::_op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { - (void)SvUPGRADE(ver, SVt_PVNV); + SvUPGRADE(ver, SVt_PVNV); SvNV_set(ver, str_to_version(ver)); SvNOK_on(ver); /* hint that it is a version */ } @@ -1060,7 +1121,7 @@ S_tokeq(pTHX_ SV *sv) goto finish; d = s; if ( PL_hints & HINT_NEW_STRING ) { - pv = sv_2mortal(newSVpvn(SvPVX(pv), len)); + pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len)); if (SvUTF8(sv)) SvUTF8_on(pv); } @@ -1072,7 +1133,7 @@ S_tokeq(pTHX_ SV *sv) *d++ = *s++; } *d = '\0'; - SvCUR_set(sv, d - SvPVX(sv)); + SvCUR_set(sv, d - SvPVX_const(sv)); finish: if ( PL_hints & HINT_NEW_STRING ) return new_constant(NULL, 0, "q", sv, pv, "q"); @@ -1114,7 +1175,7 @@ S_tokeq(pTHX_ SV *sv) STATIC I32 S_sublex_start(pTHX) { - register I32 op_type = yylval.ival; + register const I32 op_type = yylval.ival; if (op_type == OP_NULL) { yylval.opval = PL_lex_op; @@ -1127,11 +1188,8 @@ S_sublex_start(pTHX) if (SvTYPE(sv) == SVt_PVIV) { /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ STRLEN len; - char *p; - SV *nsv; - - p = SvPV(sv, len); - nsv = newSVpvn(p, len); + const char *p = SvPV_const(sv, len); + SV * const nsv = newSVpvn(p, len); if (SvUTF8(sv)) SvUTF8_on(nsv); SvREFCNT_dec(sv); @@ -1205,8 +1263,8 @@ S_sublex_push(pTHX) PL_lex_dojoin = FALSE; PL_lex_brackets = 0; - New(899, PL_lex_brackstack, 120, char); - New(899, PL_lex_casestack, 12, char); + Newx(PL_lex_brackstack, 120, char); + Newx(PL_lex_casestack, 12, char); PL_lex_casemods = 0; *PL_lex_casestack = '\0'; PL_lex_starts = 0; @@ -1232,7 +1290,7 @@ S_sublex_done(pTHX) { dVAR; if (!PL_lex_starts++) { - SV *sv = newSVpvn("",0); + SV * const sv = newSVpvn("",0); if (SvUTF8(PL_linestr)) SvUTF8_on(sv); PL_expect = XOPERATOR; @@ -1367,6 +1425,9 @@ S_scan_const(pTHX_ char *start) I32 has_utf8 = FALSE; /* Output constant is UTF8 */ I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */ UV uv; +#ifdef EBCDIC + UV literal_endpoint = 0; +#endif const char *leaveit = /* set of acceptably-backslashed characters */ PL_lex_inpat @@ -1390,7 +1451,7 @@ S_scan_const(pTHX_ char *start) I32 max; /* last character in range */ if (has_utf8) { - char *c = (char*)utf8_hop((U8*)d, -1); + char * const c = (char*)utf8_hop((U8*)d, -1); char *e = d++; while (e-- > c) *(e + 1) = *e; @@ -1401,7 +1462,7 @@ S_scan_const(pTHX_ char *start) continue; } - i = d - SvPVX(sv); /* remember current offset */ + i = d - SvPVX_const(sv); /* remember current offset */ SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */ d = SvPVX(sv) + i; /* refresh d after realloc */ d -= 2; /* eat the first char and the - */ @@ -1416,8 +1477,9 @@ S_scan_const(pTHX_ char *start) } #ifdef EBCDIC - if ((isLOWER(min) && isLOWER(max)) || - (isUPPER(min) && isUPPER(max))) { + if (literal_endpoint == 2 && + ((isLOWER(min) && isLOWER(max)) || + (isUPPER(min) && isUPPER(max)))) { if (isLOWER(min)) { for (i = min; i <= max; i++) if (isLOWER(i)) @@ -1436,6 +1498,9 @@ S_scan_const(pTHX_ char *start) /* mark the range as done, and continue */ dorange = FALSE; didrange = TRUE; +#ifdef EBCDIC + literal_endpoint = 0; +#endif continue; } @@ -1454,6 +1519,9 @@ S_scan_const(pTHX_ char *start) } else { didrange = FALSE; +#ifdef EBCDIC + literal_endpoint = 0; +#endif } } @@ -1554,9 +1622,9 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - if (ckWARN(WARN_MISC) && - isALNUM(*s) && - *s != '_') + if (isALNUM(*s) && + *s != '_' && + ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Unrecognized escape \\%c passed through", *s); @@ -1579,7 +1647,7 @@ S_scan_const(pTHX_ char *start) case 'x': ++s; if (*s == '{') { - char* e = strchr(s, '}'); + char* const e = strchr(s, '}'); I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | PERL_SCAN_DISALLOW_PREFIX; STRLEN len; @@ -1628,15 +1696,15 @@ S_scan_const(pTHX_ char *start) } } if (hicount) { - STRLEN offset = d - SvPVX(sv); + const STRLEN offset = d - SvPVX_const(sv); U8 *src, *dst; d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset; src = (U8 *)d - 1; dst = src+hicount; d += hicount; - while (src >= (U8 *)SvPVX(sv)) { + while (src >= (const U8 *)SvPVX_const(sv)) { if (!NATIVE_IS_INVARIANT(*src)) { - U8 ch = NATIVE_TO_ASCII(*src); + const U8 ch = NATIVE_TO_ASCII(*src); *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch); *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch); } @@ -1674,7 +1742,7 @@ S_scan_const(pTHX_ char *start) char* e = strchr(s, '}'); SV *res; STRLEN len; - char *str; + const char *str; if (!e) { yyerror("Missing right brace on \\N{}"); @@ -1696,7 +1764,7 @@ S_scan_const(pTHX_ char *start) res, Nullsv, "\\N{...}" ); if (has_utf8) sv_utf8_upgrade(res); - str = SvPV(res,len); + str = SvPV_const(res,len); #ifdef EBCDIC_NEVER_MIND /* charnames uses pack U and that has been * recently changed to do the below uni->native @@ -1706,19 +1774,19 @@ S_scan_const(pTHX_ char *start) * gets revoked, but the semantics is still * desireable for charnames. --jhi */ { - UV uv = utf8_to_uvchr((U8*)str, 0); + UV uv = utf8_to_uvchr((const U8*)str, 0); if (uv < 0x100) { U8 tmpbuf[UTF8_MAXBYTES+1], *d; d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv)); sv_setpvn(res, (char *)tmpbuf, d - tmpbuf); - str = SvPV(res, len); + str = SvPV_const(res, len); } } #endif if (!has_utf8 && SvUTF8(res)) { - char *ostart = SvPVX(sv); + const char * const ostart = SvPVX_const(sv); SvCUR_set(sv, d - ostart); SvPOK_on(sv); *d = '\0'; @@ -1729,7 +1797,7 @@ S_scan_const(pTHX_ char *start) has_utf8 = TRUE; } if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */ - char *odest = SvPVX(sv); + const char * const odest = SvPVX_const(sv); SvGROW(sv, (SvLEN(sv) + len - (e - s + 4))); d = SvPVX(sv) + (d - odest); @@ -1787,18 +1855,22 @@ S_scan_const(pTHX_ char *start) s++; continue; } /* end if (backslash) */ +#ifdef EBCDIC + else + literal_endpoint++; +#endif default_action: /* If we started with encoded form, or already know we want it and then encode the next character */ if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) { STRLEN len = 1; - UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s); - STRLEN need = UNISKIP(NATIVE_TO_UNI(uv)); + const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s); + const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv)); s += len; if (need > len) { /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */ - STRLEN off = d - SvPVX(sv); + const STRLEN off = d - SvPVX_const(sv); d = SvGROW(sv, SvLEN(sv) + (need-len)) + off; } d = (char*)uvchr_to_utf8((U8*)d, uv); @@ -1811,7 +1883,7 @@ S_scan_const(pTHX_ char *start) /* terminate the string and set up the sv */ *d = '\0'; - SvCUR_set(sv, d - SvPVX(sv)); + SvCUR_set(sv, d - SvPVX_const(sv)); if (SvCUR(sv) >= SvLEN(sv)) Perl_croak(aTHX_ "panic: constant overflowed allocated space"); @@ -1910,7 +1982,7 @@ S_intuit_more(pTHX_ register char *s) int weight = 2; /* let's weigh the evidence */ char seen[256]; unsigned char un_char = 255, last_un_char; - char *send = strchr(s,']'); + const char * const send = strchr(s,']'); char tmpbuf[sizeof PL_tokenbuf * 4]; if (!send) /* has to be an expression */ @@ -1937,7 +2009,8 @@ S_intuit_more(pTHX_ register char *s) weight -= seen[un_char] * 10; if (isALNUM_lazy_if(s+1,UTF)) { scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE); - if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV)) + if ((int)strlen(tmpbuf) > 1 + && gv_fetchpv(tmpbuf, 0, SVt_PV)) weight -= 100; else weight -= 10; @@ -2026,7 +2099,7 @@ S_intuit_more(pTHX_ register char *s) */ STATIC int -S_intuit_method(pTHX_ char *start, GV *gv) +S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) { char *s = start + (*start == '$'); char tmpbuf[sizeof PL_tokenbuf]; @@ -2034,16 +2107,17 @@ S_intuit_method(pTHX_ char *start, GV *gv) GV* indirgv; if (gv) { - CV *cv; - if (GvIO(gv)) + if (SvTYPE(gv) == SVt_PVGV && GvIO(gv)) return 0; - if ((cv = GvCVu(gv))) { - char *proto = SvPVX(cv); - if (proto) { - if (*proto == ';') - proto++; - if (*proto == '*') - return 0; + if (cv) { + if (SvPOK(cv)) { + const char *proto = SvPVX_const(cv); + if (proto) { + if (*proto == ';') + proto++; + if (*proto == '*') + return 0; + } } } else gv = 0; @@ -2068,7 +2142,7 @@ S_intuit_method(pTHX_ char *start, GV *gv) tmpbuf[len] = '\0'; goto bare_package; } - indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); + indirgv = gv_fetchpv(tmpbuf, 0, SVt_PVCV); if (indirgv && GvCVu(indirgv)) return 0; /* filehandle or package name makes it a method */ @@ -2100,7 +2174,7 @@ STATIC const char* S_incl_perldb(pTHX) { if (PL_perldb) { - const char *pdb = PerlEnv_getenv("PERL5DB"); + const char * const pdb = PerlEnv_getenv("PERL5DB"); if (pdb) return pdb; @@ -2138,12 +2212,11 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) PL_rsfp_filters = newAV(); if (!datasv) datasv = NEWSV(255,0); - if (!SvUPGRADE(datasv, SVt_PVIO)) - Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO"); - IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */ + SvUPGRADE(datasv, SVt_PVIO); + IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", - (void*)funcp, SvPV_nolen(datasv))); + IoANY(datasv), SvPV_nolen(datasv))); av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -2155,12 +2228,15 @@ void Perl_filter_del(pTHX_ filter_t funcp) { SV *datasv; - DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp)); + +#ifdef DEBUGGING + DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp))); +#endif if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); - if (IoANY(datasv) == (void *)funcp) { + if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) { IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; IoANY(datasv) = (void *)NULL; sv_free(av_pop(PL_rsfp_filters)); @@ -2190,7 +2266,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) if (maxlen) { /* Want a block */ int len ; - int old_len = SvCUR(buf_sv) ; + const int old_len = SvCUR(buf_sv); /* ensure buf_sv is large enough */ SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ; @@ -2220,10 +2296,10 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ - funcp = (filter_t)IoANY(datasv); + funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", - idx, (void*)funcp, SvPV_nolen(datasv))); + idx, datasv, SvPV_nolen_const(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -2260,22 +2336,46 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) if (len > 2 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && - (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) + (gv = gv_fetchpv(pkgname, 0, SVt_PVHV))) { return GvHV(gv); /* Foo:: */ } /* use constant CLASS => 'MyClass' */ - if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { + if ((gv = gv_fetchpv(pkgname, 0, SVt_PVCV))) { SV *sv; if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { - pkgname = SvPV_nolen(sv); + pkgname = SvPV_nolen_const(sv); } } return gv_stashpv(pkgname, FALSE); } +STATIC char * +S_tokenize_use(pTHX_ int is_use, char *s) { + if (PL_expect != XSTATE) + yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", + is_use ? "use" : "no")); + s = skipspace(s); + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { + s = force_version(s, TRUE); + if (*s == ';' || (s = skipspace(s), *s == ';')) { + PL_nextval[PL_nexttoke].opval = Nullop; + force_next(WORD); + } + else if (*s == 'v') { + s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s, FALSE); + } + } + else { + s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s, FALSE); + } + yylval.ival = is_use; + return s; +} #ifdef DEBUGGING static const char* const exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", @@ -2317,16 +2417,17 @@ Perl_yylex(pTHX) { register char *s = PL_bufptr; register char *d; - register I32 tmp; STRLEN len; - GV *gv = Nullgv; - GV **gvp = 0; bool bof = FALSE; - I32 orig_keyword = 0; DEBUG_T( { - PerlIO_printf(Perl_debug_log, "### LEX_%s\n", - lex_state_names[PL_lex_state]); + SV* tmp = newSVpvn("", 0); + PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n", + (IV)CopLINE(PL_curcop), + lex_state_names[PL_lex_state], + exp_name[PL_expect], + pv_display(tmp, s, strlen(s), 0, 60)); + SvREFCNT_dec(tmp); } ); /* check if there's an identifier for us to look at */ if (PL_pending_ident) @@ -2350,10 +2451,6 @@ Perl_yylex(pTHX) PL_expect = PL_lex_expect; PL_lex_defer = LEX_NORMAL; } - DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, - (IV)PL_nexttype[PL_nexttoke]); }); - return REPORT(PL_nexttype[PL_nexttoke]); /* interpolated case modifiers like \L \U, including \Q and \E. @@ -2366,11 +2463,9 @@ Perl_yylex(pTHX) #endif /* handle \E or end of string */ if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') { - char oldmod; - /* if at a \E */ if (PL_lex_casemods) { - oldmod = PL_lex_casestack[--PL_lex_casemods]; + const char oldmod = PL_lex_casestack[--PL_lex_casemods]; PL_lex_casestack[PL_lex_casemods] = '\0'; if (PL_bufptr != PL_bufend @@ -2387,7 +2482,7 @@ Perl_yylex(pTHX) } else { DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Saw case modifier at '%s'\n", PL_bufptr); }); + "### Saw case modifier\n"); }); s = PL_bufptr + 1; if (s[1] == '\\' && s[2] == 'E') { PL_bufptr = s + 3; @@ -2395,6 +2490,7 @@ Perl_yylex(pTHX) return yylex(); } else { + I32 tmp; if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ if ((*s == 'L' || *s == 'U') && @@ -2444,7 +2540,7 @@ Perl_yylex(pTHX) if (PL_bufptr == PL_bufend) return REPORT(sublex_done()); DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Interpolated variable at '%s'\n", PL_bufptr); }); + "### Interpolated variable\n"); }); PL_expect = XTERM; PL_lex_dojoin = (*PL_bufptr == '@'); PL_lex_state = LEX_INTERPNORMAL; @@ -2544,10 +2640,6 @@ Perl_yylex(pTHX) s = PL_bufptr; PL_oldoldbufptr = PL_oldbufptr; PL_oldbufptr = s; - DEBUG_T( { - PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n", - exp_name[PL_expect], s); - } ); retry: switch (*s) { @@ -2563,10 +2655,9 @@ Perl_yylex(pTHX) PL_last_uni = 0; PL_last_lop = 0; if (PL_lex_brackets) { - if (PL_lex_formbrack) - yyerror("Format not terminated"); - else - yyerror("Missing right curly or square bracket"); + yyerror(PL_lex_formbrack + ? "Format not terminated" + : "Missing right curly or square bracket"); } DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); @@ -2626,12 +2717,14 @@ Perl_yylex(pTHX) sv_catpv(PL_linestr,"our @F=split(' ');"); } } + if (PL_minus_E) + sv_catpv(PL_linestr,"use feature ':5.10';"); sv_catpvn(PL_linestr, "\n", 1); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV *sv = NEWSV(85,0); + SV * const sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); @@ -2666,7 +2759,7 @@ Perl_yylex(pTHX) } PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_last_lop = PL_last_uni = Nullch; - sv_setpv(PL_linestr,""); + sv_setpvn(PL_linestr,"",0); TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } /* If it looks like the start of a BOM or raw UTF-16, @@ -2707,7 +2800,7 @@ Perl_yylex(pTHX) if (PL_doextract) { /* Incest with pod. */ if (*s == '=' && strnEQ(s, "=cut", 4)) { - sv_setpv(PL_linestr, ""); + sv_setpvn(PL_linestr, "", 0); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; @@ -2718,7 +2811,7 @@ Perl_yylex(pTHX) } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV *sv = NEWSV(85,0); + SV * const sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); @@ -2764,7 +2857,8 @@ Perl_yylex(pTHX) * at least, set argv[0] to the basename of the Perl * interpreter. So, having found "#!", we'll set it right. */ - SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */ + SV * const x + = GvSV(gv_fetchpv("\030", GV_ADD, SVt_PV)); /* $^X */ assert(SvPOK(x) || SvGMAGICAL(x)); if (sv_eq(x, CopFILESV(PL_curcop))) { sv_setpvn(x, ipath, ipathend - ipath); @@ -2773,8 +2867,8 @@ Perl_yylex(pTHX) else { STRLEN blen; STRLEN llen; - char *bstart = SvPV(CopFILESV(PL_curcop),blen); - char *lstart = SvPV(x,llen); + const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen); + const char * const lstart = SvPV_const(x,llen); if (llen < blen) { bstart += blen - llen; if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') { @@ -2820,7 +2914,7 @@ Perl_yylex(pTHX) * contains the start of the Perl program. */ if (d && *s != '#') { - char *c = ipath; + const char *c = ipath; while (*c && !strchr("; \t\r\n\f\v#", *c)) c++; if (c < d) @@ -2845,7 +2939,7 @@ Perl_yylex(pTHX) while (s < PL_bufend && isSPACE(*s)) s++; if (s < PL_bufend) { - Newz(899,newargv,PL_origargc+3,char*); + Newxz(newargv,PL_origargc+3,char*); newargv[1] = s; while (s < PL_bufend && !isSPACE(*s)) s++; @@ -2862,18 +2956,18 @@ Perl_yylex(pTHX) } #endif if (d) { - U32 oldpdb = PL_perldb; - bool oldn = PL_minus_n; - bool oldp = PL_minus_p; + const U32 oldpdb = PL_perldb; + const bool oldn = PL_minus_n; + const bool oldp = PL_minus_p; while (*d && !isSPACE(*d)) d++; while (SPACE_OR_TAB(*d)) d++; if (*d++ == '-') { - bool switches_done = PL_doswitches; + const bool switches_done = PL_doswitches; do { if (*d == 'M' || *d == 'm' || *d == 'C') { - char *m = d; + const char * const m = d; while (*d && !isSPACE(*d)) d++; Perl_croak(aTHX_ "Too late for \"-%.*s\" option", (int)(d - m), m); @@ -2893,7 +2987,7 @@ Perl_yylex(pTHX) /* if we have already added "LINE: while (<>) {", we must not do it again */ { - sv_setpv(PL_linestr, ""); + sv_setpvn(PL_linestr, "", 0); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; @@ -2962,6 +3056,7 @@ Perl_yylex(pTHX) case '-': if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { I32 ftst = 0; + char tmp; s++; PL_bufptr = s; @@ -2972,8 +3067,8 @@ Perl_yylex(pTHX) if (strnEQ(s,"=>",2)) { s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw unary minus before =>, forcing word '%s'\n", s); + DEBUG_T( { S_printbuf(aTHX_ + "### Saw unary minus before =>, forcing word %s\n", s); } ); OPERATOR('-'); /* unary minus */ } @@ -3004,7 +3099,7 @@ Perl_yylex(pTHX) case 'T': ftst = OP_FTTEXT; break; case 'B': ftst = OP_FTBINARY; break; case 'M': case 'A': case 'C': - gv_fetchpv("\024",TRUE, SVt_PV); + gv_fetchpv("\024",GV_ADD, SVt_PV); switch (tmp) { case 'M': ftst = OP_FTMTIME; break; case 'A': ftst = OP_FTATIME; break; @@ -3018,7 +3113,7 @@ Perl_yylex(pTHX) if (ftst) { PL_last_lop_op = (OPCODE)ftst; DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw file test %c\n", (int)ftst); + "### Saw file test %c\n", (int)tmp); } ); FTST(ftst); } @@ -3032,49 +3127,53 @@ Perl_yylex(pTHX) s = --PL_bufptr; } } - tmp = *s++; - if (*s == tmp) { - s++; + { + const char tmp = *s++; + if (*s == tmp) { + s++; + if (PL_expect == XOPERATOR) + TERM(POSTDEC); + else + OPERATOR(PREDEC); + } + else if (*s == '>') { + s++; + s = skipspace(s); + if (isIDFIRST_lazy_if(s,UTF)) { + s = force_word(s,METHOD,FALSE,TRUE,FALSE); + TOKEN(ARROW); + } + else if (*s == '$') + OPERATOR(ARROW); + else + TERM(ARROW); + } if (PL_expect == XOPERATOR) - TERM(POSTDEC); - else - OPERATOR(PREDEC); - } - else if (*s == '>') { - s++; - s = skipspace(s); - if (isIDFIRST_lazy_if(s,UTF)) { - s = force_word(s,METHOD,FALSE,TRUE,FALSE); - TOKEN(ARROW); + Aop(OP_SUBTRACT); + else { + if (isSPACE(*s) || !isSPACE(*PL_bufptr)) + check_uni(); + OPERATOR('-'); /* unary minus */ } - else if (*s == '$') - OPERATOR(ARROW); - else - TERM(ARROW); - } - if (PL_expect == XOPERATOR) - Aop(OP_SUBTRACT); - else { - if (isSPACE(*s) || !isSPACE(*PL_bufptr)) - check_uni(); - OPERATOR('-'); /* unary minus */ } case '+': - tmp = *s++; - if (*s == tmp) { - s++; + { + const char tmp = *s++; + if (*s == tmp) { + s++; + if (PL_expect == XOPERATOR) + TERM(POSTINC); + else + OPERATOR(PREINC); + } if (PL_expect == XOPERATOR) - TERM(POSTINC); - else - OPERATOR(PREINC); - } - if (PL_expect == XOPERATOR) - Aop(OP_ADD); - else { - if (isSPACE(*s) || !isSPACE(*PL_bufptr)) - check_uni(); - OPERATOR('+'); + Aop(OP_ADD); + else { + if (isSPACE(*s) || !isSPACE(*PL_bufptr)) + check_uni(); + OPERATOR('+'); + } } case '*': @@ -3113,13 +3212,22 @@ Perl_yylex(pTHX) PL_lex_brackets++; /* FALL THROUGH */ case '~': + if (s[1] == '~' + && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) + && FEATURE_IS_ENABLED("~~", 2)) + { + s += 2; + Eop(OP_SMARTMATCH); + } case ',': - tmp = *s++; - OPERATOR(tmp); + { + const char tmp = *s++; + OPERATOR(tmp); + } case ':': if (s[1] == ':') { len = 0; - goto just_a_word; + goto just_a_word_zero_gv; } s++; switch (PL_expect) { @@ -3138,6 +3246,7 @@ Perl_yylex(pTHX) s = skipspace(s); attrs = Nullop; while (isIDFIRST_lazy_if(s,UTF)) { + I32 tmp; d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) { if (tmp < 0) tmp = -tmp; @@ -3219,26 +3328,30 @@ Perl_yylex(pTHX) else if (s == d) break; /* require real whitespace or :'s */ } - tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ - if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) { - char q = ((*s == '\'') ? '"' : '\''); - /* If here for an expression, and parsed no attrs, back off. */ - if (tmp == '=' && !attrs) { - s = PL_bufptr; - break; + { + const char tmp + = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ + if (*s != ';' && *s != '}' && *s != tmp + && (tmp != '=' || *s != ')')) { + const char q = ((*s == '\'') ? '"' : '\''); + /* If here for an expression, and parsed no attrs, back + off. */ + if (tmp == '=' && !attrs) { + s = PL_bufptr; + break; + } + /* MUST advance bufptr here to avoid bogus "at end of line" + context messages from yyerror(). + */ + PL_bufptr = s; + yyerror( *s + ? Perl_form(aTHX_ "Invalid separator character " + "%c%c%c in attribute list", q, *s, q) + : "Unterminated attribute list" ); + if (attrs) + op_free(attrs); + OPERATOR(':'); } - /* MUST advance bufptr here to avoid bogus "at end of line" - context messages from yyerror(). - */ - PL_bufptr = s; - if (!*s) - yyerror("Unterminated attribute list"); - else - yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list", - q, *s, q)); - if (attrs) - op_free(attrs); - OPERATOR(':'); } got_attrs: if (attrs) { @@ -3258,14 +3371,18 @@ Perl_yylex(pTHX) TOKEN('('); case ';': CLINE; - tmp = *s++; - OPERATOR(tmp); + { + const char tmp = *s++; + OPERATOR(tmp); + } case ')': - tmp = *s++; - s = skipspace(s); - if (*s == '{') - PREBLOCK(tmp); - TERM(tmp); + { + const char tmp = *s++; + s = skipspace(s); + if (*s == '{') + PREBLOCK(tmp); + TERM(tmp); + } case ']': s++; if (PL_lex_brackets <= 0) @@ -3313,7 +3430,7 @@ Perl_yylex(pTHX) while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; if (*d == '}') { - char minus = (PL_tokenbuf[0] == '-'); + const char minus = (PL_tokenbuf[0] == '-'); s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); if (minus) force_next('-'); @@ -3331,7 +3448,7 @@ Perl_yylex(pTHX) PL_expect = XSTATE; break; default: { - char *t; + const char *t; if (PL_oldoldbufptr == PL_last_lop) PL_lex_brackstack[PL_lex_brackets++] = XTERM; else @@ -3354,7 +3471,7 @@ Perl_yylex(pTHX) * eval"") we have to resolve the ambiguity. This code * covers the case where the first term in the curlies is a * quoted string. Most other cases need to be explicitly - * disambiguated by prepending a `+' before the opening + * disambiguated by prepending a "+" before the opening * curly in order to force resolution as an anon hash. * * XXX should probably propagate the outer expectation @@ -3377,7 +3494,7 @@ Perl_yylex(pTHX) && !isALNUM(*t)))) { /* skip q//-like construct */ - char *tmps; + const char *tmps; char open, close, term; I32 brackets = 1; @@ -3473,13 +3590,12 @@ Perl_yylex(pTHX) TOKEN(';'); case '&': s++; - tmp = *s++; - if (tmp == '&') + if (*s++ == '&') AOPERATOR(ANDAND); s--; if (PL_expect == XOPERATOR) { - if (ckWARN(WARN_SEMICOLON) - && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart) + if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON) + && isIDFIRST_lazy_if(s,UTF)) { CopLINE_dec(PL_curcop); Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); @@ -3500,50 +3616,53 @@ Perl_yylex(pTHX) case '|': s++; - tmp = *s++; - if (tmp == '|') + if (*s++ == '|') AOPERATOR(OROR); s--; BOop(OP_BIT_OR); case '=': s++; - tmp = *s++; - if (tmp == '=') - Eop(OP_EQ); - if (tmp == '>') - OPERATOR(','); - if (tmp == '~') - PMop(OP_MATCH); - if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp); - s--; - if (PL_expect == XSTATE && isALPHA(tmp) && - (s == PL_linestart+1 || s[-2] == '\n') ) { - if (PL_in_eval && !PL_rsfp) { - d = PL_bufend; - while (s < d) { - if (*s++ == '\n') { - incline(s); - if (strnEQ(s,"=cut",4)) { - s = strchr(s,'\n'); - if (s) - s++; - else - s = d; - incline(s); - goto retry; + const char tmp = *s++; + if (tmp == '=') + Eop(OP_EQ); + if (tmp == '>') + OPERATOR(','); + if (tmp == '~') + PMop(OP_MATCH); + if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) + && strchr("+-*/%.^&|<",tmp)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Reversed %c= operator",(int)tmp); + s--; + if (PL_expect == XSTATE && isALPHA(tmp) && + (s == PL_linestart+1 || s[-2] == '\n') ) + { + if (PL_in_eval && !PL_rsfp) { + d = PL_bufend; + while (s < d) { + if (*s++ == '\n') { + incline(s); + if (strnEQ(s,"=cut",4)) { + s = strchr(s,'\n'); + if (s) + s++; + else + s = d; + incline(s); + goto retry; + } + } } + goto retry; } + s = PL_bufend; + PL_doextract = TRUE; + goto retry; } - goto retry; - } - s = PL_bufend; - PL_doextract = TRUE; - goto retry; } if (PL_lex_brackets < PL_lex_formbrack) { - char *t; + const char *t; #ifdef PERL_STRICT_CR for (t = s; SPACE_OR_TAB(*t); t++) ; #else @@ -3559,27 +3678,30 @@ Perl_yylex(pTHX) OPERATOR(ASSIGNOP); case '!': s++; - tmp = *s++; - if (tmp == '=') { - /* was this !=~ where !~ was meant? - * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ - - if (*s == '~' && ckWARN(WARN_SYNTAX)) { - char *t = s+1; - - while (t < PL_bufend && isSPACE(*t)) - ++t; - - if (*t == '/' || *t == '?' || - ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) || - (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "!=~ should be !~"); - } - Eop(OP_NE); - } - if (tmp == '~') - PMop(OP_NOT); + { + const char tmp = *s++; + if (tmp == '=') { + /* was this !=~ where !~ was meant? + * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ + + if (*s == '~' && ckWARN(WARN_SYNTAX)) { + const char *t = s+1; + + while (t < PL_bufend && isSPACE(*t)) + ++t; + + if (*t == '/' || *t == '?' || + ((*t == 'm' || *t == 's' || *t == 'y') + && !isALNUM(t[1])) || + (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "!=~ should be !~"); + } + Eop(OP_NE); + } + if (tmp == '~') + PMop(OP_NOT); + } s--; OPERATOR('!'); case '<': @@ -3593,25 +3715,29 @@ Perl_yylex(pTHX) TERM(sublex_start()); } s++; - tmp = *s++; - if (tmp == '<') - SHop(OP_LEFT_SHIFT); - if (tmp == '=') { - tmp = *s++; - if (tmp == '>') - Eop(OP_NCMP); - s--; - Rop(OP_LE); + { + char tmp = *s++; + if (tmp == '<') + SHop(OP_LEFT_SHIFT); + if (tmp == '=') { + tmp = *s++; + if (tmp == '>') + Eop(OP_NCMP); + s--; + Rop(OP_LE); + } } s--; Rop(OP_LT); case '>': s++; - tmp = *s++; - if (tmp == '>') - SHop(OP_RIGHT_SHIFT); - if (tmp == '=') - Rop(OP_GE); + { + const char tmp = *s++; + if (tmp == '>') + SHop(OP_RIGHT_SHIFT); + if (tmp == '=') + Rop(OP_GE); + } s--; Rop(OP_GT); @@ -3621,7 +3747,7 @@ Perl_yylex(pTHX) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; - depcom(); + deprecate_old(commaless_variable_list); return REPORT(','); /* grandfather non-comma-format format */ } } @@ -3659,92 +3785,102 @@ Perl_yylex(pTHX) } d = s; - tmp = (I32)*s; - if (PL_lex_state == LEX_NORMAL) - s = skipspace(s); + { + const char tmp = *s; + if (PL_lex_state == LEX_NORMAL) + s = skipspace(s); - if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { - char *t; - if (*s == '[') { - PL_tokenbuf[0] = '@'; - if (ckWARN(WARN_SYNTAX)) { - for(t = s + 1; - isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; - t++) ; - if (*t++ == ',') { - PL_bufptr = skipspace(PL_bufptr); - while (t < PL_bufend && *t != ']') - t++; - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Multidimensional syntax %.*s not supported", - (t - PL_bufptr) + 1, PL_bufptr); - } - } - } - else if (*s == '{') { - PL_tokenbuf[0] = '%'; - if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") && - (t = strchr(s, '}')) && (t = strchr(t, '='))) - { - char tmpbuf[sizeof PL_tokenbuf]; - STRLEN len; - for (t++; isSPACE(*t); t++) ; - if (isIDFIRST_lazy_if(t,UTF)) { - t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); - for (; isSPACE(*t); t++) ; - if (*t == ';' && get_cv(tmpbuf, FALSE)) + if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) + && intuit_more(s)) { + if (*s == '[') { + PL_tokenbuf[0] = '@'; + if (ckWARN(WARN_SYNTAX)) { + char *t; + for(t = s + 1; + isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; + t++) ; + if (*t++ == ',') { + PL_bufptr = skipspace(PL_bufptr); + while (t < PL_bufend && *t != ']') + t++; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "You need to quote \"%s\"", tmpbuf); + "Multidimensional syntax %.*s not supported", + (t - PL_bufptr) + 1, PL_bufptr); + } } } + else if (*s == '{') { + char *t; + PL_tokenbuf[0] = '%'; + if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX) + && (t = strchr(s, '}')) && (t = strchr(t, '='))) + { + char tmpbuf[sizeof PL_tokenbuf]; + for (t++; isSPACE(*t); t++) ; + if (isIDFIRST_lazy_if(t,UTF)) { + STRLEN len; + t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, + &len); + for (; isSPACE(*t); t++) ; + if (*t == ';' && get_cv(tmpbuf, FALSE)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "You need to quote \"%s\"", + tmpbuf); + } + } + } } - } - PL_expect = XOPERATOR; - if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { - bool islop = (PL_last_lop == PL_oldoldbufptr); - if (!islop || PL_last_lop_op == OP_GREPSTART) - PL_expect = XOPERATOR; - else if (strchr("$@\"'`q", *s)) - PL_expect = XTERM; /* e.g. print $fh "foo" */ - else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF)) - PL_expect = XTERM; /* e.g. print $fh &sub */ - else if (isIDFIRST_lazy_if(s,UTF)) { - char tmpbuf[sizeof PL_tokenbuf]; - scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); - if ((tmp = keyword(tmpbuf, len))) { - /* binary operators exclude handle interpretations */ - switch (tmp) { - case -KEY_x: - case -KEY_eq: - case -KEY_ne: - case -KEY_gt: - case -KEY_lt: - case -KEY_ge: - case -KEY_le: - case -KEY_cmp: - break; - default: - PL_expect = XTERM; /* e.g. print $fh length() */ - break; + PL_expect = XOPERATOR; + if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { + const bool islop = (PL_last_lop == PL_oldoldbufptr); + if (!islop || PL_last_lop_op == OP_GREPSTART) + PL_expect = XOPERATOR; + else if (strchr("$@\"'`q", *s)) + PL_expect = XTERM; /* e.g. print $fh "foo" */ + else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF)) + PL_expect = XTERM; /* e.g. print $fh &sub */ + else if (isIDFIRST_lazy_if(s,UTF)) { + char tmpbuf[sizeof PL_tokenbuf]; + int t2; + scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); + if ((t2 = keyword(tmpbuf, len))) { + /* binary operators exclude handle interpretations */ + switch (t2) { + case -KEY_x: + case -KEY_eq: + case -KEY_ne: + case -KEY_gt: + case -KEY_lt: + case -KEY_ge: + case -KEY_le: + case -KEY_cmp: + break; + default: + PL_expect = XTERM; /* e.g. print $fh length() */ + break; + } + } + else { + PL_expect = XTERM; /* e.g. print $fh subr() */ } } - else { - PL_expect = XTERM; /* e.g. print $fh subr() */ - } + else if (isDIGIT(*s)) + PL_expect = XTERM; /* e.g. print $fh 3 */ + else if (*s == '.' && isDIGIT(s[1])) + PL_expect = XTERM; /* e.g. print $fh .3 */ + else if ((*s == '?' || *s == '-' || *s == '+') + && !isSPACE(s[1]) && s[1] != '=') + PL_expect = XTERM; /* e.g. print $fh -1 */ + else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' + && s[1] != '/') + PL_expect = XTERM; /* e.g. print $fh /.../ + XXX except DORDOR operator + */ + else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) + && s[2] != '=') + PL_expect = XTERM; /* print $fh <<"EOF" */ } - else if (isDIGIT(*s)) - PL_expect = XTERM; /* e.g. print $fh 3 */ - else if (*s == '.' && isDIGIT(s[1])) - PL_expect = XTERM; /* e.g. print $fh .3 */ - else if ((*s == '?' || *s == '-' || *s == '+') - && !isSPACE(s[1]) && s[1] != '=') - PL_expect = XTERM; /* e.g. print $fh -1 */ - else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/') - PL_expect = XTERM; /* e.g. print $fh /.../ - XXX except DORDOR operator */ - else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=') - PL_expect = XTERM; /* print $fh <<"EOF" */ } PL_pending_ident = '$'; TOKEN('$'); @@ -3764,9 +3900,9 @@ Perl_yylex(pTHX) PL_tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ - if (ckWARN(WARN_SYNTAX)) { - if (*s == '[' || *s == '{') { - char *t = s + 1; + if (*s == '[' || *s == '{') { + if (ckWARN(WARN_SYNTAX)) { + const char *t = s + 1; while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t))) t++; if (*t == '}' || *t == ']') { @@ -3789,7 +3925,7 @@ Perl_yylex(pTHX) } case '?': /* may either be conditional or pattern */ if(PL_expect == XOPERATOR) { - tmp = *s++; + char tmp = *s++; if(tmp == '?') { OPERATOR('?'); } @@ -3831,7 +3967,7 @@ Perl_yylex(pTHX) goto rightbracket; } if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { - tmp = *s++; + char tmp = *s++; if (*s == tmp) { s++; if (*s == tmp) { @@ -3850,22 +3986,18 @@ Perl_yylex(pTHX) case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': s = scan_num(s, &yylval); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw number in '%s'\n", s); - } ); + DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Number",s); TERM(THING); case '\'': s = scan_str(s,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw string before '%s'\n", s); - } ); + DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; - depcom(); + deprecate_old(commaless_variable_list); return REPORT(','); /* grandfather non-comma-format format */ } else @@ -3878,13 +4010,11 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw string before '%s'\n", s); - } ); + DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; - depcom(); + deprecate_old(commaless_variable_list); return REPORT(','); /* grandfather non-comma-format format */ } else @@ -3893,6 +4023,8 @@ Perl_yylex(pTHX) if (!s) missingterm((char*)0); yylval.ival = OP_CONST; + /* FIXME. I think that this can be const if char *d is replaced by + more localised variables. */ for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) { yylval.ival = OP_STRINGIFY; @@ -3903,9 +4035,7 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw backtick string before '%s'\n", s); - } ); + DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) @@ -3916,7 +4046,7 @@ Perl_yylex(pTHX) case '\\': s++; - if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s)) + if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", *s, *s); if (PL_expect == XOPERATOR) @@ -3925,9 +4055,7 @@ Perl_yylex(pTHX) case 'v': if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { - char *start = s; - start++; - start++; + char *start = s + 2; while (isDIGIT(*start) || *start == '_') start++; if (*start == '.' && isDIGIT(start[1])) { @@ -3938,10 +4066,10 @@ Perl_yylex(pTHX) else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE || PL_expect == XTERMORDORDOR)) { - char c = *start; + const char c = *start; GV *gv; *start = '\0'; - gv = gv_fetchpv(s, FALSE, SVt_PVCV); + gv = gv_fetchpv(s, 0, SVt_PVCV); *start = c; if (!gv) { s = scan_num(s, &yylval); @@ -3986,9 +4114,10 @@ Perl_yylex(pTHX) case 'z': case 'Z': keylookup: { - orig_keyword = 0; - gv = Nullgv; - gvp = 0; + I32 tmp; + I32 orig_keyword = 0; + GV *gv = Nullgv; + GV **gvp = 0; PL_bufptr = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); @@ -4034,7 +4163,7 @@ Perl_yylex(pTHX) GV *hgv = Nullgv; /* hidden (loser) */ if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) { CV *cv; - if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) && + if ((gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV)) && (cv = GvCVu(gv))) { if (GvIMPORTED_CV(gv)) @@ -4061,16 +4190,6 @@ Perl_yylex(pTHX) { tmp = 0; /* any sub overrides "weak" keyword */ } - else if (gv && !gvp - && tmp == -KEY_err - && GvCVu(gv) - && PL_expect != XOPERATOR - && PL_expect != XTERMORDORDOR) - { - /* any sub overrides the "err" keyword, except when really an - * operator is expected */ - tmp = 0; - } else { /* no override */ tmp = -tmp; if (tmp == KEY_dump && ckWARN(WARN_MISC)) { @@ -4079,8 +4198,8 @@ Perl_yylex(pTHX) } gv = Nullgv; gvp = 0; - if (ckWARN(WARN_AMBIGUOUS) && hgv - && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ + if (hgv && tmp != KEY_x && tmp != KEY_CORE + && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous call resolved as CORE::%s(), %s", GvENAME(hgv), "qualify as such or use &"); @@ -4091,10 +4210,20 @@ Perl_yylex(pTHX) switch (tmp) { default: /* not a keyword */ + /* Trade off - by using this evil construction we can pull the + variable gv into the block labelled keylookup. If not, then + we have to give it function scope so that the goto from the + earlier ':' case doesn't bypass the initialisation. */ + if (0) { + just_a_word_zero_gv: + gv = NULL; + gvp = NULL; + } just_a_word: { SV *sv; int pkgname = 0; - char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); + const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); + CV *cv; /* Get the rest if it looks like a package qualifier */ @@ -4126,7 +4255,8 @@ Perl_yylex(pTHX) if (len > 2 && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { - if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) + if (ckWARN(WARN_BAREWORD) + && ! gv_fetchpv(PL_tokenbuf, 0, SVt_PVHV)) Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword \"%s\" refers to nonexistent package", PL_tokenbuf); @@ -4137,8 +4267,14 @@ Perl_yylex(pTHX) } else { len = 0; - if (!gv) - gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV); + if (!gv) { + /* Mustn't actually add anything to a symbol table. + But also don't want to "initialise" any placeholder + constants that might already be there into full + blown PVGVs with attached PVCV. */ + gv = gv_fetchpv(PL_tokenbuf, GV_NOADD_NOINIT, + SVt_PVCV); + } } /* if we saw a global override before, get the right name */ @@ -4161,7 +4297,7 @@ Perl_yylex(pTHX) yylval.opval->op_private = OPpCONST_BARE; /* UTF-8 package name? */ if (UTF && !IN_BYTES && - is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) + is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv))) SvUTF8_on(sv); /* And if "Foo::", then that's what it certainly is. */ @@ -4169,6 +4305,20 @@ Perl_yylex(pTHX) if (len) goto safe_bareword; + /* Do the explicit type check so that we don't need to force + the initialisation of the symbol table to have a real GV. + Beware - gv may not really be a PVGV, cv may not really be + a PVCV, (because of the space optimisations that gv_init + understands) But they're true if for this symbol there is + respectively a typeglob and a subroutine. + */ + cv = gv ? ((SvTYPE(gv) == SVt_PVGV) + /* Real typeglob, so get the real subroutine: */ + ? GvCVu(gv) + /* A proxy for a subroutine in this package? */ + : SvOK(gv) ? (CV *) gv : NULL) + : NULL; + /* See if it's the indirect object for a list operator. */ if (PL_oldoldbufptr && @@ -4186,16 +4336,22 @@ Perl_yylex(pTHX) /* Two barewords in a row may indicate method call. */ - if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv))) + if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && + (tmp = intuit_method(s, gv, cv))) return REPORT(tmp); /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ + /* Also, if "_" follows a filetest operator, it's a bareword */ - if ( !immediate_paren && (PL_last_lop_op == OP_SORT || - ((!gv || !GvCVu(gv)) && + if ( + ( !immediate_paren && (PL_last_lop_op == OP_SORT || + ((!gv || !cv) && (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)))) + || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0' + && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP)) + ) { PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR; goto bareword; @@ -4217,9 +4373,9 @@ Perl_yylex(pTHX) /* If followed by a paren, it's certainly a subroutine. */ if (*s == '(') { CLINE; - if (gv && GvCVu(gv)) { + if (cv) { for (d = s + 1; SPACE_OR_TAB(*d); d++) ; - if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { + if (*d == ')' && (sv = gv_const_sv(gv))) { s = d + 1; goto its_constant; } @@ -4233,7 +4389,7 @@ Perl_yylex(pTHX) /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) { + if ((*s == '$' || *s == '{') && (!gv || !cv)) { PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_METHOD; PREBLOCK(METHOD); @@ -4243,20 +4399,18 @@ Perl_yylex(pTHX) if (!orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') - && (tmp = intuit_method(s,gv))) + && (tmp = intuit_method(s, gv, cv))) return REPORT(tmp); /* Not a method, so call it a subroutine (if defined) */ - if (gv && GvCVu(gv)) { - CV* cv; + if (cv) { if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS)) Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ - cv = GvCV(gv); - if ((sv = cv_const_sv(cv))) { + if ((sv = gv_const_sv(gv))) { its_constant: SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); @@ -4265,6 +4419,14 @@ Perl_yylex(pTHX) } /* Resolve to GV now. */ + if (SvTYPE(gv) != SVt_PVGV) { + gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV); + assert (SvTYPE(gv) == SVt_PVGV); + /* cv must have been some sort of placeholder, so + now needs replacing with a real code reference. */ + cv = GvCV(gv); + } + op_free(yylval.opval); yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); yylval.opval->op_private |= OPpENTERSUB_NOPAREN; @@ -4273,7 +4435,7 @@ Perl_yylex(pTHX) /* Is there a prototype? */ if (SvPOK(cv)) { STRLEN len; - char *proto = SvPV((SV*)cv, len); + const char *proto = SvPV_const((SV*)cv, len); if (!len) TERM(FUNC0SUB); if (*proto == '$' && proto[1] == '\0') @@ -4298,8 +4460,8 @@ Perl_yylex(pTHX) yylval.opval->op_private |= OPpCONST_STRICT; else { bareword: - if (ckWARN(WARN_RESERVED)) { - if (lastchar != '-') { + if (lastchar != '-') { + if (ckWARN(WARN_RESERVED)) { for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; if (!*d && !gv_stashpv(PL_tokenbuf,FALSE)) Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, @@ -4334,27 +4496,26 @@ Perl_yylex(pTHX) case KEY___PACKAGE__: yylval.opval = (OP*)newSVOP(OP_CONST, 0, (PL_curstash - ? newSVpv(HvNAME(PL_curstash), 0) + ? newSVhek(HvNAME_HEK(PL_curstash)) : &PL_sv_undef)); TERM(THING); case KEY___DATA__: case KEY___END__: { GV *gv; - - /*SUPPRESS 560*/ if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) { const char *pname = "main"; if (PL_tokenbuf[2] == 'D') - pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash); - gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); + pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash); + gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD, + SVt_PVIO); GvMULTI_on(gv); if (!GvIO(gv)) GvIOp(gv) = newIO(); IoIFP(GvIOp(gv)) = PL_rsfp; #if defined(HAS_FCNTL) && defined(F_SETFD) { - int fd = PerlIO_fileno(PL_rsfp); + const int fd = PerlIO_fileno(PL_rsfp); fcntl(fd,F_SETFD,fd >= 3); } #endif @@ -4445,6 +4606,9 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf); if (tmp < 0) tmp = -tmp; + else if (tmp == KEY_require || tmp == KEY_do) + /* that's a way to remember we saw "CORE::" */ + orig_keyword = tmp; goto reserved_word; } goto just_a_word; @@ -4473,14 +4637,34 @@ Perl_yylex(pTHX) case KEY_bless: LOP(OP_BLESS,XTERM); + case KEY_break: + FUN0(OP_BREAK); + case KEY_chop: UNI(OP_CHOP); case KEY_continue: + /* When 'use switch' is in effect, continue has a dual + life as a control operator. */ + { + if (!FEATURE_IS_ENABLED("switch", 6)) + PREBLOCK(CONTINUE); + else { + /* We have to disambiguate the two senses of + "continue". If the next token is a '{' then + treat it as the start of a continue block; + otherwise treat it as a control operator. + */ + s = skipspace(s); + if (*s == '{') PREBLOCK(CONTINUE); + else + FUN0(OP_CONTINUE); + } + } case KEY_chdir: - (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */ + (void)gv_fetchpv("ENV", GV_ADD, SVt_PVHV); /* may use HOME */ UNI(OP_CHDIR); case KEY_close: @@ -4522,12 +4706,21 @@ Perl_yylex(pTHX) case KEY_chroot: UNI(OP_CHROOT); + case KEY_default: + PREBLOCK(DEFAULT); + case KEY_do: s = skipspace(s); if (*s == '{') PRETERMBLOCK(DO); if (*s != '\'') s = force_word(s,WORD,TRUE,TRUE,FALSE); + if (orig_keyword == KEY_do) { + orig_keyword = 0; + yylval.ival = 1; + } + else + yylval.ival = 0; OPERATOR(DO); case KEY_die: @@ -4738,6 +4931,10 @@ Perl_yylex(pTHX) case KEY_getlogin: FUN0(OP_GETLOGIN); + case KEY_given: + yylval.ival = CopLINE(PL_curcop); + OPERATOR(GIVEN); + case KEY_glob: set_csh(); LOP(OP_GLOB,XTERM); @@ -4857,11 +5054,7 @@ Perl_yylex(pTHX) Eop(OP_SNE); case KEY_no: - if (PL_expect != XSTATE) - yyerror("\"no\" not allowed in expression"); - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - yylval.ival = 0; + s = tokenize_use(0, s); OPERATOR(USE); case KEY_not: @@ -4873,16 +5066,17 @@ Perl_yylex(pTHX) case KEY_open: s = skipspace(s); if (isIDFIRST_lazy_if(s,UTF)) { - char *t; + const char *t; for (d = s; isALNUM_lazy_if(d,UTF); d++) ; for (t=d; *t && isSPACE(*t); t++) ; if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) /* [perl #16184] */ && !(t[0] == '=' && t[1] == '>') ) { + int len = (int)(d-s); Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), "Precedence problem: open %.*s should be open(%.*s)", - d - s, s, d - s, s); + len, s, len, s); } } LOP(OP_OPEN,XTERM); @@ -4944,6 +5138,7 @@ Perl_yylex(pTHX) s = scan_str(s,FALSE,FALSE); if (!s) missingterm((char*)0); + PL_expect = XOPERATOR; force_next(')'); if (SvCUR(PL_lex_stuff)) { OP *words = Nullop; @@ -4953,7 +5148,7 @@ Perl_yylex(pTHX) SV *sv; for (; isSPACE(*d) && len; --len, ++d) ; if (len) { - char *b = d; + const char *b = d; if (!warned && ckWARN(WARN_QW)) { for (; !isSPACE(*d) && len; --len, ++d) { if (*d == ',') { @@ -5029,7 +5224,18 @@ Perl_yylex(pTHX) else if (*s == '<') yyerror("<> should be quotes"); } - UNI(OP_REQUIRE); + if (orig_keyword == KEY_require) { + orig_keyword = 0; + yylval.ival = 1; + } + else + yylval.ival = 0; + PL_expect = XTERM; + PL_bufptr = s; + PL_last_uni = PL_oldbufptr; + PL_last_lop_op = OP_REQUIRE; + s = skipspace(s); + return REPORT( (int)REQUIRE ); case KEY_reset: UNI(OP_RESET); @@ -5086,6 +5292,10 @@ Perl_yylex(pTHX) else TOKEN(1); /* force error */ + case KEY_say: + checkcomma(s,PL_tokenbuf,"filehandle"); + LOP(OP_SAY,XREF); + case KEY_chomp: UNI(OP_CHOMP); @@ -5211,7 +5421,7 @@ Perl_yylex(pTHX) SSize_t tboffset = 0; expectation attrful; bool have_name, have_proto, bad_proto; - int key = tmp; + const int key = tmp; s = skipspace(s); @@ -5238,7 +5448,7 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "Missing name in \"my sub\""); PL_expect = XTERMBLOCK; attrful = XATTRTERM; - sv_setpv(PL_subname,"?"); + sv_setpvn(PL_subname,"?",1); have_name = FALSE; } @@ -5392,25 +5602,7 @@ Perl_yylex(pTHX) LOP(OP_UNSHIFT,XTERM); case KEY_use: - if (PL_expect != XSTATE) - yyerror("\"use\" not allowed in expression"); - s = skipspace(s); - if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { - s = force_version(s, TRUE); - if (*s == ';' || (s = skipspace(s), *s == ';')) { - PL_nextval[PL_nexttoke].opval = Nullop; - force_next(WORD); - } - else if (*s == 'v') { - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - } - } - else { - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - } - yylval.ival = 1; + s = tokenize_use(1, s); OPERATOR(USE); case KEY_values: @@ -5419,6 +5611,10 @@ Perl_yylex(pTHX) case KEY_vec: LOP(OP_VEC,XTERM); + case KEY_when: + yylval.ival = CopLINE(PL_curcop); + OPERATOR(WHEN); + case KEY_while: yylval.ival = CopLINE(PL_curcop); OPERATOR(WHILE); @@ -5442,10 +5638,10 @@ Perl_yylex(pTHX) char ctl_l[2]; ctl_l[0] = toCTRL('L'); ctl_l[1] = '\0'; - gv_fetchpv(ctl_l,TRUE, SVt_PV); + gv_fetchpv(ctl_l, GV_ADD, SVt_PV); } #else - gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */ + gv_fetchpv("\f", GV_ADD, SVt_PV); /* Make sure $^L is defined */ #endif UNI(OP_ENTERWRITE); @@ -5479,7 +5675,7 @@ S_pending_ident(pTHX) PL_pending_ident = 0; DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Tokener saw identifier '%s'\n", PL_tokenbuf); }); + "### Pending identifier '%s'\n", PL_tokenbuf); }); /* if we're in a my(), we can't allow dynamics here. $foo'bar has already been turned into $foo::bar, so @@ -5524,7 +5720,9 @@ S_pending_ident(pTHX) /* might be an "our" variable" */ if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { /* build ops for a bareword */ - SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0); + HV * const stash = PAD_COMPNAME_OURSTASH(tmp); + HEK * const stashname = HvNAME_HEK(stash); + SV * const sym = newSVhek(stashname); sv_catpvn(sym, "::", 2); sv_catpv(sym, PL_tokenbuf+1); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); @@ -5569,7 +5767,7 @@ S_pending_ident(pTHX) table. */ if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { - GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); + GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV); if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) && ckWARN(WARN_AMBIGUOUS)) { @@ -5583,10 +5781,26 @@ S_pending_ident(pTHX) /* build ops for a bareword */ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, - ((PL_tokenbuf[0] == '$') ? SVt_PV - : (PL_tokenbuf[0] == '@') ? SVt_PVAV - : SVt_PVHV)); + gv_fetchpv( + PL_tokenbuf+1, + PL_in_eval + ? (GV_ADDMULTI | GV_ADDINEVAL) + /* If the identifier refers to a stash, don't autovivify it. + * Change 24660 had the side effect of causing symbol table + * hashes to always be defined, even if they were freshly + * created and the only reference in the entire program was + * the single statement with the defined %foo::bar:: test. + * It appears that all code in the wild doing this actually + * wants to know whether sub-packages have been loaded, so + * by avoiding auto-vivifying symbol tables, we ensure that + * defined %foo::bar:: continues to be false, and the existing + * tests still give the expected answers, even though what + * they're actually testing has now changed subtly. + */ + : !(*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'), + ((PL_tokenbuf[0] == '$') ? SVt_PV + : (PL_tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); return WORD; } @@ -5777,7 +5991,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 3: /* 28 tokens of length 3 */ + case 3: /* 29 tokens of length 3 */ switch (name[0]) { case 'E': @@ -5866,7 +6080,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) case 'r': if (name[2] == 'r') { /* err */ - return -KEY_err; + return (FEATURE_IS_ENABLED("err", 3) ? -KEY_err : 0); } goto unknown; @@ -6002,6 +6216,14 @@ Perl_keyword (pTHX_ const char *name, I32 len) case 's': switch (name[1]) { + case 'a': + if (name[2] == 'y') + { /* say */ + return (FEATURE_IS_ENABLED("say", 3) ? -KEY_say : 0); + } + + goto unknown; + case 'i': if (name[2] == 'n') { /* sin */ @@ -6062,7 +6284,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 4: /* 40 tokens of length 4 */ + case 4: /* 41 tokens of length 4 */ switch (name[0]) { case 'C': @@ -6492,8 +6714,9 @@ Perl_keyword (pTHX_ const char *name, I32 len) } case 'w': - if (name[1] == 'a') + switch (name[1]) { + case 'a': switch (name[2]) { case 'i': @@ -6515,6 +6738,12 @@ Perl_keyword (pTHX_ const char *name, I32 len) default: goto unknown; } + + case 'h': + if (name[2] == 'e' && + name[3] == 'n') + { /* when */ + return (FEATURE_IS_ENABLED("switch", 6) ? KEY_when : 0); } goto unknown; @@ -6523,7 +6752,11 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 5: /* 36 tokens of length 5 */ + default: + goto unknown; + } + + case 5: /* 38 tokens of length 5 */ switch (name[0]) { case 'B': @@ -6576,8 +6809,10 @@ Perl_keyword (pTHX_ const char *name, I32 len) } case 'b': - if (name[1] == 'l' && - name[2] == 'e' && + switch (name[1]) + { + case 'l': + if (name[2] == 'e' && name[3] == 's' && name[4] == 's') { /* bless */ @@ -6586,6 +6821,20 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; + case 'r': + if (name[2] == 'e' && + name[3] == 'a' && + name[4] == 'k') + { /* break */ + return (FEATURE_IS_ENABLED("switch", 6) ? -KEY_break : 0); + } + + goto unknown; + + default: + goto unknown; + } + case 'c': switch (name[1]) { @@ -6699,6 +6948,17 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } + case 'g': + if (name[1] == 'i' && + name[2] == 'v' && + name[3] == 'e' && + name[4] == 'n') + { /* given */ + return (FEATURE_IS_ENABLED("switch", 6) ? KEY_given : 0); + } + + goto unknown; + case 'i': switch (name[1]) { @@ -7435,7 +7695,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 7: /* 28 tokens of length 7 */ + case 7: /* 29 tokens of length 7 */ switch (name[0]) { case 'D': @@ -7506,9 +7766,22 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; case 'e': - if (name[2] == 'f' && - name[3] == 'i' && - name[4] == 'n' && + if (name[2] == 'f') + { + switch (name[3]) + { + case 'a': + if (name[4] == 'u' && + name[5] == 'l' && + name[6] == 't') + { /* default */ + return (FEATURE_IS_ENABLED("switch", 6) ? KEY_default : 0); + } + + goto unknown; + + case 'i': + if (name[4] == 'n' && name[5] == 'e' && name[6] == 'd') { /* defined */ @@ -7520,6 +7793,13 @@ Perl_keyword (pTHX_ const char *name, I32 len) default: goto unknown; } + } + + goto unknown; + + default: + goto unknown; + } case 'f': if (name[1] == 'o' && @@ -8893,9 +9173,9 @@ unknown: } STATIC void -S_checkcomma(pTHX_ register char *s, char *name, const char *what) +S_checkcomma(pTHX_ register char *s, const char *name, const char *what) { - char *w; + const char *w; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ if (ckWARN(WARN_SYNTAX)) { @@ -8926,8 +9206,8 @@ S_checkcomma(pTHX_ register char *s, char *name, const char *what) while (s < PL_bufend && isSPACE(*s)) s++; if (*s == ',') { - int kw; - *s = '\0'; + I32 kw; + *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */ kw = keyword(w, s - w) || get_cv(w, FALSE) != 0; *s = ','; if (kw) @@ -8947,11 +9227,11 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type) { dVAR; dSP; - HV *table = GvHV(PL_hintgv); /* ^H */ + HV * const table = GvHV(PL_hintgv); /* ^H */ SV *res; SV **cvp; SV *cv, *typesv; - const char *why1, *why2, *why3; + const char *why1 = "", *why2 = "", *why3 = ""; if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; @@ -8973,7 +9253,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", (type ? type: "undef"), why1, why2, why3); msgdone: - yyerror(SvPVX(msg)); + yyerror(SvPVX_const(msg)); SvREFCNT_dec(msg); return sv; } @@ -9011,9 +9291,8 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, /* Check the eval first */ if (!PL_in_eval && SvTRUE(ERRSV)) { - STRLEN n_a; sv_catpv(ERRSV, "Propagated"); - yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */ + yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */ (void)POPs; res = SvREFCNT_inc(sv); } @@ -9045,7 +9324,7 @@ STATIC char * S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { register char *d = dest; - register char *e = d + destlen - 3; /* two-character token, ending NUL */ + register char * const e = d + destlen - 3; /* two-character token, ending NUL */ for (;;) { if (d >= e) Perl_croak(aTHX_ ident_too_long); @@ -9079,11 +9358,11 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag } STATIC char * -S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni) +S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni) { register char *d; register char *e; - char *bracket = 0; + char *bracket = Nullch; char funny = *s++; if (isSPACE(*s)) @@ -9154,7 +9433,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (bracket) { if (isSPACE(s[-1])) { while (s < send) { - char ch = *s++; + const char ch = *s++; if (!SPACE_OR_TAB(ch)) { *d = ch; break; @@ -9258,11 +9537,14 @@ STATIC char * S_scan_pat(pTHX_ char *start, I32 type) { PMOP *pm; - char *s; + char *s = scan_str(start,FALSE,FALSE); - s = scan_str(start,FALSE,FALSE); - if (!s) - Perl_croak(aTHX_ "Search pattern not terminated"); + if (!s) { + char * const delimiter = skipspace(start); + Perl_croak(aTHX_ *delimiter == '?' + ? "Search pattern not terminated or ternary operator parsed as search pattern" + : "Search pattern not terminated" ); + } pm = (PMOP*)newPMOP(type, 0); if (PL_multi_open == '?') @@ -9276,10 +9558,10 @@ S_scan_pat(pTHX_ char *start, I32 type) pmflag(&pm->op_pmflags,*s++); } /* issue a warning if /c is specified,but /g is not */ - if (ckWARN(WARN_REGEXP) && - (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)) + if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL) + && ckWARN(WARN_REGEXP)) { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g); + Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" ); } pm->op_pmpermflags = pm->op_pmflags; @@ -9331,10 +9613,8 @@ S_scan_subst(pTHX_ char *start) break; } - /* /c is not meaningful with s/// */ - if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE)) - { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst); + if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) { + Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" ); } if (es) { @@ -9406,7 +9686,7 @@ S_scan_trans(pTHX_ char *start) } no_more: - New(803, tbl, complement&&!del?258:256, short); + Newx(tbl, complement&&!del?258:256, short); o = newPVOP(OP_TRANS, 0, (char*)tbl); o->op_private &= ~OPpTRANS_ALL; o->op_private |= del|squash|complement| @@ -9431,7 +9711,7 @@ S_scan_heredoc(pTHX_ register char *s) register char *d; register char *e; char *peek; - int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR)); + const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR)); s += 2; d = PL_tokenbuf; @@ -9467,7 +9747,7 @@ S_scan_heredoc(pTHX_ register char *s) #ifndef PERL_STRICT_CR d = strchr(s, '\r'); if (d) { - char *olds = s; + char * const olds = s; s = d; while (s < PL_bufend) { if (*s == '\r') { @@ -9484,7 +9764,7 @@ S_scan_heredoc(pTHX_ register char *s) } *d = '\0'; PL_bufend = d; - SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr)); + SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); s = olds; } #endif @@ -9515,7 +9795,7 @@ S_scan_heredoc(pTHX_ register char *s) if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) { char *bufptr = PL_sublex_info.super_bufptr; char *bufend = PL_sublex_info.super_bufend; - char *olds = s - SvCUR(herewas); + char * const olds = s - SvCUR(herewas); s = strchr(bufptr, '\n'); if (!s) s = bufend; @@ -9533,7 +9813,7 @@ S_scan_heredoc(pTHX_ register char *s) sv_setpvn(tmpstr,d+1,s-d); s += len - 1; sv_catpvn(herewas,s,bufend-s); - Copy(SvPVX(herewas),bufptr,SvCUR(herewas) + 1,char); + Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char); s = olds; goto retval; @@ -9577,7 +9857,7 @@ S_scan_heredoc(pTHX_ register char *s) { PL_bufend[-2] = '\n'; PL_bufend--; - SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr)); + SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); } else if (PL_bufend[-1] == '\r') PL_bufend[-1] = '\n'; @@ -9595,7 +9875,7 @@ S_scan_heredoc(pTHX_ register char *s) av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv); } if (*s == term && memEQ(s,PL_tokenbuf,len)) { - STRLEN off = PL_bufend - 1 - SvPVX(PL_linestr); + STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); *(SvPVX(PL_linestr) + off ) = ' '; sv_catsv(PL_linestr,herewas); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -9614,7 +9894,7 @@ retval: } SvREFCNT_dec(herewas); if (!IN_BYTES) { - if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) + if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr))) SvUTF8_on(tmpstr); else if (PL_encoding) sv_recode_to_utf8(tmpstr, PL_encoding); @@ -9645,7 +9925,7 @@ S_scan_inputsymbol(pTHX_ char *start) { register char *s = start; /* current position in buffer */ register char *d; - register char *e; + const char *e; char *end; I32 len; @@ -9706,7 +9986,7 @@ S_scan_inputsymbol(pTHX_ char *start) Copy("ARGV",d,5,char); /* Check whether readline() is overriden */ - if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV)) + if (((gv_readline = gv_fetchpv("readline", 0, SVt_PVCV)) && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) || ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE)) @@ -9725,8 +10005,9 @@ S_scan_inputsymbol(pTHX_ char *start) */ if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { - SV *sym = sv_2mortal( - newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0)); + HV *stash = PAD_COMPNAME_OURSTASH(tmp); + HEK *stashname = HvNAME_HEK(stash); + SV *sym = sv_2mortal(newSVhek(stashname)); sv_catpvn(sym, "::", 2); sv_catpv(sym, d+1); d = SvPVX(sym); @@ -9769,7 +10050,7 @@ intro_sym: /* If it's none of the above, it must be a literal filehandle ( or ) so build a simple readline OP */ else { - GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO); + GV *gv = gv_fetchpv(d, GV_ADD, SVt_PVIO); PL_lex_op = readline_overriden ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, @@ -9888,10 +10169,10 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) bool cont = TRUE; while (cont) { - int offset = s - SvPVX(PL_linestr); - bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, + int offset = s - SvPVX_const(PL_linestr); + const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, &offset, (char*)termstr, termlen); - char *ns = SvPVX(PL_linestr) + offset; + const char *ns = SvPVX_const(PL_linestr) + offset; char *svlast = SvEND(sv) - 1; for (; s < ns; s++) { @@ -9903,8 +10184,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) else { /* handle quoted delimiters */ if (SvCUR(sv) > 1 && *(svlast-1) == '\\') { - char *t; - for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';) + const char *t; + for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';) t--; if ((svlast-1 - t) % 2) { if (!keep_quoted) { @@ -9919,10 +10200,11 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) cont = FALSE; } else { - char *t, *w; + const char *t; + char *w; if (!last) last = SvPVX(sv); - for (w = t = last; t < svlast; w++, t++) { + for (t = w = last; t < svlast; w++, t++) { /* At here, all closes are "was quoted" one, so we don't check PL_multi_close. */ if (*t == '\\') { @@ -9939,7 +10221,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) if (w < t) { *w++ = term; *w = '\0'; - SvCUR_set(sv, w - SvPVX(sv)); + SvCUR_set(sv, w - SvPVX_const(sv)); } last = w; if (--brackets <= 0) @@ -10017,7 +10299,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) } /* terminate the copied string and update the sv's end-of-string */ *to = '\0'; - SvCUR_set(sv, to - SvPVX(sv)); + SvCUR_set(sv, to - SvPVX_const(sv)); /* * this next chunk reads more into the buffer if we're not done yet @@ -10027,18 +10309,18 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) break; /* handle case where we are done yet :-) */ #ifndef PERL_STRICT_CR - if (to - SvPVX(sv) >= 2) { + if (to - SvPVX_const(sv) >= 2) { if ((to[-2] == '\r' && to[-1] == '\n') || (to[-2] == '\n' && to[-1] == '\r')) { to[-2] = '\n'; to--; - SvCUR_set(sv, to - SvPVX(sv)); + SvCUR_set(sv, to - SvPVX_const(sv)); } else if (to[-1] == '\r') to[-1] = '\n'; } - else if (to - SvPVX(sv) == 1 && to[-1] == '\r') + else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r') to[-1] = '\n'; #endif @@ -10216,7 +10498,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* _ are ignored -- but warned about if consecutive */ case '_': - if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; @@ -10296,7 +10578,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) sv = NEWSV(92,0); if (overflowed) { - if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) + if (n > 4294967295.0 && ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", Base, max); @@ -10304,7 +10586,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } else { #if UVSIZE > 4 - if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) + if (u > 0xffffffff && ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", Base, max); @@ -10336,7 +10618,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if -w is on */ if (*s == '_') { - if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; @@ -10378,7 +10660,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if (d >= e) Perl_croak(aTHX_ number_too_long); if (*s == '_') { - if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s; @@ -10435,9 +10717,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) *d++ = *s++; } else { - if (ckWARN(WARN_SYNTAX) && - ((lastub && s == lastub + 1) || - (!isDIGIT(s[1]) && s[1] != '_'))) + if (((lastub && s == lastub + 1) || + (!isDIGIT(s[1]) && s[1] != '_')) + && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; @@ -10514,7 +10796,6 @@ S_scan_formline(pTHX_ register char *s) while (!needargs) { if (*s == '.') { - /*SUPPRESS 530*/ #ifdef PERL_STRICT_CR for (t = s+1;SPACE_OR_TAB(*t); t++) ; #else @@ -10555,7 +10836,7 @@ S_scan_formline(pTHX_ register char *s) else break; } - s = eol; + s = (char*)eol; if (PL_rsfp) { s = filter_gets(PL_linestr, PL_rsfp, 0); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); @@ -10579,7 +10860,7 @@ S_scan_formline(pTHX_ register char *s) else PL_lex_state = LEX_FORMLINE; if (!IN_BYTES) { - if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff))) + if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff))) SvUTF8_on(stuff); else if (PL_encoding) sv_recode_to_utf8(stuff, PL_encoding); @@ -10610,7 +10891,7 @@ S_set_csh(pTHX) I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { - I32 oldsavestack_ix = PL_savestack_ix; + const I32 oldsavestack_ix = PL_savestack_ix; CV* outsidecv = PL_compcv; if (PL_compcv) { @@ -10654,8 +10935,9 @@ Perl_yyerror(pTHX_ const char *s) if (!yychar || (yychar == ';' && !PL_rsfp)) where = "at EOF"; - else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 && - PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) { + else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr && + PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr && + PL_oldbufptr != PL_bufptr) { /* Only for NetWare: The code below is removed for NetWare because it abends/crashes on NetWare @@ -10670,8 +10952,8 @@ Perl_yyerror(pTHX_ const char *s) context = PL_oldoldbufptr; contlen = PL_bufptr - PL_oldoldbufptr; } - else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 && - PL_oldbufptr != PL_bufptr) { + else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr && + PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) { /* Only for NetWare: The code below is removed for NetWare because it abends/crashes on NetWare @@ -10705,7 +10987,7 @@ Perl_yyerror(pTHX_ const char *s) Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar); else Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); - where = SvPVX(where_sv); + where = SvPVX_const(where_sv); } msg = sv_2mortal(newSVpv(s, 0)); Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ", @@ -10733,7 +11015,7 @@ Perl_yyerror(pTHX_ const char *s) OutCopFILE(PL_curcop)); } PL_in_my = 0; - PL_in_my_stash = Nullhv; + PL_in_my_stash = NULL; return 0; } #ifdef __SC__ @@ -10743,8 +11025,7 @@ Perl_yyerror(pTHX_ const char *s) STATIC char* S_swallow_bom(pTHX_ U8 *s) { - STRLEN slen; - slen = SvCUR(PL_linestr); + const STRLEN slen = SvCUR(PL_linestr); switch (s[0]) { case 0xFF: if (s[1] == 0xFE) { @@ -10760,7 +11041,7 @@ S_swallow_bom(pTHX_ U8 *s) I32 newlen; filter_add(utf16rev_textfilter, NULL); - New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); + Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); utf16_to_utf8_reversed(s, news, PL_bufend - (char*)s - 1, &newlen); @@ -10786,7 +11067,7 @@ S_swallow_bom(pTHX_ U8 *s) I32 newlen; filter_add(utf16_textfilter, NULL); - New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); + Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); utf16_to_utf8(s, news, PL_bufend - (char*)s, &newlen); @@ -10843,7 +11124,7 @@ S_swallow_bom(pTHX_ U8 *s) static void restore_rsfp(pTHX_ void *f) { - PerlIO *fp = (PerlIO*)f; + PerlIO * const fp = (PerlIO*)f; if (PL_rsfp == PerlIO_stdin()) PerlIO_clearerr(PL_rsfp); @@ -10856,17 +11137,17 @@ restore_rsfp(pTHX_ void *f) static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) { - STRLEN old = SvCUR(sv); - I32 count = FILTER_READ(idx+1, sv, maxlen); + const STRLEN old = SvCUR(sv); + const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter(%p): %d %d (%d)\n", utf16_textfilter, idx, maxlen, (int) count)); if (count) { U8* tmps; I32 newlen; - New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); - Copy(SvPVX(sv), tmps, old, char); - utf16_to_utf8((U8*)SvPVX(sv) + old, tmps + old, + Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8); + Copy(SvPVX_const(sv), tmps, old, char); + utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old, SvCUR(sv) - old, &newlen); sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old); } @@ -10877,17 +11158,17 @@ utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) { - STRLEN old = SvCUR(sv); - I32 count = FILTER_READ(idx+1, sv, maxlen); + const STRLEN old = SvCUR(sv); + const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16rev_textfilter(%p): %d %d (%d)\n", utf16rev_textfilter, idx, maxlen, (int) count)); if (count) { U8* tmps; I32 newlen; - New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); - Copy(SvPVX(sv), tmps, old, char); - utf16_to_utf8((U8*)SvPVX(sv) + old, tmps + old, + Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8); + Copy(SvPVX_const(sv), tmps, old, char); + utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old, SvCUR(sv) - old, &newlen); sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old); } @@ -10931,16 +11212,15 @@ Perl_scan_vstring(pTHX_ const char *s, SV *sv) } if (!isALPHA(*pos)) { - UV rev; U8 tmpbuf[UTF8_MAXBYTES+1]; - U8 *tmpend; if (*s == 'v') s++; /* get past 'v' */ sv_setpvn(sv, "", 0); for (;;) { - rev = 0; + U8 *tmpend; + UV rev = 0; { /* this is atoi() that tolerates underscores */ const char *end = pos; @@ -10989,5 +11269,5 @@ Perl_scan_vstring(pTHX_ const char *s, SV *sv) * indent-tabs-mode: t * End: * - * vim: shiftwidth=4: -*/ + * ex: set ts=8 sts=4 sw=4 noet: + */