X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=63408570dd6b50758dd316aeac9e77ca8b25b750;hb=360aca433d51a01ddd748b8606c6c288bdb2f7fc;hp=e91fa8c480cbf37a5db07cb23b66f4eddf63b88f;hpb=6a65c6a0721422f3dbac9c301f2d6e8b04b74975;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index e91fa8c..6340857 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; @@ -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)); @@ -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 { @@ -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': @@ -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,8 +1467,10 @@ 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) - warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na)); + if (PL_filter_debug) { + STRLEN n_a; + warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a)); + } av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -1464,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; @@ -1494,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 */ @@ -1523,15 +1540,17 @@ 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,PL_na)); + idx, funcp, SvPV(datasv,n_a)); + } /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -1619,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); @@ -1834,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 @@ -2111,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) { @@ -2965,6 +2991,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) case 'z': case 'Z': keylookup: { + STRLEN n_a; gv = Nullgv; gvp = 0; @@ -3161,7 +3188,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) if (gv && GvCVu(gv)) { CV *cv; if ((cv = GvCV(gv)) && SvPOK(cv)) - PL_last_proto = SvPV((SV*)cv, PL_na); + PL_last_proto = SvPV((SV*)cv, n_a); for (d = s + 1; *d == ' ' || *d == '\t'; d++) ; if (*d == ')' && (sv = cv_const_sv(cv))) { s = d + 1; @@ -3817,36 +3844,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); @@ -4119,7 +4156,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) PL_lex_stuff = Nullsv; } - if (*SvPV(PL_subname,PL_na) == '?') { + if (*SvPV(PL_subname,n_a) == '?') { sv_setpv(PL_subname,"__ANON__"); TOKEN(ANONSUB); } @@ -4959,7 +4996,6 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) bool oldcatch = CATCH_GET; SV **cvp; SV *cv, *typesv; - char buf[128]; if (!table) { yyerror("%^H is not defined"); @@ -4967,6 +5003,7 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) } cvp = hv_fetch(table, key, strlen(key), FALSE); if (!cvp || !SvOK(*cvp)) { + char buf[128]; sprintf(buf,"$^H{%s} is not defined", key); yyerror(buf); return sv; @@ -5012,6 +5049,7 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) POPSTACK; if (!SvOK(res)) { + char buf[128]; sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key); yyerror(buf); } @@ -5126,7 +5164,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++; } @@ -5154,8 +5192,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++; @@ -5172,6 +5212,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++; @@ -5299,6 +5352,9 @@ 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); while (es-- > 0) @@ -5488,7 +5544,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)) ) { @@ -5552,8 +5634,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); @@ -5889,7 +5972,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, @@ -5923,18 +6006,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; @@ -5944,6 +6028,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] == '.') @@ -5953,7 +6040,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 */ @@ -5970,13 +6057,21 @@ scan_num(char *start) /* 8 and 9 are not octal */ case '8': case '9': - if (shift != 4) + if (shift == 3) yyerror("Illegal octal digit"); + else + if (shift == 1) + yyerror("Illegal binary digit"); /* 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("Illegal binary digit"); + /* FALL THROUGH */ + + case '0': case '1': b = *s++ & 15; /* ASCII digit -> value of digit */ goto digit; @@ -5997,7 +6092,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 */