};
#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. */
STMT_START { \
CopLINE_set(PL_curcop, PL_multi_end); \
if (PL_multi_end != PL_multi_start) \
- PL_parser->lex_shared->herelines = 0; \
+ 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);
}
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;
}
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,
break;
PL_parser->bufptr = s;
l = CopLINE(PL_curcop);
- CopLINE(PL_curcop) += PL_parser->lex_shared->herelines + 1;
+ CopLINE(PL_curcop) += PL_parser->herelines + 1;
got_more = lex_next_chunk(flags);
CopLINE_set(PL_curcop, l);
s = PL_parser->bufptr;
{
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 =
- CopLINE(PL_curcop) == (line_t)PL_multi_start - 1;
+ const bool is_heredoc = PL_multi_close == '<';
ENTER;
- assert(CopLINE(PL_curcop) == (line_t)PL_multi_start
- || CopLINE(PL_curcop) == (line_t)PL_multi_start - 1);
-
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);
SAVEVPTR(PL_lex_inpat);
SAVEI16(PL_lex_inwhat);
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);
PL_lex_starts = 0;
PL_lex_state = LEX_INTERPCONCAT;
if (is_heredoc)
- CopLINE_inc(PL_curcop);
+ CopLINE_set(PL_curcop, (line_t)PL_multi_start);
PL_copline = NOLINE;
Newxz(shared, 1, LEXSHARED);
shared->ls_prev = PL_parser->lex_shared;
PL_parser->lex_shared = shared;
- if (!is_heredoc && PL_multi_start != PL_multi_end) {
- shared->herelines = shared->ls_prev->herelines;
- shared->ls_prev->herelines = 0;
- }
PL_lex_inwhat = PL_sublex_info.sub_inwhat;
if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
/* 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);
if (SvTYPE(PL_linestr) >= SVt_PVNV) {
CopLINE(PL_curcop) +=
((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
- + PL_parser->lex_shared->herelines;
- PL_parser->lex_shared->herelines = 0;
+ + 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;
* 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 (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;
* 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 (! 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;
}
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;
* 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)))
- {
- COPLINE_SET_FROM_MULTI_END;
- 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) {
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
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) {
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();
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 &",
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);
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);
}
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");
}
}}
}
-#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);
+ }
}
/* Is the byte 'd' a legal single character identifier name? 'u' is true
|| (((U8)(d)) <= 8 && (d) != 0) \
|| (((U8)(d)) == 13)))) \
|| (((U8)(d)) == toCTRL('?')))
- if (s < send
+ 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);
#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);
first_start = PL_multi_start;
first_line = CopLINE(PL_curcop);
- 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);
#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;
/* mark where we are */
PL_multi_start = CopLINE(PL_curcop);
PL_multi_open = term;
- herelines = PL_parser->lex_shared->herelines;
+ herelines = PL_parser->herelines;
/* find corresponding closing delimiter */
if (term && (tmps = strchr("([{< )]}> )]}>",term)))
PL_multi_end = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, PL_multi_start);
- PL_parser->lex_shared->herelines = herelines;
+ 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)
/* 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;