X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=ad8dfbe9d008ab01b3d7f212703a6349965b7259;hb=248e23d9b695ef46108b0307a3e93bc148355a94;hp=2ccafc96429b7b7c42acdf2ea3beeba6958cf750;hpb=09ecc4b69a964aa52843e24f44be5f67b6fadd59;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 2ccafc9..ad8dfbe 100644 --- a/toke.c +++ b/toke.c @@ -14,11 +14,12 @@ #include "EXTERN.h" #include "perl.h" +#ifndef PERL_OBJECT static void check_uni _((void)); static void force_next _((I32 type)); static char *force_version _((char *start)); static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick)); -static SV *q _((SV *sv)); +static SV *tokeq _((SV *sv)); static char *scan_const _((char *start)); static char *scan_formline _((char *s)); static char *scan_heredoc _((char *s)); @@ -49,21 +50,13 @@ static int uni _((I32 f, char *s)); #endif static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append)); static void restore_rsfp _((void *f)); +static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)); static void restore_expect _((void *e)); static void restore_lex_expect _((void *e)); +#endif /* PERL_OBJECT */ static char ident_too_long[] = "Identifier too long"; -static char *linestart; /* beg. of most recently read line */ - -static char pending_ident; /* pending identifier lookup */ - -static struct { - I32 super_state; /* lexer state to save */ - I32 sub_inwhat; /* "lex_inwhat" to use */ - OP *sub_op; /* "lex_op" to use */ -} sublex_info; - /* The following are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). */ @@ -145,7 +138,7 @@ static struct { /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP) -static int +STATIC int ao(int toketype) { if (*bufptr == '=') { @@ -159,7 +152,7 @@ ao(int toketype) return toketype; } -static void +STATIC void no_op(char *what, char *s) { char *oldbp = bufptr; @@ -182,7 +175,7 @@ no_op(char *what, char *s) bufptr = oldbp; } -static void +STATIC void missingterm(char *s) { char tmpbuf[3]; @@ -215,7 +208,7 @@ deprecate(char *s) warn("Use of %s is deprecated", s); } -static void +STATIC void depcom(void) { deprecate("comma-less variable list"); @@ -223,7 +216,7 @@ depcom(void) #ifdef WIN32 -static I32 +STATIC I32 win32_textfilter(int idx, SV *sv, int maxlen) { I32 count = FILTER_READ(idx+1, sv, maxlen); @@ -305,7 +298,7 @@ lex_end(void) doextract = FALSE; } -static void +STATIC void restore_rsfp(void *f) { PerlIO *fp = (PerlIO*)f; @@ -317,21 +310,21 @@ restore_rsfp(void *f) rsfp = fp; } -static void +STATIC void restore_expect(void *e) { /* a safe way to store a small integer in a pointer */ expect = (expectation)((char *)e - tokenbuf); } -static void +STATIC void restore_lex_expect(void *e) { /* a safe way to store a small integer in a pointer */ lex_expect = (expectation)((char *)e - tokenbuf); } -static void +STATIC void incline(char *s) { dTHR; @@ -372,7 +365,7 @@ incline(char *s) curcop->cop_line = atoi(n)-1; } -static char * +STATIC char * skipspace(register char *s) { dTHR; @@ -428,7 +421,7 @@ skipspace(register char *s) } } -static void +STATIC void check_uni(void) { char *s; char ch; @@ -452,7 +445,7 @@ check_uni(void) { #undef UNI #define UNI(f) return uni(f,s) -static int +STATIC int uni(I32 f, char *s) { yylval.ival = f; @@ -473,7 +466,7 @@ uni(I32 f, char *s) #define LOP(f,x) return lop(f,x,s) -static I32 +STATIC I32 lop(I32 f, expectation x, char *s) { dTHR; @@ -494,7 +487,7 @@ lop(I32 f, expectation x, char *s) return LSTOP; } -static void +STATIC void force_next(I32 type) { nexttype[nexttoke] = type; @@ -506,7 +499,7 @@ force_next(I32 type) } } -static char * +STATIC char * force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick) { register char *s; @@ -538,7 +531,7 @@ force_word(register char *start, int token, int check_keyword, int allow_pack, i return s; } -static void +STATIC void force_ident(register char *s, int kind) { if (s && *s) { @@ -551,7 +544,7 @@ force_ident(register 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, in_eval ? (GV_ADDMULTI | 8) : TRUE, + gv_fetchpv(s, in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : kind == '%' ? SVt_PVHV : @@ -561,7 +554,7 @@ force_ident(register char *s, int kind) } } -static char * +STATIC char * force_version(char *s) { OP *version = Nullop; @@ -588,26 +581,29 @@ force_version(char *s) return (s); } -static SV * -q(SV *sv) +STATIC SV * +tokeq(SV *sv) { register char *s; register char *send; register char *d; - STRLEN len; + STRLEN len = 0; + SV *pv = sv; if (!SvLEN(sv)) - return sv; + goto finish; s = SvPV_force(sv, len); if (SvIVX(sv) == -1) - return sv; + goto finish; send = s + len; while (s < send && *s != '\\') s++; if (s == send) - return sv; + goto finish; d = s; + if ( hints & HINT_NEW_STRING ) + pv = sv_2mortal(newSVpv(SvPVX(pv), len)); while (s < send) { if (*s == '\\') { if (s + 1 < send && (s[1] == '\\')) @@ -617,11 +613,13 @@ q(SV *sv) } *d = '\0'; SvCUR_set(sv, d - SvPVX(sv)); - + finish: + if ( hints & HINT_NEW_STRING ) + return new_constant(NULL, 0, "q", sv, pv, "q"); return sv; } -static I32 +STATIC I32 sublex_start(void) { register I32 op_type = yylval.ival; @@ -632,11 +630,20 @@ sublex_start(void) return THING; } if (op_type == OP_CONST || op_type == OP_READLINE) { - SV *sv = q(lex_stuff); - STRLEN len; - char *p = SvPV(sv, len); - yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len)); - SvREFCNT_dec(sv); + SV *sv = tokeq(lex_stuff); + + if (SvTYPE(sv) == SVt_PVIV) { + /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ + STRLEN len; + char *p; + SV *nsv; + + p = SvPV(sv, len); + nsv = newSVpv(p, len); + SvREFCNT_dec(sv); + sv = nsv; + } + yylval.opval = (OP*)newSVOP(op_type, 0, sv); lex_stuff = Nullsv; return THING; } @@ -656,7 +663,7 @@ sublex_start(void) return FUNC; } -static I32 +STATIC I32 sublex_push(void) { dTHR; @@ -709,7 +716,7 @@ sublex_push(void) return '('; } -static I32 +STATIC I32 sublex_done(void) { if (!lex_starts++) { @@ -827,7 +834,7 @@ sublex_done(void) */ -static char * +STATIC char * scan_const(char *start) { register char *send = bufend; /* end of the constant */ @@ -840,7 +847,7 @@ scan_const(char *start) /* leaveit is the set of acceptably-backslashed characters */ char *leaveit = lex_inpat - ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#" + ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#" : ""; while (s < send || dorange) { @@ -1029,15 +1036,23 @@ scan_const(char *start) } /* return the substring (via yylval) only if we parsed anything */ - if (s > bufptr) + if (s > bufptr) { + if ( hints & ( lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) + sv = new_constant(start, s - start, (lex_inpat ? "qr" : "q"), + sv, Nullsv, + ( lex_inwhat == OP_TRANS + ? "tr" + : ( (lex_inwhat == OP_SUBST && !lex_inpat) + ? "s" + : "qq"))); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); - else + } else SvREFCNT_dec(sv); return s; } /* This is the one truly awful dwimmer necessary to conflate C and sed. */ -static int +STATIC int intuit_more(register char *s) { if (lex_brackets) @@ -1167,7 +1182,7 @@ intuit_more(register char *s) return TRUE; } -static int +STATIC int intuit_method(char *start, GV *gv) { char *s = start + (*start == '$'); @@ -1226,7 +1241,7 @@ intuit_method(char *start, GV *gv) return 0; } -static char* +STATIC char* incl_perldb(void) { if (perldb) { @@ -1355,10 +1370,10 @@ filter_read(int idx, SV *buf_sv, int maxlen) /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ - return (*funcp)(idx, buf_sv, maxlen); + return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen); } -static char * +STATIC char * filter_gets(register SV *sv, register PerlIO *fp, STRLEN append) { #ifdef WIN32FILTER @@ -1507,7 +1522,7 @@ yylex(void) /* build ops for a bareword */ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0)); yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE, + gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, ((tokenbuf[0] == '$') ? SVt_PV : (tokenbuf[0] == '@') ? SVt_PVAV : SVt_PVHV)); @@ -1664,7 +1679,9 @@ yylex(void) if (SvIVX(linestr) == '\'') { SV *sv = newSVsv(linestr); if (!lex_inpat) - sv = q(sv); + sv = tokeq(sv); + else if ( hints & HINT_NEW_RE ) + sv = new_constant(NULL, 0, "qr", sv, sv, "q"); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); s = bufend; } @@ -2804,14 +2821,28 @@ yylex(void) } if (tmp < 0) { /* second-class keyword? */ - if (expect != XOPERATOR && (*s != ':' || s[1] != ':') && - (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) && - GvCVu(gv) && GvIMPORTED_CV(gv)) || - ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) && - (gv = *gvp) != (GV*)&sv_undef && - GvCVu(gv) && GvIMPORTED_CV(gv)))) - { - tmp = 0; /* overridden by importation */ + GV *ogv = Nullgv; /* override (winner) */ + GV *hgv = Nullgv; /* hidden (loser) */ + if (expect != XOPERATOR && (*s != ':' || s[1] != ':')) { + CV *cv; + if ((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) && + (cv = GvCVu(gv))) + { + if (GvIMPORTED_CV(gv)) + ogv = gv; + else if (! CvMETHOD(cv)) + hgv = gv; + } + if (!ogv && + (gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) && + (gv = *gvp) != (GV*)&sv_undef && + GvCVu(gv) && GvIMPORTED_CV(gv)) + { + ogv = gv; + } + } + if (ogv) { + tmp = 0; /* overridden by import or by GLOBAL */ } else if (gv && !gvp && -tmp==KEY_lock /* XXX generalizable kludge */ @@ -2819,8 +2850,13 @@ yylex(void) { tmp = 0; /* any sub overrides "weak" keyword */ } - else { - tmp = -tmp; gv = Nullgv; gvp = 0; + else { /* no override */ + tmp = -tmp; + gv = Nullgv; + gvp = 0; + if (dowarn && hgv) + warn("Ambiguous call resolved as CORE::%s(), " + "qualify as such or use &", GvENAME(hgv)); } } @@ -2901,8 +2937,11 @@ yylex(void) oldoldbufptr < bufptr && (oldoldbufptr == last_lop || oldoldbufptr == last_uni) && /* NO SKIPSPACE BEFORE HERE! */ - (expect == XREF || - ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) ) + (expect == XREF + || ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF + || (last_lop_op == OP_ENTERSUB + && last_proto + && last_proto[last_proto[0] == ';' ? 1 : 0] == '*')) ) { bool immediate_paren = *s == '('; @@ -2983,16 +3022,17 @@ yylex(void) /* Is there a prototype? */ if (SvPOK(cv)) { STRLEN len; - char *proto = SvPV((SV*)cv, len); + last_proto = SvPV((SV*)cv, len); if (!len) TERM(FUNC0SUB); - if (strEQ(proto, "$")) + if (strEQ(last_proto, "$")) OPERATOR(UNIOPSUB); - if (*proto == '&' && *s == '{') { + if (*last_proto == '&' && *s == '{') { sv_setpv(subname,"__ANON__"); PREBLOCK(LSTOPSUB); } - } + } else + last_proto = NULL; nextval[nexttoke].opval = yylval.opval; expect = XTERM; force_next(WORD); @@ -3595,7 +3635,7 @@ yylex(void) } } force_next(')'); - nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff)); + nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff)); lex_stuff = Nullsv; force_next(THING); force_next(','); @@ -4378,6 +4418,8 @@ keyword(register char *d, I32 len) case 3: if (strEQ(d,"ord")) return -KEY_ord; if (strEQ(d,"oct")) return -KEY_oct; + if (strEQ(d,"our")) { deprecate("reserved word \"our\""); + return 0;} break; case 4: if (strEQ(d,"open")) return -KEY_open; @@ -4649,7 +4691,7 @@ keyword(register char *d, I32 len) return 0; } -static void +STATIC void checkcomma(register char *s, char *name, char *what) { char *w; @@ -4691,7 +4733,76 @@ checkcomma(register char *s, char *name, char *what) } } -static char * +STATIC SV * +new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) +{ + dSP; + HV *table = GvHV(hintgv); /* ^H */ + BINOP myop; + SV *res; + bool oldcatch = CATCH_GET; + SV **cvp; + SV *cv, *typesv; + char buf[128]; + + if (!table) { + yyerror("%^H is not defined"); + return sv; + } + cvp = hv_fetch(table, key, strlen(key), FALSE); + if (!cvp || !SvOK(*cvp)) { + sprintf(buf,"$^H{%s} is not defined", key); + yyerror(buf); + return sv; + } + sv_2mortal(sv); /* Parent created it permanently */ + cv = *cvp; + if (!pv) + pv = sv_2mortal(newSVpv(s, len)); + if (type) + typesv = sv_2mortal(newSVpv(type, 0)); + else + typesv = &sv_undef; + CATCH_SET(TRUE); + Zero(&myop, 1, BINOP); + myop.op_last = (OP *) &myop; + myop.op_next = Nullop; + myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; + + PUSHSTACKi(PERLSI_OVERLOAD); + ENTER; + SAVEOP(); + op = (OP *) &myop; + if (PERLDB_SUB && curstash != debstash) + op->op_private |= OPpENTERSUB_DB; + PUTBACK; + pp_pushmark(ARGS); + + EXTEND(sp, 4); + PUSHs(pv); + PUSHs(sv); + PUSHs(typesv); + PUSHs(cv); + PUTBACK; + + if (op = pp_entersub(ARGS)) + CALLRUNOPS(); + LEAVE; + SPAGAIN; + + res = POPs; + PUTBACK; + CATCH_SET(oldcatch); + POPSTACK; + + if (!SvOK(res)) { + sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key); + yyerror(buf); + } + return SvREFCNT_inc(res); +} + +STATIC char * scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { register char *d = dest; @@ -4718,7 +4829,7 @@ scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLE } } -static char * +STATIC char * scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni) { register char *d; @@ -4849,13 +4960,11 @@ void pmflag(U16 *pmfl, int ch) *pmfl |= PMf_MULTILINE; else if (ch == 's') *pmfl |= PMf_SINGLELINE; - else if (ch == 't') - *pmfl |= PMf_TAINTMEM; else if (ch == 'x') *pmfl |= PMf_EXTENDED; } -static char * +STATIC char * scan_pat(char *start) { PMOP *pm; @@ -4872,7 +4981,7 @@ scan_pat(char *start) pm = (PMOP*)newPMOP(OP_MATCH, 0); if (multi_open == '?') pm->op_pmflags |= PMf_ONCE; - while (*s && strchr("iogcmstx", *s)) + while (*s && strchr("iogcmsx", *s)) pmflag(&pm->op_pmflags,*s++); pm->op_pmpermflags = pm->op_pmflags; @@ -4881,7 +4990,7 @@ scan_pat(char *start) return s; } -static char * +STATIC char * scan_subst(char *start) { register char *s; @@ -4922,7 +5031,7 @@ scan_subst(char *start) s++; es++; } - else if (strchr("iogcmstx", *s)) + else if (strchr("iogcmsx", *s)) pmflag(&pm->op_pmflags,*s++); else break; @@ -4948,7 +5057,7 @@ scan_subst(char *start) return s; } -static char * +STATIC char * scan_trans(char *start) { register char* s; @@ -5001,7 +5110,7 @@ scan_trans(char *start) return s; } -static char * +STATIC char * scan_heredoc(register char *s) { dTHR; @@ -5053,7 +5162,7 @@ scan_heredoc(register char *s) s--, herewas = newSVpv(s,d-s); s += SvCUR(herewas); - tmpstr = NEWSV(87,80); + tmpstr = NEWSV(87,79); sv_upgrade(tmpstr, SVt_PVIV); if (term == '\'') { op_type = OP_CONST; @@ -5145,7 +5254,7 @@ scan_heredoc(register char *s) */ -static char * +STATIC char * scan_inputsymbol(char *start) { register char *s = start; /* current position in buffer */ @@ -5281,7 +5390,7 @@ scan_inputsymbol(char *start) */ -static char * +STATIC char * scan_str(char *start) { dTHR; @@ -5311,8 +5420,8 @@ scan_str(char *start) multi_close = term; /* create a new SV to hold the contents. 87 is leak category, I'm - assuming. 80 is the SV's initial length. What a random number. */ - sv = NEWSV(87,80); + assuming. 79 is the SV's initial length. What a random number. */ + sv = NEWSV(87,79); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = term; (void)SvPOK_only(sv); /* validate pointer */ @@ -5543,7 +5652,8 @@ scan_num(char *start) digit: n = u << shift; /* make room for the digit */ - if (!overflowed && (n >> shift) != u) { + if (!overflowed && (n >> shift) != u + && !(hints & HINT_NEW_BINARY)) { warn("Integer overflow in %s number", (shift == 4) ? "hex" : "octal"); overflowed = TRUE; @@ -5559,6 +5669,8 @@ scan_num(char *start) out: sv = NEWSV(92,0); sv_setuv(sv, u); + if ( hints & HINT_NEW_BINARY) + sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); } break; @@ -5660,6 +5772,9 @@ scan_num(char *start) sv_setiv(sv, tryiv); else sv_setnv(sv, value); + if ( floatit ? (hints & HINT_NEW_FLOAT) : (hints & HINT_NEW_INTEGER) ) + sv = new_constant(tokenbuf, d - tokenbuf, + (floatit ? "float" : "integer"), sv, Nullsv, NULL); break; } @@ -5670,7 +5785,7 @@ scan_num(char *start) return s; } -static char * +STATIC char * scan_formline(register char *s) { dTHR; @@ -5740,7 +5855,7 @@ scan_formline(register char *s) return s; } -static void +STATIC void set_csh(void) { #ifdef CSH