X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=b8abbd854f001057679312ed03b534e0853cf490;hb=da80cd87614d1347c811f58b124b84de7a7b192a;hp=e1f98dc1656a84f8723086f03c3de71d2b9ff8cc;hpb=f3040f2ca0eac516f4e8401bd98f55bfdf329a5d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index e1f98dc..b8abbd8 100644 --- a/toke.c +++ b/toke.c @@ -343,6 +343,8 @@ static struct debug_tokens { { OROP, TOKENTYPE_IVAL, "OROP" }, { OROR, TOKENTYPE_NONE, "OROR" }, { PACKAGE, TOKENTYPE_NONE, "PACKAGE" }, + { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" }, + { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" }, { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, { POSTDEC, TOKENTYPE_NONE, "POSTDEC" }, { POSTINC, TOKENTYPE_NONE, "POSTINC" }, @@ -4298,6 +4300,9 @@ Perl_yylex(pTHX) if (!PL_in_my || PL_lex_state != LEX_NORMAL) break; PL_bufptr = s; /* update in case we back off */ + if (*s == '=') { + deprecate(":= for an empty attribute list"); + } goto grabattrs; case XATTRBLOCK: PL_expect = XBLOCK; @@ -5217,6 +5222,7 @@ Perl_yylex(pTHX) case 'z': case 'Z': keylookup: { + bool anydelim; I32 tmp; orig_keyword = 0; @@ -5227,34 +5233,19 @@ Perl_yylex(pTHX) s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); /* Some keywords can be followed by any delimiter, including ':' */ - tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) || + anydelim = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) || (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') || (PL_tokenbuf[0] == 'q' && strchr("qwxr", PL_tokenbuf[1]))))); /* x::* is just a word, unless x is "CORE" */ - if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) + if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) goto just_a_word; d = s; while (d < PL_bufend && isSPACE(*d)) d++; /* no comments skipped here, or s### is misparsed */ - /* Is this a label? */ - if (!tmp && PL_expect == XSTATE - && d < PL_bufend && *d == ':' && *(d + 1) != ':') { - tmp = keyword(PL_tokenbuf, len, 0); - if (tmp) - Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf); - s = d + 1; - pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf); - CLINE; - TOKEN(LABEL); - } - else - /* Check for keywords */ - tmp = keyword(PL_tokenbuf, len, 0); - /* Is this a word before a => operator? */ if (*d == '=' && d[1] == '>') { CLINE; @@ -5265,6 +5256,47 @@ Perl_yylex(pTHX) TERM(WORD); } + /* Check for plugged-in keyword */ + { + OP *o; + int result; + char *saved_bufptr = PL_bufptr; + PL_bufptr = s; + result = CALL_FPTR(PL_keyword_plugin)(aTHX_ PL_tokenbuf, len, &o); + s = PL_bufptr; + if (result == KEYWORD_PLUGIN_DECLINE) { + /* not a plugged-in keyword */ + PL_bufptr = saved_bufptr; + } else if (result == KEYWORD_PLUGIN_STMT) { + pl_yylval.opval = o; + CLINE; + PL_expect = XSTATE; + return REPORT(PLUGSTMT); + } else if (result == KEYWORD_PLUGIN_EXPR) { + pl_yylval.opval = o; + CLINE; + PL_expect = XOPERATOR; + return REPORT(PLUGEXPR); + } else { + Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'", + PL_tokenbuf); + } + } + + /* Check for built-in keyword */ + tmp = keyword(PL_tokenbuf, len, 0); + + /* Is this a label? */ + if (!anydelim && PL_expect == XSTATE + && d < PL_bufend && *d == ':' && *(d + 1) != ':') { + if (tmp) + Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf); + s = d + 1; + pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf); + CLINE; + TOKEN(LABEL); + } + if (tmp < 0) { /* second-class keyword? */ GV *ogv = NULL; /* override (winner) */ GV *hgv = NULL; /* hidden (loser) */ @@ -5329,6 +5361,7 @@ Perl_yylex(pTHX) SV *sv; int pkgname = 0; const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); + OP *rv2cv_op; CV *cv; #ifdef PERL_MAD SV *nextPL_nextwhite = 0; @@ -5422,19 +5455,29 @@ 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) ? MUTABLE_CV(gv) : NULL) - : NULL; + cv = NULL; + { + OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc(sv)); + const_op->op_private = OPpCONST_BARE; + rv2cv_op = newCVREF(0, const_op); + } + if (rv2cv_op->op_type == OP_RV2CV && + (rv2cv_op->op_flags & OPf_KIDS)) { + OP *rv_op = cUNOPx(rv2cv_op)->op_first; + switch (rv_op->op_type) { + case OP_CONST: { + SV *sv = cSVOPx_sv(rv_op); + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) + cv = (CV*)SvRV(sv); + } break; + case OP_GV: { + GV *gv = cGVOPx_gv(rv_op); + CV *maybe_cv = GvCVu(gv); + if (maybe_cv && SvTYPE((SV*)maybe_cv) == SVt_PVCV) + cv = maybe_cv; + } break; + } + } /* See if it's the indirect object for a list operator. */ @@ -5457,8 +5500,10 @@ Perl_yylex(pTHX) /* Two barewords in a row may indicate method call. */ if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && - (tmp = intuit_method(s, gv, cv))) + (tmp = intuit_method(s, gv, cv))) { + op_free(rv2cv_op); return REPORT(tmp); + } /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ @@ -5466,7 +5511,7 @@ Perl_yylex(pTHX) if ( ( !immediate_paren && (PL_last_lop_op == OP_SORT || - ((!gv || !cv) && + (!cv && (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)))) || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0' @@ -5489,6 +5534,7 @@ Perl_yylex(pTHX) /* Is this a word before a => operator? */ if (*s == '=' && s[1] == '>' && !pkgname) { + op_free(rv2cv_op); CLINE; sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf); if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) @@ -5503,7 +5549,7 @@ Perl_yylex(pTHX) d = s + 1; while (SPACE_OR_TAB(*d)) d++; - if (*d == ')' && (sv = gv_const_sv(gv))) { + if (*d == ')' && (sv = cv_const_sv(cv))) { s = d + 1; goto its_constant; } @@ -5524,6 +5570,7 @@ Perl_yylex(pTHX) PL_thistoken = newSVpvs(""); } #endif + op_free(rv2cv_op); force_next(WORD); pl_yylval.ival = 0; TOKEN('&'); @@ -5531,7 +5578,8 @@ Perl_yylex(pTHX) /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && (!gv || !cv)) { + if ((*s == '$' || *s == '{') && !cv) { + op_free(rv2cv_op); PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_METHOD; PREBLOCK(METHOD); @@ -5541,8 +5589,10 @@ Perl_yylex(pTHX) if (!orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') - && (tmp = intuit_method(s, gv, cv))) + && (tmp = intuit_method(s, gv, cv))) { + op_free(rv2cv_op); return REPORT(tmp); + } /* Not a method, so call it a subroutine (if defined) */ @@ -5552,25 +5602,17 @@ Perl_yylex(pTHX) "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ - if ((sv = gv_const_sv(gv))) { + if ((sv = cv_const_sv(cv))) { its_constant: + op_free(rv2cv_op); SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv); ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); pl_yylval.opval->op_private = 0; TOKEN(WORD); } - /* 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(pl_yylval.opval); - pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + pl_yylval.opval = rv2cv_op; pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; @@ -5638,7 +5680,7 @@ Perl_yylex(pTHX) if (probable_sub) { gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV); op_free(pl_yylval.opval); - pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + pl_yylval.opval = rv2cv_op; pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; @@ -5690,6 +5732,7 @@ Perl_yylex(pTHX) } } } + op_free(rv2cv_op); safe_bareword: if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) { @@ -7051,7 +7094,7 @@ S_pending_ident(pTHX) yyerror(Perl_form(aTHX_ "No package name allowed for " "variable %s in \"our\"", PL_tokenbuf)); - tmp = allocmy(PL_tokenbuf); + tmp = allocmy(PL_tokenbuf, tokenbuf_len, 0); } else { if (has_colon) @@ -7059,7 +7102,7 @@ S_pending_ident(pTHX) PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf)); pl_yylval.opval = newOP(OP_PADANY, 0); - pl_yylval.opval->op_targ = allocmy(PL_tokenbuf); + pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, 0); return PRIVATEREF; } } @@ -7078,7 +7121,7 @@ S_pending_ident(pTHX) if (!has_colon) { if (!PL_in_my) - tmp = pad_findmy(PL_tokenbuf); + tmp = pad_findmy(PL_tokenbuf, tokenbuf_len, 0); if (tmp != NOT_IN_PAD) { /* might be an "our" variable" */ if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { @@ -7129,7 +7172,8 @@ S_pending_ident(pTHX) and @foo isn't a variable we can find in the symbol table. */ - if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { + if (ckWARN(WARN_AMBIGUOUS) && + pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0, SVt_PVAV); if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) @@ -7139,9 +7183,9 @@ S_pending_ident(pTHX) ) { /* Downgraded from fatal to warning 20000522 mjd */ - Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Possible unintended interpolation of %s in string", - PL_tokenbuf); + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Possible unintended interpolation of %s in string", + PL_tokenbuf); } } @@ -10931,21 +10975,28 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL return s; } +static U32 +S_pmflag(U32 pmfl, const char ch) { + switch (ch) { + CASE_STD_PMMOD_FLAGS_PARSE_SET(&pmfl); + case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break; + case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break; + case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break; + case KEEPCOPY_PAT_MOD: pmfl |= PMf_KEEPCOPY; break; + } + return pmfl; +} + void Perl_pmflag(pTHX_ U32* pmfl, int ch) { PERL_ARGS_ASSERT_PMFLAG; - PERL_UNUSED_CONTEXT; + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Perl_pmflag() is deprecated, and will be removed from the XS API"); + if (ch<256) { - const char c = (char)ch; - switch (c) { - CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl); - case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break; - case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break; - case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break; - case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break; - } + *pmfl = S_pmflag(*pmfl, (char)ch); } } @@ -10999,7 +11050,7 @@ S_scan_pat(pTHX_ char *start, I32 type) modstart = s; #endif while (*s && strchr(valid_flags, *s)) - pmflag(&pm->op_pmflags,*s++); + pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++); #ifdef PERL_MAD if (PL_madskills && modstart != s) { SV* tmptoken = newSVpvn(modstart, s - modstart); @@ -11079,7 +11130,7 @@ S_scan_subst(pTHX_ char *start) es++; } else if (strchr(S_PAT_MODS, *s)) - pmflag(&pm->op_pmflags,*s++); + pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++); else break; } @@ -11578,7 +11629,7 @@ S_scan_inputsymbol(pTHX_ char *start) /* try to find it in the pad for this block, otherwise find add symbol table ops */ - const PADOFFSET tmp = pad_findmy(d); + const PADOFFSET tmp = pad_findmy(d, len, 0); if (tmp != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { HV * const stash = PAD_COMPNAME_OURSTASH(tmp); @@ -12782,7 +12833,8 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter)); SV *const utf8_buffer = filter; IV status = IoPAGE(filter); - const bool reverse = IoLINES(filter); + const bool reverse = (bool) IoLINES(filter); + I32 retval; /* As we're automatically added, at the lowest level, and hence only called from this file, we can be sure that we're not called in block mode. Hence @@ -12815,7 +12867,10 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) nl = SvEND(utf8_buffer); } if (nl) { - sv_catpvn(sv, SvPVX(utf8_buffer), nl - SvPVX(utf8_buffer)); + STRLEN got = nl - SvPVX(utf8_buffer); + /* Did we have anything to append? */ + retval = got != 0; + sv_catpvn(sv, SvPVX(utf8_buffer), got); /* Everything else in this code works just fine if SVp_POK isn't set. This, however, needs it, and we need it to work, else we loop infinitely because the buffer is never consumed. */ @@ -12886,7 +12941,7 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) status, (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer))); DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);}); - return SvCUR(sv); + return retval; } static U8 * @@ -13000,6 +13055,18 @@ Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv) return (char *)s; } +int +Perl_keyword_plugin_standard(pTHX_ + char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) +{ + PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD; + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(keyword_ptr); + PERL_UNUSED_ARG(keyword_len); + PERL_UNUSED_ARG(op_ptr); + return KEYWORD_PLUGIN_DECLINE; +} + /* * Local variables: * c-indentation-style: bsd