=cut
*/
+#define LEX_NO_INCLINE 0x40000000
#define LEX_NO_NEXT_CHUNK 0x80000000
void
Perl_lex_read_space(pTHX_ U32 flags)
{
char *s, *bufend;
+ const bool can_incline = !(flags & LEX_NO_INCLINE);
bool need_incline = 0;
- if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
+ if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
#ifdef PERL_MAD
if (PL_skipwhite) {
} while (!(c == '\n' || (c == 0 && s == bufend)));
} else if (c == '\n') {
s++;
- PL_parser->linestart = s;
- if (s == bufend)
- need_incline = 1;
- else
- incline(s);
+ if (can_incline) {
+ PL_parser->linestart = s;
+ if (s == bufend)
+ need_incline = 1;
+ else
+ incline(s);
+ }
} else if (isSPACE(c)) {
s++;
} else if (c == 0 && s == bufend) {
if (flags & LEX_NO_NEXT_CHUNK)
break;
PL_parser->bufptr = s;
- COPLINE_INC_WITH_HERELINES;
+ if (can_incline) COPLINE_INC_WITH_HERELINES;
got_more = lex_next_chunk(flags);
- CopLINE_dec(PL_curcop);
+ if (can_incline) CopLINE_dec(PL_curcop);
s = PL_parser->bufptr;
bufend = PL_parser->bufend;
if (!got_more)
break;
- if (need_incline && PL_parser->rsfp) {
+ if (can_incline && need_incline && PL_parser->rsfp) {
incline(s);
need_incline = 0;
}
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
"Prototype after '%c' for %"SVf" : %s",
greedy_proto, SVfARG(name), p);
+ if (in_brackets)
+ Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
+ "Missing ']' in prototype for %"SVf" : %s",
+ SVfARG(name), p);
if (bad_proto)
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
"Illegal character in prototype for %"SVf" : %s",
CopLINE_set(PL_curcop, line_num);
}
+#define skipspace(s) skipspace_flags(s, 0)
+
#ifdef PERL_MAD
/* skip space before PL_thistoken */
if (av) {
SV * const sv = newSV_type(SVt_PVMG);
if (orig_sv)
- sv_setsv(sv, orig_sv);
+ sv_setsv_flags(sv, orig_sv, 0); /* no cow */
else
sv_setpvn(sv, buf, len);
(void)SvIOK_on(sv);
*/
STATIC char *
-S_skipspace(pTHX_ char *s)
+S_skipspace_flags(pTHX_ char *s, U32 flags)
{
#ifdef PERL_MAD
char *start = s;
#endif /* PERL_MAD */
- PERL_ARGS_ASSERT_SKIPSPACE;
+ PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
#ifdef PERL_MAD
if (PL_skipwhite) {
sv_free(PL_skipwhite);
} else {
STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
PL_bufptr = s;
- lex_read_space(LEX_KEEP_PREVIOUS |
+ lex_read_space(flags | LEX_KEEP_PREVIOUS |
(PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
LEX_NO_NEXT_CHUNK : 0));
s = PL_bufptr;
* char, which will be done separately.
* Stop on (?{..}) and friends */
- else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
+ 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++);
}
- else if (!PL_lex_casemods && !in_charclass &&
+ else if (!PL_lex_casemods &&
( s[2] == '{' /* This should match regcomp.c */
|| (s[2] == '?' && s[3] == '{')))
{
}
/* likewise skip #-initiated comments in //x patterns */
- else if (*s == '#' && PL_lex_inpat &&
+ 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++);
return yylex();
}
+ /* We really do *not* want PL_linestr ever becoming a COW. */
+ assert (!SvIsCOW(PL_linestr));
s = PL_bufptr;
PL_oldoldbufptr = PL_oldbufptr;
PL_oldbufptr = s;
PL_bufend = s; */
}
#else
- *s = '\0';
- PL_bufend = s;
+ while (s < PL_bufend && *s != '\n')
+ s++;
+ if (s < PL_bufend)
+ s++;
+ else if (s > PL_bufend) /* Found by Ilya: feed random input to Perl. */
+ Perl_croak(aTHX_ "panic: input overflow");
#endif
}
goto retry;
/* Is this a word before a => operator? */
if (*d == '=' && d[1] == '>') {
+ fat_arrow:
CLINE;
pl_yylval.opval
= (OP*)newSVOP(OP_CONST, 0,
}
}
+ if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
+ && (!anydelim || *s != '#')) {
+ /* no override, and not s### either; skipspace is safe here
+ * check for => on following line */
+ 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;
+ PL_bufptr = SvPVX(PL_linestr) + bufoff;
+ s = SvPVX(PL_linestr) + soff;
+ }
+
reserved_word:
switch (tmp) {
d = s + 1;
while (SPACE_OR_TAB(*d))
d++;
- if (*d == ')' && (sv = cv_const_sv(cv))) {
+ if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
s = d + 1;
goto its_constant;
}
UTF8fARG(UTF, l, PL_tokenbuf));
}
/* Check for a constant sub */
- if ((sv = cv_const_sv(cv))) {
+ if ((sv = cv_const_sv_or_av(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 = OPpCONST_FOLDED;
- pl_yylval.opval->op_flags |= OPf_SPECIAL;
+ if (SvTYPE(sv) == SVt_PVAV)
+ pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
+ pl_yylval.opval);
+ else {
+ pl_yylval.opval->op_private = OPpCONST_FOLDED;
+ pl_yylval.opval->op_folded = 1;
+ pl_yylval.opval->op_flags |= OPf_SPECIAL;
+ }
TOKEN(WORD);
}
}
CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
- lex_grow_linestr(SvCUR(PL_linestr) + 2);
+ s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
+ /* ^That should be enough to avoid this needing to grow: */
sv_catpvs(PL_linestr, "\n\0");
+ assert(s == SvPVX(PL_linestr));
+ PL_bufend = SvEND(PL_linestr);
}
s = PL_bufptr;
#ifdef PERL_MAD
int offset = s - SvPVX_const(PL_linestr);
const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
&offset, (char*)termstr, termlen);
- const char * const ns = SvPVX_const(PL_linestr) + offset;
- char * const svlast = SvEND(sv) - 1;
+ const char *ns;
+ char *svlast;
+
+ if (SvIsCOW(PL_linestr)) {
+ STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
+ STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
+ STRLEN last_lop_pos, re_eval_start_pos, s_pos;
+ char *buf = SvPVX(PL_linestr);
+ bufend_pos = PL_parser->bufend - buf;
+ bufptr_pos = PL_parser->bufptr - buf;
+ oldbufptr_pos = PL_parser->oldbufptr - buf;
+ oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
+ 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_parser->lex_shared->re_eval_start ?
+ PL_parser->lex_shared->re_eval_start - buf : 0;
+ s_pos = s - buf;
+
+ sv_force_normal(PL_linestr);
+
+ buf = SvPVX(PL_linestr);
+ PL_parser->bufend = buf + bufend_pos;
+ 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;
+ if (PL_parser->lex_shared->re_eval_start)
+ PL_parser->lex_shared->re_eval_start =
+ buf + re_eval_start_pos;
+ s = buf + s_pos;
+ }
+ ns = SvPVX_const(PL_linestr) + offset;
+ svlast = SvEND(sv) - 1;
for (; s < ns; s++) {
if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
https://perl5.git.perl.org / perl5.git / blobdiff