/* 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 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 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) UNI3(f,0,0)
+
/* grandfather return to old style */
#define OLDLOP(f) \
do { \
{ 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" },
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.
*/
Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
{
dVAR;
- HV * const hinthv = GvHV(PL_hintgv);
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;
memcpy(&he_name[8], name, namelen);
- return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
+ return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
+ REFCOUNTED_HE_EXISTS));
}
/*
code in I<line> comes first and must consist of complete lines of input,
and I<rsfp> supplies the remainder of the source.
-The I<flags> parameter is reserved for future use, and must always
-be zero, except for one flag that is currently reserved for perl's internal
-use.
+The I<flags> parameter is reserved for future use. Currently it is only
+used by perl internally, so extensions should always pass zero.
=cut
*/
/* 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)
{
dVAR;
const char *s = NULL;
- STRLEN len;
yy_parser *parser, *oparser;
- if (flags && flags & ~(LEX_START_SAME_FILTER|LEX_IGNORE_UTF8_HINTS))
+ if (flags && flags & ~LEX_START_FLAGS)
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
/* create and initialise a parser */
parser->rsfp = rsfp;
parser->rsfp_filters =
!(flags & LEX_START_SAME_FILTER) || !oparser
- ? newAV()
- : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
+ ? NULL
+ : MUTABLE_AV(SvREFCNT_inc(
+ oparser->rsfp_filters
+ ? oparser->rsfp_filters
+ : (oparser->rsfp_filters = newAV())
+ ));
Newx(parser->lex_brackstack, 120, char);
Newx(parser->lex_casestack, 12, char);
*parser->lex_casestack = '\0';
if (line) {
+ STRLEN len;
s = SvPV_const(line, len);
+ parser->linestr = flags & LEX_START_COPIED
+ ? SvREFCNT_inc_simple_NN(line)
+ : newSVpvn_flags(s, len, SvUTF8(line));
+ if (!len || s[len-1] != ';')
+ sv_catpvs(parser->linestr, "\n;");
} else {
- len = 0;
- }
-
- if (!len) {
parser->linestr = newSVpvs("\n;");
- } else {
- parser->linestr = newSVpvn_flags(s, len, SvUTF8(line));
- if (s[len-1] != ';')
- sv_catpvs(parser->linestr, "\n;");
}
parser->oldoldbufptr =
parser->oldbufptr =
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;
+ parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+ |LEX_DONT_CLOSE_RSFP);
- parser->in_pod = 0;
+ 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;
}
}
if (flags & LEX_FAKE_EOF) {
goto eof;
- } else if (!PL_parser->rsfp) {
+ } else if (!PL_parser->rsfp && !PL_parser->filtered) {
got_some = 0;
} else if (filter_gets(linestr, old_bufend_pos)) {
got_some = 1;
/* 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);
PL_parser->rsfp = NULL;
- PL_parser->in_pod = 0;
+ PL_parser->in_pod = PL_parser->filtered = 0;
#ifdef PERL_MAD
if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
PL_faketokens = 1;
tmplen = 0;
}
- if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
+ if (!PL_rsfp && !PL_parser->filtered) {
/* must copy *{"::_<(eval N)[oldfilename:L]"}
* to *{"::_<newfilename"} */
/* However, the long form of evals is only turned on by the
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;
* 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] ) )
*/
/*
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);
/*
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) {
register 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
SvPV_nolen(datasv)));
av_unshift(PL_rsfp_filters, 1);
av_store(PL_rsfp_filters, 0, datasv) ;
+ if (
+ !PL_parser->filtered
+ && PL_parser->lex_flags & LEX_EVALBYTES
+ && PL_bufptr < PL_bufend
+ ) {
+ const char *s = PL_bufptr;
+ while (s < PL_bufend) {
+ if (*s == '\n') {
+ SV *linestr = PL_parser->linestr;
+ char *buf = SvPVX(linestr);
+ STRLEN const bufptr_pos = PL_parser->bufptr - buf;
+ STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
+ STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
+ STRLEN const linestart_pos = PL_parser->linestart - buf;
+ STRLEN const last_uni_pos =
+ PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
+ STRLEN const last_lop_pos =
+ PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
+ av_push(PL_rsfp_filters, linestr);
+ PL_parser->linestr =
+ newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
+ buf = SvPVX(PL_parser->linestr);
+ PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
+ PL_parser->bufptr = buf + bufptr_pos;
+ PL_parser->oldbufptr = buf + oldbufptr_pos;
+ PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
+ PL_parser->linestart = buf + linestart_pos;
+ if (PL_parser->last_uni)
+ PL_parser->last_uni = buf + last_uni_pos;
+ if (PL_parser->last_lop)
+ PL_parser->last_lop = buf + last_lop_pos;
+ SvLEN(linestr) = SvCUR(linestr);
+ SvCUR(linestr) = s-SvPVX(linestr);
+ PL_parser->filtered = 1;
+ break;
+ }
+ s++;
+ }
+ }
return(datasv);
}
/* This API is bad. It should have been using unsigned int for maxlen.
Not sure if we want to change the API, but if not we should sanity
check the value here. */
- const unsigned int correct_length
+ unsigned int correct_length
= maxlen < 0 ?
#ifdef PERL_MICRO
0x7FFFFFFF
idx));
return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
}
+ if (SvTYPE(datasv) != SVt_PVIO) {
+ if (correct_length) {
+ /* Want a block */
+ const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
+ if (!remainder) return 0; /* eof */
+ if (correct_length > remainder) correct_length = remainder;
+ sv_catpvn(buf_sv, SvEND(datasv), correct_length);
+ SvCUR_set(datasv, SvCUR(datasv) + correct_length);
+ } else {
+ /* Want a line */
+ const char *s = SvEND(datasv);
+ const char *send = SvPVX(datasv) + SvLEN(datasv);
+ while (s < send) {
+ if (*s == '\n') {
+ s++;
+ break;
+ }
+ s++;
+ }
+ if (s == send) return 0; /* eof */
+ sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
+ SvCUR_set(datasv, s-SvPVX(datasv));
+ }
+ return SvCUR(buf_sv);
+ }
/* Get function pointer hidden within datasv */
funcp = DPTR2FPTR(filter_t, IoANY(datasv));
DEBUG_P(PerlIO_printf(Perl_debug_log,
}
/* put off final whitespace till peg */
- if (optype == ';' && !PL_rsfp) {
+ if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
PL_nextwhite = PL_thiswhite;
PL_thiswhite = 0;
}
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);
register char *s = PL_bufptr;
register char *d;
STRLEN len;
- bool bof = FALSE;
+ bool bof = FALSE, formbrack = FALSE;
U32 fake_eof = 0;
/* orig_keyword, gvp, and gv are initialized here because
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;
+ PL_lex_state = PL_parser->form_lex_state;
s = scan_formline(PL_bufptr);
if (!PL_lex_formbrack)
+ {
+ formbrack = TRUE;
goto rightbracket;
+ }
OPERATOR(';');
}
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_madskills)
PL_faketokens = 0;
#endif
- if (!PL_rsfp) {
+ if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
PL_last_uni = 0;
PL_last_lop = 0;
if (PL_lex_brackets &&
PL_parser->in_pod = 0;
}
}
- if (PL_rsfp)
+ if (PL_rsfp || PL_parser->filtered)
incline(s);
} while (PL_parser->in_pod);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
if (PL_madskills)
PL_faketokens = 0;
#endif
- if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
- if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
+ if (PL_lex_state != LEX_NORMAL ||
+ (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
+ if (*s == '#' && s == PL_linestart && PL_in_eval
+ && !PL_rsfp && !PL_parser->filtered) {
/* handle eval qq[#line 1 "foo"\n ...] */
CopLINE_dec(PL_curcop);
incline(s);
}
if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
s = SKIPSPACE0(s);
- if (!PL_in_eval || PL_rsfp)
+ if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
incline(s);
}
else {
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);
}
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);
}
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("");
if (PL_expect == XSTATE && isALPHA(tmp) &&
(s == PL_linestart+1 || s[-2] == '\n') )
{
- if (PL_in_eval && !PL_rsfp) {
+ if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
d = PL_bufend;
while (s < d) {
if (*s++ == '\n') {
#endif
t++;
if (*t == '\n' || *t == '#') {
- s--;
PL_expect = XBLOCK;
+ formbrack = TRUE;
+ ENTER;
+ SAVEI8(PL_parser->form_lex_state);
+ PL_parser->form_lex_state = PL_lex_state;
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 ))));
}
}
}
{
PL_lex_formbrack = 0;
PL_expect = XSTATE;
+ formbrack = TRUE;
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);
}
{
STRLEN protolen = CvPROTOLEN(cv);
const char *proto = CvPROTO(cv);
+ bool optional;
if (!protolen)
TERM(FUNC0SUB);
- while (*proto == ';')
+ if ((optional = *proto == ';'))
+ do
proto++;
+ while (*proto == ';');
if (
(
(
*proto == '\\' && proto[1] && proto[2] == '\0'
)
)
- OPERATOR(UNIOPSUB);
+ UNIPROTO(UNIOPSUB,optional);
if (*proto == '\\' && proto[1] == '[') {
const char *p = proto + 2;
while(*p && *p != ']')
++p;
- if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
+ if(*p == ']' && !p[1])
+ UNIPROTO(UNIOPSUB,optional);
}
if (*proto == '&' && *s == '{') {
if (PL_curstash)
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);
goto fake_eof;
}
+ case KEY___SUB__:
+ FUN0OP(newPVOP(OP_RUNCV,0,NULL));
+
case KEY_AUTOLOAD:
case KEY_DESTROY:
case KEY_BEGIN:
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;
UNIBRACK(OP_ENTEREVAL);
}
+ case KEY_evalbytes:
+ PL_expect = XTERM;
+ UNIBRACK(-OP_ENTEREVAL);
+
case KEY_eof:
UNI(OP_EOF);
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;
+ PL_lex_formbrack = PL_lex_brackets + 1;
#ifdef PERL_MAD
PL_thistoken = subtoken;
s = d;
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)
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++ = ':';
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) {
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);
dVAR;
register 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)|
register char *d;
register char *e;
char *peek;
- const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
+ const int outer = (PL_rsfp || PL_parser->filtered)
+ && !(PL_lex_inwhat == OP_SCALAR);
#ifdef PERL_MAD
I32 stuffstart = s - SvPVX(PL_linestr);
char *tstart;
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 == '\\')
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) {
+ if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp
+ && !PL_parser->filtered) {
char * const bufptr = PL_sublex_info.super_bufptr;
char * const bufend = PL_sublex_info.super_bufend;
char * const olds = s - SvCUR(herewas);
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 */
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) {
char * const svlast = SvEND(sv) - 1;
for (; s < ns; s++) {
- if (*s == '\n' && !PL_rsfp)
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
CopLINE_inc(PL_curcop);
}
if (!found)
if (PL_multi_open == PL_multi_close) {
for (; s < PL_bufend; s++,to++) {
/* embedded newlines increment the current line number */
- if (*s == '\n' && !PL_rsfp)
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
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++;
}
/* read until we run out of string, or we find the terminator */
for (; s < PL_bufend; s++,to++) {
/* embedded newlines increment the line count */
- if (*s == '\n' && !PL_rsfp)
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
CopLINE_inc(PL_curcop);
/* backslashes can escape the open or closing characters */
if (*s == '\\' && s+1 < PL_bufend) {
/* 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);
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. */
break;
}
}
- if (PL_in_eval && !PL_rsfp) {
- 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) {
+ if ((PL_rsfp || PL_parser->filtered)
+ && PL_parser->form_lex_state == LEX_NORMAL) {
bool got_some;
#ifdef PERL_MAD
if (PL_madskills) {
if (SvCUR(stuff)) {
PL_expect = XTERM;
if (needargs) {
- PL_lex_state = LEX_NORMAL;
+ PL_lex_state = PL_parser->form_lex_state;
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next(',');
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