};
#endif
-#ifdef ff_next
-#undef ff_next
-#endif
-
#include "keywords.h"
/* CLINE is a macro that ensures PL_copline has a sane value */
-#ifdef CLINE
-#undef CLINE
-#endif
#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
#ifdef PERL_MAD
* PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
* PREREF : *EXPR where EXPR is not a simple identifier
* TERM : expression term
+ * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
* LOOPX : loop exiting command (goto, last, dump, etc)
* FTST : file test operator
* FUN0 : zero-argument function
#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
#define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
+#define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
#define COPLINE_INC_WITH_HERELINES \
STMT_START { \
CopLINE_inc(PL_curcop); \
- if (PL_parser->lex_shared->herelines) \
- CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \
- PL_parser->lex_shared->herelines = 0; \
+ if (PL_parser->herelines) \
+ CopLINE(PL_curcop) += PL_parser->herelines, \
+ PL_parser->herelines = 0; \
+ } STMT_END
+/* Called after scan_str to update CopLINE(PL_curcop), but only when there
+ * is no sublex_push to follow. */
+#define COPLINE_SET_FROM_MULTI_END \
+ STMT_START { \
+ CopLINE_set(PL_curcop, PL_multi_end); \
+ if (PL_multi_end != PL_multi_start) \
+ PL_parser->herelines = 0; \
} STMT_END
{ PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
{ PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
+ { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
{ POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
{ POSTINC, TOKENTYPE_NONE, "POSTINC" },
{ POWOP, TOKENTYPE_OPNUM, "POWOP" },
PERL_ARGS_ASSERT_PRINTBUF;
+ GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
+ GCC_DIAG_RESTORE;
SvREFCNT_dec(tmp);
}
if (nl)
*nl = '\0';
}
- else if (isCNTRL(PL_multi_close)) {
+ else if ((U8) PL_multi_close < 32) {
*tmpbuf = '^';
tmpbuf[1] = (char)toCTRL(PL_multi_close);
tmpbuf[2] = '\0';
parser->nexttoke = 0;
#endif
parser->error_count = oparser ? oparser->error_count : 0;
- parser->copline = NOLINE;
+ parser->copline = parser->preambling = NOLINE;
parser->lex_state = LEX_NORMAL;
parser->expect = XSTATE;
parser->rsfp = rsfp;
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
- |LEX_DONT_CLOSE_RSFP);
+
+ assert(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+ |LEX_DONT_CLOSE_RSFP));
+ parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+ |LEX_DONT_CLOSE_RSFP));
parser->in_pod = parser->filtered = 0;
}
ENTER;
SAVESPTR(PL_warnhook);
PL_warnhook = PERL_WARNHOOK_FATAL;
- utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
+ utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
LEAVE;
}
}
PL_parser->last_uni = buf + last_uni_pos;
if (PL_parser->last_lop)
PL_parser->last_lop = buf + last_lop_pos;
+ if (PL_parser->preambling != NOLINE) {
+ CopLINE_set(PL_curcop, PL_parser->preambling + 1);
+ PL_parser->preambling = NOLINE;
+ }
if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
PL_curstash != PL_debstash) {
/* debugger active and we're not compiling the debugger code,
bufend = PL_parser->bufend;
}
}
- unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
+ unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
if (retlen == (STRLEN)-1) {
/* malformed UTF-8 */
ENTER;
SAVESPTR(PL_warnhook);
PL_warnhook = PERL_WARNHOOK_FATAL;
- utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
+ utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
LEAVE;
}
return unichar;
s++;
} else if (c == 0 && s == bufend) {
bool got_more;
+ line_t l;
#ifdef PERL_MAD
if (PL_madskills)
sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
if (flags & LEX_NO_NEXT_CHUNK)
break;
PL_parser->bufptr = s;
- if (can_incline) COPLINE_INC_WITH_HERELINES;
+ l = CopLINE(PL_curcop);
+ CopLINE(PL_curcop) += PL_parser->herelines + 1;
got_more = lex_next_chunk(flags);
- if (can_incline) CopLINE_dec(PL_curcop);
+ CopLINE_set(PL_curcop, l);
s = PL_parser->bufptr;
bufend = PL_parser->bufend;
if (!got_more)
{
AV *av = CopFILEAVx(PL_curcop);
if (av) {
- SV * const sv = newSV_type(SVt_PVMG);
+ SV * sv;
+ if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
+ else {
+ sv = *av_fetch(av, 0, 1);
+ SvUPGRADE(sv, SVt_PVMG);
+ }
+ if (!SvPOK(sv)) sv_setpvs(sv,"");
if (orig_sv)
- sv_setsv_flags(sv, orig_sv, 0); /* no cow */
+ sv_catsv(sv, orig_sv);
else
- sv_setpvn(sv, buf, len);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(av, CopLINE(PL_curcop), sv);
+ sv_catpvn(sv, buf, len);
+ if (!SvIOK(sv)) {
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, 0);
+ }
+ if (PL_parser->preambling == NOLINE)
+ av_store(av, CopLINE(PL_curcop), sv);
}
}
#endif
}
+/*
+ * S_postderef
+ *
+ * This subroutine handles postfix deref syntax after the arrow has already
+ * been emitted. @* $* etc. are emitted as two separate token right here.
+ * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
+ * only the first, leaving yylex to find the next.
+ */
+
+static int
+S_postderef(pTHX_ int const funny, char const next)
+{
+ dVAR;
+ assert(funny == DOLSHARP || strchr("$@%&*", funny));
+ assert(strchr("*[{", next));
+ if (next == '*') {
+ PL_expect = XOPERATOR;
+ if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
+ assert('@' == funny || '$' == funny || DOLSHARP == funny);
+ PL_lex_state = LEX_INTERPEND;
+ start_force(PL_curforce);
+ force_next(POSTJOIN);
+ }
+ start_force(PL_curforce);
+ force_next(next);
+ PL_bufptr+=2;
+ }
+ else {
+ if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
+ && !PL_lex_brackets)
+ PL_lex_dojoin = 2;
+ PL_expect = XOPERATOR;
+ PL_bufptr++;
+ }
+ return funny;
+}
+
void
Perl_yyunlex(pTHX)
{
char *s;
char *send;
char *d;
- STRLEN len = 0;
SV *pv = sv;
PERL_ARGS_ASSERT_TOKEQ;
- if (!SvLEN(sv))
- goto finish;
-
- s = SvPV_force(sv, len);
- if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
+ assert (SvPOK(sv));
+ assert (SvLEN(sv));
+ assert (!SvIsCOW(sv));
+ if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
goto finish;
- send = s + len;
+ s = SvPVX(sv);
+ send = SvEND(sv);
/* This is relying on the SV being "well formed" with a trailing '\0' */
while (s < send && !(*s == '\\' && s[1] == '\\'))
s++;
goto finish;
d = s;
if ( PL_hints & HINT_NEW_STRING ) {
- pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
+ pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
+ SVs_TEMP | SvUTF8(sv));
}
while (s < send) {
if (*s == '\\') {
PL_lex_op = NULL;
return THING;
}
- if (op_type == OP_CONST || op_type == OP_READLINE) {
+ if (op_type == OP_CONST) {
SV *sv = tokeq(PL_lex_stuff);
if (SvTYPE(sv) == SVt_PVIV) {
}
pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
PL_lex_stuff = NULL;
- /* Allow <FH> // "foo" */
- if (op_type == OP_READLINE)
- PL_expect = XTERMORDORDOR;
- return THING;
- }
- else if (op_type == OP_BACKTICK && PL_lex_op) {
- /* readpipe() was overridden */
- cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
- pl_yylval.opval = PL_lex_op;
- PL_lex_op = NULL;
- PL_lex_stuff = NULL;
return THING;
}
{
dVAR;
LEXSHARED *shared;
+ const bool is_heredoc = PL_multi_close == '<';
ENTER;
PL_lex_state = PL_sublex_info.super_state;
- SAVEBOOL(PL_lex_dojoin);
+ SAVEI8(PL_lex_dojoin);
SAVEI32(PL_lex_brackets);
SAVEI32(PL_lex_allbrackets);
SAVEI32(PL_lex_formbrack);
SAVESPTR(PL_lex_repl);
SAVEVPTR(PL_lex_inpat);
SAVEI16(PL_lex_inwhat);
- SAVECOPLINE(PL_curcop);
+ if (is_heredoc)
+ {
+ SAVECOPLINE(PL_curcop);
+ SAVEI32(PL_multi_end);
+ SAVEI32(PL_parser->herelines);
+ PL_parser->herelines = 0;
+ }
+ SAVEI8(PL_multi_close);
SAVEPPTR(PL_bufptr);
SAVEPPTR(PL_bufend);
SAVEPPTR(PL_oldbufptr);
SAVEGENERICPV(PL_lex_casestack);
SAVEGENERICPV(PL_parser->lex_shared);
SAVEBOOL(PL_parser->lex_re_reparsing);
+ SAVEI32(PL_copline);
/* The here-doc parser needs to be able to peek into outer lexing
scopes to find the body of the here-doc. So we put PL_linestr and
*PL_lex_casestack = '\0';
PL_lex_starts = 0;
PL_lex_state = LEX_INTERPCONCAT;
- CopLINE_set(PL_curcop, (line_t)PL_multi_start);
+ if (is_heredoc)
+ CopLINE_set(PL_curcop, (line_t)PL_multi_start);
+ PL_copline = NOLINE;
Newxz(shared, 1, LEXSHARED);
shared->ls_prev = PL_parser->lex_shared;
/* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
assert(PL_lex_inwhat != OP_TRANSR);
- if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
+ if (PL_lex_repl) {
+ assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
PL_linestr = PL_lex_repl;
PL_lex_inpat = 0;
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
PL_lex_state = LEX_INTERPCONCAT;
PL_lex_repl = NULL;
}
+ if (SvTYPE(PL_linestr) >= SVt_PVNV) {
+ CopLINE(PL_curcop) +=
+ ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
+ + PL_parser->herelines;
+ PL_parser->herelines = 0;
+ }
return ',';
}
else {
+ const line_t l = CopLINE(PL_curcop);
#ifdef PERL_MAD
if (PL_madskills) {
if (PL_thiswhite) {
}
#endif
LEAVE;
+ if (PL_multi_close == '<')
+ PL_parser->herelines += l - PL_multi_end;
PL_bufend = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
PL_expect = XOPERATOR;
{
/* If warnings are on, this will print a more detailed analysis of what
* is wrong than the error message below */
- utf8n_to_uvuni(first_bad_char_loc,
+ utf8n_to_uvchr(first_bad_char_loc,
e - ((char *) first_bad_char_loc),
NULL, 0);
* validation. */
table = GvHV(PL_hintgv); /* ^H */
cvp = hv_fetchs(table, "charnames", FALSE);
- if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
- && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
+ if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
+ SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
{
const char * const name = HvNAME(stash);
- if strEQ(name, "_charnames") {
+ if (HvNAMELEN(stash) == sizeof("_charnames")-1
+ && strEQ(name, "_charnames")) {
return res;
}
}
if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
/* If warnings are on, this will print a more detailed analysis of
* what is wrong than the error message below */
- utf8n_to_uvuni(first_bad_char_loc,
+ utf8n_to_uvchr(first_bad_char_loc,
(char *) first_bad_char_loc - str,
NULL, 0);
char *e = d++;
while (e-- > c)
*(e + 1) = *e;
- *c = (char)I8_TO_NATIVE_UTF8(0xff);
+ *c = (char) ILLEGAL_UTF8_BYTE;
/* mark the range as done, and continue */
dorange = FALSE;
didrange = TRUE;
#ifdef EBCDIC
if (literal_endpoint == 2 &&
- ((isLOWER(min) && isLOWER(max)) ||
- (isUPPER(min) && isUPPER(max)))) {
- if (isLOWER(min)) {
- for (i = min; i <= max; i++)
- if (isLOWER(i))
- *d++ = NATIVE_TO_NEED(has_utf8,i);
- } else {
- for (i = min; i <= max; i++)
- if (isUPPER(i))
- *d++ = NATIVE_TO_NEED(has_utf8,i);
+ ((isLOWER_A(min) && isLOWER_A(max)) ||
+ (isUPPER_A(min) && isUPPER_A(max))))
+ {
+ for (i = min; i <= max; i++) {
+ if (isALPHA_A(i))
+ *d++ = i;
}
}
else
if (uvmax) {
d = (char*)uvchr_to_utf8((U8*)d, 0x100);
if (uvmax > 0x101)
- *d++ = (char)UTF_TO_NATIVE(0xff);
+ *d++ = (char) ILLEGAL_UTF8_BYTE;
if (uvmax > 0x100)
d = (char*)uvchr_to_utf8((U8*)d, uvmax);
}
&& !native_range
#endif
) {
- *d++ = (char)I8_TO_NATIVE_UTF8(0xff); /* use illegal utf8 byte--see pmtrans */
+ *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
s++;
continue;
}
else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
if (s[2] == '#') {
while (s+1 < send && *s != ')')
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
+ *d++ = *s++;
}
else if (!PL_lex_casemods &&
( s[2] == '{' /* This should match regcomp.c */
else if (*s == '#' && PL_lex_inpat && !in_charclass &&
((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
while (s+1 < send && *s != '\n')
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
+ *d++ = *s++;
}
/* no further processing of single-quoted regex */
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
+ /* diag_listed_as: \%d better written as $%d */
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
*--s = '$';
break;
|| s[1] != '{'
|| regcurly(s + 1, FALSE)))
{
- *d++ = NATIVE_TO_NEED(has_utf8,'\\');
+ *d++ = '\\';
goto default_action;
}
* to recode the rest of the string into utf8 */
/* Here uv is the ordinal of the next character being added */
- if (!NATIVE_IS_INVARIANT(uv)) {
+ if (!UVCHR_IS_INVARIANT(uv)) {
if (!has_utf8 && uv > 255) {
/* Might need to recode whatever we have accumulated so
* far if it contains any chars variant in utf8 or
}
if (has_utf8) {
- d = (char*)uvuni_to_utf8((U8*)d, uv);
+ d = (char*)uvchr_to_utf8((U8*)d, uv);
if (PL_lex_inwhat == OP_TRANS &&
PL_sublex_info.sub_op) {
PL_sublex_info.sub_op->op_private |=
* now, while preserving the fact that it was a named character
* so that the regex compiler knows this */
- /* This section of code doesn't generally use the
- * NATIVE_TO_NEED() macro to transform the input. I (khw) did
- * a close examination of this macro and determined it is a
- * no-op except on utfebcdic variant characters. Every
- * character generated by this that would normally need to be
- * enclosed by this macro is invariant, so the macro is not
- * needed, and would complicate use of copy(). XXX There are
- * other parts of this file where the macro is used
- * inconsistently, but are saved by it being a no-op */
-
/* The structure of this section of code (besides checking for
* errors and upgrading to utf8) is:
* Further disambiguate between the two meanings of \N, and if
if (! PL_lex_inpat) {
yyerror("Missing right brace on \\N{}");
} else {
- yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
+ yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
}
continue;
}
has_utf8 = TRUE;
}
- /* Add the string to the output */
+ /* Add the (Unicode) code point to the output. */
if (UNI_IS_INVARIANT(uv)) {
- *d++ = (char) uv;
+ *d++ = (char) LATIN1_TO_NATIVE(uv);
}
- else d = (char*)uvuni_to_utf8((U8*)d, uv);
+ else {
+ d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
+ }
}
}
else /* Here is \N{NAME} but not \N{U+...}. */
char hex_string[2 * UTF8_MAXBYTES + 5];
/* Get the first character of the result. */
- U32 uv = utf8n_to_uvuni((U8 *) str,
+ U32 uv = utf8n_to_uvchr((U8 *) str,
len,
&char_length,
UTF8_ALLOW_ANYUV);
/* Convert first code point to hex, including
- * the boiler plate before it. For all these,
- * we convert to native format so that
- * downstream code can continue to assume the
- * input is native */
+ * the boiler plate before it. */
output_length =
my_snprintf(hex_string, sizeof(hex_string),
- "\\N{U+%X",
- (unsigned int) UNI_TO_NATIVE(uv));
+ "\\N{U+%X",
+ (unsigned int) uv);
/* Make sure there is enough space to hold it */
d = off + SvGROW(sv, off
* its ordinal in hex */
while ((str += char_length) < str_end) {
const STRLEN off = d - SvPVX_const(sv);
- U32 uv = utf8n_to_uvuni((U8 *) str,
+ U32 uv = utf8n_to_uvchr((U8 *) str,
str_end - str,
&char_length,
UTF8_ALLOW_ANYUV);
output_length =
my_snprintf(hex_string,
- sizeof(hex_string),
- ".%X",
- (unsigned int) UNI_TO_NATIVE(uv));
+ sizeof(hex_string),
+ ".%X",
+ (unsigned int) uv);
d = off + SvGROW(sv, off
+ output_length
/* printf-style backslashes, formfeeds, newlines, etc */
case 'b':
- *d++ = NATIVE_TO_NEED(has_utf8,'\b');
+ *d++ = '\b';
break;
case 'n':
- *d++ = NATIVE_TO_NEED(has_utf8,'\n');
+ *d++ = '\n';
break;
case 'r':
- *d++ = NATIVE_TO_NEED(has_utf8,'\r');
+ *d++ = '\r';
break;
case 'f':
- *d++ = NATIVE_TO_NEED(has_utf8,'\f');
+ *d++ = '\f';
break;
case 't':
- *d++ = NATIVE_TO_NEED(has_utf8,'\t');
+ *d++ = '\t';
break;
case 'e':
- *d++ = ASCII_TO_NEED(has_utf8,'\033');
+ *d++ = ASCII_TO_NATIVE('\033');
break;
case 'a':
- *d++ = NATIVE_TO_NEED(has_utf8,'\a');
+ *d++ = '\a';
break;
} /* end switch */
default_action:
/* If we started with encoded form, or already know we want it,
then encode the next character */
- if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
+ if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
STRLEN len = 1;
* routine that does the conversion checks for errors like
* malformed utf8 */
- const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
- const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
+ const UV nextuv = (this_utf8)
+ ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
+ : (UV) ((U8) *s);
+ const STRLEN need = UNISKIP(nextuv);
if (!has_utf8) {
SvCUR_set(sv, d - SvPVX_const(sv));
SvPOK_on(sv);
#endif
}
else {
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
+ *d++ = *s++;
}
} /* while loop to process each character */
}
/* return the substring (via pl_yylval) only if we parsed anything */
- if (s > PL_bufptr) {
+ if (s > start) {
+ char *s2 = start;
+ for (; s2 < s; s2++) {
+ if (*s2 == '\n')
+ COPLINE_INC_WITH_HERELINES;
+ }
SvREFCNT_inc_simple_void_NN(sv);
if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
&& ! PL_parser->lex_re_reparsing)
* It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
*
* ->[ and ->{ return TRUE
+ * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
* { and [ outside a pattern are always subscripts, so return TRUE
* if we're outside a pattern and it's not { or [, then return FALSE
* if we're in a pattern and the first char is a {
return TRUE;
if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
return TRUE;
+ if (*s == '-' && s[1] == '>'
+ && FEATURE_POSTDEREF_QQ_IS_ENABLED
+ && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
+ ||(s[2] == '@' && strchr("*[{",s[3])) ))
+ return TRUE;
if (*s != '{' && *s != '[')
return FALSE;
if (!PL_lex_inpat)
weight -= seen[un_char] * 10;
if (isWORDCHAR_lazy_if(s+1,UTF)) {
int len;
- scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
+ char *tmp = PL_bufend;
+ PL_bufend = (char*)send;
+ scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
+ PL_bufend = tmp;
len = (int)strlen(tmpbuf);
if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
UTF ? SVf_UTF8 : 0, SVt_PV))
/* 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. */
- unsigned int correct_length
- = maxlen < 0 ?
-#ifdef PERL_MICRO
- 0x7FFFFFFF
-#else
- INT_MAX
-#endif
- : maxlen;
+ unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
PERL_ARGS_ASSERT_FILTER_READ;
return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
}
-/*
- * S_readpipe_override
- * Check whether readpipe() is overridden, and generates the appropriate
- * optree, provided sublex_start() is called afterwards.
- */
-STATIC void
-S_readpipe_override(pTHX)
-{
- GV **gvp;
- GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
- pl_yylval.ival = OP_BACKTICK;
- if ((gv_readpipe
- && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
- ||
- ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
- && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
- && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
- {
- PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST,
- newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
- newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
- }
-}
-
#ifdef PERL_MAD
/*
* Perl_madlex
#ifdef DEBUGGING
static const char* const exp_name[] =
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
- "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
+ "ATTRTERM", "TERMBLOCK", "POSTDEREF", "TERMORDORDOR"
};
#endif
(p[0] == 'q' && strchr("qwxr", p[1]))));
}
+static void
+S_check_scalar_slice(pTHX_ char *s)
+{
+ s++;
+ while (*s == ' ' || *s == '\t') s++;
+ if (*s == 'q' && s[1] == 'w'
+ && !isWORDCHAR_lazy_if(s+2,UTF))
+ return;
+ while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
+ s += UTF ? UTF8SKIP(s) : 1;
+ if (*s == '}' || *s == ']')
+ pl_yylval.ival = OPpSLICEWARNING;
+}
+
/*
yylex
*/
-#ifdef __SC__
-#pragma segment Perl_yylex
-#endif
int
Perl_yylex(pTHX)
{
char *d;
STRLEN len;
bool bof = FALSE;
- const bool saw_infix_sigil = PL_parser->saw_infix_sigil;
+ const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
U8 formbrack = 0;
U32 fake_eof = 0;
} );
switch (PL_lex_state) {
-#ifdef COMMENTARY
- case LEX_NORMAL: /* Some compilers will produce faster */
- case LEX_INTERPNORMAL: /* code if we comment these out. */
+ case LEX_NORMAL:
+ case LEX_INTERPNORMAL:
break;
-#endif
/* when we've already built the next token, just pull it out of the queue */
case LEX_KNOWNEXT:
case LEX_INTERPEND:
if (PL_lex_dojoin) {
+ const U8 dojoin_was = PL_lex_dojoin;
PL_lex_dojoin = FALSE;
PL_lex_state = LEX_INTERPCONCAT;
#ifdef PERL_MAD
}
#endif
PL_lex_allbrackets--;
- return REPORT(')');
+ return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
}
if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
&& SvEVALED(PL_lex_repl))
goto keylookup;
{
SV *dsv = newSVpvs_flags("", SVs_TEMP);
- const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
+ const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
UTF8SKIP(s),
SVs_TEMP | SVf_UTF8),
- 10, UNI_DISPLAY_ISPRINT))
+ 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;
} else {
d = PL_linestart;
- }
- *s = '\0';
- 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);
+ }
+ Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
+ UTF8fARG(UTF, (s - d), d),
+ (int) len + 1);
}
case 4:
case 26:
SETERRNO(0,SS_NORMAL);
sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
}
+ PL_parser->preambling = CopLINE(PL_curcop);
} else
sv_setpvs(PL_linestr,"");
if (PL_preambleav) {
* check if it in fact is. */
if (bof && PL_rsfp &&
(*s == 0 ||
- *(U8*)s == 0xEF ||
+ *(U8*)s == BOM_UTF8_FIRST_BYTE ||
*(U8*)s >= 0xFE ||
s[1] == 0)) {
Off_t offset = (IV)PerlIO_tell(PL_rsfp);
DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
OPERATOR('-'); /* unary minus */
}
- PL_last_uni = PL_oldbufptr;
switch (tmp) {
case 'r': ftst = OP_FTEREAD; break;
case 'w': ftst = OP_FTEWRITE; break;
break;
}
if (ftst) {
+ PL_last_uni = PL_oldbufptr;
PL_last_lop_op = (OPCODE)ftst;
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw file test %c\n", (int)tmp);
else if (*s == '>') {
s++;
s = SKIPSPACE1(s);
+ if (FEATURE_POSTDEREF_IS_ENABLED && (
+ ((*s == '$' || *s == '&') && s[1] == '*')
+ ||(*s == '$' && s[1] == '#' && s[2] == '*')
+ ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
+ ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
+ ))
+ {
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__POSTDEREF),
+ "Postfix dereference is experimental"
+ );
+ PL_expect = XPOSTDEREF;
+ TOKEN(ARROW);
+ }
if (isIDFIRST_lazy_if(s,UTF)) {
s = force_word(s,METHOD,FALSE,TRUE);
TOKEN(ARROW);
}
case '*':
+ if (PL_expect == XPOSTDEREF) POSTDEREF('*');
if (PL_expect != XOPERATOR) {
- s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
+ s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
PL_expect = XOPERATOR;
force_ident(PL_tokenbuf, '*');
if (!*PL_tokenbuf)
Mop(OP_MULTIPLY);
case '%':
+ {
if (PL_expect == XOPERATOR) {
if (s[1] == '=' && !PL_lex_allbrackets &&
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
PL_parser->saw_infix_sigil = 1;
Mop(OP_MODULO);
}
+ else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
PL_tokenbuf[0] = '%';
- s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
+ s = scan_ident(s, PL_tokenbuf + 1,
sizeof PL_tokenbuf - 1, FALSE);
+ pl_yylval.ival = 0;
if (!PL_tokenbuf[1]) {
PREREF('%');
}
+ if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
+ if (*s == '[')
+ PL_tokenbuf[0] = '@';
+ }
PL_expect = XOPERATOR;
force_ident_maybe_lex('%');
TERM('%');
-
+ }
case '^':
if (!PL_lex_allbrackets && PL_lex_fakeeof >=
(s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
}
sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
if (*d == '(') {
- d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
+ d = scan_str(d,TRUE,TRUE,FALSE,FALSE,NULL);
+ COPLINE_SET_FROM_MULTI_END;
if (!d) {
/* MUST advance bufptr here to avoid bogus
"at end of line" context messages from yyerror().
TOKEN(0);
s++;
if (PL_lex_brackets <= 0)
+ /* diag_listed_as: Unmatched right %s bracket */
yyerror("Unmatched right square bracket");
else
--PL_lex_brackets;
rightbracket:
s++;
if (PL_lex_brackets <= 0)
+ /* diag_listed_as: Unmatched right %s bracket */
yyerror("Unmatched right curly bracket");
else
PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
}
TOKEN(';');
case '&':
+ if (PL_expect == XPOSTDEREF) POSTDEREF('&');
s++;
if (*s++ == '&') {
if (!PL_lex_allbrackets && PL_lex_fakeeof >=
}
PL_tokenbuf[0] = '&';
- s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
+ s = scan_ident(s - 1, PL_tokenbuf + 1,
sizeof PL_tokenbuf - 1, TRUE);
if (PL_tokenbuf[1]) {
PL_expect = XOPERATOR;
return deprecate_commaless_var_list();
}
}
+ else if (PL_expect == XPOSTDEREF) {
+ if (s[1] == '#') {
+ s++;
+ POSTDEREF(DOLSHARP);
+ }
+ POSTDEREF('$');
+ }
if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
PL_tokenbuf[0] = '@';
- s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
+ s = scan_ident(s + 1, PL_tokenbuf + 1,
sizeof PL_tokenbuf - 1, FALSE);
if (PL_expect == XOPERATOR)
no_op("Array length", s);
}
PL_tokenbuf[0] = '$';
- s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
+ s = scan_ident(s, PL_tokenbuf + 1,
sizeof PL_tokenbuf - 1, FALSE);
if (PL_expect == XOPERATOR)
no_op("Scalar", s);
case '@':
if (PL_expect == XOPERATOR)
no_op("Array", s);
+ else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
PL_tokenbuf[0] = '@';
- s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ pl_yylval.ival = 0;
if (!PL_tokenbuf[1]) {
PREREF('@');
}
/* Warn about @ where they meant $. */
if (*s == '[' || *s == '{') {
if (ckWARN(WARN_SYNTAX)) {
- const char *t = s + 1;
- while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \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 %"UTF8f" better written as $%"UTF8f,
- UTF8fARG(UTF, t-PL_bufptr, PL_bufptr),
- UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1));
- }
+ S_check_scalar_slice(aTHX_ s);
}
}
}
TERM(THING);
case '\'':
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
+ COPLINE_SET_FROM_MULTI_END;
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,FALSE, FALSE);
- DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
+ DEBUG_T( {
+ if (s)
+ printbuf("### Saw string before %s\n", s);
+ else
+ PerlIO_printf(Perl_debug_log,
+ "### Saw unterminated string\n");
+ } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
return deprecate_commaless_var_list();
break;
}
}
+ if (pl_yylval.ival == OP_CONST)
+ COPLINE_SET_FROM_MULTI_END;
TERM(sublex_start());
case '`':
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
missingterm(NULL);
- readpipe_override();
+ pl_yylval.ival = OP_BACKTICK;
TERM(sublex_start());
case '\\':
s++;
- if (PL_lex_inwhat && isDIGIT(*s))
+ if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+ && isDIGIT(*s))
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
*s, *s);
if (PL_expect == XOPERATOR)
anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
/* x::* is just a word, unless x is "CORE" */
- if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
+ if (!anydelim && *s == ':' && s[1] == ':') {
+ if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
goto just_a_word;
+ }
d = s;
while (d < PL_bufend && isSPACE(*d))
if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
CV *cv;
if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
- UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
+ (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
+ SVt_PVCV)) &&
(cv = GvCVu(gv)))
{
if (GvIMPORTED_CV(gv))
}
if (!ogv &&
(gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
- UTF ? -(I32)len : (I32)len, FALSE)) &&
- (gv = *gvp) && isGV_with_GP(gv) &&
- GvCVu(gv) && GvIMPORTED_CV(gv))
+ len, FALSE)) &&
+ (gv = *gvp) && (
+ isGV_with_GP(gv)
+ ? GvCVu(gv) && GvIMPORTED_CV(gv)
+ : SvPCS_IMPORTED(gv)
+ && (gv_init(gv, PL_globalstash, PL_tokenbuf,
+ len, 0), 1)
+ ))
{
ogv = gv;
}
}
gv = NULL;
gvp = 0;
- if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
+ if (hgv && tmp != KEY_x) /* never ambiguous */
Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous call resolved as CORE::%s(), "
"qualify as such or use &",
&& (!anydelim || *s != '#')) {
/* no override, and not s### either; skipspace is safe here
* check for => on following line */
+ bool arrow;
STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
STRLEN soff = s - SvPVX(PL_linestr);
s = skipspace_flags(s, LEX_NO_INCLINE);
- if (*s == '=' && s[1] == '>') goto fat_arrow;
+ arrow = *s == '=' && s[1] == '>';
PL_bufptr = SvPVX(PL_linestr) + bufoff;
s = SvPVX(PL_linestr) + soff;
+ if (arrow)
+ goto fat_arrow;
}
reserved_word:
pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
pl_yylval.opval);
else {
- pl_yylval.opval->op_private = OPpCONST_FOLDED;
+ pl_yylval.opval->op_private = 0;
pl_yylval.opval->op_folded = 1;
pl_yylval.opval->op_flags |= OPf_SPECIAL;
}
while (isLOWER(*d))
d++;
if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
+ {
+ /* PL_warn_reserved is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
+ GCC_DIAG_RESTORE;
+ }
}
}
}
}
goto just_a_word;
- case KEY_CORE:
- if (*s == ':' && s[1] == ':') {
+ case_KEY_CORE:
+ {
STRLEN olen = len;
d = s;
s += 2;
orig_keyword = tmp;
goto reserved_word;
}
- goto just_a_word;
case KEY_abs:
UNI(OP_ABS);
*PL_tokenbuf = '&';
d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
1, &len);
- if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
+ if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
+ && !keyword(PL_tokenbuf + 1, len, 0)) {
d = SKIPSPACE1(d);
if (*d == '(') {
force_ident_maybe_lex('&');
strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
p += 3;
p = PEEKSPACE(p);
+ /* skip optional package name, as in "for my abc $x (..)" */
if (isIDFIRST_lazy_if(p,UTF)) {
- p = scan_ident(p, PL_bufend,
- PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
+ p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
p = PEEKSPACE(p);
}
if (*p != '$')
case KEY_glob:
LOP(
- orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
+ orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
XTERM
);
LOP(OP_PIPE_OP,XTERM);
case KEY_q:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
+ COPLINE_SET_FROM_MULTI_END;
if (!s)
missingterm(NULL);
pl_yylval.ival = OP_CONST;
case KEY_qw: {
OP *words = NULL;
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
+ COPLINE_SET_FROM_MULTI_END;
if (!s)
missingterm(NULL);
PL_expect = XOPERATOR;
}
case KEY_qq:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
pl_yylval.ival = OP_STRINGIFY;
TERM(sublex_start());
case KEY_qx:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
- readpipe_override();
+ pl_yylval.ival = OP_BACKTICK;
TERM(sublex_start());
case KEY_return:
/* Look for a prototype */
if (*s == '(') {
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
+ COPLINE_SET_FROM_MULTI_END;
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
(void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
FUN0(OP_WANTARRAY);
case KEY_write:
-#ifdef EBCDIC
- {
- char ctl_l[2];
- ctl_l[0] = toCTRL('L');
- ctl_l[1] = '\0';
- gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
- }
-#else
- /* Make sure $^L is defined */
- gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
-#endif
+ /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
+ * we use the same number on EBCDIC */
+ gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
UNI(OP_ENTERWRITE);
case KEY_x:
}
}}
}
-#ifdef __SC__
-#pragma segment Main
-#endif
/*
S_pending_ident
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
else {
- if (has_colon)
+ if (has_colon) {
+ /* PL_no_myglob is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
UTF ? SVf_UTF8 : 0);
+ GCC_DIAG_RESTORE;
+ }
pl_yylval.opval = newOP(OP_PADANY, 0);
pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
newSVpvs(":full"),
newSVpvs(":short"),
NULL);
- SPAGAIN;
+ assert(sp == PL_stack_sp);
table = GvHV(PL_hintgv);
if (table
&& (PL_hints & HINT_LOCALIZE_HH)
else if ( isWORDCHAR_A(**s) ) {
do {
*(*d)++ = *(*s)++;
- } while isWORDCHAR_A(**s);
+ } while (isWORDCHAR_A(**s) && *d < e);
}
else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
*(*d)++ = ':';
}
STATIC char *
-S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
+S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
{
dVAR;
- char *bracket = NULL;
+ I32 herelines = PL_parser->herelines;
+ SSize_t bracket = -1;
char funny = *s++;
char *d = dest;
char * const e = d + destlen - 3; /* two-character token, ending NUL */
bool is_utf8 = cBOOL(UTF);
+ I32 orig_copline = 0, tmp_copline = 0;
PERL_ARGS_ASSERT_SCAN_IDENT;
}
/* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
if (*s == '{') {
- bracket = s;
+ bracket = s - SvPVX(PL_linestr);
s++;
- while (s < send && SPACE_OR_TAB(*s))
- s++;
+ orig_copline = CopLINE(PL_curcop);
+ if (s < PL_bufend && isSPACE(*s)) {
+ s = PEEKSPACE(s);
+ }
}
-#define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
- || isCNTRL_A((U8)(d)) \
- || isDIGIT_A((U8)(d)) \
- || (!(u) && !UTF8_IS_INVARIANT((U8)(d))))
- if (s < send
+/* Is the byte 'd' a legal single character identifier name? 'u' is true
+ * iff Unicode semantics are to be used. The legal ones are any of:
+ * a) ASCII digits
+ * b) ASCII punctuation
+ * c) When not under Unicode rules, any upper Latin1 character
+ * d) \c?, \c\, \c^, \c_, and \cA..\cZ, minus the ones that have traditionally
+ * been matched by \s on ASCII platforms. That is: \c?, plus 1-32, minus
+ * the \s ones. */
+#define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
+ || isDIGIT_A((U8)(d)) \
+ || (!(u) && !isASCII((U8)(d))) \
+ || ((((U8)(d)) < 32) \
+ && (((((U8)(d)) >= 14) \
+ || (((U8)(d)) <= 8 && (d) != 0) \
+ || (((U8)(d)) == 13)))) \
+ || (((U8)(d)) == toCTRL('?')))
+ if (s < PL_bufend
&& (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
{
+ if ( isCNTRL_A((U8)*s) ) {
+ deprecate("literal control characters in variable names");
+ }
+
if (is_utf8) {
const STRLEN skip = UTF8SKIP(s);
STRLEN i;
/* Warn about ambiguous code after unary operators if {...} notation isn't
used. There's no difference in ambiguity; it's merely a heuristic
about when not to warn. */
- else if (ck_uni && !bracket)
+ else if (ck_uni && bracket == -1)
check_uni();
- if (bracket) {
+ if (bracket != -1) {
/* If we were processing {...} notation then... */
if (isIDFIRST_lazy_if(d,is_utf8)) {
/* if it starts as a valid identifier, assume that it is one.
d += is_utf8 ? UTF8SKIP(d) : 1;
parse_ident(&s, &d, e, 1, is_utf8);
*d = '\0';
- while (s < send && SPACE_OR_TAB(*s))
- s++;
+ tmp_copline = CopLINE(PL_curcop);
+ if (s < PL_bufend && isSPACE(*s)) {
+ s = PEEKSPACE(s);
+ }
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
/* ${foo[0]} and ${foo{bar}} notation. */
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
const char * const brack =
(const char *)
((*s == '[') ? "[...]" : "{...}");
+ orig_copline = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, tmp_copline);
/* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
+ CopLINE_set(PL_curcop, orig_copline);
}
bracket++;
PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
*d = '\0';
}
- while (s < send && SPACE_OR_TAB(*s))
- s++;
-
+ if ( !tmp_copline )
+ tmp_copline = CopLINE(PL_curcop);
+ if (s < PL_bufend && isSPACE(*s)) {
+ s = PEEKSPACE(s);
+ }
+
/* Expect to find a closing } after consuming any trailing whitespace.
*/
if (*s == '}') {
SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
if (funny == '#')
funny = '@';
+ orig_copline = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, tmp_copline);
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
funny, tmp, funny, tmp);
+ CopLINE_set(PL_curcop, orig_copline);
}
}
}
else {
/* Didn't find the closing } at the point we expected, so restore
state such that the next thing to process is the opening { and */
- s = bracket; /* let the parser handle it */
+ s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
+ CopLINE_set(PL_curcop, orig_copline);
+ PL_parser->herelines = herelines;
*dest = '\0';
}
}
yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
}
else if (c == 'a') {
+ /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
}
else {
PERL_ARGS_ASSERT_SCAN_PAT;
s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
- TRUE /* look for escaped bracketed metas */ );
+ TRUE /* look for escaped bracketed metas */, NULL);
if (!s) {
const char * const delimiter = skipspace(start);
char *s;
PMOP *pm;
I32 first_start;
+ line_t first_line;
I32 es = 0;
char charset = '\0'; /* character set modifier */
#ifdef PERL_MAD
char *modstart;
#endif
+ char *t;
PERL_ARGS_ASSERT_SCAN_SUBST;
pl_yylval.ival = OP_NULL;
s = scan_str(start,!!PL_madskills,FALSE,FALSE,
- TRUE /* look for escaped bracketed metas */ );
+ TRUE /* look for escaped bracketed metas */, &t);
if (!s)
Perl_croak(aTHX_ "Substitution pattern not terminated");
- if (s[-1] == PL_multi_open)
- s--;
+ s = t;
#ifdef PERL_MAD
if (PL_madskills) {
CURMAD('q', PL_thisopen);
#endif
first_start = PL_multi_start;
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ first_line = CopLINE(PL_curcop);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
SvREFCNT_dec(PL_sublex_info.repl);
PL_sublex_info.repl = repl;
}
+ if (CopLINE(PL_curcop) != first_line) {
+ sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
+ ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
+ CopLINE(PL_curcop) - first_line;
+ CopLINE_set(PL_curcop, first_line);
+ }
PL_lex_op = (OP*)pm;
pl_yylval.ival = OP_SUBST;
#ifdef PERL_MAD
char *modstart;
#endif
+ char *t;
PERL_ARGS_ASSERT_SCAN_TRANS;
pl_yylval.ival = OP_NULL;
- s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,&t);
if (!s)
Perl_croak(aTHX_ "Transliteration pattern not terminated");
- if (s[-1] == PL_multi_open)
- s--;
+ s = t;
#ifdef PERL_MAD
if (PL_madskills) {
CURMAD('q', PL_thisopen);
}
#endif
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
char *e;
char *peek;
const bool infile = PL_rsfp || PL_parser->filtered;
+ const line_t origline = CopLINE(PL_curcop);
LEXSHARED *shared = PL_parser->lex_shared;
#ifdef PERL_MAD
I32 stuffstart = s - SvPVX(PL_linestr);
SvIV_set(tmpstr, '\\');
}
- PL_multi_start = CopLINE(PL_curcop) + 1;
+ PL_multi_start = origline + 1 + PL_parser->herelines;
PL_multi_open = PL_multi_close = '<';
/* inside a string eval or quote-like operator */
if (!infile || PL_lex_inwhat) {
while (s < bufend - len + 1 &&
memNE(s,PL_tokenbuf,len) ) {
if (*s++ == '\n')
- ++shared->herelines;
+ ++PL_parser->herelines;
}
if (s >= bufend - len + 1) {
goto interminable;
#endif
s += len - 1;
/* the preceding stmt passes a newline */
- shared->herelines++;
+ PL_parser->herelines++;
/* s now points to the newline after the heredoc terminator.
d points to the newline before the body of the heredoc.
#endif
PL_bufptr = PL_bufend;
CopLINE_set(PL_curcop,
- PL_multi_start + shared->herelines);
+ origline + 1 + PL_parser->herelines);
if (!lex_next_chunk(LEX_NO_TERM)
&& (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
SvREFCNT_dec(linestr_save);
goto interminable;
}
- CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
+ CopLINE_set(PL_curcop, origline);
if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
/* ^That should be enough to avoid this needing to grow: */
#ifdef PERL_MAD
stuffstart = s - SvPVX(PL_linestr);
#endif
- shared->herelines++;
+ PL_parser->herelines++;
PL_last_lop = PL_last_uni = NULL;
#ifndef PERL_STRICT_CR
if (PL_bufend - PL_linestart >= 2) {
}
}
}
- PL_multi_end = CopLINE(PL_curcop);
+ PL_multi_end = origline + PL_parser->herelines;
if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
SvPV_shrink_to_cur(tmpstr);
}
interminable:
SvREFCNT_dec(tmpstr);
- CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
+ CopLINE_set(PL_curcop, origline);
missingterm(PL_tokenbuf + 1);
}
if (d - PL_tokenbuf != len) {
pl_yylval.ival = OP_GLOB;
- s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s)
Perl_croak(aTHX_ "Glob not terminated");
return s;
else {
bool readline_overriden = FALSE;
GV *gv_readline;
- GV **gvp;
/* we're in a filehandle read situation */
d = PL_tokenbuf;
/* Check whether readline() is overriden */
gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
- if ((gv_readline
- && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
- ||
- ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
- && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
- && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
+ if ((gv_readline = gv_override("readline",8)))
readline_overriden = TRUE;
/* if <$fh>, create the ops to turn the variable into a
deprecate_escaped_meta issue a deprecation warning for cer-
tain paired metacharacters that appear
escaped within it
+ delimp if non-null, this is set to the position of
+ the closing delimiter, or just after it if
+ the closing and opening delimiters differ
+ (i.e., the opening delimiter of a substitu-
+ tion replacement)
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, int re_reparse,
- bool deprecate_escaped_meta
+ bool deprecate_escaped_meta, char **delimp
)
{
dVAR;
STRLEN termlen; /* length of terminating string */
int last_off = 0; /* last position for nesting bracket */
char *escaped_open = NULL;
+ line_t herelines;
#ifdef PERL_MAD
int stuffstart;
char *tstart;
/* mark where we are */
PL_multi_start = CopLINE(PL_curcop);
PL_multi_open = term;
+ herelines = PL_parser->herelines;
/* find corresponding closing delimiter */
if (term && (tmps = strchr("([{< )]}> )]}>",term)))
* happen for <>, as they aren't metas. */
if (deprecate_escaped_meta
&& (PL_multi_open == PL_multi_close
- || ! ckWARN_d(WARN_DEPRECATED)
- || PL_multi_open == '<'))
+ || PL_multi_open == '<'
+ || ! ckWARN_d(WARN_DEPRECATED)))
{
deprecate_escaped_meta = FALSE;
}
SvUTF8_on(sv);
PL_multi_end = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, PL_multi_start);
+ PL_parser->herelines = herelines;
/* if we allocated too much space, give some back */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
PL_sublex_info.repl = sv;
else
PL_lex_stuff = sv;
+ if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
return s;
}
return oldsavestack_ix;
}
-#ifdef __SC__
-#pragma segment Perl_yylex
-#endif
static int
S_yywarn(pTHX_ const char *const s, U32 flags)
{
}
msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
- OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+ OutCopFILE(PL_curcop),
+ (IV)(PL_parser->preambling == NOLINE
+ ? CopLINE(PL_curcop)
+ : PL_parser->preambling));
if (context)
Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
UTF8fARG(UTF, contlen, context));
PL_in_my_stash = NULL;
return 0;
}
-#ifdef __SC__
-#pragma segment Main
-#endif
STATIC char*
S_swallow_bom(pTHX_ U8 *s)
#endif
}
break;
- case 0xEF:
- if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
- if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
- s += 3; /* UTF-8 */
- }
- break;
+ case BOM_UTF8_FIRST_BYTE: {
+ const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
+ if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
+ if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
+ s += len + 1; /* UTF-8 */
+ }
+ break;
+ }
case 0:
if (slen > 3) {
if (s[1] == 0) {
#endif
}
}
-#ifdef EBCDIC
- case 0xDD:
- if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
- if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
- s += 4; /* UTF-8 */
- }
- break;
-#endif
default:
if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
/* Append native character for the rev point */
tmpend = uvchr_to_utf8(tmpbuf, rev);
sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
- if (!NATIVE_IS_INVARIANT(rev))
+ if (!UVCHR_IS_INVARIANT(rev))
SvUTF8_on(sv);
if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
s = ++pos;
https://perl5.git.perl.org / perl5.git / blobdiff