X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a3b680e6b77dd7f88268fad8b1dbdf4f641dd836..89552e80fce1de87a2720adec023baa6ccc9b702:/toke.c diff --git a/toke.c b/toke.c index 381af0b..287aa94 100644 --- a/toke.c +++ b/toke.c @@ -66,17 +66,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[] = { @@ -107,15 +112,6 @@ static const char* const lex_state_names[] = { #endif #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) -/* According to some strict interpretations of ANSI C89 one cannot - * cast void pointers to code pointers or vice versa (as filter_add(), - * filter_del(), and filter_read() will want to do). We should still - * be able to use a union for sneaky "casting". */ -typedef union { - XPVIO* iop; - filter_t filter; -} xpvio_filter_u; - /* * Convenience functions to return different tokens and prime the * lexer for the next token. They all take an argument. @@ -176,25 +172,29 @@ typedef union { * 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) @@ -288,7 +288,7 @@ S_tokereport(pTHX_ const char* s, I32 rv) const char *name = Nullch; enum token_type type = TOKENTYPE_NONE; const struct debug_tokens *p; - SV* report = newSVpvn("<== ", 4); + SV* const report = newSVpvn("<== ", 4); for (p = debug_tokens; p->token; p++) { if (p->token == (int)rv) { @@ -320,25 +320,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* tmp = newSVpvn("", 0); + PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); + SvREFCNT_dec(tmp); +} + #endif /* @@ -380,8 +390,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; @@ -398,12 +408,12 @@ S_no_op(pTHX_ const char *what, char *s) 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; @@ -424,7 +434,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'; } @@ -436,7 +446,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; } @@ -496,8 +506,8 @@ S_depcom(pTHX) static void strip_return(SV *sv) { - register const char *s = SvPVX(sv); - register const 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') { @@ -534,7 +544,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); @@ -575,8 +585,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; @@ -590,7 +600,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)); @@ -669,6 +679,43 @@ S_incline(pTHX_ char *s) ch = *t; *t = '\0'; if (t - s > 0) { +#ifndef USE_ITHREADS + const char *cf = CopFILE(PL_curcop); + if (cf && strlen(cf) > 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 */ } @@ -1069,7 +1116,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); } @@ -1081,7 +1128,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"); @@ -1123,7 +1170,7 @@ S_tokeq(pTHX_ SV *sv) STATIC I32 S_sublex_start(pTHX) { - const register I32 op_type = yylval.ival; + register const I32 op_type = yylval.ival; if (op_type == OP_NULL) { yylval.opval = PL_lex_op; @@ -1136,7 +1183,7 @@ S_sublex_start(pTHX) if (SvTYPE(sv) == SVt_PVIV) { /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ STRLEN len; - const char *p = SvPV(sv, len); + const char *p = SvPV_const(sv, len); SV * const nsv = newSVpvn(p, len); if (SvUTF8(sv)) SvUTF8_on(nsv); @@ -1211,8 +1258,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; @@ -1238,7 +1285,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; @@ -1373,6 +1420,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 @@ -1396,7 +1446,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; @@ -1407,7 +1457,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 - */ @@ -1422,8 +1472,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)) @@ -1442,6 +1493,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; } @@ -1460,6 +1514,9 @@ S_scan_const(pTHX_ char *start) } else { didrange = FALSE; +#ifdef EBCDIC + literal_endpoint = 0; +#endif } } @@ -1560,9 +1617,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); @@ -1585,7 +1642,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; @@ -1634,15 +1691,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); } @@ -1680,7 +1737,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{}"); @@ -1702,7 +1759,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 @@ -1712,19 +1769,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'; @@ -1735,7 +1792,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); @@ -1793,18 +1850,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); @@ -1817,7 +1878,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"); @@ -1916,7 +1977,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; - const char *send = strchr(s,']'); + const char * const send = strchr(s,']'); char tmpbuf[sizeof PL_tokenbuf * 4]; if (!send) /* has to be an expression */ @@ -2044,7 +2105,7 @@ S_intuit_method(pTHX_ char *start, GV *gv) if (GvIO(gv)) return 0; if ((cv = GvCVu(gv))) { - const char *proto = SvPVX(cv); + const char *proto = SvPVX_const(cv); if (proto) { if (*proto == ';') proto++; @@ -2106,7 +2167,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; @@ -2137,8 +2198,6 @@ S_incl_perldb(pTHX) SV * Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) { - xpvio_filter_u u; - if (!funcp) return Nullsv; @@ -2146,12 +2205,11 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) PL_rsfp_filters = newAV(); if (!datasv) datasv = NEWSV(255,0); - (void)SvUPGRADE(datasv, SVt_PVIO); - u.filter = funcp; - IoANY(datasv) = u.iop; /* 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*)u.iop, SvPV_nolen(datasv))); + IoANY(datasv), SvPV_nolen(datasv))); av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -2163,18 +2221,15 @@ void Perl_filter_del(pTHX_ filter_t funcp) { SV *datasv; - xpvio_filter_u u; #ifdef DEBUGGING - u.filter = funcp; - DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)u.iop)); + 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)); - u.iop = IoANY(datasv); - if (u.filter == funcp) { + if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) { IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; IoANY(datasv) = (void *)NULL; sv_free(av_pop(PL_rsfp_filters)); @@ -2193,7 +2248,6 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) { filter_t funcp; SV *datasv = NULL; - xpvio_filter_u u; if (!PL_rsfp_filters) return -1; @@ -2235,11 +2289,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 */ - u.iop = IoANY(datasv); - funcp = u.filter; + funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", - idx, (void*)u.iop, 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 */ @@ -2285,13 +2338,37 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) if ((gv = gv_fetchpv(pkgname, FALSE, 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", @@ -2341,8 +2418,13 @@ Perl_yylex(pTHX) 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) @@ -2366,10 +2448,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. @@ -2401,7 +2479,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; @@ -2458,7 +2536,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; @@ -2558,10 +2636,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) { @@ -2645,7 +2719,7 @@ Perl_yylex(pTHX) 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); @@ -2732,7 +2806,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); @@ -2778,7 +2852,7 @@ 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", TRUE, SVt_PV)); /* $^X */ assert(SvPOK(x) || SvGMAGICAL(x)); if (sv_eq(x, CopFILESV(PL_curcop))) { sv_setpvn(x, ipath, ipathend - ipath); @@ -2787,8 +2861,8 @@ Perl_yylex(pTHX) else { STRLEN blen; STRLEN llen; - const char *bstart = SvPV(CopFILESV(PL_curcop),blen); - const 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] == '/') { @@ -2859,7 +2933,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++; @@ -2887,7 +2961,7 @@ Perl_yylex(pTHX) const bool switches_done = PL_doswitches; do { if (*d == 'M' || *d == 'm' || *d == 'C') { - const 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); @@ -2986,8 +3060,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 */ } @@ -3032,7 +3106,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); } @@ -3368,7 +3442,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 @@ -3492,8 +3566,8 @@ Perl_yylex(pTHX) 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); @@ -3528,7 +3602,7 @@ Perl_yylex(pTHX) OPERATOR(','); if (tmp == '~') PMop(OP_MATCH); - if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) + 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) && @@ -3678,10 +3752,10 @@ Perl_yylex(pTHX) 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)) { + char *t; for(t = s + 1; isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; t++) ; @@ -3696,9 +3770,10 @@ Perl_yylex(pTHX) } } else if (*s == '{') { + char *t; PL_tokenbuf[0] = '%'; - if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") && - (t = strchr(s, '}')) && (t = strchr(t, '='))) + 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++) ; @@ -3778,8 +3853,8 @@ Perl_yylex(pTHX) PL_tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ - if (ckWARN(WARN_SYNTAX)) { - if (*s == '[' || *s == '{') { + if (*s == '[' || *s == '{') { + if (ckWARN(WARN_SYNTAX)) { const char *t = s + 1; while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t))) t++; @@ -3864,18 +3939,14 @@ 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; @@ -3892,9 +3963,7 @@ 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; @@ -3907,6 +3976,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; @@ -3917,9 +3988,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) @@ -3930,7 +3999,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) @@ -4091,8 +4160,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 &"); @@ -4173,7 +4242,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. */ @@ -4203,11 +4272,16 @@ Perl_yylex(pTHX) /* 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 || + if ( + ( !immediate_paren && (PL_last_lop_op == OP_SORT || ((!gv || !GvCVu(gv)) && (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; @@ -4285,7 +4359,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') @@ -4310,8 +4384,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, @@ -4346,19 +4420,17 @@ 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); + pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash); gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); GvMULTI_on(gv); if (!GvIO(gv)) @@ -4457,6 +4529,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; @@ -4540,6 +4615,12 @@ Perl_yylex(pTHX) 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: @@ -4869,11 +4950,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: @@ -4892,9 +4969,10 @@ Perl_yylex(pTHX) /* [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); @@ -4956,6 +5034,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; @@ -5041,7 +5120,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); @@ -5404,25 +5494,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: @@ -5491,7 +5563,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 @@ -5536,7 +5608,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); @@ -8959,11 +9033,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; @@ -8985,7 +9059,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; } @@ -9023,9 +9097,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); } @@ -9057,7 +9130,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); @@ -9095,7 +9168,7 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL { register char *d; register char *e; - char *bracket = 0; + char *bracket = Nullch; char funny = *s++; if (isSPACE(*s)) @@ -9272,8 +9345,12 @@ S_scan_pat(pTHX_ char *start, I32 type) PMOP *pm; char *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 == '?') @@ -9287,8 +9364,8 @@ 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); } @@ -9343,7 +9420,7 @@ S_scan_subst(pTHX_ char *start) } /* /c is not meaningful with s/// */ - if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE)) + if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) { Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst); } @@ -9417,7 +9494,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| @@ -9478,7 +9555,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') { @@ -9495,7 +9572,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 @@ -9526,7 +9603,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; @@ -9544,7 +9621,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; @@ -9588,7 +9665,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'; @@ -9606,7 +9683,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); @@ -9625,7 +9702,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); @@ -9656,7 +9733,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; @@ -9736,8 +9813,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); @@ -9899,10 +9977,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++) { @@ -9915,7 +9993,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* handle quoted delimiters */ if (SvCUR(sv) > 1 && *(svlast-1) == '\\') { const char *t; - for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';) + for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';) t--; if ((svlast-1 - t) % 2) { if (!keep_quoted) { @@ -9951,7 +10029,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) @@ -10029,7 +10107,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 @@ -10039,18 +10117,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 @@ -10228,7 +10306,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++; @@ -10308,7 +10386,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); @@ -10316,7 +10394,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); @@ -10348,7 +10426,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++; @@ -10390,7 +10468,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; @@ -10447,9 +10525,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++; @@ -10526,7 +10604,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 @@ -10567,7 +10644,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); @@ -10591,7 +10668,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); @@ -10666,8 +10743,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 @@ -10682,8 +10760,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 @@ -10717,7 +10795,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", ", @@ -10771,7 +10849,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); @@ -10797,7 +10875,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); @@ -10875,9 +10953,9 @@ utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) 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); } @@ -10896,9 +10974,9 @@ utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) 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); }