#define yychar (*PL_yycharp)
#define yylval (*PL_yylvalp)
-static const char ident_too_long[] =
- "Identifier too long";
-static const char c_without_g[] =
- "Use of /c modifier is meaningless without /g";
-static const char c_in_subst[] =
- "Use of /c modifier is meaningless in s///";
+static const char ident_too_long[] = "Identifier too long";
static void restore_rsfp(pTHX_ void *f);
#ifndef PERL_NO_UTF16_FILTER
/* #define LEX_NOTPARSING 11 is done in perl.h. */
-#define LEX_NORMAL 10
-#define LEX_INTERPNORMAL 9
-#define LEX_INTERPCASEMOD 8
-#define LEX_INTERPPUSH 7
-#define LEX_INTERPSTART 6
-#define LEX_INTERPEND 5
-#define LEX_INTERPENDMAYBE 4
-#define LEX_INTERPCONCAT 3
-#define LEX_INTERPCONST 2
-#define LEX_FORMLINE 1
-#define LEX_KNOWNEXT 0
+#define LEX_NORMAL 10 /* normal code (ie not within "...") */
+#define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
+#define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
+#define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
+#define LEX_INTERPSTART 6 /* expecting the start of a $var */
+
+ /* at end of code, eg "$x" followed by: */
+#define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
+#define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
+
+#define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
+ string or after \E, $foo, etc */
+#define LEX_INTERPCONST 2 /* NOT USED */
+#define LEX_FORMLINE 1 /* expecting a format line */
+#define LEX_KNOWNEXT 0 /* next token known; just return it */
+
#ifdef DEBUGGING
static const char* const lex_state_names[] = {
*/
#ifdef DEBUGGING /* Serve -DT. */
-# define REPORT(retval) tokereport(s,(int)retval)
+# define REPORT(retval) tokereport((I32)retval)
#else
# define REPORT(retval) (retval)
#endif
/* dump the returned token in rv, plus any optional arg in yylval */
STATIC int
-S_tokereport(pTHX_ const char* s, I32 rv)
+S_tokereport(pTHX_ I32 rv)
{
if (DEBUG_T_TEST) {
const char *name = Nullch;
Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
break;
case TOKENTYPE_OPVAL:
- if (yylval.opval)
+ if (yylval.opval) {
Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
PL_op_name[yylval.opval->op_type]);
+ if (yylval.opval->op_type == OP_CONST) {
+ Perl_sv_catpvf(aTHX_ report, " %s",
+ SvPEEK(cSVOPx_sv(yylval.opval)));
+ }
+
+ }
else
Perl_sv_catpv(aTHX_ report, "(opval=null)");
break;
}
- Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop));
- if (s - PL_bufptr > 0)
- sv_catpvn(report, PL_bufptr, s - PL_bufptr);
- else {
- if (PL_oldbufptr && *PL_oldbufptr)
- sv_catpv(report, PL_tokenbuf);
- }
- PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen_const(report));
+ PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
};
return (int)rv;
}
+
+/* print the buffer with suitable escapes */
+
+STATIC void
+S_printbuf(pTHX_ const char* fmt, const char* s)
+{
+ SV* const tmp = newSVpvn("", 0);
+ PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
+ SvREFCNT_dec(tmp);
+}
+
#endif
/*
if (t < PL_bufptr && isSPACE(*t))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\t(Do you need to predeclare %.*s?)\n",
- t - PL_oldoldbufptr, PL_oldoldbufptr);
+ (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
}
else {
assert(s >= oldbp);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
+ "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
}
}
PL_bufptr = oldbp;
#endif
) {
*tmpbuf = '^';
- tmpbuf[1] = toCTRL(PL_multi_close);
+ tmpbuf[1] = (char)toCTRL(PL_multi_close);
tmpbuf[2] = '\0';
s = tmpbuf;
}
ch = *t;
*t = '\0';
if (t - s > 0) {
+#ifndef USE_ITHREADS
+ const char * const cf = CopFILE(PL_curcop);
+ STRLEN tmplen = cf ? strlen(cf) : 0;
+ if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
+ /* must copy *{"::_<(eval N)[oldfilename:L]"}
+ * to *{"::_<newfilename"} */
+ char smallbuf[256], smallbuf2[256];
+ char *tmpbuf, *tmpbuf2;
+ GV **gvp, *gv2;
+ STRLEN tmplen2 = strlen(s);
+ if (tmplen + 3 < sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else
+ Newx(tmpbuf, tmplen + 3, char);
+ if (tmplen2 + 3 < sizeof smallbuf2)
+ tmpbuf2 = smallbuf2;
+ else
+ Newx(tmpbuf2, tmplen2 + 3, char);
+ tmpbuf[0] = tmpbuf2[0] = '_';
+ tmpbuf[1] = tmpbuf2[1] = '<';
+ memcpy(tmpbuf + 2, cf, ++tmplen);
+ memcpy(tmpbuf2 + 2, s, ++tmplen2);
+ ++tmplen; ++tmplen2;
+ gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
+ if (gvp) {
+ gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
+ if (!isGV(gv2))
+ gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
+ /* adjust ${"::_<newfilename"} to store the new file name */
+ GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
+ GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
+ GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ }
+ if (tmpbuf != smallbuf) Safefree(tmpbuf);
+ if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
+ }
+#endif
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, s);
}
STATIC I32
S_sublex_start(pTHX)
{
- const register I32 op_type = yylval.ival;
+ register const I32 op_type = yylval.ival;
if (op_type == OP_NULL) {
yylval.opval = PL_lex_op;
I32 has_utf8 = FALSE; /* Output constant is UTF8 */
I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
UV uv;
+#ifdef EBCDIC
+ UV literal_endpoint = 0;
+#endif
const char *leaveit = /* set of acceptably-backslashed characters */
PL_lex_inpat
}
#ifdef EBCDIC
- if ((isLOWER(min) && isLOWER(max)) ||
- (isUPPER(min) && isUPPER(max))) {
+ if (literal_endpoint == 2 &&
+ ((isLOWER(min) && isLOWER(max)) ||
+ (isUPPER(min) && isUPPER(max)))) {
if (isLOWER(min)) {
for (i = min; i <= max; i++)
if (isLOWER(i))
/* mark the range as done, and continue */
dorange = FALSE;
didrange = TRUE;
+#ifdef EBCDIC
+ literal_endpoint = 0;
+#endif
continue;
}
}
else {
didrange = FALSE;
+#ifdef EBCDIC
+ literal_endpoint = 0;
+#endif
}
}
s++;
continue;
} /* end if (backslash) */
+#ifdef EBCDIC
+ else
+ literal_endpoint++;
+#endif
default_action:
/* If we started with encoded form, or already know we want it
return gv_stashpv(pkgname, FALSE);
}
+STATIC char *
+S_tokenize_use(pTHX_ int is_use, char *s) {
+ if (PL_expect != XSTATE)
+ yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
+ is_use ? "use" : "no"));
+ s = skipspace(s);
+ if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
+ s = force_version(s, TRUE);
+ if (*s == ';' || (s = skipspace(s), *s == ';')) {
+ PL_nextval[PL_nexttoke].opval = Nullop;
+ force_next(WORD);
+ }
+ else if (*s == 'v') {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s, FALSE);
+ }
+ }
+ else {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s, FALSE);
+ }
+ yylval.ival = is_use;
+ return s;
+}
#ifdef DEBUGGING
static const char* const exp_name[] =
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
I32 orig_keyword = 0;
DEBUG_T( {
- PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
- lex_state_names[PL_lex_state]);
+ SV* tmp = newSVpvn("", 0);
+ PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
+ (IV)CopLINE(PL_curcop),
+ lex_state_names[PL_lex_state],
+ exp_name[PL_expect],
+ pv_display(tmp, s, strlen(s), 0, 60));
+ SvREFCNT_dec(tmp);
} );
/* check if there's an identifier for us to look at */
if (PL_pending_ident)
PL_expect = PL_lex_expect;
PL_lex_defer = LEX_NORMAL;
}
- DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
- (IV)PL_nexttype[PL_nexttoke]); });
-
return REPORT(PL_nexttype[PL_nexttoke]);
/* interpolated case modifiers like \L \U, including \Q and \E.
}
else {
DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Saw case modifier at '%s'\n", PL_bufptr); });
+ "### Saw case modifier\n"); });
s = PL_bufptr + 1;
if (s[1] == '\\' && s[2] == 'E') {
PL_bufptr = s + 3;
if (PL_bufptr == PL_bufend)
return REPORT(sublex_done());
DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Interpolated variable at '%s'\n", PL_bufptr); });
+ "### Interpolated variable\n"); });
PL_expect = XTERM;
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
s = PL_bufptr;
PL_oldoldbufptr = PL_oldbufptr;
PL_oldbufptr = s;
- DEBUG_T( {
- PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
- exp_name[PL_expect], s);
- } );
retry:
switch (*s) {
PL_last_uni = 0;
PL_last_lop = 0;
if (PL_lex_brackets) {
- if (PL_lex_formbrack)
- yyerror("Format not terminated");
- else
- yyerror("Missing right curly or square bracket");
+ yyerror(PL_lex_formbrack
+ ? "Format not terminated"
+ : "Missing right curly or square bracket");
}
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Tokener got EOF\n");
* 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)); /* $^X */
+ SV * const x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
assert(SvPOK(x) || SvGMAGICAL(x));
if (sv_eq(x, CopFILESV(PL_curcop))) {
sv_setpvn(x, ipath, ipathend - ipath);
if (strnEQ(s,"=>",2)) {
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw unary minus before =>, forcing word '%s'\n", s);
+ DEBUG_T( { S_printbuf(aTHX_
+ "### Saw unary minus before =>, forcing word %s\n", s);
} );
OPERATOR('-'); /* unary minus */
}
if (ftst) {
PL_last_lop_op = (OPCODE)ftst;
DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw file test %c\n", (int)ftst);
+ "### Saw file test %c\n", (int)tmp);
} );
FTST(ftst);
}
context messages from yyerror().
*/
PL_bufptr = s;
- if (!*s)
- yyerror("Unterminated attribute list");
- else
- yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
- q, *s, q));
+ yyerror( *s
+ ? Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list", q, *s, q)
+ : "Unterminated attribute list" );
if (attrs)
op_free(attrs);
OPERATOR(':');
OPERATOR(',');
if (tmp == '~')
PMop(OP_MATCH);
- if (tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp) && ckWARN(WARN_SYNTAX))
+ if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
s--;
if (PL_expect == XSTATE && isALPHA(tmp) &&
else if (*s == '{') {
char *t;
PL_tokenbuf[0] = '%';
- if (strEQ(PL_tokenbuf+1, "SIG") && (t = strchr(s, '}'))
- && (t = strchr(t, '=')) && ckWARN(WARN_SYNTAX))
+ if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
+ && (t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof PL_tokenbuf];
for (t++; isSPACE(*t); t++) ;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
s = scan_num(s, &yylval);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw number in '%s'\n", s);
- } );
+ DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
case '\'':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw string before '%s'\n", s);
- } );
+ DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
case '"':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw string before '%s'\n", s);
- } );
+ DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
case '`':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw backtick string before '%s'\n", s);
- } );
+ DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
/* If not a declared subroutine, it's an indirect object. */
/* (But it's an indir obj regardless for sort.) */
+ /* Also, if "_" follows a filetest operator, it's a bareword */
- if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
+ if (
+ ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
((!gv || !GvCVu(gv)) &&
(PL_last_lop_op != OP_MAPSTART &&
PL_last_lop_op != OP_GREPSTART))))
+ || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
+ && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
+ )
{
PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
goto bareword;
Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
if (tmp < 0)
tmp = -tmp;
+ else if (tmp == KEY_require || tmp == KEY_do)
+ /* that's a way to remember we saw "CORE::" */
+ orig_keyword = tmp;
goto reserved_word;
}
goto just_a_word;
PRETERMBLOCK(DO);
if (*s != '\'')
s = force_word(s,WORD,TRUE,TRUE,FALSE);
+ if (orig_keyword == KEY_do) {
+ orig_keyword = 0;
+ yylval.ival = 1;
+ }
+ else
+ yylval.ival = 0;
OPERATOR(DO);
case KEY_die:
Eop(OP_SNE);
case KEY_no:
- if (PL_expect != XSTATE)
- yyerror("\"no\" not allowed in expression");
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, FALSE);
- yylval.ival = 0;
+ s = tokenize_use(0, s);
OPERATOR(USE);
case KEY_not:
/* [perl #16184] */
&& !(t[0] == '=' && t[1] == '>')
) {
+ int len = (int)(d-s);
Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
"Precedence problem: open %.*s should be open(%.*s)",
- d - s, s, d - s, s);
+ len, s, len, s);
}
}
LOP(OP_OPEN,XTERM);
else if (*s == '<')
yyerror("<> should be quotes");
}
- UNI(OP_REQUIRE);
+ if (orig_keyword == KEY_require) {
+ orig_keyword = 0;
+ yylval.ival = 1;
+ }
+ else
+ yylval.ival = 0;
+ PL_expect = XTERM;
+ PL_bufptr = s;
+ PL_last_uni = PL_oldbufptr;
+ PL_last_lop_op = OP_REQUIRE;
+ s = skipspace(s);
+ return REPORT( (int)REQUIRE );
case KEY_reset:
UNI(OP_RESET);
LOP(OP_UNSHIFT,XTERM);
case KEY_use:
- if (PL_expect != XSTATE)
- yyerror("\"use\" not allowed in expression");
- s = skipspace(s);
- if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
- s = force_version(s, TRUE);
- if (*s == ';' || (s = skipspace(s), *s == ';')) {
- PL_nextval[PL_nexttoke].opval = Nullop;
- force_next(WORD);
- }
- else if (*s == 'v') {
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, FALSE);
- }
- }
- else {
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, FALSE);
- }
- yylval.ival = 1;
+ s = tokenize_use(1, s);
OPERATOR(USE);
case KEY_values:
PL_pending_ident = 0;
DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
+ "### Pending identifier '%s'\n", PL_tokenbuf); });
/* if we're in a my(), we can't allow dynamics here.
$foo'bar has already been turned into $foo::bar, so
{
register char *d;
register char *e;
- char *bracket = 0;
+ char *bracket = Nullch;
char funny = *s++;
if (isSPACE(*s))
char *s = scan_str(start,FALSE,FALSE);
if (!s) {
- char *delimiter = skipspace(start);
+ char * const delimiter = skipspace(start);
Perl_croak(aTHX_ *delimiter == '?'
? "Search pattern not terminated or ternary operator parsed as search pattern"
: "Search pattern not terminated" );
if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
&& ckWARN(WARN_REGEXP))
{
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
}
pm->op_pmpermflags = pm->op_pmflags;
break;
}
- /* /c is not meaningful with s/// */
- if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
- {
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
+ if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
}
if (es) {
static void
restore_rsfp(pTHX_ void *f)
{
- PerlIO *fp = (PerlIO*)f;
+ PerlIO * const fp = (PerlIO*)f;
if (PL_rsfp == PerlIO_stdin())
PerlIO_clearerr(PL_rsfp);
}
if (!isALPHA(*pos)) {
- UV rev;
U8 tmpbuf[UTF8_MAXBYTES+1];
- U8 *tmpend;
if (*s == 'v') s++; /* get past 'v' */
sv_setpvn(sv, "", 0);
for (;;) {
- rev = 0;
+ U8 *tmpend;
+ UV rev = 0;
{
/* this is atoi() that tolerates underscores */
const char *end = pos;
https://perl5.git.perl.org / perl5.git / blobdiff