/*
=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_lex_casestack (PL_parser->lex_casestack)
#define PL_lex_defer (PL_parser->lex_defer)
#define PL_lex_dojoin (PL_parser->lex_dojoin)
-#define PL_lex_expect (PL_parser->lex_expect)
#define PL_lex_formbrack (PL_parser->lex_formbrack)
#define PL_lex_inpat (PL_parser->lex_inpat)
#define PL_lex_inwhat (PL_parser->lex_inwhat)
#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
#define SPACE_OR_TAB(c) isBLANK_A(c)
+#define HEXFP_PEEK(s) \
+ (((s[0] == '.') && \
+ (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
+ isALPHA_FOLD_EQ(s[0], 'p'))
+
/* LEX_* are values for PL_lex_state, the state of the lexer.
* They are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
#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
* PWop : power operator
* PMop : pattern-matching operator
* Aop : addition-level operator
+ * AopNOASSIGN : addition-level operator that is never part of .=
* Mop : multiplication-level operator
* Eop : equality-testing operator
* Rop : relational operator <= != gt
#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 LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
+ pl_yylval.ival=f, \
+ PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
+ 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 FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
+#define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
{ 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" },
STATIC int
S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
{
- dVAR;
-
PERL_ARGS_ASSERT_TOKEREPORT;
if (DEBUG_T_TEST) {
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);
}
/*
* S_ao
*
- * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
- * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
+ * This subroutine looks for an '=' next to the operator that has just been
+ * parsed and turns it into an ASSIGNOP if it finds one.
*/
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 = parser->preambling = NOLINE;
parser->lex_state = LEX_NORMAL;
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);}");
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;
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;
if (*e != '\n' && *e != '\0')
return; /* false alarm */
- line_num = atoi(n)-1;
+ line_num = grok_atou(n, &e) - 1;
if (t - s > 0) {
const STRLEN len = t - s;
#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)
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;
/*
* S_lop
* Build a list operator (or something that might be one). The rules:
- * - if we have a next token, then it's a list operator [why?]
+ * - if we have a next token, then it's a list operator (no parens) for
+ * which the next token has already been parsed; e.g.,
+ * sort foo @args
+ * sort foo (@args)
* - if the next thing is an opening paren, then it's a function
* - else it's a list operator
*/
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
- dVAR;
-
PERL_ARGS_ASSERT_LOP;
pl_yylval.ival = f;
CLINE;
- PL_expect = x;
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
+ PL_expect = x;
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_defer = PL_lex_state;
- PL_lex_expect = PL_expect;
PL_lex_state = LEX_KNOWNEXT;
}
-#endif
}
/*
*/
static int
-S_postderef(pTHX_ char const funny, char const next)
+S_postderef(pTHX_ int const funny, char const next)
{
- dVAR;
- assert(strchr("$@%&*", funny));
+ 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);
+ assert('@' == funny || '$' == funny || DOLSHARP == funny);
PL_lex_state = LEX_INTERPEND;
- start_force(PL_curforce);
force_next(POSTJOIN);
}
- start_force(PL_curforce);
force_next(next);
PL_bufptr+=2;
}
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;
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 = PL_multi_close == '<';
ENTER;
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);
}
else {
const line_t l = CopLINE(PL_curcop);
-#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
LEAVE;
if (PL_multi_close == '<')
PL_parser->herelines += l - PL_multi_end;
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. */
+ SV *sv = newSV(send - start); /* sv for the constant. See note below
+ on sizing. */
char *s = start; /* start of the constant */
char *d = SvPVX(sv); /* destination for copies */
- bool dorange = FALSE; /* are we in a translit range? */
- bool didrange = FALSE; /* did we just finish a range? */
- bool in_charclass = FALSE; /* within /[...]/ */
- bool has_utf8 = FALSE; /* Output constant is UTF8 */
- bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
- to be UTF8? But, this can
- show as true when the source
- isn't utf8, as for example
- when it is entirely composed
- of hex constants */
+ bool dorange = FALSE; /* are we in a translit range? */
+ bool didrange = FALSE; /* did we just finish a range? */
+ bool in_charclass = FALSE; /* within /[...]/ */
+ bool has_utf8 = FALSE; /* Output constant is UTF8 */
+ bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
+ UTF8? But, this can show as true
+ when the source isn't utf8, as for
+ example when it is entirely composed
+ of hex constants */
SV *res; /* result from charnames */
/* Note on sizing: The scanned constant is placed into sv, which is
i = d - SvPVX_const(sv); /* remember current offset */
#ifdef EBCDIC
SvGROW(sv,
- SvLEN(sv) + (has_utf8 ?
- (512 - UTF_CONTINUATION_MARK +
- UNISKIP(0x100))
+ SvLEN(sv) + ((has_utf8)
+ ? (512 - UTF_CONTINUATION_MARK
+ + UNISKIP(0x100))
: 256));
/* How many two-byte within 0..255: 128 in UTF-8,
* 96 in UTF-8-mod. */
}
#ifdef EBCDIC
+ /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
+ * any subsets of these ranges into individual characters */
if (literal_endpoint == 2 &&
((isLOWER_A(min) && isLOWER_A(max)) ||
(isUPPER_A(min) && isUPPER_A(max))))
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)))
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");
*d++ = '\t';
break;
case 'e':
- *d++ = ASCII_TO_NATIVE('\033');
+ *d++ = ESC_NATIVE;
break;
case 'a':
*d++ = '\a';
* It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
*
* ->[ and ->{ return TRUE
- * ->$* ->@* ->@[ and ->@{ return TRUE if postfix_interpolate is enabled
+ * ->$* ->$#* ->@* ->@[ ->@{ 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] == '>'
&& FEATURE_POSTDEREF_QQ_IS_ENABLED
- && ( (s[2] == '$' && s[3] == '*')
+ && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
||(s[2] == '@' && strchr("*[{",s[3])) ))
return TRUE;
if (*s != '{' && *s != '[')
/* In a pattern, so maybe we have {n,m}. */
if (*s == '{') {
- if (regcurly(s, FALSE)) {
+ if (regcurly(s)) {
return FALSE;
}
return TRUE;
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.
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)
- : SvPCS_IMPORTED(gv_readpipe)
- && (gv_init(gv_readpipe, PL_globalstash, "readpipe",
- 8, 0), 1)
- )))
- {
- 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", "POSTDEREF", "TERMORDORDOR"
+ "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
+ "TERMORDORDOR"
};
#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_lex_state = PL_lex_defer;
- 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(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
else
return yylex();
&& (!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(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
return yylex();
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(dojoin_was == 1 ? ')' : POSTJOIN);
}
}
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(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
else {
PL_bufptr = s;
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))
: 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;
}
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,
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 */
}
* line contains "Perl" rather than "perl" */
if (!d) {
for (d = ipathend-4; d >= ipath; --d) {
- if ((*d == 'p' || *d == 'P')
+ if (isALPHA_FOLD_EQ(*d, 'p')
&& !ibcmp(d, "perl", 4))
{
break;
!= PL_unicode)
baduni = TRUE;
}
- if (baduni || *d1 == 'M' || *d1 == 'm') {
+ if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
const char * const m = d1;
while (*d1 && !isSPACE(*d1))
d1++;
}
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 '-':
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] == '{'))
))
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
if (*s == '[')
PL_tokenbuf[0] = '@';
-
- /* Warn about % where they meant $. */
- if (*s == '[' || *s == '{') {
- if (ckWARN(WARN_SYNTAX)) {
- S_check_scalar_slice(aTHX_ s);
- }
- }
}
PL_expect = XOPERATOR;
force_ident_maybe_lex('%');
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);
CLINE;
s++;
- OPERATOR(';');
+ PL_expect = XSTATE;
+ TOKEN(';');
case ')':
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
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 XATTRTERM:
+ case XTERMBLOCK:
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
case XATTRBLOCK:
case XBLOCK:
PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
PL_lex_allbrackets++;
PL_expect = XSTATE;
break;
- case XATTRTERM:
- case XTERMBLOCK:
- PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ case XBLOCKTERM:
+ PL_lex_brackstack[PL_lex_brackets++] = XTERM;
PL_lex_allbrackets++;
PL_expect = XSTATE;
break;
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);
}
}
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) POSTDEREF('$');
+ 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] = '@';
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);
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
DEBUG_T( {
if (s)
printbuf("### Saw string before %s\n", s);
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 '\\':
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))
} else if (result == KEYWORD_PLUGIN_STMT) {
pl_yylval.opval = o;
CLINE;
- PL_expect = XSTATE;
+ if (!PL_nexttoke) PL_expect = XSTATE;
return REPORT(PLUGSTMT);
} else if (result == KEYWORD_PLUGIN_EXPR) {
pl_yylval.opval = o;
CLINE;
- PL_expect = XOPERATOR;
+ if (!PL_nexttoke) PL_expect = XOPERATOR;
return REPORT(PLUGEXPR);
} else {
Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
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
+ PL_expect = XOPERATOR;
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);
if (!PL_lex_allbrackets &&
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- PREBLOCK(METHOD);
+ PL_expect = XBLOCKTERM;
+ PL_bufptr = s;
+ return REPORT(METHOD);
}
/* If followed by a bareword, see if it looks like indir obj. */
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_DBMCLOSE);
case KEY_dump:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_DUMP);
case KEY_else:
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)))
}
if (*p != '$')
Perl_croak(aTHX_ "Missing $ on loop variable");
-#ifdef PERL_MAD
- s = SvPVX(PL_linestr) + soff;
-#endif
}
OPERATOR(FOR);
LOP(OP_GREPSTART, XREF);
case KEY_goto:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_GOTO);
case KEY_gmtime:
case KEY_glob:
LOP(
- orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
+ orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
XTERM
);
LOP(OP_KILL,XTERM);
case KEY_last:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_LAST);
case KEY_lc:
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);
case KEY_next:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_NEXT);
case KEY_ne:
case KEY_no:
s = tokenize_use(0, s);
- TERM(USE);
+ TOKEN(USE);
case KEY_not:
if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
s = force_word(s,WORD,FALSE,TRUE);
s = SKIPSPACE1(s);
s = force_strict_version(s);
- PL_lex_expect = XBLOCK;
- OPERATOR(PACKAGE);
+ PREBLOCK(PACKAGE);
case KEY_pipe:
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:
case KEY_require:
s = SKIPSPACE1(s);
- PL_expect = XOPERATOR;
if (isDIGIT(*s)) {
s = force_version(s, FALSE);
}
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;
}
else
pl_yylval.ival = 0;
- PL_expect = XTERM;
+ PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
PL_bufptr = s;
PL_last_uni = PL_oldbufptr;
PL_last_lop_op = OP_REQUIRE;
UNI(OP_RESET);
case KEY_redo:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_REDO);
case KEY_rename:
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);
}
case KEY_use:
s = tokenize_use(1, s);
- OPERATOR(USE);
+ TOKEN(USE);
case KEY_values:
UNI(OP_VALUES);
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 (;;) {
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, char *dest, STRLEN destlen, I32 ck_uni)
{
- dVAR;
I32 herelines = PL_parser->herelines;
SSize_t bracket = -1;
char funny = *s++;
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);
}
}
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;
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);
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 */
PL_parser->herelines++;
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,
origline + 1 + PL_parser->herelines);
PL_bufend = SvEND(PL_linestr);
}
s = PL_bufptr;
-#ifdef PERL_MAD
- stuffstart = s - SvPVX(PL_linestr);
-#endif
PL_parser->herelines++;
PL_last_lop = PL_last_uni = NULL;
#ifndef PERL_STRICT_CR
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
newUNOP(OP_RV2SV, 0,
newGVOP(OP_GV, 0, gv)));
}
- if (!readline_overriden)
- PL_lex_op->op_flags |= OPf_SPECIAL;
/* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
pl_yylval.ival = OP_NULL;
}
/* 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;
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_sublex_info.repl = sv;
else
PL_lex_stuff = sv;
+ if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
return s;
}
\d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
\.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
- 0b[01](_?[01])*
- 0[0-7](_?[0-7])*
- 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
+ 0b[01](_?[01])* binary integers
+ 0[0-7](_?[0-7])* octal integers
+ 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
+ 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
thing it reads.
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 */
bool floatit; /* boolean: int or float? */
const char *lastub = NULL; /* position of last underbar */
static const char* const number_too_long = "Number too long";
+ /* Hexadecimal floating point.
+ *
+ * In many places (where we have quads and NV is IEEE 754 double)
+ * we can fit the mantissa bits of a NV into an unsigned quad.
+ * (Note that UVs might not be quads even when we have quads.)
+ * This will not work everywhere, though (either no quads, or
+ * using long doubles), in which case we have to resort to NV,
+ * which will probably mean horrible loss of precision due to
+ * multiple fp operations. */
+ bool hexfp = FALSE;
+ int total_bits = 0;
+#if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
+# define HEXFP_UQUAD
+ Uquad_t hexfp_uquad = 0;
+ int hexfp_frac_bits = 0;
+#else
+# define HEXFP_NV
+ NV hexfp_nv = 0.0;
+#endif
+ NV hexfp_mult = 1.0;
+ UV high_non_zero = 0; /* highest digit */
PERL_ARGS_ASSERT_SCAN_NUM;
const char *base, *Base, *max;
/* check for hex */
- if (s[1] == 'x' || s[1] == 'X') {
+ if (isALPHA_FOLD_EQ(s[1], 'x')) {
shift = 4;
s += 2;
just_zero = FALSE;
- } else if (s[1] == 'b' || s[1] == 'B') {
+ } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
shift = 1;
s += 2;
just_zero = FALSE;
}
/* check for a decimal in disguise */
- else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
+ else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
goto decimal;
/* so it must be octal */
else {
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 */
if (!overflowed) {
x = u << shift; /* make room for the digit */
+ total_bits += shift;
+
if ((x >> shift) != u
&& !(PL_hints & HINT_NEW_BINARY)) {
overflowed = TRUE;
* amount. */
n += (NV) b;
}
+
+ if (high_non_zero == 0 && b > 0)
+ high_non_zero = b;
+
+ /* this could be hexfp, but peek ahead
+ * to avoid matching ".." */
+ if (UNLIKELY(HEXFP_PEEK(s))) {
+ goto out;
+ }
+
break;
}
}
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
}
+ if (UNLIKELY(HEXFP_PEEK(s))) {
+ /* Do sloppy (on the underbars) but quick detection
+ * (and value construction) for hexfp, the decimal
+ * detection will shortly be more thorough with the
+ * underbar checks. */
+ const char* h = s;
+#ifdef HEXFP_UQUAD
+ hexfp_uquad = u;
+#else /* HEXFP_NV */
+ hexfp_nv = u;
+#endif
+ if (*h == '.') {
+#ifdef HEXFP_NV
+ NV mult = 1 / 16.0;
+#endif
+ h++;
+ while (isXDIGIT(*h) || *h == '_') {
+ if (isXDIGIT(*h)) {
+ U8 b = XDIGIT_VALUE(*h);
+ total_bits += shift;
+#ifdef HEXFP_UQUAD
+ hexfp_uquad <<= shift;
+ hexfp_uquad |= b;
+ hexfp_frac_bits += shift;
+#else /* HEXFP_NV */
+ hexfp_nv += b * mult;
+ mult /= 16.0;
+#endif
+ }
+ h++;
+ }
+ }
+
+ if (total_bits >= 4) {
+ if (high_non_zero < 0x8)
+ total_bits--;
+ if (high_non_zero < 0x4)
+ total_bits--;
+ if (high_non_zero < 0x2)
+ total_bits--;
+ }
+
+ if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
+ bool negexp = FALSE;
+ h++;
+ if (*h == '+')
+ h++;
+ else if (*h == '-') {
+ negexp = TRUE;
+ h++;
+ }
+ if (isDIGIT(*h)) {
+ I32 hexfp_exp = 0;
+ while (isDIGIT(*h) || *h == '_') {
+ if (isDIGIT(*h)) {
+ hexfp_exp *= 10;
+ hexfp_exp += *h - '0';
+#ifdef NV_MIN_EXP
+ if (negexp &&
+ -hexfp_exp < NV_MIN_EXP - 1) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Hexadecimal float: exponent underflow");
+#endif
+ break;
+ }
+ else {
+#ifdef NV_MAX_EXP
+ if (!negexp &&
+ hexfp_exp > NV_MAX_EXP - 1) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Hexadecimal float: exponent overflow");
+ break;
+ }
+#endif
+ }
+ }
+ h++;
+ }
+ if (negexp)
+ hexfp_exp = -hexfp_exp;
+#ifdef HEXFP_UQUAD
+ hexfp_exp -= hexfp_frac_bits;
+#endif
+ hexfp_mult = pow(2.0, hexfp_exp);
+ hexfp = TRUE;
+ goto decimal;
+ }
+ }
+ }
+
if (overflowed) {
if (n > 4294967295.0)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
decimal:
d = PL_tokenbuf;
e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
- floatit = FALSE;
+ floatit = FALSE;
+ if (hexfp) {
+ floatit = TRUE;
+ *d++ = '0';
+ *d++ = 'x';
+ s = start + 2;
+ }
/* read next group of digits and _ and copy into d */
- while (isDIGIT(*s) || *s == '_') {
+ while (isDIGIT(*s) || *s == '_' ||
+ UNLIKELY(hexfp && isXDIGIT(*s))) {
/* skip underscores, checking for misplaced ones
if -w is on
*/
/* copy, ignoring underbars, until we run out of digits.
*/
- for (; isDIGIT(*s) || *s == '_'; s++) {
+ for (; isDIGIT(*s) || *s == '_' ||
+ UNLIKELY(hexfp && isXDIGIT(*s));
+ s++) {
/* fixed length buffer check */
if (d >= e)
Perl_croak(aTHX_ "%s", number_too_long);
}
/* read exponent part, if present */
- if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
- floatit = TRUE;
+ if ((isALPHA_FOLD_EQ(*s, 'e')
+ || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
+ && strchr("+-0123456789_", s[1]))
+ {
+ floatit = TRUE;
+
+ /* regardless of whether user said 3E5 or 3e5, use lower 'e',
+ ditto for p (hexfloats) */
+ if ((isALPHA_FOLD_EQ(*s, 'e'))) {
+ /* At least some Mach atof()s don't grok 'E' */
+ *d++ = 'e';
+ }
+ else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
+ *d++ = 'p';
+ }
+
s++;
- /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
- *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
/* stray preinitial _ */
if (*s == '_') {
floatit = TRUE;
}
if (floatit) {
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
/* terminate the string */
*d = '\0';
- nv = Atof(PL_tokenbuf);
- sv = newSVnv(nv);
+ if (UNLIKELY(hexfp)) {
+# ifdef NV_MANT_DIG
+ if (total_bits > NV_MANT_DIG)
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Hexadecimal float: mantissa overflow");
+# endif
+#ifdef HEXFP_UQUAD
+ nv = hexfp_uquad * hexfp_mult;
+#else /* HEXFP_NV */
+ nv = hexfp_nv * hexfp_mult;
+#endif
+ } else {
+ nv = Atof(PL_tokenbuf);
+ }
+ RESTORE_NUMERIC_LOCAL();
+ sv = newSVnv(nv);
}
if ( floatit
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;
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;
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;
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