X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=24bf27dd5eac9bc30c9d54934f839343c963d446;hb=5152d7c70255adc94c2a3e2b618f1dda3b081e12;hp=128b828d1ce1901655a91227047b9f0d81621d28;hpb=c3e0f9031ff4516c836ba169441f96b6f70efbe7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 128b828..24bf27d 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,14 +175,14 @@ no_op(char *what, char *s) bufptr = oldbp; } -static void +STATIC void missingterm(char *s) { char tmpbuf[3]; char q; if (s) { char *nl = strrchr(s,'\n'); - if (nl) + if (nl) *nl = '\0'; } else if (multi_close < 32 || multi_close == 127) { @@ -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,23 +310,21 @@ restore_rsfp(void *f) rsfp = fp; } -static void -restore_expect(e) -void *e; +STATIC void +restore_expect(void *e) { /* a safe way to store a small integer in a pointer */ expect = (expectation)((char *)e - tokenbuf); } -static void -restore_lex_expect(e) -void *e; +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; @@ -374,7 +365,7 @@ incline(char *s) curcop->cop_line = atoi(n)-1; } -static char * +STATIC char * skipspace(register char *s) { dTHR; @@ -413,8 +404,6 @@ skipspace(register char *s) PerlIO_clearerr(rsfp); else (void)PerlIO_close(rsfp); - if (e_fp == rsfp) - e_fp = Nullfp; rsfp = Nullfp; return s; } @@ -432,7 +421,7 @@ skipspace(register char *s) } } -static void +STATIC void check_uni(void) { char *s; char ch; @@ -456,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; @@ -477,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; @@ -498,7 +487,7 @@ lop(I32 f, expectation x, char *s) return LSTOP; } -static void +STATIC void force_next(I32 type) { nexttype[nexttoke] = type; @@ -510,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; @@ -542,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) { @@ -555,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 : TRUE, + gv_fetchpv(s, in_eval ? (GV_ADDMULTI | 8) : TRUE, kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : kind == '%' ? SVt_PVHV : @@ -565,7 +554,7 @@ force_ident(register char *s, int kind) } } -static char * +STATIC char * force_version(char *s) { OP *version = Nullop; @@ -592,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] == '\\')) @@ -621,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; @@ -636,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; } @@ -660,7 +663,7 @@ sublex_start(void) return FUNC; } -static I32 +STATIC I32 sublex_push(void) { dTHR; @@ -713,7 +716,7 @@ sublex_push(void) return '('; } -static I32 +STATIC I32 sublex_done(void) { if (!lex_starts++) { @@ -768,6 +771,12 @@ sublex_done(void) processing a pattern (lex_inpat is true), a transliteration (lex_inwhat & OP_TRANS is true), or a double-quoted string. + Returns a pointer to the character scanned up to. Iff this is + advanced from the start pointer supplied (ie if anything was + successfully parsed), will leave an OP for the substring scanned + in yylval. Caller must intuit reason for not parsing further + by looking at the next characters herself. + In patterns: backslashes: double-quoted style: \r and \n @@ -825,7 +834,7 @@ sublex_done(void) */ -static char * +STATIC char * scan_const(char *start) { register char *send = bufend; /* end of the constant */ @@ -835,17 +844,11 @@ scan_const(char *start) bool dorange = FALSE; /* are we in a translit range? */ I32 len; /* ? */ - /* - leave is the set of acceptably-backslashed characters. - - I do *not* understand why there's the double hook here. - */ + /* leaveit is the set of acceptably-backslashed characters */ char *leaveit = lex_inpat - ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#" - : (lex_inwhat & OP_TRANS) - ? "" - : ""; + ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#" + : ""; while (s < send || dorange) { /* get transliterations out of the way (they're most literal) */ @@ -1032,16 +1035,24 @@ scan_const(char *start) Renew(SvPVX(sv), SvLEN(sv), char); } - /* ??? */ - if (s > bufptr) + /* return the substring (via yylval) only if we parsed anything */ + 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) @@ -1078,7 +1089,7 @@ intuit_more(register char *s) else { int weight = 2; /* let's weigh the evidence */ char seen[256]; - unsigned char un_char = 0, last_un_char; + unsigned char un_char = 255, last_un_char; char *send = strchr(s,']'); char tmpbuf[sizeof tokenbuf * 4]; @@ -1144,6 +1155,8 @@ intuit_more(register char *s) weight += 30; if (strchr("zZ79~",s[1])) weight += 30; + if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$')) + weight -= 5; /* cope with negative subscript */ break; default: if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) && @@ -1169,7 +1182,7 @@ intuit_more(register char *s) return TRUE; } -static int +STATIC int intuit_method(char *start, GV *gv) { char *s = start + (*start == '$'); @@ -1228,7 +1241,7 @@ intuit_method(char *start, GV *gv) return 0; } -static char* +STATIC char* incl_perldb(void) { if (perldb) { @@ -1357,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 @@ -1509,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 : TRUE, + gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE, ((tokenbuf[0] == '$') ? SVt_PV : (tokenbuf[0] == '@') ? SVt_PVAV : SVt_PVHV)); @@ -1666,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; } @@ -1793,8 +1808,6 @@ yylex(void) PerlIO_clearerr(rsfp); else (void)PerlIO_close(rsfp); - if (e_fp == rsfp) - e_fp = Nullfp; rsfp = Nullfp; } if (!in_eval && (minus_n || minus_p)) { @@ -2233,13 +2246,8 @@ yylex(void) else lex_brackstack[lex_brackets++] = XOPERATOR; s = skipspace(s); - if (*s == '}') { - if (expect == XSTATE) { - lex_brackstack[lex_brackets-1] = XSTATE; - break; - } + if (*s == '}') OPERATOR(HASHBRACK); - } /* This hack serves to disambiguate a pair of curlies * as being a block or an anon hash. Normally, expectation * determines that, but in cases where we're not in a @@ -2848,7 +2856,8 @@ yylex(void) s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len, TRUE, &morelen); if (!morelen) - croak("Bad name after %s::", tokenbuf); + croak("Bad name after %s%s", tokenbuf, + *s == '\'' ? "'" : "::"); len += morelen; } @@ -2909,8 +2918,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 == '('; @@ -2991,16 +3003,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); @@ -3603,7 +3616,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(','); @@ -4657,7 +4670,7 @@ keyword(register char *d, I32 len) return 0; } -static void +STATIC void checkcomma(register char *s, char *name, char *what) { char *w; @@ -4699,7 +4712,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 = perl_get_hv("\10", FALSE); /* ^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(SI_OVERLOAD); + ENTER; + SAVEOP(); + op = (OP *) &myop; + if (PERLDB_SUB && curstash != debstash) + op->op_private |= OPpENTERSUB_DB; + PUTBACK; + pp_pushmark(ARGS); + + EXTEND(sp, 3); + 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; @@ -4726,7 +4808,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; @@ -4857,11 +4939,13 @@ 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; @@ -4878,7 +4962,7 @@ scan_pat(char *start) pm = (PMOP*)newPMOP(OP_MATCH, 0); if (multi_open == '?') pm->op_pmflags |= PMf_ONCE; - while (*s && strchr("iogcmsx", *s)) + while (*s && strchr("iogcmstx", *s)) pmflag(&pm->op_pmflags,*s++); pm->op_pmpermflags = pm->op_pmflags; @@ -4887,7 +4971,7 @@ scan_pat(char *start) return s; } -static char * +STATIC char * scan_subst(char *start) { register char *s; @@ -4923,13 +5007,15 @@ scan_subst(char *start) multi_start = first_start; /* so whole substitution is taken together */ pm = (PMOP*)newPMOP(OP_SUBST, 0); - while (*s && strchr("iogcmsex", *s)) { + while (*s) { if (*s == 'e') { s++; es++; } - else + else if (strchr("iogcmstx", *s)) pmflag(&pm->op_pmflags,*s++); + else + break; } if (es) { @@ -4952,7 +5038,7 @@ scan_subst(char *start) return s; } -static char * +STATIC char * scan_trans(char *start) { register char* s; @@ -4969,7 +5055,7 @@ scan_trans(char *start) if (lex_stuff) SvREFCNT_dec(lex_stuff); lex_stuff = Nullsv; - croak("Translation pattern not terminated"); + croak("Transliteration pattern not terminated"); } if (s[-1] == multi_open) s--; @@ -4982,7 +5068,7 @@ scan_trans(char *start) if (lex_repl) SvREFCNT_dec(lex_repl); lex_repl = Nullsv; - croak("Translation replacement not terminated"); + croak("Transliteration replacement not terminated"); } New(803,tbl,256,short); @@ -5005,7 +5091,7 @@ scan_trans(char *start) return s; } -static char * +STATIC char * scan_heredoc(register char *s) { dTHR; @@ -5057,7 +5143,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; @@ -5085,7 +5171,7 @@ scan_heredoc(register char *s) } sv_setpvn(tmpstr,d+1,s-d); s += len - 1; - curcop->cop_line++; /* the preceding stmt passes a newline */ + curcop->cop_line++; /* the preceding stmt passes a newline */ sv_catpvn(herewas,s,bufend-s); sv_setsv(linestr,herewas); @@ -5149,7 +5235,7 @@ scan_heredoc(register char *s) */ -static char * +STATIC char * scan_inputsymbol(char *start) { register char *s = start; /* current position in buffer */ @@ -5285,7 +5371,7 @@ scan_inputsymbol(char *start) */ -static char * +STATIC char * scan_str(char *start) { dTHR; @@ -5315,8 +5401,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 */ @@ -5547,7 +5633,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; @@ -5563,6 +5650,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; @@ -5664,6 +5753,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; } @@ -5674,7 +5766,7 @@ scan_num(char *start) return s; } -static char * +STATIC char * scan_formline(register char *s) { dTHR; @@ -5744,7 +5836,7 @@ scan_formline(register char *s) return s; } -static void +STATIC void set_csh(void) { #ifdef CSH