/* 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.
? 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).
*/
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;
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));
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 {
s++;
/* some backslashes we leave behind */
- if (*s && strchr(leaveit, *s)) {
+ if (*leaveit && *s && strchr(leaveit, *s)) {
*d++ = '\\';
*d++ = *s++;
continue;
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':
* 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)
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);
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;
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 */
}
/* 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 */
*/
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);
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
else
newargv = PL_origargv;
newargv[0] = ipath;
- execv(ipath, newargv);
+ PerlProc_execv(ipath, newargv);
croak("Can't exec %s", ipath);
}
if (d) {
case 'z': case 'Z':
keylookup: {
+ STRLEN n_a;
gv = Nullgv;
gvp = 0;
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;
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);
PL_lex_stuff = Nullsv;
}
- if (*SvPV(PL_subname,PL_na) == '?') {
+ if (*SvPV(PL_subname,n_a) == '?') {
sv_setpv(PL_subname,"__ANON__");
TOKEN(ANONSUB);
}
bool oldcatch = CATCH_GET;
SV **cvp;
SV *cv, *typesv;
- char buf[128];
if (!table) {
yyerror("%^H is not defined");
}
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;
POPSTACK;
if (!SvOK(res)) {
+ char buf[128];
sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
yyerror(buf);
}
if (s < send)
*d = *s++;
d[1] = '\0';
- if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
+ if (*d == '^' && *s && isCONTROLVAR(*s)) {
*d = toCTRL(*s);
s++;
}
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++;
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++;
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)
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)) ) {
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);
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,
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;
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] == '.')
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 */
/* 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;
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 */