/*
=head1 Lexer interface
-
This is the lower layer of the Perl parser, managing characters and tokens.
=for apidoc AmU|yy_parser *|PL_parser
#define PL_multi_end (PL_parser->multi_end)
#define PL_error_count (PL_parser->error_count)
-#ifdef PERL_MAD
-# define PL_endwhite (PL_parser->endwhite)
-# define PL_faketokens (PL_parser->faketokens)
-# define PL_lasttoke (PL_parser->lasttoke)
-# define PL_nextwhite (PL_parser->nextwhite)
-# define PL_realtokenstart (PL_parser->realtokenstart)
-# define PL_skipwhite (PL_parser->skipwhite)
-# define PL_thisclose (PL_parser->thisclose)
-# define PL_thismad (PL_parser->thismad)
-# define PL_thisopen (PL_parser->thisopen)
-# define PL_thisstuff (PL_parser->thisstuff)
-# define PL_thistoken (PL_parser->thistoken)
-# define PL_thiswhite (PL_parser->thiswhite)
-# define PL_thiswhite (PL_parser->thiswhite)
-# define PL_nexttoke (PL_parser->nexttoke)
-# define PL_curforce (PL_parser->curforce)
-#else
# define PL_nexttoke (PL_parser->nexttoke)
# define PL_nexttype (PL_parser->nexttype)
# define PL_nextval (PL_parser->nextval)
-#endif
static const char* const ident_too_long = "Identifier too long";
-#ifdef PERL_MAD
-# define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
-# define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
-#else
-# define CURMAD(slot,sv)
# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
-#endif
#define XENUMMASK 0x3f
#define XFAKEEOF 0x40
};
#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
-# define SKIPSPACE0(s) skipspace0(s)
-# define SKIPSPACE1(s) skipspace1(s)
-# define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
-# define PEEKSPACE(s) skipspace2(s,0)
-#else
# define SKIPSPACE0(s) skipspace(s)
# define SKIPSPACE1(s) skipspace(s)
# define SKIPSPACE2(s,tsv) skipspace(s)
# define PEEKSPACE(s) skipspace(s)
-#endif
/*
* Convenience functions to return different tokens and prime the
* 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
{ OROP, TOKENTYPE_IVAL, "OROP" },
{ OROR, TOKENTYPE_NONE, "OROR" },
{ PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
- { PEG, TOKENTYPE_NONE, "PEG" },
{ PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
{ PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
+ { 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);
}
STATIC int
S_ao(pTHX_ int toketype)
{
- dVAR;
if (*PL_bufptr == '=') {
PL_bufptr++;
if (toketype == ANDAND)
STATIC void
S_no_op(pTHX_ const char *const what, char *s)
{
- dVAR;
char * const oldbp = PL_bufptr;
const bool is_first = (PL_oldbufptr == PL_linestart);
STATIC void
S_missingterm(pTHX_ char *s)
{
- dVAR;
char tmpbuf[3];
char q;
if (s) {
bool
Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
{
- dVAR;
char he_name[8 + MAX_FEATURE_LEN] = "feature_";
PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
void
Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
{
- dVAR;
const char *s = NULL;
yy_parser *parser, *oparser;
if (flags && flags & ~LEX_START_FLAGS)
/* initialise lexer state */
-#ifdef PERL_MAD
- parser->curforce = -1;
-#else
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;
}
void
Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
{
-#ifdef PERL_MAD
- I32 nexttoke = parser->lasttoke;
-#else
I32 nexttoke = parser->nexttoke;
-#endif
PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
while (nexttoke--) {
-#ifdef PERL_MAD
- if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
- & 0xffff)
- && parser->nexttoke[nexttoke].next_val.opval
- && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
- && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
- op_free(parser->nexttoke[nexttoke].next_val.opval);
- parser->nexttoke[nexttoke].next_val.opval = NULL;
- }
-#else
if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
&& parser->nextval[nexttoke].opval
&& parser->nextval[nexttoke].opval->op_slabbed
op_free(parser->nextval[nexttoke].opval);
parser->nextval[nexttoke].opval = NULL;
}
-#endif
}
}
Direct pointer to the end of the chunk of text currently being lexed, the
end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
-+ SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
++ SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
always located at the end of the buffer, and does not count as part of
the buffer's contents.
=for apidoc Amx|char *|lex_grow_linestr|STRLEN len
Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
-at least I<len> octets (including terminating NUL). Returns a
+at least I<len> octets (including terminating C<NUL>). Returns a
pointer to the reallocated buffer. This is necessary before making
any direct modification of the buffer that would increase its length.
L</lex_stuff_pvn> provides a more convenient way to insert text into
(void)PerlIO_close(PL_parser->rsfp);
PL_parser->rsfp = NULL;
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;
-#endif
if (!PL_in_eval && PL_minus_p) {
sv_catpvs(linestr,
/*{*/";}continue{print or die qq(-p destination: $!\\n);}");
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,
bool need_incline = 0;
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) {
- sv_free(PL_skipwhite);
- PL_skipwhite = NULL;
- }
- if (PL_madskills)
- PL_skipwhite = newSVpvs("");
-#endif /* PERL_MAD */
s = PL_parser->bufptr;
bufend = PL_parser->bufend;
while (1) {
} 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);
-#endif /* PERL_MAD */
if (flags & LEX_NO_NEXT_CHUNK)
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;
break;
}
}
-#ifdef PERL_MAD
- if (PL_madskills)
- sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
-#endif /* PERL_MAD */
PL_parser->bufptr = s;
}
STATIC void
S_incline(pTHX_ const char *s)
{
- dVAR;
const char *t;
const char *n;
const char *e;
#define skipspace(s) skipspace_flags(s, 0)
-#ifdef PERL_MAD
-/* skip space before PL_thistoken */
-
-STATIC char *
-S_skipspace0(pTHX_ char *s)
-{
- PERL_ARGS_ASSERT_SKIPSPACE0;
-
- s = skipspace(s);
- if (!PL_madskills)
- return s;
- if (PL_skipwhite) {
- if (!PL_thiswhite)
- PL_thiswhite = newSVpvs("");
- sv_catsv(PL_thiswhite, PL_skipwhite);
- sv_free(PL_skipwhite);
- PL_skipwhite = 0;
- }
- PL_realtokenstart = s - SvPVX(PL_linestr);
- return s;
-}
-
-/* skip space after PL_thistoken */
-
-STATIC char *
-S_skipspace1(pTHX_ char *s)
-{
- const char *start = s;
- I32 startoff = start - SvPVX(PL_linestr);
-
- PERL_ARGS_ASSERT_SKIPSPACE1;
-
- s = skipspace(s);
- if (!PL_madskills)
- return s;
- start = SvPVX(PL_linestr) + startoff;
- if (!PL_thistoken && PL_realtokenstart >= 0) {
- const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
- PL_thistoken = newSVpvn(tstart, start - tstart);
- }
- PL_realtokenstart = -1;
- if (PL_skipwhite) {
- if (!PL_nextwhite)
- PL_nextwhite = newSVpvs("");
- sv_catsv(PL_nextwhite, PL_skipwhite);
- sv_free(PL_skipwhite);
- PL_skipwhite = 0;
- }
- return s;
-}
-
-STATIC char *
-S_skipspace2(pTHX_ char *s, SV **svp)
-{
- char *start;
- const I32 startoff = s - SvPVX(PL_linestr);
-
- PERL_ARGS_ASSERT_SKIPSPACE2;
-
- s = skipspace(s);
- if (!PL_madskills || !svp)
- return s;
- start = SvPVX(PL_linestr) + startoff;
- if (!PL_thistoken && PL_realtokenstart >= 0) {
- char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
- PL_thistoken = newSVpvn(tstart, start - tstart);
- PL_realtokenstart = -1;
- }
- if (PL_skipwhite) {
- if (!*svp)
- *svp = newSVpvs("");
- sv_setsv(*svp, PL_skipwhite);
- sv_free(PL_skipwhite);
- PL_skipwhite = 0;
- }
-
- return s;
-}
-#endif
STATIC void
S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
{
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);
}
}
STATIC char *
S_skipspace_flags(pTHX_ char *s, U32 flags)
{
-#ifdef PERL_MAD
- char *start = s;
-#endif /* PERL_MAD */
PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
-#ifdef PERL_MAD
- if (PL_skipwhite) {
- sv_free(PL_skipwhite);
- PL_skipwhite = NULL;
- }
-#endif /* PERL_MAD */
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
PL_bufptr = PL_linestart;
return s;
}
-#ifdef PERL_MAD
- if (PL_madskills)
- PL_skipwhite = newSVpvn(start, s-start);
-#endif /* PERL_MAD */
return s;
}
STATIC void
S_check_uni(pTHX)
{
- dVAR;
const char *s;
const char *t;
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
- dVAR;
-
PERL_ARGS_ASSERT_LOP;
pl_yylval.ival = f;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = (OPCODE)f;
-#ifdef PERL_MAD
- if (PL_lasttoke)
- goto lstop;
-#else
if (PL_nexttoke)
goto lstop;
-#endif
if (*s == '(')
return REPORT(FUNC);
s = PEEKSPACE(s);
}
}
-#ifdef PERL_MAD
- /*
- * S_start_force
- * Sets up for an eventual force_next(). start_force(0) basically does
- * an unshift, while start_force(-1) does a push. yylex removes items
- * on the "pop" end.
- */
-
-STATIC void
-S_start_force(pTHX_ int where)
-{
- int i;
-
- if (where < 0) /* so people can duplicate start_force(PL_curforce) */
- where = PL_lasttoke;
- assert(PL_curforce < 0 || PL_curforce == where);
- if (PL_curforce != where) {
- for (i = PL_lasttoke; i > where; --i) {
- PL_nexttoke[i] = PL_nexttoke[i-1];
- }
- PL_lasttoke++;
- }
- if (PL_curforce < 0) /* in case of duplicate start_force() */
- Zero(&PL_nexttoke[where], 1, NEXTTOKE);
- PL_curforce = where;
- if (PL_nextwhite) {
- if (PL_madskills)
- curmad('^', newSVpvs(""));
- CURMAD('_', PL_nextwhite);
- }
-}
-
-STATIC void
-S_curmad(pTHX_ char slot, SV *sv)
-{
- MADPROP **where;
-
- if (!sv)
- return;
- if (PL_curforce < 0)
- where = &PL_thismad;
- else
- where = &PL_nexttoke[PL_curforce].next_mad;
-
- if (PL_faketokens)
- sv_setpvs(sv, "");
- else {
- if (!IN_BYTES) {
- if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
- SvUTF8_on(sv);
- else if (PL_encoding) {
- sv_recode_to_utf8(sv, PL_encoding);
- }
- }
- }
-
- /* keep a slot open for the head of the list? */
- if (slot != '_' && *where && (*where)->mad_key == '^') {
- (*where)->mad_key = slot;
- sv_free(MUTABLE_SV(((*where)->mad_val)));
- (*where)->mad_val = (void*)sv;
- }
- else
- addmad(newMADsv(slot, sv), where, 0);
-}
-#else
-# define start_force(where) NOOP
-# define curmad(slot, sv) NOOP
-#endif
-
/*
* S_force_next
* When the lexer realizes it knows the next token (for instance,
* it is reordering tokens for the parser) then it can call S_force_next
* to know what token to return the next time the lexer is called. Caller
- * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
- * and possibly PL_expect to ensure the lexer handles the token correctly.
+ * will need to set PL_nextval[] and possibly PL_expect to ensure
+ * the lexer handles the token correctly.
*/
STATIC void
S_force_next(pTHX_ I32 type)
{
- dVAR;
#ifdef DEBUGGING
if (DEBUG_T_TEST) {
PerlIO_printf(Perl_debug_log, "### forced token:\n");
tokereport(type, &NEXTVAL_NEXTTOKE);
}
#endif
-#ifdef PERL_MAD
- if (PL_curforce < 0)
- start_force(PL_lasttoke);
- PL_nexttoke[PL_curforce].next_type = type;
- if (PL_lex_state != LEX_KNOWNEXT)
- PL_lex_defer = PL_lex_state;
- PL_lex_state = LEX_KNOWNEXT;
- PL_lex_expect = PL_expect;
- PL_curforce = -1;
-#else
PL_nexttype[PL_nexttoke] = type;
PL_nexttoke++;
if (PL_lex_state != LEX_KNOWNEXT) {
PL_lex_expect = PL_expect;
PL_lex_state = LEX_KNOWNEXT;
}
-#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)
+{
+ 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;
+ force_next(POSTJOIN);
+ }
+ 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
int yyc = PL_parser->yychar;
if (yyc != YYEMPTY) {
if (yyc) {
- start_force(-1);
NEXTVAL_NEXTTOKE = PL_parser->yylval;
if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
PL_lex_allbrackets--;
STATIC SV *
S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
{
- dVAR;
SV * const sv = newSVpvn_utf8(start, len,
!IN_BYTES
&& UTF
STATIC char *
S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
{
- dVAR;
char *s;
STRLEN len;
if (keyword(s2, len, 0))
return start;
}
- start_force(PL_curforce);
- if (PL_madskills)
- curmad('X', newSVpvn(start,s-start));
if (token == METHOD) {
s = SKIPSPACE1(s);
if (*s == '(')
PL_expect = XOPERATOR;
}
}
- if (PL_madskills)
- curmad('g', newSVpvs( "forced" ));
NEXTVAL_NEXTTOKE.opval
= (OP*)newSVOP(OP_CONST,0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
STATIC void
S_force_ident(pTHX_ const char *s, int kind)
{
- dVAR;
-
PERL_ARGS_ASSERT_FORCE_IDENT;
if (s[0]) {
const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
UTF ? SVf_UTF8 : 0));
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = o;
force_next(WORD);
if (kind) {
static void
S_force_ident_maybe_lex(pTHX_ char pit)
{
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = pit;
force_next('p');
}
STATIC char *
S_force_version(pTHX_ char *s, int guessing)
{
- dVAR;
OP *version = NULL;
char *d;
-#ifdef PERL_MAD
- I32 startoff = s - SvPVX(PL_linestr);
-#endif
PERL_ARGS_ASSERT_FORCE_VERSION;
if (isDIGIT(*d)) {
while (isDIGIT(*d) || *d == '_' || *d == '.')
d++;
-#ifdef PERL_MAD
- if (PL_madskills) {
- start_force(PL_curforce);
- curmad('X', newSVpvn(s,d-s));
- }
-#endif
if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
SV *ver;
-#ifdef USE_LOCALE_NUMERIC
- 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;
if (SvPOK(ver) && !SvNIOK(ver)) {
}
}
else if (guessing) {
-#ifdef PERL_MAD
- if (PL_madskills) {
- sv_free(PL_nextwhite); /* let next token collect whitespace */
- PL_nextwhite = 0;
- s = SvPVX(PL_linestr) + startoff;
- }
-#endif
return s;
}
}
-#ifdef PERL_MAD
- if (PL_madskills && !version) {
- sv_free(PL_nextwhite); /* let next token collect whitespace */
- PL_nextwhite = 0;
- s = SvPVX(PL_linestr) + startoff;
- }
-#endif
/* NOTE: The parser sees the package name and the VERSION swapped */
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = version;
force_next(WORD);
STATIC char *
S_force_strict_version(pTHX_ char *s)
{
- dVAR;
OP *version = NULL;
-#ifdef PERL_MAD
- I32 startoff = s - SvPVX(PL_linestr);
-#endif
const char *errstr = NULL;
PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
return s;
}
-#ifdef PERL_MAD
- if (PL_madskills && !version) {
- sv_free(PL_nextwhite); /* let next token collect whitespace */
- PL_nextwhite = 0;
- s = SvPVX(PL_linestr) + startoff;
- }
-#endif
/* NOTE: The parser sees the package name and the VERSION swapped */
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = version;
force_next(WORD);
STATIC SV *
S_tokeq(pTHX_ SV *sv)
{
- dVAR;
char *s;
char *send;
char *d;
- STRLEN len = 0;
SV *pv = sv;
PERL_ARGS_ASSERT_TOKEQ;
- if (!SvLEN(sv))
+ assert (SvPOK(sv));
+ assert (SvLEN(sv));
+ assert (!SvIsCOW(sv));
+ if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
goto finish;
-
- s = SvPV_force(sv, len);
- if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
- 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 == '\\') {
STATIC I32
S_sublex_start(pTHX)
{
- dVAR;
const I32 op_type = pl_yylval.ival;
if (op_type == OP_NULL) {
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;
}
STATIC I32
S_sublex_push(pTHX)
{
- 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;
STATIC I32
S_sublex_done(pTHX)
{
- dVAR;
if (!PL_lex_starts++) {
SV * const sv = newSVpvs("");
if (SvUTF8(PL_linestr))
/* 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 {
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (PL_thiswhite) {
- if (!PL_endwhite)
- PL_endwhite = newSVpvs("");
- sv_catsv(PL_endwhite, PL_thiswhite);
- PL_thiswhite = 0;
- }
- if (PL_thistoken)
- sv_setpvs(PL_thistoken,"");
- else
- PL_realtokenstart = -1;
- }
-#endif
+ const line_t l = CopLINE(PL_curcop);
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;
}
}
* look to see that the first character is legal. Then loop through the
* rest checking that each is a continuation */
- /* This code needs to be sync'ed with a regex in _charnames.pm which does
- * the same thing */
+ /* This code makes the reasonable assumption that the only Latin1-range
+ * characters that begin a character name alias are alphabetic, otherwise
+ * would have to create a isCHARNAME_BEGIN macro */
if (! UTF) {
if (! isALPHAU(*s)) {
if (! isCHARNAME_CONT(*s)) {
goto bad_charname;
}
- if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
+ if (*s == ' ' && *(s-1) == ' ') {
+ goto multi_spaces;
+ }
+ if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "A sequence of multiple spaces in a charnames "
+ "NO-BREAK SPACE in a charnames "
"alias definition is deprecated");
}
s++;
}
- if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Trailing white-space in a charnames alias "
- "definition is deprecated");
- }
}
else {
/* Similarly for utf8. For invariants can check directly; for other
if (! isCHARNAME_CONT(*s)) {
goto bad_charname;
}
- if (*s == ' ' && *(s-1) == ' '
- && ckWARN_d(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "A sequence of multiple spaces in a charnam"
- "es alias definition is deprecated");
+ if (*s == ' ' && *(s-1) == ' ') {
+ goto multi_spaces;
}
s++;
}
{
goto bad_charname;
}
+ if (*s == *NBSP_UTF8
+ && *(s+1) == *(NBSP_UTF8+1)
+ && ckWARN_d(WARN_DEPRECATED))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "NO-BREAK SPACE in a charnames "
+ "alias definition is deprecated");
+ }
s += 2;
}
else {
s += UTF8SKIP(s);
}
}
- if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Trailing white-space in a charnames alias "
- "definition is deprecated");
- }
+ }
+ if (*(s-1) == ' ') {
+ yyerror_pv(
+ Perl_form(aTHX_
+ "charnames alias definitions may not contain trailing "
+ "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
+ (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(e - s + 1), s + 1
+ ),
+ UTF ? SVf_UTF8 : 0);
+ return NULL;
}
if (SvUTF8(res)) { /* Don't accept malformed input */
return res;
bad_charname: {
- int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
/* The final %.*s makes sure that should the trailing NUL be missing
* that this print won't run off the end of the string */
yyerror_pv(
Perl_form(aTHX_
"Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
- (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
- (int)(e - s + bad_char_size), s + bad_char_size
+ (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(e - s + 1), s + 1
),
UTF ? SVf_UTF8 : 0);
return NULL;
}
+
+ multi_spaces:
+ yyerror_pv(
+ Perl_form(aTHX_
+ "charnames alias definitions may not contain a sequence of "
+ "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
+ (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(e - s + 1), s + 1
+ ),
+ UTF ? SVf_UTF8 : 0);
+ return NULL;
}
/*
STATIC char *
S_scan_const(pTHX_ char *start)
{
- dVAR;
char *send = PL_bufend; /* end of the constant */
SV *sv = newSV(send - start); /* sv for the constant. See
note below on sizing. */
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;
else if (PL_lex_inpat
&& (*s != 'N'
|| s[1] != '{'
- || regcurly(s + 1, FALSE)))
+ || regcurly(s + 1)))
{
*d++ = '\\';
goto default_action;
*d++ = *s++;
continue;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
{
if ((isALPHANUMERIC(*s)))
* 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;
}
d += 5;
while (str < str_end) {
char hex_string[4];
- my_snprintf(hex_string, sizeof(hex_string),
- "%02X.", (U8) *str);
+ int len =
+ my_snprintf(hex_string,
+ sizeof(hex_string),
+ "%02X.", (U8) *str);
+ PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
Copy(hex_string, d, 3, char);
d += 3;
str++;
const STRLEN off = d - SvPVX_const(sv);
d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
}
+ if (! SvUTF8(res)) { /* Make sure is \N{} return is UTF-8 */
+ sv_utf8_upgrade(res);
+ str = SvPV_const(res, len);
+ }
Copy(str, d, len, char);
d += len;
}
case 'c':
s++;
if (s < send) {
- *d++ = grok_bslash_c(*s++, has_utf8, 1);
+ *d++ = grok_bslash_c(*s++, 1);
}
else {
yyerror("Missing control char name in \\c");
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;
}
/* return the substring (via pl_yylval) only if we parsed anything */
- if (s > PL_bufptr) {
- char *s2 = PL_bufptr;
+ if (s > start) {
+ char *s2 = start;
for (; s2 < s; s2++) {
if (*s2 == '\n')
COPLINE_INC_WITH_HERELINES;
* 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 {
STATIC int
S_intuit_more(pTHX_ char *s)
{
- dVAR;
-
PERL_ARGS_ASSERT_INTUIT_MORE;
if (PL_lex_brackets)
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)
/* In a pattern, so maybe we have {n,m}. */
if (*s == '{') {
- if (regcurly(s, FALSE)) {
+ if (regcurly(s)) {
return FALSE;
}
return TRUE;
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))
STATIC int
S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
{
- dVAR;
char *s = start + (*start == '$');
char tmpbuf[sizeof PL_tokenbuf];
STRLEN len;
GV* indirgv;
-#ifdef PERL_MAD
- int soff;
-#endif
PERL_ARGS_ASSERT_INTUIT_METHOD;
if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
isUPPER(*PL_tokenbuf))
return 0;
-#ifdef PERL_MAD
- len = start - SvPVX(PL_linestr);
-#endif
s = PEEKSPACE(s);
-#ifdef PERL_MAD
- start = SvPVX(PL_linestr) + len;
-#endif
PL_bufptr = start;
PL_expect = XREF;
return *s == '(' ? FUNCMETH : METHOD;
if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
len -= 2;
tmpbuf[len] = '\0';
-#ifdef PERL_MAD
- soff = s - SvPVX(PL_linestr);
-#endif
goto bare_package;
}
indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
return 0;
/* filehandle or package name makes it a method */
if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
-#ifdef PERL_MAD
- soff = s - SvPVX(PL_linestr);
-#endif
s = PEEKSPACE(s);
if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
return 0; /* no assumptions -- "=>" quotes bareword */
bare_package:
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
- if (PL_madskills)
- curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
- ( UTF ? SVf_UTF8 : 0 )));
PL_expect = XTERM;
force_next(WORD);
PL_bufptr = s;
-#ifdef PERL_MAD
- PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
-#endif
return *s == '(' ? FUNCMETH : METHOD;
}
}
SV *
Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
{
- dVAR;
if (!funcp)
return NULL;
void
Perl_filter_del(pTHX_ filter_t funcp)
{
- dVAR;
SV *datasv;
PERL_ARGS_ASSERT_FILTER_DEL;
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- dVAR;
filter_t funcp;
SV *datasv = NULL;
/* 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;
STATIC char *
S_filter_gets(pTHX_ SV *sv, STRLEN append)
{
- dVAR;
-
PERL_ARGS_ASSERT_FILTER_GETS;
#ifdef PERL_CR_FILTER
STATIC HV *
S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
{
- dVAR;
GV *gv;
PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
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
- * The intent of this yylex wrapper is to minimize the changes to the
- * tokener when we aren't interested in collecting madprops. It remains
- * to be seen how successful this strategy will be...
- */
-
-int
-Perl_madlex(pTHX)
-{
- int optype;
- char *s = PL_bufptr;
-
- /* make sure PL_thiswhite is initialized */
- PL_thiswhite = 0;
- PL_thismad = 0;
-
- /* previous token ate up our whitespace? */
- if (!PL_lasttoke && PL_nextwhite) {
- PL_thiswhite = PL_nextwhite;
- PL_nextwhite = 0;
- }
-
- /* isolate the token, and figure out where it is without whitespace */
- PL_realtokenstart = -1;
- PL_thistoken = 0;
- optype = yylex();
- s = PL_bufptr;
- assert(PL_curforce < 0);
-
- if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
- if (!PL_thistoken) {
- if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
- PL_thistoken = newSVpvs("");
- else {
- char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
- PL_thistoken = newSVpvn(tstart, s - tstart);
- }
- }
- if (PL_thismad) /* install head */
- CURMAD('X', PL_thistoken);
- }
-
- /* last whitespace of a sublex? */
- if (optype == ')' && PL_endwhite) {
- CURMAD('X', PL_endwhite);
- }
-
- if (!PL_thismad) {
-
- /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
- if (!PL_thiswhite && !PL_endwhite && !optype) {
- sv_free(PL_thistoken);
- PL_thistoken = 0;
- return 0;
- }
-
- /* put off final whitespace till peg */
- if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
- PL_nextwhite = PL_thiswhite;
- PL_thiswhite = 0;
- }
- else if (PL_thisopen) {
- CURMAD('q', PL_thisopen);
- if (PL_thistoken)
- sv_free(PL_thistoken);
- PL_thistoken = 0;
- }
- else {
- /* Store actual token text as madprop X */
- CURMAD('X', PL_thistoken);
- }
-
- if (PL_thiswhite) {
- /* add preceding whitespace as madprop _ */
- CURMAD('_', PL_thiswhite);
- }
-
- if (PL_thisstuff) {
- /* add quoted material as madprop = */
- CURMAD('=', PL_thisstuff);
- }
-
- if (PL_thisclose) {
- /* add terminating quote as madprop Q */
- CURMAD('Q', PL_thisclose);
- }
- }
-
- /* special processing based on optype */
-
- switch (optype) {
-
- /* opval doesn't need a TOKEN since it can already store mp */
- case WORD:
- case METHOD:
- case FUNCMETH:
- case THING:
- case PMFUNC:
- case PRIVATEREF:
- case FUNC0SUB:
- case UNIOPSUB:
- case LSTOPSUB:
- if (pl_yylval.opval)
- append_madprops(PL_thismad, pl_yylval.opval, 0);
- PL_thismad = 0;
- return optype;
-
- /* fake EOF */
- case 0:
- optype = PEG;
- if (PL_endwhite) {
- addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
- PL_endwhite = 0;
- }
- break;
-
- /* pval */
- case LABEL:
- break;
-
- case ']':
- case '}':
- if (PL_faketokens)
- break;
- /* remember any fake bracket that lexer is about to discard */
- if (PL_lex_brackets == 1 &&
- ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
- {
- s = PL_bufptr;
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
- s++;
- if (*s == '}') {
- PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
- addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
- PL_thiswhite = 0;
- PL_bufptr = s - 1;
- break; /* don't bother looking for trailing comment */
- }
- else
- s = PL_bufptr;
- }
- if (optype == ']')
- break;
- /* FALLTHROUGH */
-
- /* attach a trailing comment to its statement instead of next token */
- case ';':
- if (PL_faketokens)
- break;
- if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
- s = PL_bufptr;
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
- s++;
- if (*s == '\n' || *s == '#') {
- while (s < PL_bufend && *s != '\n')
- s++;
- if (s < PL_bufend)
- s++;
- PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
- addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
- PL_thiswhite = 0;
- PL_bufptr = s;
- }
- }
- break;
-
- /* ival */
- default:
- break;
-
- }
-
- /* Create new token struct. Note: opvals return early above. */
- pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
- PL_thismad = 0;
- return optype;
-}
-#endif
STATIC char *
S_tokenize_use(pTHX_ int is_use, char *s) {
- dVAR;
-
PERL_ARGS_ASSERT_TOKENIZE_USE;
if (PL_expect != XSTATE)
s = force_version(s, TRUE);
if (*s == ';' || *s == '}'
|| (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = NULL;
force_next(WORD);
}
#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:
-#ifdef PERL_MAD
- PL_lasttoke--;
- pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
- if (PL_madskills) {
- PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
- PL_nexttoke[PL_lasttoke].next_mad = 0;
- if (PL_thismad && PL_thismad->mad_key == '_') {
- PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
- PL_thismad->mad_val = 0;
- mad_free(PL_thismad);
- PL_thismad = 0;
- }
- }
- if (!PL_lasttoke) {
- PL_lex_state = PL_lex_defer;
- PL_expect = PL_lex_expect;
- PL_lex_defer = LEX_NORMAL;
- if (!PL_nexttoke[PL_lasttoke].next_type)
- return yylex();
- }
-#else
PL_nexttoke--;
pl_yylval = PL_nextval[PL_nexttoke];
if (!PL_nexttoke) {
PL_expect = PL_lex_expect;
PL_lex_defer = LEX_NORMAL;
}
-#endif
{
I32 next_type;
-#ifdef PERL_MAD
- next_type = PL_nexttoke[PL_lasttoke].next_type;
-#else
next_type = PL_nexttype[PL_nexttoke];
-#endif
if (next_type & (7<<24)) {
if (next_type & (1<<24)) {
if (PL_lex_brackets > 100)
|| oldmod == 'F')) {
PL_bufptr += 2;
PL_lex_state = LEX_INTERPCONCAT;
-#ifdef PERL_MAD
- if (PL_madskills)
- PL_thistoken = newSVpvs("\\E");
-#endif
}
PL_lex_allbrackets--;
return REPORT(')');
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) {
- if (!PL_thiswhite)
- PL_thiswhite = newSVpvs("");
- sv_catpvn(PL_thiswhite, PL_bufptr, 2);
- }
- PL_bufptr += 2;
- }
-#else
if (PL_bufptr != PL_bufend)
PL_bufptr += 2;
-#endif
PL_lex_state = LEX_INTERPCONCAT;
return yylex();
}
"### Saw case modifier\n"); });
s = PL_bufptr + 1;
if (s[1] == '\\' && s[2] == 'E') {
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (!PL_thiswhite)
- PL_thiswhite = newSVpvs("");
- sv_catpvn(PL_thiswhite, PL_bufptr, 4);
- }
-#endif
PL_bufptr = s + 3;
PL_lex_state = LEX_INTERPCONCAT;
return yylex();
}
else {
I32 tmp;
- 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 (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' || *s == 'F') &&
(strchr(PL_lex_casestack, 'L')
|| strchr(PL_lex_casestack, 'U')
PL_lex_casestack[PL_lex_casemods++] = *s;
PL_lex_casestack[PL_lex_casemods] = '\0';
PL_lex_state = LEX_INTERPCONCAT;
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next((2<<24)|'(');
- start_force(PL_curforce);
if (*s == 'l')
NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
else if (*s == 'u')
NEXTVAL_NEXTTOKE.ival = OP_FC;
else
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
- */
- SvPVX(tmpsv)[1] = *s;
- curmad('_', tmpsv);
- }
PL_bufptr = s + 1;
}
force_next(FUNC);
if (PL_lex_starts) {
s = PL_bufptr;
PL_lex_starts = 0;
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (PL_thistoken)
- sv_free(PL_thistoken);
- PL_thistoken = newSVpvs("");
- }
-#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_lex_casemods == 1 && PL_lex_inpat)
OPERATOR(',');
&& (!PL_lex_inpat || PL_lex_casemods));
PL_lex_state = LEX_INTERPNORMAL;
if (PL_lex_dojoin) {
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next(',');
- start_force(PL_curforce);
force_ident("\"", '$');
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next('$');
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next((2<<24)|'(');
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
}
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
- if (PL_madskills) {
- if (PL_thistoken)
- sv_free(PL_thistoken);
- PL_thistoken = newSVpvs("");
- }
-#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
OPERATOR(',');
PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
break;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
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
- if (PL_madskills) {
- if (PL_thistoken)
- sv_free(PL_thistoken);
- PL_thistoken = newSVpvs("");
- }
-#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))
}
else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
PL_bufptr - PL_parser->lex_shared->re_eval_start);
- start_force(PL_curforce);
- /* XXX probably need a CURMAD(something) here */
NEXTVAL_NEXTTOKE.opval =
(OP*)newSVOP(OP_CONST, 0,
sv);
}
if (s != PL_bufptr) {
- start_force(PL_curforce);
- if (PL_madskills) {
- curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
- }
NEXTVAL_NEXTTOKE = pl_yylval;
PL_expect = XTERM;
force_next(THING);
if (PL_lex_starts++) {
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (PL_thistoken)
- sv_free(PL_thistoken);
- PL_thistoken = newSVpvs("");
- }
-#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
OPERATOR(',');
PL_parser->saw_infix_sigil = 0;
retry:
-#ifdef PERL_MAD
- if (PL_thistoken) {
- sv_free(PL_thistoken);
- PL_thistoken = 0;
- }
- PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
-#endif
switch (*s) {
default:
if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
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;
+ d = UTF ? (char *) utf8_hop((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:
goto fake_eof; /* emulate EOF on ^D or ^Z */
case 0:
-#ifdef PERL_MAD
- if (PL_madskills)
- PL_faketokens = 0;
-#endif
if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
PL_last_uni = 0;
PL_last_lop = 0;
PL_last_lop = 0;
if (!PL_in_eval && !PL_preambled) {
PL_preambled = TRUE;
-#ifdef PERL_MAD
- if (PL_madskills)
- PL_faketokens = 1;
-#endif
if (PL_perldb) {
/* Generate a string of Perl code to load the debugger.
* If PERL5DB is set, it will return the contents of that,
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) {
TOKEN(';'); /* not infinite loop because rsfp is NULL now */
}
CopLINE_dec(PL_curcop);
-#ifdef PERL_MAD
- if (!PL_rsfp)
- PL_realtokenstart = -1;
-#endif
s = PL_bufptr;
/* If it looks like the start of a BOM or raw UTF-16,
* check if it in fact is. */
}
if (PL_parser->in_pod) {
/* Incest with pod. */
-#ifdef PERL_MAD
- if (PL_madskills)
- sv_catsv(PL_thiswhite, PL_linestr);
-#endif
if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
sv_setpvs(PL_linestr, "");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
s++;
if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
s++;
-#ifdef PERL_MAD
- if (PL_madskills)
- PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
-#endif
d = NULL;
if (!PL_in_eval) {
if (*s == '#' && *(s+1) == '!')
* at least, set argv[0] to the basename of the Perl
* interpreter. So, having found "#!", we'll set it right.
*/
- SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
- SVt_PV)); /* $^X */
- assert(SvPOK(x) || SvGMAGICAL(x));
- if (sv_eq(x, CopFILESV(PL_curcop))) {
- sv_setpvn(x, ipath, ipathend - ipath);
- SvSETMAGIC(x);
- }
- else {
- STRLEN blen;
- STRLEN llen;
- const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
- const char * const lstart = SvPV_const(x,llen);
- if (llen < blen) {
- bstart += blen - llen;
- if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
- sv_setpvn(x, ipath, ipathend - ipath);
- SvSETMAGIC(x);
- }
+ SV* copfilesv = CopFILESV(PL_curcop);
+ if (copfilesv) {
+ SV * const x =
+ GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
+ SVt_PV)); /* $^X */
+ assert(SvPOK(x) || SvGMAGICAL(x));
+ if (sv_eq(x, copfilesv)) {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ else {
+ STRLEN blen;
+ STRLEN llen;
+ const char *bstart = SvPV_const(copfilesv, blen);
+ const char * const lstart = SvPV_const(x, llen);
+ if (llen < blen) {
+ bstart += blen - llen;
+ if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ }
}
+ }
+ else {
+ /* Anything to do if no copfilesv? */
}
TAINT_NOT; /* $^X is always tainted, but that's OK */
}
}
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
PL_lex_state = LEX_FORMLINE;
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next(FORMRBRACK);
TOKEN(';');
"\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
#endif
case ' ': case '\t': case '\f': case 013:
-#ifdef PERL_MAD
- PL_realtokenstart = -1;
- if (PL_madskills) {
- if (!PL_thiswhite)
- PL_thiswhite = newSVpvs("");
- sv_catpvn(PL_thiswhite, s, 1);
- }
-#endif
s++;
goto retry;
case '#':
case '\n':
-#ifdef PERL_MAD
- PL_realtokenstart = -1;
- if (PL_madskills)
- PL_faketokens = 0;
-#endif
if (PL_lex_state != LEX_NORMAL ||
(PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
+ const bool in_comment = *s == '#';
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 || PL_parser->filtered)
- incline(s);
- }
- else {
- const bool in_comment = *s == '#';
- d = s;
- while (d < PL_bufend && *d != '\n')
- d++;
- if (d < PL_bufend)
- d++;
- else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
- Perl_croak(aTHX_ "panic: input overflow, %p > %p",
- d, PL_bufend);
-#ifdef PERL_MAD
- if (PL_madskills)
- PL_thiswhite = newSVpvn(s, d - s);
-#endif
- s = d;
- if (in_comment && d == PL_bufend
- && PL_lex_state == LEX_INTERPNORMAL
- && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
- && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
- else incline(s);
- }
+ d = s;
+ while (d < PL_bufend && *d != '\n')
+ d++;
+ if (d < PL_bufend)
+ d++;
+ else if (d > PL_bufend)
+ /* Found by Ilya: feed random input to Perl. */
+ Perl_croak(aTHX_ "panic: input overflow, %p > %p",
+ d, PL_bufend);
+ s = d;
+ if (in_comment && d == PL_bufend
+ && PL_lex_state == LEX_INTERPNORMAL
+ && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+ && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
+ else
+ incline(s);
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
PL_lex_state = LEX_FORMLINE;
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next(FORMRBRACK);
TOKEN(';');
}
}
else {
-#ifdef PERL_MAD
- if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
- if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
- PL_faketokens = 0;
- s = SKIPSPACE0(s);
- TOKEN(PEG); /* make sure any #! line is accessible */
- }
- s = SKIPSPACE0(s);
- }
- else {
-#endif
- if (PL_madskills) d = s;
- while (s < PL_bufend && *s != '\n')
- s++;
- if (s < PL_bufend)
- {
- s++;
- if (s < PL_bufend)
- incline(s);
- }
- else if (s > PL_bufend) /* Found by Ilya: feed random input to Perl. */
- Perl_croak(aTHX_ "panic: input overflow");
-#ifdef PERL_MAD
- if (PL_madskills && CopLINE(PL_curcop) >= 1) {
- if (!PL_thiswhite)
- PL_thiswhite = newSVpvs("");
- if (CopLINE(PL_curcop) == 1) {
- sv_setpvs(PL_thiswhite, "");
- PL_faketokens = 0;
- }
- sv_catpvn(PL_thiswhite, d, s - d);
- }
- }
-#endif
+ while (s < PL_bufend && *s != '\n')
+ s++;
+ if (s < PL_bufend)
+ {
+ s++;
+ if (s < PL_bufend)
+ incline(s);
+ }
+ else if (s > PL_bufend)
+ /* Found by Ilya: feed random input to Perl. */
+ Perl_croak(aTHX_ "panic: input overflow");
}
goto retry;
case '-':
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))
goto just_a_word_zero_gv;
}
s++;
+ {
+ OP *attrs;
+
switch (PL_expect) {
- OP *attrs;
-#ifdef PERL_MAD
- I32 stuffstart;
-#endif
case XOPERATOR:
if (!PL_in_my || PL_lex_state != LEX_NORMAL)
break;
case XATTRTERM:
PL_expect = XTERMBLOCK;
grabattrs:
-#ifdef PERL_MAD
- stuffstart = s - SvPVX(PL_linestr) - 1;
-#endif
s = PEEKSPACE(s);
attrs = NULL;
while (isIDFIRST_lazy_if(s,UTF)) {
}
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,NULL);
COPLINE_SET_FROM_MULTI_END;
if (!d) {
/* MUST advance bufptr here to avoid bogus
/* XXX losing whitespace on sequential attributes here */
}
{
- const char tmp
- = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
- if (*s != ';' && *s != '}' && *s != tmp
- && (tmp != '=' || *s != ')')) {
+ if (*s != ';' && *s != '}' &&
+ !(PL_expect == XOPERATOR
+ ? (*s == '=' || *s == ')')
+ : (*s == '{' || *s == '('))) {
const char q = ((*s == '\'') ? '"' : '\'');
/* If here for an expression, and parsed no attrs, back
off. */
- if (tmp == '=' && !attrs) {
+ if (PL_expect == XOPERATOR && !attrs) {
s = PL_bufptr;
break;
}
}
got_attrs:
if (attrs) {
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = attrs;
- CURMAD('_', PL_nextwhite);
force_next(THING);
}
-#ifdef PERL_MAD
- if (PL_madskills) {
- PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
- (s - SvPVX(PL_linestr)) - stuffstart);
- }
-#endif
TOKEN(COLONATTR);
}
+ }
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
s--;
TOKEN(0);
TOKEN(0);
s++;
if (PL_lex_brackets <= 0)
+ /* diag_listed_as: Unmatched right %s bracket */
yyerror("Unmatched right square bracket");
else
--PL_lex_brackets;
force_next('-');
}
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case XATTRBLOCK:
case XBLOCK:
PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
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];
PL_expect &= XENUMMASK;
PL_lex_state = LEX_INTERPEND;
PL_bufptr = s;
-#if 0
- if (PL_madskills) {
- if (!PL_thiswhite)
- PL_thiswhite = newSVpvs("");
- sv_catpvs(PL_thiswhite,"}");
- }
-#endif
return yylex(); /* ignore fake brackets */
}
if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
PL_bufptr = s;
return yylex(); /* ignore fake brackets */
}
- start_force(PL_curforce);
- if (PL_madskills) {
- curmad('X', newSVpvn(s-1,1));
- CURMAD('_', PL_thiswhite);
- }
force_next(formbrack ? '.' : '}');
if (formbrack) LEAVE;
-#ifdef PERL_MAD
- if (PL_madskills && !PL_thistoken)
- PL_thistoken = newSVpvs("");
-#endif
if (formbrack == 2) { /* means . where arguments were expected */
- start_force(PL_curforce);
force_next(';');
TOKEN(FORMRBRACK);
}
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;
}
goto retry;
}
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (!PL_thiswhite)
- PL_thiswhite = newSVpvs("");
- sv_catpvn(PL_thiswhite, PL_linestart,
- PL_bufend - PL_linestart);
- }
-#endif
s = PL_bufend;
PL_parser->in_pod = 1;
goto retry;
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('@');
case '/': /* may be division, defined-or, or pattern */
- if (PL_expect == XTERMORDORDOR && s[1] == '/') {
+ if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
if (!PL_lex_allbrackets && PL_lex_fakeeof >=
(s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
TOKEN(0);
s += 2;
AOPERATOR(DORDOR);
}
- case '?': /* may either be conditional or pattern */
- if (PL_expect == XOPERATOR) {
- char tmp = *s++;
- if(tmp == '?') {
- if (!PL_lex_allbrackets &&
- PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
- s--;
- TOKEN(0);
- }
- PL_lex_allbrackets++;
- OPERATOR('?');
- }
- else {
- tmp = *s++;
- if(tmp == '/') {
- /* A // operator. */
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN :
- LEX_FAKEEOF_LOGIC)) {
- s -= 2;
- TOKEN(0);
- }
- AOPERATOR(DORDOR);
- }
- else {
- s--;
- if (*s == '=' && !PL_lex_allbrackets &&
- PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
- s--;
- TOKEN(0);
- }
- Mop(OP_DIVIDE);
- }
- }
- }
- else {
- /* Disable warning on "study /blah/" */
- if (PL_oldoldbufptr == PL_last_uni
- && (*PL_last_uni != 's' || s - PL_last_uni < 5
- || memNE(PL_last_uni, "study", 5)
- || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
- ))
- check_uni();
- if (*s == '?')
- deprecate("?PATTERN? without explicit operator");
- s = scan_pat(s,OP_MATCH);
- TERM(sublex_start());
- }
+ else if (PL_expect == XOPERATOR) {
+ s++;
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
+ Mop(OP_DIVIDE);
+ }
+ else {
+ /* Disable warning on "study /blah/" */
+ if (PL_oldoldbufptr == PL_last_uni
+ && (*PL_last_uni != 's' || s - PL_last_uni < 5
+ || memNE(PL_last_uni, "study", 5)
+ || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
+ ))
+ check_uni();
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
+ }
+
+ case '?': /* conditional */
+ s++;
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
+ s--;
+ TOKEN(0);
+ }
+ PL_lex_allbrackets++;
+ OPERATOR('?');
case '.':
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
}
Aop(OP_CONCAT);
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
s = scan_num(s, &pl_yylval);
TERM(THING);
case '\'':
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL);
COPLINE_SET_FROM_MULTI_END;
DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
else
no_op("String",s);
}
- if (!s)
- missingterm(NULL);
pl_yylval.ival = OP_CONST;
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,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,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 &",
lastchar && PL_bufptr - 2 >= PL_linestart
? PL_bufptr[-2]
: 0;
-#ifdef PERL_MAD
- SV *nextPL_nextwhite = 0;
-#endif
/* Get the rest if it looks like a package qualifier */
in which case Foo is a bareword
(and a package name). */
- if (len > 2 && !PL_madskills &&
+ if (len > 2 &&
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
if (ckWARN(WARN_BAREWORD)
SvREFCNT_dec(tmp_sv);
}
-#ifdef PERL_MAD
- if (PL_madskills && !PL_thistoken) {
- char *start = SvPVX(PL_linestr) + PL_realtokenstart;
- PL_thistoken = newSVpvn(start,s - start);
- PL_realtokenstart = s - SvPVX(PL_linestr);
- }
-#endif
/* Presume this is going to be a bareword of some sort. */
CLINE;
/* (Now we can afford to cross potential line boundary.) */
s = SKIPSPACE2(s,nextPL_nextwhite);
-#ifdef PERL_MAD
- PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
-#endif
/* Two barewords in a row may indicate method call. */
}
PL_expect = XOPERATOR;
-#ifdef PERL_MAD
- if (isSPACE(*s))
- s = SKIPSPACE2(s,nextPL_nextwhite);
- PL_nextwhite = nextPL_nextwhite;
-#else
s = skipspace(s);
-#endif
/* Is this a word before a => operator? */
if (*s == '=' && s[1] == '>' && !pkgname) {
goto its_constant;
}
}
-#ifdef PERL_MAD
- if (PL_madskills) {
- PL_nextwhite = PL_thiswhite;
- PL_thiswhite = 0;
- }
- start_force(PL_curforce);
-#endif
NEXTVAL_NEXTTOKE.opval =
off ? rv2cv_op : pl_yylval.opval;
PL_expect = XOPERATOR;
-#ifdef PERL_MAD
- if (PL_madskills) {
- PL_nextwhite = nextPL_nextwhite;
- curmad('X', PL_thistoken);
- PL_thistoken = newSVpvs("");
- }
-#endif
if (off)
op_free(pl_yylval.opval), force_next(PRIVATEREF);
else op_free(rv2cv_op), force_next(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;
}
PL_last_lop_op = OP_ENTERSUB;
/* Is there a prototype? */
if (
-#ifdef PERL_MAD
- cv &&
-#endif
SvPOK(cv))
{
STRLEN protolen = CvPROTOLEN(cv);
PREBLOCK(LSTOPSUB);
}
}
-#ifdef PERL_MAD
- {
- if (PL_madskills) {
- PL_nextwhite = PL_thiswhite;
- PL_thiswhite = 0;
- }
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
- PL_expect = XTERM;
- if (PL_madskills) {
- PL_nextwhite = nextPL_nextwhite;
- curmad('X', PL_thistoken);
- PL_thistoken = newSVpvs("");
- }
- force_next(off ? PRIVATEREF : WORD);
- if (!PL_lex_allbrackets &&
- PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
- PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- TOKEN(NOAMP);
- }
- }
-
- /* Guess harder when madskills require "best effort". */
- if (PL_madskills && (!gv || !GvCVu(gv))) {
- int probable_sub = 0;
- if (strchr("\"'`$@%0123456789!*+{[<", *s))
- probable_sub = 1;
- else if (isALPHA(*s)) {
- char tmpbuf[1024];
- STRLEN tmplen;
- d = s;
- d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
- if (!keyword(tmpbuf, tmplen, 0))
- probable_sub = 1;
- else {
- while (d < PL_bufend && isSPACE(*d))
- d++;
- if (*d == '=' && d[1] == '>')
- probable_sub = 1;
- }
- }
- if (probable_sub) {
- gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
- SVt_PVCV);
- op_free(pl_yylval.opval);
- pl_yylval.opval =
- off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
- pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
- PL_last_lop = PL_oldbufptr;
- PL_last_lop_op = OP_ENTERSUB;
- PL_nextwhite = PL_thiswhite;
- PL_thiswhite = 0;
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
- PL_expect = XTERM;
- PL_nextwhite = nextPL_nextwhite;
- curmad('X', PL_thistoken);
- PL_thistoken = newSVpvs("");
- force_next(off ? PRIVATEREF : WORD);
- if (!PL_lex_allbrackets &&
- PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
- PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- TOKEN(NOAMP);
- }
-#else
NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XTERM;
force_next(off ? PRIVATEREF : WORD);
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
TOKEN(NOAMP);
-#endif
}
/* Call it a bare word */
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;
+ }
}
}
}
ENTER;
SAVETMPS;
PUSHMARK(sp);
- EXTEND(SP, 1);
XPUSHs(PL_encoding);
PUTBACK;
call_method("name", G_SCALAR);
}
}
#endif
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (PL_realtokenstart >= 0) {
- char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
- if (!PL_endwhite)
- PL_endwhite = newSVpvs("");
- sv_catsv(PL_endwhite, PL_thiswhite);
- PL_thiswhite = 0;
- sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
- PL_realtokenstart = -1;
- }
- while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
- != NULL) ;
- }
-#endif
PL_rsfp = NULL;
}
goto fake_eof;
}
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('&');
UNI(OP_EXISTS);
case KEY_exit:
- if (PL_madskills)
- UNI(OP_INT);
UNI(OP_EXIT);
case KEY_eval:
s = SKIPSPACE1(s);
if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
char *p = s;
-#ifdef PERL_MAD
- int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
-#endif
if ((PL_bufend - p) >= 3 &&
strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
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 != '$')
Perl_croak(aTHX_ "Missing $ on loop variable");
-#ifdef PERL_MAD
- s = SvPVX(PL_linestr) + soff;
-#endif
}
OPERATOR(FOR);
case KEY_glob:
LOP(
- orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
+ orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
XTERM
);
PL_in_my = (U16)tmp;
s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
-#ifdef PERL_MAD
- char* start = s;
-#endif
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
{
PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
if (!PL_in_my_stash) {
char tmpbuf[1024];
+ int len;
PL_bufptr = s;
- my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
+ len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
+ PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
}
-#ifdef PERL_MAD
- if (PL_madskills) { /* just add type to declarator token */
- sv_catsv(PL_thistoken, PL_nextwhite);
- PL_nextwhite = 0;
- sv_catpvn(PL_thistoken, start, s - start);
- }
-#endif
}
pl_yylval.ival = 1;
OPERATOR(MY);
LOP(OP_PIPE_OP,XTERM);
case KEY_q:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
- COPLINE_SET_FROM_MULTI_END;
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
+ COPLINE_SET_FROM_MULTI_END;
pl_yylval.ival = OP_CONST;
TERM(sublex_start());
case KEY_qw: {
OP *words = NULL;
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
- COPLINE_SET_FROM_MULTI_END;
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
+ COPLINE_SET_FROM_MULTI_END;
PL_expect = XOPERATOR;
if (SvCUR(PL_lex_stuff)) {
int warned_comma = !ckWARN(WARN_QW);
}
case KEY_qq:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,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,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
- readpipe_override();
+ pl_yylval.ival = OP_BACKTICK;
TERM(sublex_start());
case KEY_return:
gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
GV_ADD | (UTF ? SVf_UTF8 : 0));
else if (*s == '<')
- yyerror("<> should be quotes");
+ yyerror("<> at require-statement should be quotes");
}
if (orig_keyword == KEY_require) {
orig_keyword = 0;
expectation attrful;
bool have_name, have_proto;
const int key = tmp;
-#ifndef PERL_MAD
SV *format_name = NULL;
-#endif
-
-#ifdef PERL_MAD
- SV *tmpwhite = 0;
-
- char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
- SV *subtoken = PL_madskills
- ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
- : NULL;
- PL_thistoken = 0;
d = s;
- s = SKIPSPACE2(s,tmpwhite);
-#else
- d = s;
s = skipspace(s);
-#endif
if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
(*s == ':' && s[1] == ':'))
{
-#ifdef PERL_MAD
- SV *nametoke = NULL;
-#endif
PL_expect = XBLOCK;
attrful = XATTRBLOCK;
d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
&len);
-#ifdef PERL_MAD
- if (PL_madskills)
- nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
-#else
if (key == KEY_format)
format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
-#endif
*PL_tokenbuf = '&';
if (memchr(tmpbuf, ':', len) || key != KEY_sub
|| pad_findmy_pvn(
have_name = TRUE;
-#ifdef PERL_MAD
- start_force(0);
- CURMAD('X', nametoke);
- CURMAD('_', tmpwhite);
- force_ident_maybe_lex('&');
-
- s = SKIPSPACE2(d,tmpwhite);
-#else
s = skipspace(d);
-#endif
}
else {
if (key == KEY_my || key == KEY_our || key==KEY_state)
}
if (key == KEY_format) {
-#ifdef PERL_MAD
- PL_thistoken = subtoken;
- s = d;
-#else
if (format_name) {
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval
= (OP*)newSVOP(OP_CONST,0, format_name);
NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
force_next(WORD);
}
-#endif
PREBLOCK(FORMAT);
}
/* Look for a prototype */
- if (*s == '(') {
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
+ s = scan_str(s,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));
have_proto = TRUE;
-#ifdef PERL_MAD
- start_force(0);
- CURMAD('q', PL_thisopen);
- CURMAD('_', tmpwhite);
- CURMAD('=', PL_thisstuff);
- CURMAD('Q', PL_thisclose);
- NEXTVAL_NEXTTOKE.opval =
- (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
- PL_lex_stuff = NULL;
- force_next(THING);
-
- s = SKIPSPACE2(s,tmpwhite);
-#else
s = skipspace(s);
-#endif
}
else
have_proto = FALSE;
if (*s == ':' && s[1] != ':')
PL_expect = attrful;
- else if (*s != '{' && key == KEY_sub) {
+ else if ((*s != '{' && *s != '(') && key == KEY_sub) {
if (!have_name)
Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
else if (*s != ';' && *s != '}')
Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
}
-#ifdef PERL_MAD
- start_force(0);
- if (tmpwhite) {
- if (PL_madskills)
- curmad('^', newSVpvs(""));
- CURMAD('_', tmpwhite);
- }
- force_next(0);
-
- PL_thistoken = subtoken;
- PERL_UNUSED_VAR(have_proto);
-#else
if (have_proto) {
NEXTVAL_NEXTTOKE.opval =
(OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
PL_lex_stuff = NULL;
force_next(THING);
}
-#endif
if (!have_name) {
if (PL_curstash)
sv_setpvs(PL_subname, "__ANON__");
sv_setpvs(PL_subname, "__ANON__::__ANON__");
TOKEN(ANONSUB);
}
-#ifndef PERL_MAD
force_ident_maybe_lex('&');
-#endif
TOKEN(SUB);
}
}
}}
}
-#ifdef __SC__
-#pragma segment Main
-#endif
/*
S_pending_ident
static int
S_pending_ident(pTHX)
{
- dVAR;
PADOFFSET tmp = 0;
const char pit = (char)pl_yylval.ival;
const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
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,
STATIC void
S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
{
- dVAR;
-
PERL_ARGS_ASSERT_CHECKCOMMA;
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
SV *sv, SV *pv, const char *type, STRLEN typelen)
{
- dVAR; dSP;
+ dSP;
HV * table = GvHV(PL_hintgv); /* ^H */
SV *res;
SV *errsv = NULL;
newSVpvs(":full"),
newSVpvs(":short"),
NULL);
- SPAGAIN;
+ assert(sp == PL_stack_sp);
table = GvHV(PL_hintgv);
if (table
&& (PL_hints & HINT_LOCALIZE_HH)
PERL_STATIC_INLINE void
S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
- dVAR;
PERL_ARGS_ASSERT_PARSE_IDENT;
for (;;) {
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_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
- dVAR;
char *d = dest;
char * const e = d + destlen - 3; /* two-character token, ending NUL */
bool is_utf8 = cBOOL(UTF);
}
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);
+ }
}
-/* \c?, \c\, \c^, \c_, and \cA..\cZ minus the ones that have traditionally
- * been matched by \s on ASCII platforms, are the legal control char names
- * here, that is \c? plus 1-32 minus the \s ones. */
+/* 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)) <= 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);
+ funny, SVfARG(tmp), funny, SVfARG(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 {
STATIC char *
S_scan_pat(pTHX_ char *start, I32 type)
{
- dVAR;
PMOP *pm;
char *s;
const char * const valid_flags =
(const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
char charset = '\0'; /* character set modifier */
-#ifdef PERL_MAD
- char *modstart;
-#endif
PERL_ARGS_ASSERT_SCAN_PAT;
- s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
- TRUE /* look for escaped bracketed metas */ );
-
- if (!s) {
- const char * const delimiter = skipspace(start);
- Perl_croak(aTHX_
- (const char *)
- (*delimiter == '?'
- ? "Search pattern not terminated or ternary operator parsed as search pattern"
- : "Search pattern not terminated" ));
- }
+ s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
+ if (!s)
+ Perl_croak(aTHX_ "Search pattern not terminated");
pm = (PMOP*)newPMOP(type, 0);
if (PL_multi_open == '?') {
PmopSTASH_set(pm,PL_curstash);
}
}
-#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 */
}
while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
-#ifdef PERL_MAD
- if (PL_madskills && modstart != s) {
- SV* tmptoken = newSVpvn(modstart, s - modstart);
- append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
- }
-#endif
/* issue a warning if /c is specified,but /g is not */
if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
{
STATIC char *
S_scan_subst(pTHX_ char *start)
{
- dVAR;
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 */ );
+ s = scan_str(start, TRUE, FALSE, FALSE, &t);
if (!s)
Perl_croak(aTHX_ "Substitution pattern not terminated");
- if (s[-1] == PL_multi_open)
- s--;
-#ifdef PERL_MAD
- if (PL_madskills) {
- CURMAD('q', PL_thisopen);
- CURMAD('_', PL_thiswhite);
- CURMAD('E', PL_thisstuff);
- CURMAD('Q', PL_thisclose);
- PL_realtokenstart = s - SvPVX(PL_linestr);
- }
-#endif
+ s = t;
first_start = PL_multi_start;
first_line = CopLINE(PL_curcop);
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
pm = (PMOP*)newPMOP(OP_SUBST, 0);
-#ifdef PERL_MAD
- if (PL_madskills) {
- CURMAD('z', PL_thisopen);
- CURMAD('R', PL_thisstuff);
- CURMAD('Z', PL_thisclose);
- }
- modstart = s;
-#endif
while (*s) {
if (*s == EXEC_PAT_MOD) {
}
}
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (modstart != s)
- curmad('m', newSVpvn(modstart, s - modstart));
- append_madprops(PL_thismad, (OP*)pm, 0);
- PL_thismad = 0;
- }
-#endif
if ((pm->op_pmflags & PMf_CONTINUE)) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
}
STATIC char *
S_scan_trans(pTHX_ char *start)
{
- dVAR;
char* s;
OP *o;
U8 squash;
U8 del;
U8 complement;
bool nondestruct = 0;
-#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,FALSE,FALSE,FALSE,&t);
if (!s)
Perl_croak(aTHX_ "Transliteration pattern not terminated");
- if (s[-1] == PL_multi_open)
- s--;
-#ifdef PERL_MAD
- if (PL_madskills) {
- CURMAD('q', PL_thisopen);
- CURMAD('_', PL_thiswhite);
- CURMAD('E', PL_thisstuff);
- CURMAD('Q', PL_thisclose);
- PL_realtokenstart = s - SvPVX(PL_linestr);
- }
-#endif
+ s = t;
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
}
Perl_croak(aTHX_ "Transliteration replacement not terminated");
}
- if (PL_madskills) {
- CURMAD('z', PL_thisopen);
- CURMAD('R', PL_thisstuff);
- CURMAD('Z', PL_thisclose);
- }
complement = del = squash = 0;
-#ifdef PERL_MAD
- modstart = s;
-#endif
while (1) {
switch (*s) {
case 'c':
PL_lex_op = o;
pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (modstart != s)
- curmad('m', newSVpvn(modstart, s - modstart));
- append_madprops(PL_thismad, o, 0);
- PL_thismad = 0;
- }
-#endif
return s;
}
STATIC char *
S_scan_heredoc(pTHX_ char *s)
{
- dVAR;
I32 op_type = OP_SCALAR;
I32 len;
SV *tmpstr;
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);
- char *tstart;
-
- PL_realtokenstart = -1;
-#endif
PERL_ARGS_ASSERT_SCAN_HEREDOC;
*d = '\0';
len = d - PL_tokenbuf;
-#ifdef PERL_MAD
- if (PL_madskills) {
- tstart = PL_tokenbuf + 1;
- PL_thisclose = newSVpvn(tstart, len - 1);
- tstart = SvPVX(PL_linestr) + stuffstart;
- PL_thisopen = newSVpvn(tstart, s - tstart);
- stuffstart = s - SvPVX(PL_linestr);
- }
-#endif
#ifndef PERL_STRICT_CR
d = strchr(s, '\r');
if (d) {
s = olds;
}
#endif
-#ifdef PERL_MAD
- if (PL_madskills) {
- tstart = SvPVX(PL_linestr) + stuffstart;
- if (PL_thisstuff)
- sv_catpvn(PL_thisstuff, tstart, s - tstart);
- else
- PL_thisstuff = newSVpvn(tstart, s - tstart);
- }
-
- stuffstart = s - SvPVX(PL_linestr);
-#endif
tmpstr = newSV_type(SVt_PVIV);
SvGROW(tmpstr, 80);
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;
}
sv_setpvn(tmpstr,d+1,s-d);
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (PL_thisstuff)
- sv_catpvn(PL_thisstuff, d + 1, s - d);
- else
- PL_thisstuff = newSVpvn(d + 1, s - d);
- stuffstart = s - SvPVX(PL_linestr);
- }
-#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.
PL_linestr = newSVpvs("");
PL_bufend = SvPVX(PL_linestr);
while (1) {
-#ifdef PERL_MAD
- if (PL_madskills) {
- tstart = SvPVX(PL_linestr) + stuffstart;
- if (PL_thisstuff)
- sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
- else
- PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
- }
-#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: */
PL_bufend = SvEND(PL_linestr);
}
s = PL_bufptr;
-#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);
}
STATIC char *
S_scan_inputsymbol(pTHX_ char *start)
{
- dVAR;
char *s = start; /* current position in buffer */
char *end;
I32 len;
if (d - PL_tokenbuf != len) {
pl_yylval.ival = OP_GLOB;
- s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(start,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;
Copy("ARGV",d,5,char);
/* 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
/* scan_str
takes:
start position in buffer
- keep_quoted preserve \ on the embedded delimiter(s)
+ keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
+ only if they are of the open/close form
keep_delims preserve the delimiters around the string
re_reparse compiling a run-time /(?{})/:
collapse // to /, and skip encoding src
- 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
+S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
+ char **delimp
)
{
- dVAR;
SV *sv; /* scalar value: string */
const char *tmps; /* temp string, used for delimiter matching */
char *s = start; /* current position in the buffer */
U8 termstr[UTF8_MAXBYTES]; /* terminating string */
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;
-#endif
PERL_ARGS_ASSERT_SCAN_STR;
s = PEEKSPACE(s);
}
-#ifdef PERL_MAD
- if (PL_realtokenstart >= 0) {
- stuffstart = PL_realtokenstart;
- PL_realtokenstart = -1;
- }
- else
- stuffstart = start - SvPVX(PL_linestr);
-#endif
/* mark where we are, in case we need to report errors */
CLINE;
/* 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_close = term;
- /* A warning is raised if the input parameter requires it for escaped (by a
- * backslash) paired metacharacters {} [] and () when the delimiters are
- * those same characters, and the backslash is ineffective. This doesn't
- * happen for <>, as they aren't metas. */
- if (deprecate_escaped_meta
- && (PL_multi_open == PL_multi_close
- || PL_multi_open == '<'
- || ! ckWARN_d(WARN_DEPRECATED)))
- {
- deprecate_escaped_meta = FALSE;
+ if (PL_multi_open == PL_multi_close) {
+ keep_bracketed_quoted = FALSE;
}
/* create a new SV to hold the contents. 79 is the SV's initial length.
if (keep_delims)
sv_catpvn(sv, s, termlen);
s += termlen;
-#ifdef PERL_MAD
- tstart = SvPVX(PL_linestr) + stuffstart;
- if (PL_madskills && !PL_thisopen && !keep_delims) {
- PL_thisopen = newSVpvn(tstart, s - tstart);
- stuffstart = s - SvPVX(PL_linestr);
- }
-#endif
for (;;) {
if (PL_encoding && !UTF && !re_reparse) {
bool cont = TRUE;
for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
t--;
if ((svlast-1 - t) % 2) {
- if (!keep_quoted) {
+ if (!keep_bracketed_quoted) {
*(svlast-1) = term;
*svlast = '\0';
SvCUR_set(sv, SvCUR(sv) - 1);
/* At here, all closes are "was quoted" one,
so we don't check PL_multi_close. */
if (*t == '\\') {
- if (!keep_quoted && *(t+1) == PL_multi_open)
+ if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
t++;
else
*w++ = *t++;
COPLINE_INC_WITH_HERELINES;
/* handle quoted delimiters */
if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
- if (!keep_quoted
+ if (!keep_bracketed_quoted
&& (s[1] == term
|| (re_reparse && s[1] == '\\'))
)
s++;
- /* any other quotes are simply copied straight through */
- else
+ else /* any other quotes are simply copied straight through */
*to++ = *s++;
}
/* terminate when run out of buffer (the for() condition), or
COPLINE_INC_WITH_HERELINES;
/* backslashes can escape the open or closing characters */
if (*s == '\\' && s+1 < PL_bufend) {
- if (!keep_quoted &&
+ if (!keep_bracketed_quoted &&
((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
{
s++;
-
- /* Here, 'deprecate_escaped_meta' is true iff the
- * delimiters are paired metacharacters, and 's' points
- * to an occurrence of one of them within the string,
- * which was preceded by a backslash. If this is a
- * context where the delimiter is also a metacharacter,
- * the backslash is useless, and deprecated. () and []
- * are meta in any context. {} are meta only when
- * appearing in a quantifier or in things like '\p{'
- * (but '\\p{' isn't meta). They also aren't meta
- * unless there is a matching closed, escaped char
- * later on within the string. If 's' points to an
- * open, set a flag; if to a close, test that flag, and
- * raise a warning if it was set */
-
- if (deprecate_escaped_meta) {
- if (*s == PL_multi_open) {
- if (*s != '{') {
- escaped_open = s;
- }
- /* Look for a closing '\}' */
- else if (regcurly(s, TRUE)) {
- escaped_open = s;
- }
- /* Look for e.g. '\x{' */
- else if (s - start > 2
- && _generic_isCC(*(s-2),
- _CC_BACKSLASH_FOO_LBRACE_IS_META))
- { /* Exclude '\\x', '\\\\x', etc. */
- char *lookbehind = s - 4;
- bool is_meta = TRUE;
- while (lookbehind >= start
- && *lookbehind == '\\')
- {
- is_meta = ! is_meta;
- lookbehind--;
- }
- if (is_meta) {
- escaped_open = s;
- }
- }
- }
- else if (escaped_open) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
- escaped_open = NULL;
- }
- }
}
else
*to++ = *s++;
- }
+ }
/* allow nested opens and closes */
else if (*s == PL_multi_close && --brackets <= 0)
break;
/* if we're out of file, or a read fails, bail and reset the current
line marker so we can report where the unterminated string began
*/
-#ifdef PERL_MAD
- if (PL_madskills) {
- char * const tstart = SvPVX(PL_linestr) + stuffstart;
- if (PL_thisstuff)
- sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
- else
- PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
- }
-#endif
COPLINE_INC_WITH_HERELINES;
PL_bufptr = PL_bufend;
if (!lex_next_chunk(0)) {
return NULL;
}
s = PL_bufptr;
-#ifdef PERL_MAD
- stuffstart = 0;
-#endif
}
/* at this point, we have successfully read the delimited string */
if (!PL_encoding || UTF || re_reparse) {
-#ifdef PERL_MAD
- if (PL_madskills) {
- char * const tstart = SvPVX(PL_linestr) + stuffstart;
- const int len = s - tstart;
- if (PL_thisstuff)
- sv_catpvn(PL_thisstuff, tstart, len);
- else
- PL_thisstuff = newSVpvn(tstart, len);
- if (!PL_thisclose && !keep_delims)
- PL_thisclose = newSVpvn(s,termlen);
- }
-#endif
if (keep_delims)
sv_catpvn(sv, s, termlen);
s += termlen;
}
-#ifdef PERL_MAD
- else {
- if (PL_madskills) {
- char * const tstart = SvPVX(PL_linestr) + stuffstart;
- const int len = s - tstart - termlen;
- if (PL_thisstuff)
- sv_catpvn(PL_thisstuff, tstart, len);
- else
- PL_thisstuff = newSVpvn(tstart, len);
- if (!PL_thisclose && !keep_delims)
- PL_thisclose = newSVpvn(s - termlen,termlen);
- }
- }
-#endif
if (has_utf8 || (PL_encoding && !re_reparse))
SvUTF8_on(sv);
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;
}
char *
Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
{
- dVAR;
const char *s = start; /* current position in buffer */
char *d; /* destination in temp buffer */
char *e; /* end of temp buffer */
case '8': case '9':
if (shift == 3)
yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
- /* FALL THROUGH */
+ /* FALLTHROUGH */
/* octal digits */
case '2': case '3': case '4':
case '5': case '6': case '7':
if (shift == 1)
yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case '0': case '1':
b = *s++ & 15; /* ASCII digit -> value of digit */
floatit = TRUE;
}
if (floatit) {
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
/* terminate the string */
*d = '\0';
nv = Atof(PL_tokenbuf);
+ RESTORE_NUMERIC_LOCAL();
sv = newSVnv(nv);
}
STATIC char *
S_scan_formline(pTHX_ char *s)
{
- dVAR;
char *eol;
char *t;
SV * const stuff = newSVpvs("");
bool needargs = FALSE;
bool eofmt = FALSE;
-#ifdef PERL_MAD
- char *tokenstart = s;
- SV* savewhite = NULL;
-
- if (PL_madskills) {
- savewhite = PL_thiswhite;
- PL_thiswhite = 0;
- }
-#endif
PERL_ARGS_ASSERT_SCAN_FORMLINE;
if ((PL_rsfp || PL_parser->filtered)
&& PL_parser->form_lex_state == LEX_NORMAL) {
bool got_some;
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (PL_thistoken)
- sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
- else
- PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
- }
-#endif
PL_bufptr = PL_bufend;
COPLINE_INC_WITH_HERELINES;
got_some = lex_next_chunk(0);
CopLINE_dec(PL_curcop);
s = PL_bufptr;
-#ifdef PERL_MAD
- tokenstart = PL_bufptr;
-#endif
if (!got_some)
break;
}
if (SvCUR(stuff)) {
PL_expect = XSTATE;
if (needargs) {
- start_force(PL_curforce);
+ const char *s2 = s;
+ while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
+ || *s2 == 013)
+ s2++;
+ if (*s2 == '{') {
+ PL_expect = XTERMBLOCK;
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(DO);
+ }
NEXTVAL_NEXTTOKE.ival = 0;
force_next(FORMLBRACK);
}
else if (PL_encoding)
sv_recode_to_utf8(stuff, PL_encoding);
}
- start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
force_next(THING);
}
if (eofmt)
PL_lex_formbrack = 0;
}
-#ifdef PERL_MAD
- if (PL_madskills) {
- if (PL_thistoken)
- sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
- else
- PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
- PL_thiswhite = savewhite;
- }
-#endif
return s;
}
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
- dVAR;
const I32 oldsavestack_ix = PL_savestack_ix;
CV* const outsidecv = PL_compcv;
return oldsavestack_ix;
}
-#ifdef __SC__
-#pragma segment Perl_yylex
-#endif
static int
S_yywarn(pTHX_ const char *const s, U32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_YYWARN;
PL_in_eval |= EVAL_WARNONLY;
int
Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
{
- dVAR;
const char *context = NULL;
int contlen = -1;
SV *msg;
}
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)
{
- dVAR;
const STRLEN slen = SvCUR(PL_linestr);
PERL_ARGS_ASSERT_SWALLOW_BOM;
#endif
}
}
+ break;
default:
if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
static I32
S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
{
- dVAR;
SV *const filter = FILTER_DATA(idx);
/* We re-use this each time round, throwing the contents away before we
return. */
char *
Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
{
- dVAR;
const char *pos = s;
const char *start = 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;
return stmtseqop;
}
+#define lex_token_boundary() S_lex_token_boundary(aTHX)
+static void
+S_lex_token_boundary(pTHX)
+{
+ PL_oldoldbufptr = PL_oldbufptr;
+ PL_oldbufptr = PL_bufptr;
+}
+
+#define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
+static OP *
+S_parse_opt_lexvar(pTHX)
+{
+ I32 sigil, c;
+ char *s, *d;
+ OP *var;
+ lex_token_boundary();
+ sigil = lex_read_unichar(0);
+ if (lex_peek_unichar(0) == '#') {
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ return NULL;
+ }
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
+ return NULL;
+ s = PL_bufptr;
+ d = PL_tokenbuf + 1;
+ PL_tokenbuf[0] = (char)sigil;
+ parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
+ PL_bufptr = s;
+ if (d == PL_tokenbuf+1)
+ return NULL;
+ *d = 0;
+ var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
+ OPf_MOD | (OPpLVAL_INTRO<<8));
+ var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
+ return var;
+}
+
+OP *
+Perl_parse_subsignature(pTHX)
+{
+ I32 c;
+ int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
+ OP *initops = NULL;
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ while (c != /*(*/')') {
+ switch (c) {
+ case '$': {
+ OP *var, *expr;
+ if (prev_type == 2)
+ qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
+ var = parse_opt_lexvar();
+ expr = var ?
+ newBINOP(OP_AELEM, 0,
+ ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
+ OP_RV2AV),
+ newSVOP(OP_CONST, 0, newSViv(pos))) :
+ NULL;
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (c == '=') {
+ lex_token_boundary();
+ lex_read_unichar(0);
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (c == ',' || c == /*(*/')') {
+ if (var)
+ qerror(Perl_mess(aTHX_ "Optional parameter "
+ "lacks default expression"));
+ } else {
+ OP *defexpr = parse_termexpr(0);
+ if (defexpr->op_type == OP_UNDEF &&
+ !(defexpr->op_flags & OPf_KIDS)) {
+ op_free(defexpr);
+ } else {
+ OP *ifop =
+ newBINOP(OP_GE, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(pos+1)));
+ expr = var ?
+ newCONDOP(0, ifop, expr, defexpr) :
+ newLOGOP(OP_OR, 0, ifop, defexpr);
+ }
+ }
+ prev_type = 1;
+ } else {
+ if (prev_type == 1)
+ qerror(Perl_mess(aTHX_ "Mandatory parameter "
+ "follows optional parameter"));
+ prev_type = 0;
+ min_arity = pos + 1;
+ }
+ if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
+ if (expr)
+ initops = op_append_list(OP_LINESEQ, initops,
+ newSTATEOP(0, NULL, expr));
+ max_arity = ++pos;
+ } break;
+ case '@':
+ case '%': {
+ OP *var;
+ if (prev_type == 2)
+ qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
+ var = parse_opt_lexvar();
+ if (c == '%') {
+ OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
+ newBINOP(OP_BIT_AND, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(1))),
+ newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Odd name/value argument "
+ "for subroutine"))));
+ if (pos != min_arity)
+ chkop = newLOGOP(OP_AND, 0,
+ newBINOP(OP_GT, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(pos))),
+ chkop);
+ initops = op_append_list(OP_LINESEQ,
+ newSTATEOP(0, NULL, chkop),
+ initops);
+ }
+ if (var) {
+ OP *slice = pos ?
+ op_prepend_elem(OP_ASLICE,
+ newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_ASLICE, 0,
+ list(newRANGE(0,
+ newSVOP(OP_CONST, 0, newSViv(pos)),
+ newUNOP(OP_AV2ARYLEN, 0,
+ ref(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv)),
+ OP_AV2ARYLEN)))),
+ ref(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv)),
+ OP_ASLICE))) :
+ newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
+ initops = op_append_list(OP_LINESEQ, initops,
+ newSTATEOP(0, NULL,
+ newASSIGNOP(OPf_STACKED, var, 0, slice)));
+ }
+ prev_type = 2;
+ max_arity = -1;
+ } break;
+ default:
+ parse_error:
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ return NULL;
+ }
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ switch (c) {
+ case /*(*/')': break;
+ case ',':
+ do {
+ lex_token_boundary();
+ lex_read_unichar(0);
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ } while (c == ',');
+ break;
+ default:
+ goto parse_error;
+ }
+ }
+ if (min_arity != 0) {
+ initops = op_append_list(OP_LINESEQ,
+ newSTATEOP(0, NULL,
+ newLOGOP(OP_OR, 0,
+ newBINOP(OP_GE, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(min_arity))),
+ newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Too few arguments for subroutine"))))),
+ initops);
+ }
+ if (max_arity != -1) {
+ initops = op_append_list(OP_LINESEQ,
+ newSTATEOP(0, NULL,
+ newLOGOP(OP_OR, 0,
+ newBINOP(OP_LE, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(max_arity))),
+ newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Too many arguments for subroutine"))))),
+ initops);
+ }
+ return initops;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff