X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=6f5441622ae49e80714cd2eb38adc39278e0b70f;hb=6d7fb585cd8ad83f4523191641999603aa48eb76;hp=18a89bd9bbd57325d3452357f63ae6f98fe2c464;hpb=90771dc0db35b74d256518c888adeac5f760aa04;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 18a89bd..6f54416 100644 --- a/toke.c +++ b/toke.c @@ -27,6 +27,7 @@ #define yylval (*PL_yylvalp) 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 @@ -459,7 +460,7 @@ S_missingterm(pTHX_ char *s) #define FEATURE_IS_ENABLED(name, namelen) \ ((0 != (PL_hints & HINT_LOCALIZE_HH)) \ - && feature_is_enabled(name, namelen)) + && feature_is_enabled(name, namelen) ) /* * S_feature_is_enabled * Check whether the named feature is enabled. @@ -502,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. */ @@ -1022,7 +1012,7 @@ S_force_ident(pTHX_ register const char *s, int kind) /* XXX see note in pp_entereval() for why we forgo typo warnings if the symbol must be introduced in an eval. GSAR 96-10-12 */ - gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, + gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD, kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : kind == '%' ? SVt_PVHV : @@ -2019,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; @@ -2108,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]; @@ -2116,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))) { - const char *proto = SvPVX_const(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; @@ -2150,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 */ @@ -2344,13 +2336,13 @@ 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_const(sv); @@ -2426,10 +2418,7 @@ Perl_yylex(pTHX) register char *s = PL_bufptr; register char *d; STRLEN len; - GV *gv = Nullgv; - GV **gvp = 0; bool bof = FALSE; - I32 orig_keyword = 0; DEBUG_T( { SV* tmp = newSVpvn("", 0); @@ -2728,6 +2717,8 @@ 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); @@ -2866,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 * const 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); @@ -3107,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; @@ -3235,7 +3227,7 @@ Perl_yylex(pTHX) case ':': if (s[1] == ':') { len = 0; - goto just_a_word; + goto just_a_word_zero_gv; } s++; switch (PL_expect) { @@ -3755,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 */ } } @@ -4005,7 +3997,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 */ } else @@ -4022,7 +4014,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 */ } else @@ -4077,7 +4069,7 @@ Perl_yylex(pTHX) 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); @@ -4123,12 +4115,9 @@ Perl_yylex(pTHX) keylookup: { I32 tmp; - assert (orig_keyword == 0); - assert (gv == 0); - assert (gvp == 0); - orig_keyword = 0; - gv = Nullgv; - gvp = 0; + I32 orig_keyword = 0; + GV *gv = Nullgv; + GV **gvp = 0; PL_bufptr = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); @@ -4174,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)) @@ -4201,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)) { @@ -4231,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; const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); + CV *cv; /* Get the rest if it looks like a package qualifier */ @@ -4266,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); @@ -4277,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 */ @@ -4309,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 && @@ -4326,7 +4336,8 @@ 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. */ @@ -4335,7 +4346,7 @@ Perl_yylex(pTHX) if ( ( !immediate_paren && (PL_last_lop_op == OP_SORT || - ((!gv || !GvCVu(gv)) && + ((!gv || !cv) && (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)))) || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0' @@ -4362,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; } @@ -4378,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); @@ -4388,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); @@ -4410,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; @@ -4490,7 +4507,8 @@ Perl_yylex(pTHX) const char *pname = "main"; if (PL_tokenbuf[2] == 'D') pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash); - gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); + gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD, + SVt_PVIO); GvMULTI_on(gv); if (!GvIO(gv)) GvIOp(gv) = newIO(); @@ -4646,7 +4664,7 @@ Perl_yylex(pTHX) } 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: @@ -5620,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); @@ -5749,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)) { @@ -6062,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; @@ -9968,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)) @@ -10032,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,