/* LEX_* are values for PL_lex_state, the state of the lexer.
* They are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
+ *
+ * These values refer to the various states within a sublex parse,
+ * i.e. within a double quotish string
*/
/* #define LEX_NOTPARSING 11 is done in perl.h. */
* The UNIDOR macro is for unary functions that can be followed by the //
* operator (such as C<shift // 0>).
*/
-#define UNI2(f,x) { \
+#define UNI3(f,x,have_x) { \
pl_yylval.ival = f; \
- PL_expect = x; \
+ if (have_x) PL_expect = x; \
PL_bufptr = s; \
PL_last_uni = PL_oldbufptr; \
PL_last_lop_op = f; \
s = PEEKSPACE(s); \
return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
}
-#define UNI(f) UNI2(f,XTERM)
-#define UNIDOR(f) UNI2(f,XTERMORDORDOR)
+#define UNI(f) UNI3(f,XTERM,1)
+#define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
#define UNIPROTO(f,optional) { \
if (optional) PL_last_uni = PL_oldbufptr; \
OPERATOR(f); \
}
-#define UNIBRACK(f) { \
- pl_yylval.ival = f; \
- PL_bufptr = s; \
- PL_last_uni = PL_oldbufptr; \
- if (*s == '(') \
- return REPORT( (int)FUNC1 ); \
- s = PEEKSPACE(s); \
- return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
- }
+#define UNIBRACK(f) UNI3(f,0,0)
/* grandfather return to old style */
#define OLDLOP(f) \
TOKENTYPE_IVAL,
TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
TOKENTYPE_PVAL,
- TOKENTYPE_OPVAL,
- TOKENTYPE_GVVAL
+ TOKENTYPE_OPVAL
};
static struct debug_tokens {
{ EQOP, TOKENTYPE_OPNUM, "EQOP" },
{ FOR, TOKENTYPE_IVAL, "FOR" },
{ FORMAT, TOKENTYPE_NONE, "FORMAT" },
+ { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
+ { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
{ FUNC, TOKENTYPE_OPNUM, "FUNC" },
{ FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
{ FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
{ GIVEN, TOKENTYPE_IVAL, "GIVEN" },
{ HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
{ IF, TOKENTYPE_IVAL, "IF" },
- { LABEL, TOKENTYPE_PVAL, "LABEL" },
+ { LABEL, TOKENTYPE_OPVAL, "LABEL" },
{ LOCAL, TOKENTYPE_IVAL, "LOCAL" },
{ LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
{ LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
{ OROP, TOKENTYPE_IVAL, "OROP" },
{ OROR, TOKENTYPE_NONE, "OROR" },
{ PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
+ { PEG, TOKENTYPE_NONE, "PEG" },
{ PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
{ PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
{ PREDEC, TOKENTYPE_NONE, "PREDEC" },
{ PREINC, TOKENTYPE_NONE, "PREINC" },
{ PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
+ { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
{ REFGEN, TOKENTYPE_NONE, "REFGEN" },
{ RELOP, TOKENTYPE_OPNUM, "RELOP" },
+ { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
{ SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
{ SUB, TOKENTYPE_NONE, "SUB" },
{ THING, TOKENTYPE_OPVAL, "THING" },
Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
switch (type) {
case TOKENTYPE_NONE:
- case TOKENTYPE_GVVAL: /* doesn't appear to be used */
break;
case TOKENTYPE_IVAL:
Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
s = oldbp;
else
PL_bufptr = s;
- yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
+ yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
if (ckWARN_d(WARN_SYNTAX)) {
if (is_first)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\t(Missing semicolon on previous line?)\n");
else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
const char *t;
- for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
+ for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':');
+ t += UTF ? UTF8SKIP(t) : 1)
NOOP;
if (t < PL_bufptr && isSPACE(*t))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "\t(Do you need to predeclare %.*s?)\n",
- (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
+ "\t(Do you need to predeclare %"SVf"?)\n",
+ SVfARG(newSVpvn_flags(PL_oldoldbufptr, (STRLEN)(t - PL_oldoldbufptr),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
}
else {
assert(s >= oldbp);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
+ "\t(Missing operator before %"SVf"?)\n",
+ SVfARG(newSVpvn_flags(oldbp, (STRLEN)(s - oldbp),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
}
}
PL_bufptr = oldbp;
Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
}
+#include "feature.h"
+
/*
* Check whether the named feature is enabled.
*/
bool
-Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen,
- bool negate)
+Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
{
dVAR;
char he_name[8 + MAX_FEATURE_LEN] = "feature_";
PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
+ assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
+
if (namelen > MAX_FEATURE_LEN)
return FALSE;
- if (negate) he_name[8] = 'n', he_name[9] = 'o';
- memcpy(&he_name[8 + 2*negate], name, namelen);
-
- return
- (
- cop_hints_fetch_pvn(
- PL_curcop, he_name, 8 + 2*negate + namelen, 0, 0
- )
- != &PL_sv_placeholder
- )
- != negate;
+ memcpy(&he_name[8], name, namelen);
+
+ return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
+ REFCOUNTED_HE_EXISTS));
}
/*
static void
strip_return(SV *sv)
{
- register const char *s = SvPVX_const(sv);
- register const char * const e = s + SvCUR(sv);
+ const char *s = SvPVX_const(sv);
+ const char * const e = s + SvCUR(sv);
PERL_ARGS_ASSERT_STRIP_RETURN;
while (s < e) {
if (*s++ == '\r' && *s == '\n') {
/* hit a CR-LF, need to copy the rest */
- register char *d = s - 1;
+ char *d = s - 1;
*d++ = *s++;
while (s < e) {
if (*s == '\r' && s[1] == '\n')
*/
/* LEX_START_SAME_FILTER indicates that this is not a new file, so it
- can share filters with the current parser. */
+ can share filters with the current parser.
+ LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
+ caller, hence isn't owned by the parser, so shouldn't be closed on parser
+ destruction. This is used to handle the case of defaulting to reading the
+ script from the standard input because no filename was given on the command
+ line (without getting confused by situation where STDIN has been closed, so
+ the script handle is opened on fd 0) */
void
Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
parser->linestart = SvPVX(parser->linestr);
parser->bufend = parser->bufptr + SvCUR(parser->linestr);
parser->last_lop = parser->last_uni = NULL;
- parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES);
+ parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+ |LEX_DONT_CLOSE_RSFP);
parser->in_pod = parser->filtered = 0;
}
PL_curcop = parser->saved_curcop;
SvREFCNT_dec(parser->linestr);
- if (parser->rsfp == PerlIO_stdin())
+ if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
PerlIO_clearerr(parser->rsfp);
else if (parser->rsfp && (!parser->old_parser ||
(parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
SV *linestr;
char *buf;
STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
- STRLEN linestart_pos, last_uni_pos, last_lop_pos;
+ STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
linestr = PL_parser->linestr;
buf = SvPVX(linestr);
if (len <= SvLEN(linestr))
linestart_pos = PL_parser->linestart - buf;
last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
+ re_eval_start_pos = PL_sublex_info.re_eval_start ?
+ PL_sublex_info.re_eval_start - buf : 0;
+
buf = sv_grow(linestr, len);
+
PL_parser->bufend = buf + bufend_pos;
PL_parser->bufptr = buf + bufptr_pos;
PL_parser->oldbufptr = buf + oldbufptr_pos;
PL_parser->last_uni = buf + last_uni_pos;
if (PL_parser->last_lop)
PL_parser->last_lop = buf + last_lop_pos;
+ if (PL_sublex_info.re_eval_start)
+ PL_sublex_info.re_eval_start = buf + re_eval_start_pos;
return buf;
}
*/
#define LEX_FAKE_EOF 0x80000000
+#define LEX_NO_TERM 0x40000000
bool
Perl_lex_next_chunk(pTHX_ U32 flags)
STRLEN linestart_pos, last_uni_pos, last_lop_pos;
bool got_some_for_debugger = 0;
bool got_some;
- if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF))
+ if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
linestr = PL_parser->linestr;
buf = SvPVX(linestr);
} else if (filter_gets(linestr, old_bufend_pos)) {
got_some = 1;
got_some_for_debugger = 1;
+ } else if (flags & LEX_NO_TERM) {
+ got_some = 0;
} else {
if (!SvPOK(linestr)) /* can get undefined by filter_gets */
sv_setpvs(linestr, "");
/* End of real input. Close filehandle (unless it was STDIN),
* then add implicit termination.
*/
- if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin())
+ if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
PerlIO_clearerr(PL_parser->rsfp);
else if (PL_parser->rsfp)
(void)PerlIO_close(PL_parser->rsfp);
tokereport(type, &NEXTVAL_NEXTTOKE);
}
#endif
+ /* Don’t let opslab_force_free snatch it */
+ if (S_is_opval_token(type & 0xffff) && NEXTVAL_NEXTTOKE.opval) {
+ assert(!NEXTVAL_NEXTTOKE.opval->op_savefree);
+ NEXTVAL_NEXTTOKE.opval->op_savefree = 1;
+ }
#ifdef PERL_MAD
if (PL_curforce < 0)
start_force(PL_lasttoke);
S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
{
dVAR;
- register char *s;
+ char *s;
STRLEN len;
PERL_ARGS_ASSERT_FORCE_WORD;
if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
SV *ver;
#ifdef USE_LOCALE_NUMERIC
- char *loc = setlocale(LC_NUMERIC, "C");
+ char *loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
#endif
s = scan_num(s, &pl_yylval);
#ifdef USE_LOCALE_NUMERIC
setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
#endif
version = pl_yylval.opval;
ver = cSVOPx(version)->op_sv;
S_tokeq(pTHX_ SV *sv)
{
dVAR;
- register char *s;
- register char *send;
- register char *d;
+ char *s;
+ char *send;
+ char *d;
STRLEN len = 0;
SV *pv = sv;
* converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
* interact with PL_lex_state, and create fake ( ... ) argument lists
* to handle functions and concatenation.
- * They assume that whoever calls them will be setting up a fake
- * join call, because each subthing puts a ',' after it. This lets
- * "lower \luPpEr"
- * become
- * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
- *
- * (I'm not sure whether the spurious commas at the end of lcfirst's
- * arguments and join's arguments are created or not).
+ * For example,
+ * "foo\lbar"
+ * is tokenised as
+ * stringify ( const[foo] concat lcfirst ( const[bar] ) )
*/
/*
S_sublex_start(pTHX)
{
dVAR;
- register const I32 op_type = pl_yylval.ival;
+ const I32 op_type = pl_yylval.ival;
+ PL_sublex_info.super_bufptr = PL_bufptr;
+ PL_sublex_info.super_bufend = PL_bufend;
if (op_type == OP_NULL) {
pl_yylval.opval = PL_lex_op;
PL_lex_op = NULL;
SAVEBOOL(PL_lex_dojoin);
SAVEI32(PL_lex_brackets);
SAVEI32(PL_lex_allbrackets);
+ SAVEI32(PL_lex_formbrack);
SAVEI8(PL_lex_fakeeof);
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
SAVEI8(PL_lex_state);
+ SAVEPPTR(PL_sublex_info.re_eval_start);
SAVEVPTR(PL_lex_inpat);
SAVEI16(PL_lex_inwhat);
SAVECOPLINE(PL_curcop);
PL_linestr = PL_lex_stuff;
PL_lex_stuff = NULL;
+ PL_sublex_info.re_eval_start = NULL;
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
= SvPVX(PL_linestr);
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
- PL_lex_brackets = 0;
+ PL_lex_brackets = PL_lex_formbrack = 0;
PL_lex_allbrackets = 0;
PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
Newx(PL_lex_brackstack, 120, char);
/*
scan_const
- Extracts a pattern, double-quoted string, or transliteration. This
- is terrifying code.
+ Extracts the next constant part of a pattern, double-quoted string,
+ or transliteration. This is terrifying code.
+
+ For example, in parsing the double-quoted string "ab\x63$d", it would
+ stop at the '$' and return an OP_CONST containing 'abc'.
It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
processing a pattern (PL_lex_inpat is true), a transliteration
Returns a pointer to the character scanned up to. If this is
advanced from the start pointer supplied (i.e. if anything was
- successfully parsed), will leave an OP for the substring scanned
+ successfully parsed), will leave an OP_CONST for the substring scanned
in pl_yylval. Caller must intuit reason for not parsing further
by looking at the next characters herself.
In patterns:
- backslashes:
- constants: \N{NAME} only
- case and quoting: \U \Q \E
- stops on @ and $, but not for $ as tail anchor
+ expand:
+ \N{ABC} => \N{U+41.42.43}
+
+ pass through:
+ all other \-char, including \N and \N{ apart from \N{ABC}
+
+ stops on:
+ @ and $ where it appears to be a var, but not for $ as tail anchor
+ \l \L \u \U \Q \E
+ (?{ or (??{
+
In transliterations:
characters are VERY literal, except for - not at the start or end
it's a tail anchor if $ is the last thing in the string, or if it's
followed by one of "()| \r\n\t"
- \1 (backreferences) are turned into $1
+ \1 (backreferences) are turned into $1 in substitutions
The structure of the code is
while (there's a character to process) {
S_scan_const(pTHX_ char *start)
{
dVAR;
- register char *send = PL_bufend; /* end of the constant */
+ char *send = PL_bufend; /* end of the constant */
SV *sv = newSV(send - start); /* sv for the constant. See
note below on sizing. */
- register char *s = start; /* start of the constant */
- register char *d = SvPVX(sv); /* destination for copies */
+ char *s = start; /* start of the constant */
+ char *d = SvPVX(sv); /* destination for copies */
bool dorange = FALSE; /* are we in a translit range? */
bool didrange = FALSE; /* did we just finish a range? */
+ bool in_charclass = FALSE; /* within /[...]/ */
bool has_utf8 = FALSE; /* Output constant is UTF8 */
bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
to be UTF8? But, this can
/* if we get here, we're not doing a transliteration */
- /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
- except for the last char, which will be done separately. */
+ else if (*s == '[' && PL_lex_inpat && !in_charclass) {
+ char *s1 = s-1;
+ int esc = 0;
+ while (s1 >= start && *s1-- == '\\')
+ esc = !esc;
+ if (!esc)
+ in_charclass = TRUE;
+ }
+
+ else if (*s == ']' && PL_lex_inpat && in_charclass) {
+ char *s1 = s-1;
+ int esc = 0;
+ while (s1 >= start && *s1-- == '\\')
+ esc = !esc;
+ if (!esc)
+ in_charclass = FALSE;
+ }
+
+ /* skip for regexp comments /(?#comment)/, except for the last
+ * char, which will be done separately.
+ * Stop on (?{..}) and friends */
+
else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
if (s[2] == '#') {
while (s+1 < send && *s != ')')
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
- else if (s[2] == '{' /* This should match regcomp.c */
- || (s[2] == '?' && s[3] == '{'))
+ else if (!PL_lex_casemods && !in_charclass &&
+ ( s[2] == '{' /* This should match regcomp.c */
+ || (s[2] == '?' && s[3] == '{')))
{
- I32 count = 1;
- char *regparse = s + (s[2] == '{' ? 3 : 4);
- char c;
-
- while (count && (c = *regparse)) {
- if (c == '\\' && regparse[1])
- regparse++;
- else if (c == '{')
- count++;
- else if (c == '}')
- count--;
- regparse++;
- }
- if (*regparse != ')')
- regparse--; /* Leave one char for continuation. */
- while (s < regparse)
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
+ break;
}
}
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
+ /* no further processing of single-quoted regex */
+ else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
+ goto default_action;
+
/* check for embedded arrays
(@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
*/
}
/* string-change backslash escapes */
- if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
+ if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
--s;
break;
}
/* FALL THROUGH */
default:
{
- if ((isALPHA(*s) || isDIGIT(*s)))
+ if ((isALNUMC(*s)))
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Unrecognized escape \\%c passed through",
*s);
/* eg. \x24 indicates the hex constant 0x24 */
case 'x':
- ++s;
- if (*s == '{') {
- char* const e = strchr(s, '}');
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
- PERL_SCAN_DISALLOW_PREFIX;
+ {
STRLEN len;
+ const char* error;
- ++s;
- if (!e) {
- yyerror("Missing right brace on \\x{}");
+ bool valid = grok_bslash_x(s, &uv, &len, &error, 1);
+ s += len;
+ if (! valid) {
+ yyerror(error);
continue;
}
- len = e - s;
- uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
- s = e + 1;
- }
- else {
- {
- STRLEN len = 2;
- I32 flags = PERL_SCAN_DISALLOW_PREFIX;
- uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
- s += len;
- }
}
NUM_ESCAPE_INSERT:
*d = '\0';
SvCUR_set(sv, d - SvPVX_const(sv));
if (SvCUR(sv) >= SvLEN(sv))
- Perl_croak(aTHX_ "panic: constant overflowed allocated space");
+ Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
+ " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
SvPOK_on(sv);
if (PL_encoding && !has_utf8) {
} else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
type = "s";
typelen = 1;
+ } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
+ type = "q";
+ typelen = 1;
} else {
type = "qq";
typelen = 2;
*
* First argument is the stuff after the first token, e.g. "bar".
*
- * Not a method if bar is a filehandle.
+ * Not a method if foo is a filehandle.
* Not a method if foo is a subroutine prototyped to take a filehandle.
* Not a method if it's really "Foo $bar"
* Method if it's "foo $bar"
PERL_ARGS_ASSERT_INTUIT_METHOD;
- if (gv) {
- if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
+ if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
return 0;
- if (cv) {
- if (SvPOK(cv)) {
+ if (cv && SvPOK(cv)) {
const char *proto = CvPROTO(cv);
if (proto) {
if (*proto == ';')
if (*proto == '*')
return 0;
}
- }
- } else
- gv = NULL;
}
s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
/* start is the beginning of the possible filehandle/object,
*/
if (*start == '$') {
- if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
+ if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
isUPPER(*PL_tokenbuf))
return 0;
#ifdef PERL_MAD
if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
- if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
+ if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
#ifdef PERL_MAD
soff = s - SvPVX(PL_linestr);
#endif
case FUNC0SUB:
case UNIOPSUB:
case LSTOPSUB:
+ case LABEL:
if (pl_yylval.opval)
append_madprops(PL_thismad, pl_yylval.opval, 0);
PL_thismad = 0;
}
break;
- /* pval */
- case LABEL:
- break;
-
/* ival */
default:
break;
if (PL_expect != XSTATE)
yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
is_use ? "use" : "no"));
+ PL_expect = XTERM;
s = SKIPSPACE1(s);
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
s = force_version(s, TRUE);
Perl_yylex(pTHX)
{
dVAR;
- register char *s = PL_bufptr;
- register char *d;
+ char *s = PL_bufptr;
+ char *d;
STRLEN len;
bool bof = FALSE;
+ U8 formbrack = 0;
U32 fake_eof = 0;
/* orig_keyword, gvp, and gv are initialized here because
PL_lex_allbrackets--;
next_type &= 0xffff;
}
+ if (S_is_opval_token(next_type) && pl_yylval.opval)
+ pl_yylval.opval->op_savefree = 0; /* release */
#ifdef PERL_MAD
/* FIXME - can these be merged? */
return next_type;
case LEX_INTERPCASEMOD:
#ifdef DEBUGGING
if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
- Perl_croak(aTHX_ "panic: INTERPCASEMOD");
+ Perl_croak(aTHX_
+ "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
+ PL_bufptr, PL_bufend, *PL_bufptr);
#endif
/* handle \E or end of string */
if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
PL_lex_casestack[PL_lex_casemods] = '\0';
if (PL_bufptr != PL_bufend
- && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
+ && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
+ || oldmod == 'F')) {
PL_bufptr += 2;
PL_lex_state = LEX_INTERPCONCAT;
#ifdef PERL_MAD
PL_lex_allbrackets--;
return REPORT(')');
}
+ else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
+ /* Got an unpaired \E */
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Useless use of \\E");
+ }
#ifdef PERL_MAD
while (PL_bufptr != PL_bufend &&
PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
if (!PL_madskills) /* when just compiling don't need correct */
if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
- if ((*s == 'L' || *s == 'U') &&
- (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
+ if ((*s == 'L' || *s == 'U' || *s == 'F') &&
+ (strchr(PL_lex_casestack, 'L')
+ || strchr(PL_lex_casestack, 'U')
+ || strchr(PL_lex_casestack, 'F'))) {
PL_lex_casestack[--PL_lex_casemods] = '\0';
PL_lex_allbrackets--;
return REPORT(')');
NEXTVAL_NEXTTOKE.ival = OP_UC;
else if (*s == 'Q')
NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
+ else if (*s == 'F')
+ NEXTVAL_NEXTTOKE.ival = OP_FC;
else
- Perl_croak(aTHX_ "panic: yylex");
+ Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
if (PL_madskills) {
SV* const tmpsv = newSVpvs("\\ ");
/* replace the space with the character we want to escape
case LEX_INTERPSTART:
if (PL_bufptr == PL_bufend)
return REPORT(sublex_done());
- DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
"### Interpolated variable\n"); });
PL_expect = XTERM;
PL_lex_dojoin = (*PL_bufptr == '@');
NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
}
+ /* Convert (?{...}) and friends to 'do {...}' */
+ if (PL_lex_inpat && *PL_bufptr == '(') {
+ PL_sublex_info.re_eval_start = PL_bufptr;
+ PL_bufptr += 2;
+ if (*PL_bufptr != '{')
+ PL_bufptr++;
+ start_force(PL_curforce);
+ /* XXX probably need a CURMAD(something) here */
+ PL_expect = XTERMBLOCK;
+ force_next(DO);
+ }
+
if (PL_lex_starts++) {
s = PL_bufptr;
#ifdef PERL_MAD
Perl_croak(aTHX_ "Bad evalled substitution pattern");
PL_lex_repl = NULL;
}
+ if (PL_sublex_info.re_eval_start) {
+ if (*PL_bufptr != ')')
+ Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
+ PL_bufptr++;
+ /* having compiled a (?{..}) expression, return the original
+ * text too, as a const */
+ start_force(PL_curforce);
+ /* XXX probably need a CURMAD(something) here */
+ NEXTVAL_NEXTTOKE.opval =
+ (OP*)newSVOP(OP_CONST, 0,
+ newSVpvn(PL_sublex_info.re_eval_start,
+ PL_bufptr - PL_sublex_info.re_eval_start));
+ force_next(THING);
+ PL_sublex_info.re_eval_start = NULL;
+ PL_expect = XTERM;
+ return REPORT(',');
+ }
+
/* FALLTHROUGH */
case LEX_INTERPCONCAT:
#ifdef DEBUGGING
if (PL_lex_brackets)
- Perl_croak(aTHX_ "panic: INTERPCONCAT");
+ Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
+ (long) PL_lex_brackets);
#endif
if (PL_bufptr == PL_bufend)
return REPORT(sublex_done());
- if (SvIVX(PL_linestr) == '\'') {
+ /* m'foo' still needs to be parsed for possible (?{...}) */
+ if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
SV *sv = newSVsv(PL_linestr);
- if (!PL_lex_inpat)
- sv = tokeq(sv);
- else if ( PL_hints & HINT_NEW_RE )
- sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
+ sv = tokeq(sv);
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
s = PL_bufend;
}
return yylex();
case LEX_FORMLINE:
- PL_lex_state = LEX_NORMAL;
s = scan_formline(PL_bufptr);
if (!PL_lex_formbrack)
+ {
+ formbrack = 1;
goto rightbracket;
- OPERATOR(';');
+ }
+ PL_bufptr = s;
+ return yylex();
}
s = PL_bufptr;
if (isIDFIRST_lazy_if(s,UTF))
goto keylookup;
{
- unsigned char c = *s;
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
+ const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
+ UTF8SKIP(s),
+ SVs_TEMP | SVf_UTF8),
+ 10, UNI_DISPLAY_ISPRINT))
+ : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
if (len > UNRECOGNIZED_PRECEDE_COUNT) {
d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
d = PL_linestart;
}
*s = '\0';
- Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
+ sv_setpv(dsv, d);
+ if (UTF)
+ SvUTF8_on(dsv);
+ Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
}
case 4:
case 26:
}
}
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_bufptr = s;
PL_lex_state = LEX_FORMLINE;
- return yylex();
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(FORMRBRACK);
+ TOKEN(';');
}
goto retry;
case '\r':
if (d < PL_bufend)
d++;
else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
- Perl_croak(aTHX_ "panic: input overflow");
+ Perl_croak(aTHX_ "panic: input overflow, %p > %p",
+ d, PL_bufend);
#ifdef PERL_MAD
if (PL_madskills)
PL_thiswhite = newSVpvn(s, d - s);
incline(s);
}
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_bufptr = s;
PL_lex_state = LEX_FORMLINE;
- return yylex();
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(FORMRBRACK);
+ TOKEN(';');
}
}
else {
}
sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
if (*d == '(') {
- d = scan_str(d,TRUE,TRUE);
+ d = scan_str(d,TRUE,TRUE,FALSE);
if (!d) {
/* MUST advance bufptr here to avoid bogus
"at end of line" context messages from yyerror().
}
TERM(']');
case '{':
- leftbracket:
s++;
+ leftbracket:
if (PL_lex_brackets > 100) {
Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
}
switch (PL_expect) {
case XTERM:
- if (PL_lex_formbrack) {
- s--;
- PRETERMBLOCK(DO);
- }
if (PL_oldoldbufptr == PL_last_lop)
PL_lex_brackstack[PL_lex_brackets++] = XTERM;
else
pl_yylval.ival = CopLINE(PL_curcop);
if (isSPACE(*s) || *s == '#')
PL_copline = NOLINE; /* invalidate current command line number */
- TOKEN('{');
+ TOKEN(formbrack ? '=' : '{');
case '}':
if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
TOKEN(0);
else
PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
PL_lex_allbrackets--;
- if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
- PL_lex_formbrack = 0;
if (PL_lex_state == LEX_INTERPNORMAL) {
if (PL_lex_brackets == 0) {
if (PL_expect & XFAKEBRACK) {
curmad('X', newSVpvn(s-1,1));
CURMAD('_', PL_thiswhite);
}
- force_next('}');
+ force_next(formbrack ? '.' : '}');
+ if (formbrack) LEAVE;
#ifdef PERL_MAD
if (!PL_thistoken)
PL_thistoken = newSVpvs("");
#endif
+ if (formbrack == 2) { /* means . where arguments were expected */
+ start_force(PL_curforce);
+ force_next(';');
+ TOKEN(FORMRBRACK);
+ }
TOKEN(';');
case '&':
s++;
if (PL_expect == XSTATE && isALPHA(tmp) &&
(s == PL_linestart+1 || s[-2] == '\n') )
{
- if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
+ if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
+ || PL_lex_state != LEX_NORMAL) {
d = PL_bufend;
while (s < d) {
if (*s++ == '\n') {
goto retry;
}
}
- if (PL_lex_brackets < PL_lex_formbrack) {
+ if (PL_expect == XBLOCK) {
const char *t = s;
#ifdef PERL_STRICT_CR
while (SPACE_OR_TAB(*t))
#endif
t++;
if (*t == '\n' || *t == '#') {
- s--;
- PL_expect = XBLOCK;
+ formbrack = 1;
+ ENTER;
+ SAVEI8(PL_parser->form_lex_state);
+ SAVEI32(PL_lex_formbrack);
+ PL_parser->form_lex_state = PL_lex_state;
+ PL_lex_formbrack = PL_lex_brackets + 1;
goto leftbracket;
}
}
&len);
while (isSPACE(*t))
t++;
- if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
+ if (*t == ';'
+ && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "You need to quote \"%s\"",
- tmpbuf);
+ "You need to quote \"%"SVf"\"",
+ SVfARG(newSVpvn_flags(tmpbuf, len,
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
}
}
}
if (ckWARN(WARN_SYNTAX)) {
const char *t = s + 1;
while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
- t++;
+ t += UTF ? UTF8SKIP(t) : 1;
if (*t == '}' || *t == ']') {
t++;
PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
+ /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Scalar value %.*s better written as $%.*s",
- (int)(t-PL_bufptr), PL_bufptr,
- (int)(t-PL_bufptr-1), PL_bufptr+1);
+ "Scalar value %"SVf" better written as $%"SVf,
+ SVfARG(newSVpvn_flags(PL_bufptr, (STRLEN)(t-PL_bufptr),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))),
+ SVfARG(newSVpvn_flags(PL_bufptr+1, (STRLEN)(t-PL_bufptr-1),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))));
}
}
}
#endif
&& (s == PL_linestart || s[-1] == '\n') )
{
- PL_lex_formbrack = 0;
PL_expect = XSTATE;
+ formbrack = 2; /* dot seen where arguments expected */
goto rightbracket;
}
if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
TERM(THING);
case '\'':
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
TERM(sublex_start());
case '"':
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
TERM(sublex_start());
case '`':
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!anydelim && PL_expect == XSTATE
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') {
s = d + 1;
- pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVpvn_flags(PL_tokenbuf,
+ len, UTF ? SVf_UTF8 : 0));
CLINE;
TOKEN(LABEL);
}
s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
TRUE, &morelen);
if (!morelen)
- Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
+ Perl_croak(aTHX_ "Bad name after %"SVf"%s",
+ SVfARG(newSVpvn_flags(PL_tokenbuf, len,
+ (UTF ? SVf_UTF8 : 0) | SVs_TEMP )),
*s == '\'' ? "'" : "::");
len += morelen;
pkgname = 1;
if (ckWARN(WARN_BAREWORD)
&& ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
- "Bareword \"%s\" refers to nonexistent package",
- PL_tokenbuf);
+ "Bareword \"%"SVf"\" refers to nonexistent package",
+ SVfARG(newSVpvn_flags(PL_tokenbuf, len,
+ (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
len -= 2;
PL_tokenbuf[len] = '\0';
gv = NULL;
/* Not a method, so call it a subroutine (if defined) */
if (cv) {
- if (lastchar == '-')
- Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of -%s resolved as -&%s()",
- PL_tokenbuf, PL_tokenbuf);
+ if (lastchar == '-') {
+ const SV *tmpsv = newSVpvn_flags( PL_tokenbuf, len ? len : strlen(PL_tokenbuf), (UTF ? SVf_UTF8 : 0) | SVs_TEMP );
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Ambiguous use of -%"SVf" resolved as -&%"SVf"()",
+ SVfARG(tmpsv), SVfARG(tmpsv));
+ }
/* Check for a constant sub */
if ((sv = cv_const_sv(cv))) {
its_constant:
op_free(rv2cv_op);
SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
- pl_yylval.opval->op_private = 0;
+ pl_yylval.opval->op_private = OPpCONST_FOLDED;
pl_yylval.opval->op_flags |= OPf_SPECIAL;
TOKEN(WORD);
}
safe_bareword:
if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Operator or semicolon missing before %c%s",
- lastchar, PL_tokenbuf);
+ "Operator or semicolon missing before %c%"SVf,
+ lastchar, SVfARG(newSVpvn_flags(PL_tokenbuf,
+ strlen(PL_tokenbuf),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c resolved as operator %c",
lastchar, lastchar);
case KEY_CORE:
if (*s == ':' && s[1] == ':') {
- s += 2;
+ STRLEN olen = len;
d = s;
+ s += 2;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (!(tmp = keyword(PL_tokenbuf, len, 1)))
- Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
+ if ((*s == ':' && s[1] == ':')
+ || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
+ {
+ s = d;
+ len = olen;
+ Copy(PL_bufptr, PL_tokenbuf, olen, char);
+ goto just_a_word;
+ }
+ if (!tmp)
+ Perl_croak(aTHX_ "CORE::%"SVf" is not a keyword",
+ SVfARG(newSVpvn_flags(PL_tokenbuf, len,
+ (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
if (tmp < 0)
tmp = -tmp;
else if (tmp == KEY_require || tmp == KEY_do
s = SKIPSPACE1(s);
if (*s == '{')
PRETERMBLOCK(DO);
- if (*s != '\'')
- s = force_word(s,WORD,TRUE,TRUE,FALSE);
+ if (*s != '\'') {
+ d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, 1, &len);
+ if (len) {
+ d = SKIPSPACE1(d);
+ if (*d == '(') s = force_word(s,WORD,TRUE,TRUE,FALSE);
+ }
+ }
if (orig_keyword == KEY_do) {
orig_keyword = 0;
pl_yylval.ival = 1;
case KEY_fork:
FUN0(OP_FORK);
+ case KEY_fc:
+ UNI(OP_FC);
+
case KEY_fcntl:
LOP(OP_FCNTL,XTERM);
char tmpbuf[1024];
PL_bufptr = s;
my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
- yyerror(tmpbuf);
+ yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
}
#ifdef PERL_MAD
if (PL_madskills) { /* just add type to declarator token */
case KEY_no:
s = tokenize_use(0, s);
- OPERATOR(USE);
+ TERM(USE);
case KEY_not:
if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
const char *t;
- for (d = s; isALNUM_lazy_if(d,UTF);)
- d++;
+ for (d = s; isALNUM_lazy_if(d,UTF);) {
+ d += UTF ? UTF8SKIP(d) : 1;
+ if (UTF) {
+ while (UTF8_IS_CONTINUED(*d) && is_utf8_mark((U8*)d)) {
+ d += UTF ? UTF8SKIP(d) : 1;
+ }
+ }
+ }
for (t=d; isSPACE(*t);)
t++;
if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
/* [perl #16184] */
&& !(t[0] == '=' && t[1] == '>')
+ && !(t[0] == ':' && t[1] == ':')
&& !keyword(s, d-s, 0)
) {
- int parms_len = (int)(d-s);
+ SV *tmpsv = newSVpvn_flags(s, (STRLEN)(d-s),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0));
Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
- "Precedence problem: open %.*s should be open(%.*s)",
- parms_len, s, parms_len, s);
+ "Precedence problem: open %"SVf" should be open(%"SVf")",
+ SVfARG(tmpsv), SVfARG(tmpsv));
}
}
LOP(OP_OPEN,XTERM);
LOP(OP_PIPE_OP,XTERM);
case KEY_q:
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
if (!s)
missingterm(NULL);
pl_yylval.ival = OP_CONST;
case KEY_qw: {
OP *words = NULL;
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
if (!s)
missingterm(NULL);
PL_expect = XOPERATOR;
}
case KEY_qq:
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
if (!s)
missingterm(NULL);
pl_yylval.ival = OP_STRINGIFY;
TERM(sublex_start());
case KEY_qx:
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
if (!s)
missingterm(NULL);
readpipe_override();
case KEY_sort:
checkcomma(s,PL_tokenbuf,"subroutine name");
s = SKIPSPACE1(s);
- if (*s == ';' || *s == ')') /* probably a close */
- Perl_croak(aTHX_ "sort is now a reserved word");
PL_expect = XTERM;
s = force_word(s,WORD,TRUE,TRUE,FALSE);
LOP(OP_SORT,XREF);
}
if (key == KEY_format) {
- if (*s == '=')
- PL_lex_formbrack = PL_lex_brackets + 1;
#ifdef PERL_MAD
PL_thistoken = subtoken;
s = d;
(void) force_word(PL_oldbufptr + tboffset, WORD,
FALSE, TRUE, TRUE);
#endif
- OPERATOR(FORMAT);
+ PREBLOCK(FORMAT);
}
/* Look for a prototype */
const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
STRLEN tmplen;
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
/* strip spaces and check for bad characters */
}
else {
if ( underscore ) {
- if ( *p != ';' )
+ if ( !strchr(";@%", *p) )
bad_proto = TRUE;
underscore = FALSE;
}
"Illegal character %sin prototype for %"SVf" : %s",
seen_underscore ? "after '_' " : "",
SVfARG(PL_subname),
- sv_uni_display(dsv,
- newSVpvn_flags(d, tmp, SVs_TEMP | SvUTF8(PL_lex_stuff)),
- tmp, UNI_DISPLAY_ISPRINT));
+ SvUTF8(PL_lex_stuff)
+ ? sv_uni_display(dsv,
+ newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
+ tmp,
+ UNI_DISPLAY_ISPRINT)
+ : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
+ PERL_PV_ESCAPE_NONASCII));
}
SvCUR_set(PL_lex_stuff, tmp);
have_proto = TRUE;
S_pending_ident(pTHX)
{
dVAR;
- register char *d;
PADOFFSET tmp = 0;
/* pit holds the identifier we read and pending_ident is reset */
char pit = PL_pending_ident;
if (PL_in_my) {
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
if (has_colon)
- yyerror(Perl_form(aTHX_ "No package name allowed for "
+ yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
"variable %s in \"our\"",
- PL_tokenbuf));
+ PL_tokenbuf), UTF ? SVf_UTF8 : 0);
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
else {
if (has_colon)
- yyerror(Perl_form(aTHX_ PL_no_myglob,
- PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
+ yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
+ PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
+ UTF ? SVf_UTF8 : 0);
pl_yylval.opval = newOP(OP_PADANY, 0);
pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
/*
build the ops for accesses to a my() variable.
-
- Deny my($a) or my($b) in a sort block, *if* $a or $b is
- then used in a comparison. This catches most, but not
- all cases. For instance, it catches
- sort { my($a); $a <=> $b }
- but not
- sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
- (although why you'd do that is anyone's guess).
*/
if (!has_colon) {
return WORD;
}
- /* if it's a sort block and they're naming $a or $b */
- if (PL_last_lop_op == OP_SORT &&
- PL_tokenbuf[0] == '$' &&
- (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
- && !PL_tokenbuf[2])
- {
- for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
- d < PL_bufend && *d != '\n';
- d++)
- {
- if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
- Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
- PL_tokenbuf);
- }
- }
- }
-
pl_yylval.opval = newOP(OP_PADANY, 0);
pl_yylval.opval->op_targ = tmp;
return PRIVATEREF;
{
/* Downgraded from fatal to warning 20000522 mjd */
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Possible unintended interpolation of %s in string",
- PL_tokenbuf);
+ "Possible unintended interpolation of %"SVf" in string",
+ SVfARG(newSVpvn_flags(PL_tokenbuf, tokenbuf_len,
+ SVs_TEMP | ( UTF ? SVf_UTF8 : 0 ))));
}
}
while (s < PL_bufend && isSPACE(*s))
s++;
if (isIDFIRST_lazy_if(s,UTF)) {
- const char * const w = s++;
+ const char * const w = s;
+ s += UTF ? UTF8SKIP(s) : 1;
while (isALNUM_lazy_if(s,UTF))
- s++;
+ s += UTF ? UTF8SKIP(s) : 1;
while (s < PL_bufend && isSPACE(*s))
s++;
if (*s == ',') {
SV *sv, SV *pv, const char *type, STRLEN typelen)
{
dVAR; dSP;
- HV * const table = GvHV(PL_hintgv); /* ^H */
+ HV * table = GvHV(PL_hintgv); /* ^H */
SV *res;
SV **cvp;
SV *cv, *typesv;
PERL_ARGS_ASSERT_NEW_CONSTANT;
- if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
+ /* charnames doesn't work well if there have been errors found */
+ if (PL_error_count > 0 && strEQ(key,"charnames"))
+ return &PL_sv_undef;
+
+ if (!table
+ || ! (PL_hints & HINT_LOCALIZE_HH)
+ || ! (cvp = hv_fetch(table, key, keylen, FALSE))
+ || ! SvOK(*cvp))
+ {
SV *msg;
- why2 = (const char *)
- (strEQ(key,"charnames")
- ? "(possibly a missing \"use charnames ...\")"
- : "");
- msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
- (type ? type: "undef"), why2);
-
- /* This is convoluted and evil ("goto considered harmful")
- * but I do not understand the intricacies of all the different
- * failure modes of %^H in here. The goal here is to make
- * the most probable error message user-friendly. --jhi */
-
- goto msgdone;
-
+ /* Here haven't found what we're looking for. If it is charnames,
+ * perhaps it needs to be loaded. Try doing that before giving up */
+ if (strEQ(key,"charnames")) {
+ Perl_load_module(aTHX_
+ 0,
+ newSVpvs("_charnames"),
+ /* version parameter; no need to specify it, as if
+ * we get too early a version, will fail anyway,
+ * not being able to find '_charnames' */
+ NULL,
+ newSVpvs(":full"),
+ newSVpvs(":short"),
+ NULL);
+ SPAGAIN;
+ table = GvHV(PL_hintgv);
+ if (table
+ && (PL_hints & HINT_LOCALIZE_HH)
+ && (cvp = hv_fetch(table, key, keylen, FALSE))
+ && SvOK(*cvp))
+ {
+ goto now_ok;
+ }
+ }
+ if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
+ msg = Perl_newSVpvf(aTHX_
+ "Constant(%s) unknown", (type ? type: "undef"));
+ }
+ else {
+ why1 = "$^H{";
+ why2 = key;
+ why3 = "} is not defined";
report:
msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
(type ? type: "undef"), why1, why2, why3);
- msgdone:
+ }
yyerror(SvPVX_const(msg));
SvREFCNT_dec(msg);
return sv;
}
-
- /* charnames doesn't work well if there have been errors found */
- if (PL_error_count > 0 && strEQ(key,"charnames"))
- return &PL_sv_undef;
-
- cvp = hv_fetch(table, key, keylen, FALSE);
- if (!cvp || !SvOK(*cvp)) {
- why1 = "$^H{";
- why2 = key;
- why3 = "} is not defined";
- goto report;
- }
+now_ok:
sv_2mortal(sv); /* Parent created it permanently */
cv = *cvp;
if (!pv && s)
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
dVAR;
- register char *d = dest;
- register char * const e = d + destlen - 3; /* two-character token, ending NUL */
+ char *d = dest;
+ char * const e = d + destlen - 3; /* two-character token, ending NUL */
PERL_ARGS_ASSERT_SCAN_WORD;
for (;;) {
if (d >= e)
Perl_croak(aTHX_ ident_too_long);
- if (isALNUM(*s)) /* UTF handled below */
+ if (isALNUM(*s) || (!UTF && isALNUMC_L1(*s))) /* UTF handled below */
*d++ = *s++;
else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
*d++ = ':';
dVAR;
char *bracket = NULL;
char funny = *s++;
- register char *d = dest;
- register char * const e = d + destlen - 3; /* two-character token, ending NUL */
+ char *d = dest;
+ char * const e = d + destlen - 3; /* two-character token, ending NUL */
PERL_ARGS_ASSERT_SCAN_IDENT;
bracket = s;
s++;
}
- else if (ck_uni)
- check_uni();
if (s < send) {
if (UTF) {
const STRLEN skip = UTF8SKIP(s);
*d = toCTRL(*s);
s++;
}
+ else if (ck_uni && !bracket)
+ check_uni();
if (bracket) {
if (isSPACE(s[-1])) {
while (s < send) {
if (PL_lex_state == LEX_NORMAL) {
if (ckWARN(WARN_AMBIGUOUS) &&
(keyword(dest, d - dest, 0)
- || get_cvn_flags(dest, d - dest, 0)))
+ || get_cvn_flags(dest, d - dest, UTF ? SVf_UTF8 : 0)))
{
+ SV *tmp = newSVpvn_flags( dest, d - dest,
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0) );
if (funny == '#')
funny = '@';
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of %c{%s} resolved to %c%s",
- funny, dest, funny, dest);
+ "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
+ funny, tmp, funny, tmp);
}
}
}
/* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
* the parse starting at 's', based on the subset that are valid in this
* context input to this routine in 'valid_flags'. Advances s. Returns
- * TRUE if the input was a valid flag, so the next char may be as well;
- * otherwise FALSE. 'charset' should point to a NUL upon first call on the
- * current regex. This routine will set it to any charset modifier found.
- * The caller shouldn't change it. This way, another charset modifier
- * encountered in the parse can be detected as an error, as we have decided
- * allow only one */
+ * TRUE if the input should be treated as a valid flag, so the next char
+ * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
+ * first call on the current regex. This routine will set it to any
+ * charset modifier found. The caller shouldn't change it. This way,
+ * another charset modifier encountered in the parse can be detected as an
+ * error, as we have decided to allow only one */
const char c = **s;
-
- if (! strchr(valid_flags, c)) {
- if (isALNUM(c)) {
- goto deprecate;
+ STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
+
+ if ( charlen != 1 || ! strchr(valid_flags, c) ) {
+ if (isALNUM_lazy_if(*s, UTF)) {
+ yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
+ UTF ? SVf_UTF8 : 0);
+ (*s) += charlen;
+ /* Pretend that it worked, so will continue processing before
+ * dieing */
+ return TRUE;
}
return FALSE;
}
case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
case LOCALE_PAT_MOD:
-
- /* In 5.14, qr//lt is legal but deprecated; the 't' means they
- * can't be regex modifiers.
- * In 5.14, s///le is legal and ambiguous. Try to disambiguate as
- * much as easily done. s///lei, for example, has to mean regex
- * modifiers if it's not an error (as does any word character
- * following the 'e'). Otherwise, we resolve to the backwards-
- * compatible, but less likely 's/// le ...', i.e. as meaning
- * less-than-or-equal. The reason it's not likely is that s//
- * returns a number for code in the field (/r returns a string, but
- * that wasn't added until the 5.13 series), and so '<=' should be
- * used for comparing, not 'le'. */
- if (*((*s) + 1) == 't') {
- goto deprecate;
- }
- else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) {
-
- /* 'e' is valid only for substitutes, s///e. If it is not
- * valid in the current context, then 'm//le' must mean the
- * comparison operator, so use the regular deprecation message.
- */
- if (! strchr(valid_flags, 'e')) {
- goto deprecate;
- }
- Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of 's//le...' resolved as 's// le...'; Rewrite as 's//el' if you meant 'use locale rules and evaluate rhs as an expression'. In Perl 5.16, it will be resolved the other way");
- return FALSE;
- }
if (*charset) {
goto multiple_charsets;
}
*charset = c;
break;
case UNICODE_PAT_MOD:
- /* In 5.14, qr//unless and qr//until are legal but deprecated; the
- * 'n' means they can't be regex modifiers */
- if (*((*s) + 1) == 'n') {
- goto deprecate;
- }
if (*charset) {
goto multiple_charsets;
}
*charset = c;
break;
case ASCII_RESTRICT_PAT_MOD:
- /* In 5.14, qr//and is legal but deprecated; the 'n' means they
- * can't be regex modifiers */
- if (*((*s) + 1) == 'n') {
- goto deprecate;
- }
-
if (! *charset) {
set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
}
(*s)++;
return TRUE;
- deprecate:
- Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
- "Having no space between pattern and following word is deprecated");
- return FALSE;
-
multiple_charsets:
if (*charset != c) {
yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
{
dVAR;
PMOP *pm;
- char *s = scan_str(start,!!PL_madskills,FALSE);
+ char *s = scan_str(start,!!PL_madskills,FALSE, PL_reg_state.re_reparsing);
const char * const valid_flags =
(const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
char charset = '\0'; /* character set modifier */
PERL_ARGS_ASSERT_SCAN_PAT;
+ /* this was only needed for the initial scan_str; set it to false
+ * so that any (?{}) code blocks etc are parsed normally */
+ PL_reg_state.re_reparsing = FALSE;
if (!s) {
const char * const delimiter = skipspace(start);
Perl_croak(aTHX_
#ifdef PERL_MAD
modstart = s;
#endif
+
+ /* if qr/...(?{..}).../, then need to parse the pattern within a new
+ * anon CV. False positives like qr/[(?{]/ are harmless */
+
+ if (type == OP_QR) {
+ STRLEN len;
+ char *e, *p = SvPV(PL_lex_stuff, len);
+ e = p + len;
+ for (; p < e; p++) {
+ if (p[0] == '(' && p[1] == '?'
+ && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
+ {
+ pm->op_pmflags |= PMf_HAS_CV;
+ break;
+ }
+ }
+ pm->op_pmflags |= PMf_IS_QR;
+ }
+
while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
#ifdef PERL_MAD
if (PL_madskills && modstart != s) {
{
dVAR;
char *s;
- register PMOP *pm;
+ PMOP *pm;
I32 first_start;
I32 es = 0;
char charset = '\0'; /* character set modifier */
pl_yylval.ival = OP_NULL;
- s = scan_str(start,!!PL_madskills,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE);
if (!s)
Perl_croak(aTHX_ "Substitution pattern not terminated");
#endif
first_start = PL_multi_start;
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
if (es) {
SV * const repl = newSVpvs("");
- PL_sublex_info.super_bufptr = s;
- PL_sublex_info.super_bufend = PL_bufend;
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
while (es-- > 0) {
S_scan_trans(pTHX_ char *start)
{
dVAR;
- register char* s;
+ char* s;
OP *o;
- short *tbl;
U8 squash;
U8 del;
U8 complement;
pl_yylval.ival = OP_NULL;
- s = scan_str(start,!!PL_madskills,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE);
if (!s)
Perl_croak(aTHX_ "Transliteration pattern not terminated");
}
#endif
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
}
no_more:
- tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
- o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
+ o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
o->op_private &= ~OPpTRANS_ALL;
o->op_private |= del|squash|complement|
(DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
return s;
}
+/* scan_heredoc
+ Takes a pointer to the first < in <<FOO.
+ Returns a pointer to the byte following <<FOO.
+
+ This function scans a heredoc, which involves different methods
+ depending on whether we are in a string eval, quoted construct, etc.
+ This is because PL_linestr could containing a single line of input, or
+ a whole string being evalled, or the contents of the current quote-
+ like operator.
+
+ The three methods are:
+ - Steal lines from the input stream (stream)
+ - Scan the heredoc in PL_linestr and remove it therefrom (linestr)
+ - Peek at the PL_linestr of the outer lexing scope (peek)
+
+ They are used in these cases:
+ file scope or filtered eval stream
+ string eval linestr
+ multiline quoted construct linestr
+ single-line quoted construct in file stream
+ single-line quoted construct in eval peek
+
+ Single-line also applies to heredocs that begin on the last line of a
+ quote-like operator.
+*/
+
STATIC char *
S_scan_heredoc(pTHX_ register char *s)
{
I32 len;
SV *tmpstr;
char term;
- const char *found_newline;
- register char *d;
- register char *e;
+ const char *found_newline = 0;
+ char *d;
+ char *e;
char *peek;
- const int outer = (PL_rsfp || PL_parser->filtered)
- && !(PL_lex_inwhat == OP_SCALAR);
+ const bool infile = PL_rsfp || PL_parser->filtered;
#ifdef PERL_MAD
I32 stuffstart = s - SvPVX(PL_linestr);
char *tstart;
PERL_ARGS_ASSERT_SCAN_HEREDOC;
s += 2;
- d = PL_tokenbuf;
+ d = PL_tokenbuf + 1;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
- if (!outer)
- *d++ = '\n';
+ *PL_tokenbuf = '\n';
peek = s;
while (SPACE_OR_TAB(*peek))
peek++;
s = peek;
term = *s++;
s = delimcpy(d, e, s, PL_bufend, term, &len);
+ if (s == PL_bufend)
+ Perl_croak(aTHX_ "Unterminated delimiter for here document");
d += len;
- if (s < PL_bufend)
- s++;
+ s++;
}
else {
if (*s == '\\')
#ifdef PERL_MAD
if (PL_madskills) {
- tstart = PL_tokenbuf + !outer;
- PL_thisclose = newSVpvn(tstart, len - !outer);
+ tstart = PL_tokenbuf + 1;
+ PL_thisclose = newSVpvn(tstart, len - 1);
tstart = SvPVX(PL_linestr) + stuffstart;
PL_thisopen = newSVpvn(tstart, s - tstart);
stuffstart = s - SvPVX(PL_linestr);
s = olds;
}
#endif
-#ifdef PERL_MAD
- found_newline = 0;
-#endif
- if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
+ if ((infile && !PL_lex_inwhat)
+ || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s))) {
herewas = newSVpvn(s,PL_bufend-s);
}
else {
CLINE;
PL_multi_start = CopLINE(PL_curcop);
PL_multi_open = PL_multi_close = '<';
- term = *PL_tokenbuf;
- if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp
- && !PL_parser->filtered) {
+ if (!infile && PL_lex_inwhat && !found_newline) {
char * const bufptr = PL_sublex_info.super_bufptr;
char * const bufend = PL_sublex_info.super_bufend;
char * const olds = s - SvCUR(herewas);
+ term = *PL_tokenbuf;
s = strchr(bufptr, '\n');
if (!s)
s = bufend;
}
if (s >= bufend) {
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
+ missingterm(PL_tokenbuf + 1);
}
sv_setpvn(herewas,bufptr,d-bufptr+1);
sv_setpvn(tmpstr,d+1,s-d);
s = olds;
goto retval;
}
- else if (!outer) {
+ else if (!infile || found_newline) {
+ term = *PL_tokenbuf;
d = s;
while (s < PL_bufend &&
(*s != term || memNE(s,PL_tokenbuf,len)) ) {
}
if (s >= PL_bufend) {
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
+ missingterm(PL_tokenbuf + 1);
}
sv_setpvn(tmpstr,d+1,s-d);
#ifdef PERL_MAD
}
else
sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
+ term = PL_tokenbuf[1];
+ len--;
while (s >= PL_bufend) { /* multiple line string? */
#ifdef PERL_MAD
if (PL_madskills) {
#endif
PL_bufptr = s;
CopLINE_inc(PL_curcop);
- if (!outer || !lex_next_chunk(0)) {
+ if (!lex_next_chunk(LEX_NO_TERM)
+ && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
+ missingterm(PL_tokenbuf + 1);
}
CopLINE_dec(PL_curcop);
+ if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
+ lex_grow_linestr(SvCUR(PL_linestr) + 2);
+ sv_catpvs(PL_linestr, "\n\0");
+ }
s = PL_bufptr;
#ifdef PERL_MAD
stuffstart = s - SvPVX(PL_linestr);
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
PL_bufend[-1] = '\n';
#endif
- if (*s == term && memEQ(s,PL_tokenbuf,len)) {
+ if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
*(SvPVX(PL_linestr) + off ) = ' ';
lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
S_scan_inputsymbol(pTHX_ char *start)
{
dVAR;
- register char *s = start; /* current position in buffer */
+ char *s = start; /* current position in buffer */
char *end;
I32 len;
char *d = PL_tokenbuf; /* start of temp holding space */
if (d - PL_tokenbuf != len) {
pl_yylval.ival = OP_GLOB;
- s = scan_str(start,!!PL_madskills,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE);
if (!s)
Perl_croak(aTHX_ "Glob not terminated");
return s;
takes: start position in buffer
keep_quoted preserve \ on the embedded delimiter(s)
keep_delims preserve the delimiters around the string
+ re_reparse compiling a run-time /(?{})/:
+ collapse // to /, and skip encoding src
returns: position to continue reading from buffer
side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
updates the read buffer.
*/
STATIC char *
-S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
+S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse)
{
dVAR;
SV *sv; /* scalar value: string */
const char *tmps; /* temp string, used for delimiter matching */
- register char *s = start; /* current position in the buffer */
- register char term; /* terminating character */
- register char *to; /* current position in the sv's data */
+ char *s = start; /* current position in the buffer */
+ char term; /* terminating character */
+ char *to; /* current position in the sv's data */
I32 brackets = 1; /* bracket nesting level */
bool has_utf8 = FALSE; /* is there any utf8 content? */
I32 termcode; /* terminating char. code */
termlen = 1;
}
else {
- termcode = utf8_to_uvchr((U8*)s, &termlen);
+ termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
Copy(s, termstr, termlen, U8);
if (!UTF8_IS_INVARIANT(term))
has_utf8 = TRUE;
}
#endif
for (;;) {
- if (PL_encoding && !UTF) {
+ if (PL_encoding && !UTF && !re_reparse) {
bool cont = TRUE;
while (cont) {
CopLINE_inc(PL_curcop);
/* handle quoted delimiters */
if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
- if (!keep_quoted && s[1] == term)
+ if (!keep_quoted
+ && (s[1] == term
+ || (re_reparse && s[1] == '\\'))
+ )
s++;
- /* any other quotes are simply copied straight through */
+ /* any other quotes are simply copied straight through */
else
*to++ = *s++;
}
/* at this point, we have successfully read the delimited string */
- if (!PL_encoding || UTF) {
+ if (!PL_encoding || UTF || re_reparse) {
#ifdef PERL_MAD
if (PL_madskills) {
char * const tstart = SvPVX(PL_linestr) + stuffstart;
}
}
#endif
- if (has_utf8 || PL_encoding)
+ if (has_utf8 || (PL_encoding && !re_reparse))
SvUTF8_on(sv);
PL_multi_end = CopLINE(PL_curcop);
Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
{
dVAR;
- register const char *s = start; /* current position in buffer */
- register char *d; /* destination in temp buffer */
- register char *e; /* end of temp buffer */
+ const char *s = start; /* current position in buffer */
+ char *d; /* destination in temp buffer */
+ char *e; /* end of temp buffer */
NV nv; /* number read, as a double */
SV *sv = NULL; /* place to put the converted number */
bool floatit; /* boolean: int or float? */
switch (*s) {
default:
- Perl_croak(aTHX_ "panic: scan_num");
+ Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
/* if it starts with a 0, it could be an octal number, a decimal in
0.13 disguise, or a hexadecimal number, or a binary number. */
S_scan_formline(pTHX_ register char *s)
{
dVAR;
- register char *eol;
- register char *t;
+ char *eol;
+ char *t;
SV * const stuff = newSVpvs("");
bool needargs = FALSE;
bool eofmt = FALSE;
break;
}
}
- if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
- eol = (char *) memchr(s,'\n',PL_bufend-s);
- if (!eol++)
+ eol = (char *) memchr(s,'\n',PL_bufend-s);
+ if (!eol++)
eol = PL_bufend;
- }
- else
- eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
if (*s != '#') {
for (t = s; t < eol; t++) {
if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
break;
}
s = (char*)eol;
- if (PL_rsfp || PL_parser->filtered) {
+ if ((PL_rsfp || PL_parser->filtered)
+ && PL_parser->form_lex_state == LEX_NORMAL) {
bool got_some;
#ifdef PERL_MAD
if (PL_madskills) {
incline(s);
}
enough:
+ if (!SvCUR(stuff) || needargs)
+ PL_lex_state = PL_parser->form_lex_state;
if (SvCUR(stuff)) {
- PL_expect = XTERM;
+ PL_expect = XSTATE;
if (needargs) {
- PL_lex_state = LEX_NORMAL;
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
- force_next(',');
+ force_next(FORMLBRACK);
}
- else
- PL_lex_state = LEX_FORMLINE;
if (!IN_BYTES) {
if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
SvUTF8_on(stuff);
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
force_next(THING);
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
- force_next(LSTOP);
}
else {
SvREFCNT_dec(stuff);
if (eofmt)
PL_lex_formbrack = 0;
- PL_bufptr = s;
}
#ifdef PERL_MAD
if (PL_madskills) {
const I32 oldsavestack_ix = PL_savestack_ix;
CV* const outsidecv = PL_compcv;
- if (PL_compcv) {
- assert(SvTYPE(PL_compcv) == SVt_PVCV);
- }
SAVEI32(PL_subline);
save_item(PL_subname);
SAVESPTR(PL_compcv);
#pragma segment Perl_yylex
#endif
static int
-S_yywarn(pTHX_ const char *const s)
+S_yywarn(pTHX_ const char *const s, U32 flags)
{
dVAR;
PERL_ARGS_ASSERT_YYWARN;
PL_in_eval |= EVAL_WARNONLY;
- yyerror(s);
+ yyerror_pv(s, flags);
PL_in_eval &= ~EVAL_WARNONLY;
return 0;
}
int
Perl_yyerror(pTHX_ const char *const s)
{
+ PERL_ARGS_ASSERT_YYERROR;
+ return yyerror_pvn(s, strlen(s), 0);
+}
+
+int
+Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
+{
+ PERL_ARGS_ASSERT_YYERROR_PV;
+ return yyerror_pvn(s, strlen(s), flags);
+}
+
+int
+Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
+{
dVAR;
- const char *where = NULL;
const char *context = NULL;
int contlen = -1;
SV *msg;
+ SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
int yychar = PL_parser->yychar;
+ U32 is_utf8 = flags & SVf_UTF8;
- PERL_ARGS_ASSERT_YYERROR;
+ PERL_ARGS_ASSERT_YYERROR_PVN;
if (!yychar || (yychar == ';' && !PL_rsfp))
- where = "at EOF";
+ sv_catpvs(where_sv, "at EOF");
else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
PL_oldbufptr != PL_bufptr) {
contlen = PL_bufptr - PL_oldbufptr;
}
else if (yychar > 255)
- where = "next token ???";
+ sv_catpvs(where_sv, "next token ???");
else if (yychar == -2) { /* YYEMPTY */
if (PL_lex_state == LEX_NORMAL ||
(PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
- where = "at end of line";
+ sv_catpvs(where_sv, "at end of line");
else if (PL_lex_inpat)
- where = "within pattern";
+ sv_catpvs(where_sv, "within pattern");
else
- where = "within string";
+ sv_catpvs(where_sv, "within string");
}
else {
- SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
+ sv_catpvs(where_sv, "next char ");
if (yychar < 32)
Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
else if (isPRINT_LC(yychar)) {
}
else
Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
- where = SvPVX_const(where_sv);
}
- msg = sv_2mortal(newSVpv(s, 0));
+ msg = sv_2mortal(newSVpvn_flags(s, len, is_utf8));
Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
if (context)
- Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
+ Perl_sv_catpvf(aTHX_ msg, "near \"%"SVf"\"\n",
+ SVfARG(newSVpvn_flags(context, contlen,
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
else
- Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
+ Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
Perl_sv_catpvf(aTHX_ msg,
" (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
if (s[1] == 0xFE) {
/* UTF-16 little-endian? (or UTF-32LE?) */
if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
#ifndef PERL_NO_UTF16_FILTER
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
s = add_utf16_textfilter(s, TRUE);
}
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
#endif
}
s = add_utf16_textfilter(s, FALSE);
}
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
#endif
}
if (s[1] == 0) {
if (s[2] == 0xFE && s[3] == 0xFF) {
/* UTF-32 big-endian */
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
}
}
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
s = add_utf16_textfilter(s, FALSE);
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
#endif
}
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
s = add_utf16_textfilter(s, TRUE);
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
#endif
}
rev += (*end - '0') * mult;
mult *= 10;
if (orev > rev)
+ /* diag_listed_as: Integer overflow in %s number */
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in decimal number");
}
if (PL_lex_state == LEX_KNOWNEXT) {
PL_parser->yychar = yylex();
if (PL_parser->yychar == LABEL) {
- char *lpv = pl_yylval.pval;
- STRLEN llen = strlen(lpv);
SV *lsv;
PL_parser->yychar = YYEMPTY;
lsv = newSV_type(SVt_PV);
- SvPV_set(lsv, lpv);
- SvCUR_set(lsv, llen);
- SvLEN_set(lsv, llen+1);
- SvPOK_on(lsv);
+ sv_copypv(lsv, cSVOPx(pl_yylval.opval)->op_sv);
return lsv;
} else {
yyunlex();
}
} else {
char *s, *t;
- U8 c;
STRLEN wlen, bufptr_pos;
lex_read_space(0);
t = s = PL_bufptr;
- c = (U8)*s;
- if (!isIDFIRST_A(c))
+ if (!isIDFIRST_lazy_if(s, UTF))
goto no_label;
- do {
- c = (U8)*++t;
- } while(isWORDCHAR_A(c));
- wlen = t - s;
+ t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
if (word_takes_any_delimeter(s, wlen))
goto no_label;
bufptr_pos = s - SvPVX(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr;
PL_oldbufptr = s;
PL_bufptr = t+1;
- return newSVpvn(s, wlen);
+ return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
} else {
PL_bufptr = s;
no_label:
return stmtseqop;
}
-void
-Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
-{
- PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
- deprecate("qw(...) as parentheses");
- force_next((4<<24)|')');
- if (qwlist->op_type == OP_STUB) {
- op_free(qwlist);
- }
- else {
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.opval = qwlist;
- force_next(THING);
- }
- force_next((2<<24)|'(');
-}
-
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff