/* toke.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * Copyright (c) 1991-1997, 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.
char *what;
char *s;
{
- char tmpbuf[128];
char *oldbp = bufptr;
bool is_first = (oldbufptr == linestart);
+ char *msg;
+
bufptr = s;
- sprintf(tmpbuf, "%s found where operator expected", what);
- yywarn(tmpbuf);
+ New(890, msg, strlen(what) + 40, char);
+ sprintf(msg, "%s found where operator expected", what);
+ yywarn(msg);
+ Safefree(msg);
if (is_first)
warn("\t(Missing semicolon on previous line?)\n");
else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
void
lex_end()
{
+ doextract = FALSE;
}
static void
#define LOP(f,x) return lop(f,x,s)
static I32
-lop(f,x,s)
+lop
+#ifdef CAN_PROTOTYPE
+ (I32 f, expectation x, char *s)
+#else
+ (f,x,s)
I32 f;
expectation x;
char *s;
+#endif /* CAN_PROTOTYPE */
{
yylval.ival = f;
CLINE;
if (gv) {
if (GvIO(gv))
return 0;
- if (!GvCV(gv))
+ if (!GvCVu(gv))
gv = 0;
}
s = scan_word(s, tmpbuf, TRUE, &len);
}
if (!keyword(tmpbuf, len)) {
indirgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVCV);
- if (indirgv && GvCV(indirgv))
+ if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
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 %lx (%s)", funcp, SvPV(datasv,na));
+ warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
av_unshift(rsfp_filters, 1);
av_store(rsfp_filters, 0, datasv) ;
return(datasv);
filter_t funcp;
{
if (filter_debug)
- warn("filter_del func %lx", funcp);
+ warn("filter_del func %p", funcp);
if (!rsfp_filters || AvFILL(rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
/* Get function pointer hidden within datasv */
funcp = (filter_t)IoDIRP(datasv);
if (filter_debug)
- warn("filter_read %d: via function %lx (%s)\n",
+ warn("filter_read %d: via function %p (%s)\n",
idx, funcp, SvPV(datasv,na));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) {
char tmpbuf[1024];
- sprintf(tmpbuf, "Literal %s now requires backslash", tokenbuf);
+ sprintf(tmpbuf, "In string, %s now must be written as \\%s",
+ tokenbuf, tokenbuf);
yyerror(tmpbuf);
}
}
s = bufptr;
Aop(OP_CONCAT);
}
- else
- return yylex();
- break;
+ return yylex();
case LEX_INTERPENDMAYBE:
if (intuit_more(bufptr)) {
s++;
if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
s++;
- if (!in_eval && *s == '#' && s[1] == '!') {
+ d = Nullch;
+ if (!in_eval) {
+ if (*s == '#' && *(s+1) == '!')
+ d = s + 2;
+#ifdef ALTERNATE_SHEBANG
+ else {
+ static char as[] = ALTERNATE_SHEBANG;
+ if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
+ d = s + (sizeof(as) - 1);
+ }
+#endif /* ALTERNATE_SHEBANG */
+ }
+ if (d) {
+ char *ipath;
+ char *ipathend;
+
+ while (isSPACE(*d))
+ d++;
+ ipath = d;
+ while (*d && !isSPACE(*d))
+ d++;
+ ipathend = d;
+
+#ifdef ARG_ZERO_IS_SCRIPT
+ if (ipathend > ipath) {
+ /*
+ * HP-UX (at least) sets argv[0] to the script name,
+ * which makes $^X incorrect. And Digital UNIX and Linux,
+ * at least, set argv[0] to the basename of the Perl
+ * interpreter. So, having found "#!", we'll set it right.
+ */
+ SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
+ assert(SvPOK(x) || SvGMAGICAL(x));
+ if (sv_eq(x, GvSV(curcop->cop_filegv))) {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ TAINT_NOT; /* $^X is always tainted, but that's OK */
+ }
+#endif /* ARG_ZERO_IS_SCRIPT */
+
+ /*
+ * Look for options.
+ */
d = instr(s,"perl -");
if (!d)
d = instr(s,"perl");
+#ifdef ALTERNATE_SHEBANG
+ /*
+ * If the ALTERNATE_SHEBANG on this system starts with a
+ * character that can be part of a Perl expression, then if
+ * we see it but not "perl", we're probably looking at the
+ * start of Perl code, not a request to hand off to some
+ * other interpreter. Similarly, if "perl" is there, but
+ * not in the first 'word' of the line, we assume the line
+ * contains the start of the Perl program.
+ */
+ if (d && *s != '#') {
+ char *c = ipath;
+ while (*c && !strchr("; \t\r\n\f\v#", *c))
+ c++;
+ if (c < d)
+ d = Nullch; /* "perl" not in first word; ignore */
+ else
+ *s = '#'; /* Don't try to parse shebang line */
+ }
+#endif /* ALTERNATE_SHEBANG */
if (!d &&
+ *s == '#' &&
+ ipathend > ipath &&
!minus_c &&
!instr(s,"indir") &&
instr(origargv[0],"perl"))
{
char **newargv;
- char *cmd;
- s += 2;
- if (*s == ' ')
- s++;
- cmd = s;
- while (s < bufend && !isSPACE(*s))
- s++;
- *s++ = '\0';
+ *ipathend = '\0';
+ s = ipathend + 1;
while (s < bufend && isSPACE(*s))
s++;
if (s < bufend) {
}
else
newargv = origargv;
- newargv[0] = cmd;
- execv(cmd,newargv);
- croak("Can't exec %s", cmd);
+ newargv[0] = ipath;
+ execv(ipath, newargv);
+ croak("Can't exec %s", ipath);
}
if (d) {
int oldpdb = perldb;
return yylex();
}
goto retry;
- case ' ': case '\t': case '\f': case '\r': case 013:
+ case '\r':
+ croak("Illegal character \\%03o (carriage return)", '\r');
+ case ' ': case '\t': case '\f': case 013:
s++;
goto retry;
case '#':
if (strnEQ(s,"=>",2)) {
if (dowarn)
warn("Ambiguous use of -%c => resolved to \"-%c\" =>",
- tmp, tmp);
+ (int)tmp, (int)tmp);
s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
OPERATOR('-'); /* unary minus */
}
case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
default:
- croak("Unrecognized file test: -%c", tmp);
+ croak("Unrecognized file test: -%c", (int)tmp);
break;
}
}
else
lex_brackstack[lex_brackets++] = XOPERATOR;
OPERATOR(HASHBRACK);
- break;
case XOPERATOR:
while (s < bufend && (*s == ' ' || *s == '\t'))
s++;
- if (s < bufend && isIDFIRST(*s)) {
- d = scan_word(s, tokenbuf, FALSE, &len);
+ d = s;
+ tokenbuf[0] = '\0';
+ if (d < bufend && *d == '-') {
+ tokenbuf[0] = '-';
+ d++;
+ while (d < bufend && (*d == ' ' || *d == '\t'))
+ d++;
+ }
+ if (d < bufend && isIDFIRST(*d)) {
+ d = scan_word(d, tokenbuf + 1, FALSE, &len);
while (d < bufend && (*d == ' ' || *d == '\t'))
d++;
if (*d == '}') {
+ char minus = (tokenbuf[0] == '-');
if (dowarn &&
- (keyword(tokenbuf, len) ||
- perl_get_cv(tokenbuf, FALSE) ))
+ (keyword(tokenbuf + 1, len) ||
+ (minus && len == 1 && isALPHA(tokenbuf[1])) ||
+ perl_get_cv(tokenbuf + 1, FALSE) ))
warn("Ambiguous use of {%s} resolved to {\"%s\"}",
- tokenbuf, tokenbuf);
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ tokenbuf + !minus, tokenbuf + !minus);
+ s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
+ if (minus)
+ force_next('-');
}
}
/* FALL THROUGH */
bufptr = s;
return yylex(); /* ignore fake brackets */
}
- if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
+ if (*s == '-' && s[1] == '>')
+ lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
lex_state = LEX_INTERPEND;
}
}
if (tmp == '~')
PMop(OP_MATCH);
if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
- warn("Reversed %c= operator",tmp);
+ warn("Reversed %c= operator",(int)tmp);
s--;
if (expect == XSTATE && isALPHA(tmp) &&
(s == linestart+1 || s[-2] == '\n') )
expect = XTERM; /* e.g. print $fh "foo" */
else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
expect = XTERM; /* e.g. print $fh &sub */
+ else if (isIDFIRST(*s)) {
+ char tmpbuf[1024];
+ scan_word(s, tmpbuf, TRUE, &len);
+ if (keyword(tmpbuf, len))
+ expect = XTERM; /* e.g. print $fh length() */
+ else {
+ GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
+ if (gv && GvCVu(gv))
+ expect = XTERM; /* e.g. print $fh subr() */
+ }
+ }
else if (isDIGIT(*s))
expect = XTERM; /* e.g. print $fh 3 */
else if (*s == '.' && isDIGIT(s[1]))
keylookup:
bufptr = s;
s = scan_word(s, tokenbuf, FALSE, &len);
-
- if (*s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
+
+ /* Some keywords can be followed by any delimiter, including ':' */
+ tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
+ len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
+ (tokenbuf[0] == 'q' &&
+ strchr("qwx", tokenbuf[1]))));
+
+ /* x::* is just a word, unless x is "CORE" */
+ if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
goto just_a_word;
d = s;
d++; /* no comments skipped here, or s### is misparsed */
/* Is this a label? */
- if (expect == XSTATE && d < bufend && *d == ':' && *(d + 1) != ':') {
- if (len == 1 && strchr("syq", tokenbuf[0]) ||
- len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
- (tokenbuf[0] == 'q' &&
- strchr("qwx", tokenbuf[1]))))
- ; /* no */
- else {
- s = d + 1;
- yylval.pval = savepv(tokenbuf);
- CLINE;
- TOKEN(LABEL);
- }
+ if (!tmp && expect == XSTATE
+ && d < bufend && *d == ':' && *(d + 1) != ':') {
+ s = d + 1;
+ yylval.pval = savepv(tokenbuf);
+ CLINE;
+ TOKEN(LABEL);
}
/* Check for keywords */
/* (But it's an indir obj regardless for sort.) */
if ((last_lop_op == OP_SORT ||
- (!immediate_paren && (!gv || !GvCV(gv))) ) &&
+ (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
(last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
goto bareword;
/* If followed by var or block, call it a method (unless sub) */
- if ((*s == '$' || *s == '{') && (!gv || !GvCV(gv))) {
+ if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
last_lop = oldbufptr;
last_lop_op = OP_METHOD;
PREBLOCK(METHOD);
/* Not a method, so call it a subroutine (if defined) */
- if (gv && GvCV(gv)) {
+ if (gv && GvCVu(gv)) {
CV* cv = GvCV(gv);
if (*s == '(') {
nextval[nexttoke].opval = yylval.opval;
TOKEN(WORD);
}
+ case KEY___FILE__:
case KEY___LINE__:
- case KEY___FILE__: {
if (tokenbuf[2] == 'L')
(void)sprintf(tokenbuf,"%ld",(long)curcop->cop_line);
else
strcpy(tokenbuf, SvPVX(GvSV(curcop->cop_filegv)));
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
TERM(THING);
- }
+
+ case KEY___PACKAGE__:
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ (curstash
+ ? newSVsv(curstname)
+ : &sv_undef));
+ TERM(THING);
case KEY___DATA__:
case KEY___END__: {
/* Look for a prototype */
if (*s == '(') {
+ char *p;
+
s = scan_str(s);
if (!s) {
if (lex_stuff)
lex_stuff = Nullsv;
croak("Prototype not terminated");
}
+ /* strip spaces */
+ d = SvPVX(lex_stuff);
+ tmp = 0;
+ for (p = d; *p; ++p) {
+ if (!isSPACE(*p))
+ d[tmp++] = *p;
+ }
+ d[tmp] = '\0';
+ SvCUR(lex_stuff) = tmp;
+
nexttoke++;
nextval[1] = nextval[0];
nexttype[1] = nexttype[0];
switch (*d) {
case '_':
if (d[1] == '_') {
- if (strEQ(d,"__LINE__")) return -KEY___LINE__;
if (strEQ(d,"__FILE__")) return -KEY___FILE__;
+ if (strEQ(d,"__LINE__")) return -KEY___LINE__;
+ if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
if (strEQ(d,"__DATA__")) return KEY___DATA__;
if (strEQ(d,"__END__")) return KEY___END__;
}
return s;
}
if (*s == '$' && s[1] &&
- (isALPHA(s[1]) || strchr("$_{", s[1]) || strnEQ(s+1,"::",2)) )
+ (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
return s;
if (*s == '{') {
bracket = s;
}
if (bracket) {
if (isSPACE(s[-1])) {
- while (s < send && (*s == ' ' || *s == '\t')) s++;
- *d = *s;
+ while (s < send) {
+ char ch = *s++;
+ if (ch != ' ' && ch != '\t') {
+ *d = ch;
+ break;
+ }
+ }
}
if (isIDFIRST(*d)) {
d++;
{
register char *s;
register PMOP *pm;
+ I32 first_start;
I32 es = 0;
yylval.ival = OP_NULL;
if (s[-1] == multi_open)
s--;
+ first_start = multi_start;
s = scan_str(s);
if (!s) {
if (lex_stuff)
lex_repl = Nullsv;
croak("Substitution replacement not terminated");
}
+ multi_start = first_start; /* so whole substitution is taken together */
pm = (PMOP*)newPMOP(OP_SUBST, 0);
while (*s && strchr("iogmsex", *s)) {
return;
}
}
- if (!pm->op_pmshort || /* promote the better string */
- ((pm->op_pmflags & PMf_SCANFIRST) &&
- (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)) )){
+ /* promote the better string */
+ if ((!pm->op_pmshort && !(pm->op_pmregexp->reganch & ROPT_ANCH)) ||
+ ((pm->op_pmflags & PMf_SCANFIRST) &&
+ (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)))) {
SvREFCNT_dec(pm->op_pmshort); /* ok if null */
pm->op_pmshort = pm->op_pmregexp->regmust;
pm->op_pmslen = SvCUR(pm->op_pmshort);
char term;
register char *d;
char *peek;
+ int outer = (rsfp && !lex_inwhat);
s += 2;
d = tokenbuf;
- if (!rsfp)
+ if (!outer)
*d++ = '\n';
for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
if (*peek && strchr("`'\"",*peek)) {
*d = '\0';
len = d - tokenbuf;
d = "\n";
- if (rsfp || !(d=ninstr(s,bufend,d,d+1)))
+ if (outer || !(d=ninstr(s,bufend,d,d+1)))
herewas = newSVpv(s,bufend-s);
else
s--, herewas = newSVpv(s,d-s);
multi_start = curcop->cop_line;
multi_open = multi_close = '<';
term = *tokenbuf;
- if (!rsfp) {
+ if (!outer) {
d = s;
while (s < bufend &&
(*s != term || memNE(s,tokenbuf,len)) ) {
else
sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
while (s >= bufend) { /* multiple line string? */
- if (!rsfp ||
+ if (!outer ||
!(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
curcop->cop_line = multi_start;
missingterm(tokenbuf);
{
register char *s = start;
register char *d;
- I32 tryi32;
+ I32 tryiv;
double value;
SV *sv;
I32 floatit;
sv = NEWSV(92,0);
SET_NUMERIC_STANDARD();
value = atof(tokenbuf);
- tryi32 = I_32(value);
- if (!floatit && (double)tryi32 == value)
- sv_setiv(sv,tryi32);
+ tryiv = I_V(value);
+ if (!floatit && (double)tryiv == value)
+ sv_setiv(sv, tryiv);
else
- sv_setnv(sv,value);
+ sv_setnv(sv, value);
break;
}
}
int
-start_subparse()
+start_subparse(is_format, flags)
+I32 is_format;
+U32 flags;
{
int oldsavestack_ix = savestack_ix;
CV* outsidecv = compcv;
SAVEI32(pad_reset_pending);
compcv = (CV*)NEWSV(1104,0);
- sv_upgrade((SV *)compcv, SVt_PVCV);
+ sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
+ CvFLAGS(compcv) |= flags;
comppad = newAV();
comppad_name = newAV();
yyerror(s)
char *s;
{
- char tmpbuf[258];
- char *tname = tmpbuf;
+ char wbuf[40];
+ char *where = NULL;
+ char *context = NULL;
+ int contlen = -1;
if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
while (isSPACE(*oldoldbufptr))
oldoldbufptr++;
- sprintf(tname,"near \"%.*s\"",bufptr - oldoldbufptr, oldoldbufptr);
+ context = oldoldbufptr;
+ contlen = bufptr - oldoldbufptr;
}
else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
oldbufptr != bufptr) {
while (isSPACE(*oldbufptr))
oldbufptr++;
- sprintf(tname,"near \"%.*s\"",bufptr - oldbufptr, oldbufptr);
+ context = oldbufptr;
+ contlen = bufptr - oldbufptr;
}
else if (yychar > 255)
- tname = "next token ???";
+ where = "next token ???";
else if (!yychar || (yychar == ';' && !rsfp))
- (void)strcpy(tname,"at EOF");
+ where = "at EOF";
else if ((yychar & 127) == 127) {
if (lex_state == LEX_NORMAL ||
(lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
- (void)strcpy(tname,"at end of line");
+ where = "at end of line";
else if (lex_inpat)
- (void)strcpy(tname,"within pattern");
+ where = "within pattern";
else
- (void)strcpy(tname,"within string");
+ where = "within string";
}
else if (yychar < 32)
- (void)sprintf(tname,"next char ^%c",toCTRL(yychar));
+ (void)sprintf(where = wbuf, "next char ^%c", toCTRL(yychar));
+ else if (isPRINT_LC(yychar))
+ (void)sprintf(where = wbuf, "next char %c", yychar);
+ else
+ (void)sprintf(where = wbuf, "next char \\%03o", yychar & 255);
+ if (contlen == -1)
+ contlen = strlen(where);
+ (void)sprintf(buf, "%s at %s line %d, ",
+ s, SvPVX(GvSV(curcop->cop_filegv)), curcop->cop_line);
+ if (context)
+ (void)sprintf(buf+strlen(buf), "near \"%.*s\"\n", contlen, context);
else
- (void)sprintf(tname,"next char %c",yychar);
- (void)sprintf(buf, "%s at %s line %d, %s\n",
- s,SvPVX(GvSV(curcop->cop_filegv)),curcop->cop_line,tname);
- if (curcop->cop_line == multi_end && multi_start < multi_end) {
+ (void)sprintf(buf+strlen(buf), "%s\n", where);
+ if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
sprintf(buf+strlen(buf),
- " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
- multi_open,multi_close,(long)multi_start);
+ " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
+ (int)multi_open,(int)multi_close,(long)multi_start);
multi_end = 0;
}
if (in_eval & 2)
projects / p5sagit/p5-mst-13.2.git / blobdiff