X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=709db636d1986ed5edcd125834c6e3213780330b;hb=7509b6572737d9774c4d9688c4edf46238aa95f2;hp=b1bd0d701c39e1c7fd5462a59d3f3053d4207067;hpb=a30ac1520b1f2865b12dda3a3ca7d9715cb02229;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index b1bd0d7..709db63 100644 --- a/toke.c +++ b/toke.c @@ -1,6 +1,6 @@ /* toke.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -74,6 +74,10 @@ static char ident_too_long[] = "Identifier too long"; ? isALNUM(*(p)) \ : isALNUM_utf8((U8*)p)) +/* In variables name $^X, these are the legal values for X. + * 1999-02-27 mjd-perl-patch@plover.com */ +#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) + /* 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). */ @@ -199,6 +203,8 @@ no_op(char *what, char *s) t - PL_oldoldbufptr, PL_oldoldbufptr); } + else if (s <= oldbp) + warn("\t(Missing operator before end of line?)\n"); else warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); PL_bufptr = oldbp; @@ -357,7 +363,7 @@ lex_start(SV *line) PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend = PL_bufptr + SvCUR(PL_linestr); SvREFCNT_dec(PL_rs); - PL_rs = newSVpv("\n", 1); + PL_rs = newSVpvn("\n", 1); PL_rsfp = 0; } @@ -596,8 +602,6 @@ force_word(register char *start, int token, int check_keyword, int allow_pack, i PL_expect = XTERM; else { PL_expect = XOPERATOR; - force_next(')'); - force_next('('); } } PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0)); @@ -679,7 +683,7 @@ tokeq(SV *sv) goto finish; d = s; if ( PL_hints & HINT_NEW_STRING ) - pv = sv_2mortal(newSVpv(SvPVX(pv), len)); + pv = sv_2mortal(newSVpvn(SvPVX(pv), len)); while (s < send) { if (*s == '\\') { if (s + 1 < send && (s[1] == '\\')) @@ -715,7 +719,7 @@ sublex_start(void) SV *nsv; p = SvPV(sv, len); - nsv = newSVpv(p, len); + nsv = newSVpvn(p, len); SvREFCNT_dec(sv); sv = nsv; } @@ -797,7 +801,7 @@ sublex_done(void) { if (!PL_lex_starts++) { PL_expect = XOPERATOR; - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0)); + yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0)); return THING; } @@ -822,10 +826,15 @@ sublex_done(void) if (SvCOMPILED(PL_lex_repl)) { PL_lex_state = LEX_INTERPNORMAL; PL_lex_starts++; + /* we don't clear PL_lex_repl here, so that we can check later + whether this is an evalled subst; that means we rely on the + logic to ensure sublex_done() is called again only via the + branch (in yylex()) that clears PL_lex_repl, else we'll loop */ } - else + else { PL_lex_state = LEX_INTERPCONCAT; - PL_lex_repl = Nullsv; + PL_lex_repl = Nullsv; + } return ','; } else { @@ -919,10 +928,10 @@ scan_const(char *start) register char *d = SvPVX(sv); /* destination for copies */ bool dorange = FALSE; /* are we in a translit range? */ I32 len; /* ? */ - I32 utf = PL_lex_inwhat == OP_TRANS + I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) : UTF; - I32 thisutf = PL_lex_inwhat == OP_TRANS + I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF)) : UTF; @@ -1056,7 +1065,7 @@ scan_const(char *start) s++; /* some backslashes we leave behind */ - if (*s && strchr(leaveit, *s)) { + if (*leaveit && *s && strchr(leaveit, *s)) { *d++ = '\\'; *d++ = *s++; continue; @@ -1089,10 +1098,17 @@ scan_const(char *start) continue; } /* FALL THROUGH */ - /* default action is to copy the quoted character */ default: - *d++ = *s++; - continue; + { + dTHR; + if (ckWARN(WARN_UNSAFE) && isALPHA(*s)) + warner(WARN_UNSAFE, + "Unrecognized escape \\%c passed through", + *s); + /* default action is to copy the quoted character */ + *d++ = *s++; + continue; + } /* \132 indicates an octal constant */ case '0': case '1': case '2': case '3': @@ -1395,7 +1411,7 @@ intuit_method(char *start, GV *gv) return 0; /* no assumptions -- "=>" quotes bearword */ bare_package: PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, - newSVpv(tmpbuf,0)); + newSVpvn(tmpbuf,len)); PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE; PL_expect = XTERM; force_next(WORD); @@ -1436,13 +1452,12 @@ incl_perldb(void) * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for * private use must be set using malloc'd pointers. */ -static int filter_debug = 0; SV * filter_add(filter_t funcp, SV *datasv) { if (!funcp){ /* temporary handy debugging hack to be deleted */ - filter_debug = atoi((char*)datasv); + PL_filter_debug = atoi((char*)datasv); return NULL; } if (!PL_rsfp_filters) @@ -1452,7 +1467,7 @@ filter_add(filter_t funcp, SV *datasv) if (!SvUPGRADE(datasv, SVt_PVIO)) die("Can't upgrade filter_add data to SVt_PVIO"); IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ - if (filter_debug) { + if (PL_filter_debug) { STRLEN n_a; warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a)); } @@ -1466,7 +1481,7 @@ filter_add(filter_t funcp, SV *datasv) void filter_del(filter_t funcp) { - if (filter_debug) + if (PL_filter_debug) warn("filter_del func %p", funcp); if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; @@ -1496,7 +1511,7 @@ filter_read(int idx, SV *buf_sv, int maxlen) if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */ /* Provide a default input filter to make life easy. */ /* Note that we append to the line. This is handy. */ - if (filter_debug) + if (PL_filter_debug) warn("filter_read %d: from rsfp\n", idx); if (maxlen) { /* Want a block */ @@ -1525,13 +1540,13 @@ filter_read(int idx, SV *buf_sv, int maxlen) } /* Skip this filter slot if filter has been deleted */ if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){ - if (filter_debug) + if (PL_filter_debug) warn("filter_read %d: skipped (filter deleted)\n", idx); return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ funcp = (filter_t)IoDIRP(datasv); - if (filter_debug) { + if (PL_filter_debug) { STRLEN n_a; warn("filter_read %d: via function %p (%s)\n", idx, funcp, SvPV(datasv,n_a)); @@ -1623,7 +1638,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) */ if (PL_in_my) { if (strchr(PL_tokenbuf,':')) - croak(PL_no_myglob,PL_tokenbuf); + yyerror(form(PL_no_myglob,PL_tokenbuf)); yylval.opval = newOP(OP_PADANY, 0); yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); @@ -1838,6 +1853,13 @@ int yylex(PERL_YYLEX_PARAM_DECL) PL_lex_state = LEX_INTERPCONCAT; return ')'; } + if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl + && SvCOMPILED(PL_lex_repl)) + { + if (PL_bufptr != PL_bufend) + croak("Bad evalled substitution pattern"); + PL_lex_repl = Nullsv; + } /* FALLTHROUGH */ case LEX_INTERPCONCAT: #ifdef DEBUGGING @@ -1906,7 +1928,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) PL_last_uni = 0; PL_last_lop = 0; if (PL_lex_brackets) - yyerror("Missing right bracket"); + yyerror("Missing right curly or square bracket"); TOKEN(0); } if (s++ < PL_bufend) @@ -2115,7 +2137,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) else newargv = PL_origargv; newargv[0] = ipath; - execv(ipath, newargv); + PerlProc_execv(ipath, newargv); croak("Can't exec %s", ipath); } if (d) { @@ -2350,7 +2372,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) case ']': s++; if (PL_lex_brackets <= 0) - yyerror("Unmatched right bracket"); + yyerror("Unmatched right square bracket"); else --PL_lex_brackets; if (PL_lex_state == LEX_INTERPNORMAL) { @@ -2507,7 +2529,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) rightbracket: s++; if (PL_lex_brackets <= 0) - yyerror("Unmatched right bracket"); + yyerror("Unmatched right curly bracket"); else PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; if (PL_lex_brackets < PL_lex_formbrack) @@ -2701,6 +2723,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) } d = s; + tmp = (I32)*s; if (PL_lex_state == LEX_NORMAL) s = skipspace(s); @@ -2742,7 +2765,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) } PL_expect = XOPERATOR; - if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) { + if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { bool islop = (PL_last_lop == PL_oldoldbufptr); if (!islop || PL_last_lop_op == OP_GREPSTART) PL_expect = XOPERATOR; @@ -3107,7 +3130,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) /* if we saw a global override before, get the right name */ if (gvp) { - sv = newSVpv("CORE::GLOBAL::",14); + sv = newSVpvn("CORE::GLOBAL::",14); sv_catpv(sv,PL_tokenbuf); } else @@ -3822,36 +3845,46 @@ int yylex(PERL_YYLEX_PARAM_DECL) s = scan_str(s); if (!s) missingterm((char*)0); - if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) { + force_next(')'); + if (SvCUR(PL_lex_stuff)) { + OP *words = Nullop; + int warned = 0; d = SvPV_force(PL_lex_stuff, len); - for (; len; --len, ++d) { - if (*d == ',') { - warner(WARN_SYNTAX, - "Possible attempt to separate words with commas"); - break; - } - if (*d == '#') { - warner(WARN_SYNTAX, - "Possible attempt to put comments in qw() list"); - break; + while (len) { + for (; isSPACE(*d) && len; --len, ++d) ; + if (len) { + char *b = d; + if (!warned && ckWARN(WARN_SYNTAX)) { + for (; !isSPACE(*d) && len; --len, ++d) { + if (*d == ',') { + warner(WARN_SYNTAX, + "Possible attempt to separate words with commas"); + ++warned; + } + else if (*d == '#') { + warner(WARN_SYNTAX, + "Possible attempt to put comments in qw() list"); + ++warned; + } + } + } + else { + for (; !isSPACE(*d) && len; --len, ++d) ; + } + words = append_elem(OP_LIST, words, + newSVOP(OP_CONST, 0, newSVpvn(b, d-b))); } } + if (words) { + PL_nextval[PL_nexttoke].opval = words; + force_next(THING); + } } - force_next(')'); - PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff)); + if (PL_lex_stuff) + SvREFCNT_dec(PL_lex_stuff); PL_lex_stuff = Nullsv; - force_next(THING); - force_next(','); - PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1)); - force_next(THING); - force_next('('); - yylval.ival = OP_SPLIT; - CLINE; PL_expect = XTERM; - PL_bufptr = s; - PL_last_lop = PL_oldbufptr; - PL_last_lop_op = OP_SPLIT; - return FUNC; + TOKEN('('); case KEY_qq: s = scan_str(s); @@ -4979,7 +5012,7 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) sv_2mortal(sv); /* Parent created it permanently */ cv = *cvp; if (!pv) - pv = sv_2mortal(newSVpv(s, len)); + pv = sv_2mortal(newSVpvn(s, len)); if (type) typesv = sv_2mortal(newSVpv(type, 0)); else @@ -5132,7 +5165,7 @@ scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I3 if (s < send) *d = *s++; d[1] = '\0'; - if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) { + if (*d == '^' && *s && isCONTROLVAR(*s)) { *d = toCTRL(*s); s++; } @@ -5160,8 +5193,10 @@ scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I3 s = e; } else { - while (isALNUM(*s) || *s == ':') + while ((isALNUM(*s) || *s == ':') && d < e) *d++ = *s++; + if (d >= e) + croak(ident_too_long); } *d = '\0'; while (s < send && (*s == ' ' || *s == '\t')) s++; @@ -5178,6 +5213,19 @@ scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I3 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; return s; } + } + /* Handle extended ${^Foo} variables + * 1999-02-27 mjd-perl-patch@plover.com */ + else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ + && isALNUM(*s)) + { + d++; + while (isALNUM(*s) && d < e) { + *d++ = *s++; + } + if (d >= e) + croak(ident_too_long); + *d = '\0'; } if (*s == '}') { s++; @@ -5305,8 +5353,11 @@ scan_subst(char *start) if (es) { SV *repl; + PL_sublex_info.super_bufptr = s; + PL_sublex_info.super_bufend = PL_bufend; + PL_multi_end = 0; pm->op_pmflags |= PMf_EVAL; - repl = newSVpv("",0); + repl = newSVpvn("",0); while (es-- > 0) sv_catpv(repl, es ? "eval " : "do "); sv_catpvn(repl, "{ ", 2); @@ -5474,9 +5525,9 @@ scan_heredoc(register char *s) #endif d = "\n"; if (outer || !(d=ninstr(s,PL_bufend,d,d+1))) - herewas = newSVpv(s,PL_bufend-s); + herewas = newSVpvn(s,PL_bufend-s); else - s--, herewas = newSVpv(s,d-s); + s--, herewas = newSVpvn(s,d-s); s += SvCUR(herewas); tmpstr = NEWSV(87,79); @@ -5494,7 +5545,33 @@ scan_heredoc(register char *s) PL_multi_start = PL_curcop->cop_line; PL_multi_open = PL_multi_close = '<'; term = *PL_tokenbuf; - if (!outer) { + 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); + s = strchr(bufptr, '\n'); + if (!s) + s = bufend; + d = s; + while (s < bufend && + (*s != term || memNE(s,PL_tokenbuf,len)) ) { + if (*s++ == '\n') + PL_curcop->cop_line++; + } + if (s >= bufend) { + PL_curcop->cop_line = PL_multi_start; + missingterm(PL_tokenbuf); + } + sv_setpvn(herewas,bufptr,d-bufptr+1); + sv_setpvn(tmpstr,d+1,s-d); + s += len - 1; + sv_catpvn(herewas,s,bufend-s); + (void)strcpy(bufptr,SvPVX(herewas)); + + s = olds; + goto retval; + } + else if (!outer) { d = s; while (s < PL_bufend && (*s != term || memNE(s,PL_tokenbuf,len)) ) { @@ -5558,8 +5635,9 @@ scan_heredoc(register char *s) sv_catsv(tmpstr,PL_linestr); } } - PL_multi_end = PL_curcop->cop_line; s++; +retval: + PL_multi_end = PL_curcop->cop_line; if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { SvLEN_set(tmpstr, SvCUR(tmpstr) + 1); Renew(SvPVX(tmpstr), SvLEN(tmpstr), char); @@ -5592,19 +5670,23 @@ scan_inputsymbol(char *start) register char *s = start; /* current position in buffer */ register char *d; register char *e; + char *end; I32 len; d = PL_tokenbuf; /* start of temp holding space */ e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ - s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */ + end = strchr(s, '\n'); + if (!end) + end = PL_bufend; + s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */ /* die if we didn't have space for the contents of the <>, - or if it didn't end + or if it didn't end, or if we see a newline */ if (len >= sizeof PL_tokenbuf) croak("Excessively long <> operator"); - if (s >= PL_bufend) + if (s >= end) croak("Unterminated <> operator"); s++; @@ -5895,7 +5977,7 @@ scan_str(char *start) Read a number in any of the formats that Perl accepts: - 0(x[0-7A-F]+)|([0-7]+) + 0(x[0-7A-F]+)|([0-7]+)|(b[01]) [\d_]+(\.[\d_]*)?[Ee](\d+) Underbars (_) are allowed in decimal numbers. If -w is on, @@ -5929,18 +6011,19 @@ scan_num(char *start) croak("panic: scan_num"); /* if it starts with a 0, it could be an octal number, a decimal in - 0.13 disguise, or a hexadecimal number. + 0.13 disguise, or a hexadecimal number, or a binary number. */ case '0': { /* variables: u holds the "number so far" - shift the power of 2 of the base (hex == 4, octal == 3) + shift the power of 2 of the base + (hex == 4, octal == 3, binary == 1) overflowed was the number more than we can hold? Shift is used when we add a digit. It also serves as an "are - we in octal or hex?" indicator to disallow hex characters when - in octal mode. + we in octal/hex/binary?" indicator to disallow hex characters + when in octal mode. */ UV u; I32 shift; @@ -5950,6 +6033,9 @@ scan_num(char *start) if (s[1] == 'x') { shift = 4; s += 2; + } else if (s[1] == 'b') { + shift = 1; + s += 2; } /* check for a decimal in disguise */ else if (s[1] == '.') @@ -5959,7 +6045,7 @@ scan_num(char *start) shift = 3; u = 0; - /* read the rest of the octal number */ + /* read the rest of the number */ for (;;) { UV n, b; /* n is used in the overflow test, b is the digit we're adding on */ @@ -5976,13 +6062,21 @@ scan_num(char *start) /* 8 and 9 are not octal */ case '8': case '9': - if (shift != 4) - yyerror("Illegal octal digit"); + if (shift == 3) + yyerror(form("Illegal octal digit '%c'", *s)); + else + if (shift == 1) + yyerror(form("Illegal binary digit '%c'", *s)); /* FALL THROUGH */ /* octal digits */ - case '0': case '1': case '2': case '3': case '4': + case '2': case '3': case '4': case '5': case '6': case '7': + if (shift == 1) + yyerror(form("Illegal binary digit '%c'", *s)); + /* FALL THROUGH */ + + case '0': case '1': b = *s++ & 15; /* ASCII digit -> value of digit */ goto digit; @@ -6003,7 +6097,8 @@ scan_num(char *start) if (!overflowed && (n >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { warn("Integer overflow in %s number", - (shift == 4) ? "hex" : "octal"); + (shift == 4) ? "hex" + : ((shift == 3) ? "octal" : "binary")); overflowed = TRUE; } u = n | b; /* add the digit to the end */ @@ -6143,7 +6238,7 @@ scan_formline(register char *s) dTHR; register char *eol; register char *t; - SV *stuff = newSVpv("",0); + SV *stuff = newSVpvn("",0); bool needargs = FALSE; while (!needargs) { @@ -6256,7 +6351,7 @@ start_subparse(I32 is_format, U32 flags) PL_padix = 0; PL_subline = PL_curcop->cop_line; #ifdef USE_THREADS - av_store(PL_comppad_name, 0, newSVpv("@_", 2)); + av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); PL_curpad[0] = (SV*)newAV(); SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ #endif /* USE_THREADS */ @@ -6325,7 +6420,7 @@ yyerror(char *s) where = "within string"; } else { - SV *where_sv = sv_2mortal(newSVpv("next char ", 0)); + SV *where_sv = sv_2mortal(newSVpvn("next char ", 10)); if (yychar < 32) sv_catpvf(where_sv, "^%c", toCTRL(yychar)); else if (isPRINT_LC(yychar))