#define PERL_IN_TOKE_C
#include "perl.h"
-#define yychar (*PL_yycharp)
-#define yylval (*PL_yylvalp)
+#define yylval (PL_parser->yylval)
static const char ident_too_long[] = "Identifier too long";
static const char commaless_variable_list[] = "comma-less variable list";
static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
#endif
+#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 XFAKEBRACK 128
#define XENUMMASK 127
#endif
#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
+#ifdef PERL_MAD
+# define SKIPSPACE0(s) skipspace0(s)
+# define SKIPSPACE1(s) skipspace1(s)
+# define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
+# define PEEKSPACE(s) skipspace2(s,0)
+#else
+# define SKIPSPACE0(s) skipspace(s)
+# define SKIPSPACE1(s) skipspace(s)
+# define SKIPSPACE2(s,tsv) skipspace(s)
+# define PEEKSPACE(s) skipspace(s)
+#endif
+
/*
* Convenience functions to return different tokens and prime the
* lexer for the next token. They all take an argument.
PL_last_lop_op = f; \
if (*s == '(') \
return REPORT( (int)FUNC1 ); \
- s = skipspace(s); \
+ s = PEEKSPACE(s); \
return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
}
#define UNI(f) UNI2(f,XTERM)
PL_last_uni = PL_oldbufptr; \
if (*s == '(') \
return REPORT( (int)FUNC1 ); \
- s = skipspace(s); \
+ s = PEEKSPACE(s); \
return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
}
{ WHEN, TOKENTYPE_IVAL, "WHEN" },
{ WHILE, TOKENTYPE_IVAL, "WHILE" },
{ WORD, TOKENTYPE_OPVAL, "WORD" },
- { 0, TOKENTYPE_NONE, 0 }
+ { 0, TOKENTYPE_NONE, NULL }
};
/* dump the returned token in rv, plus any optional arg in yylval */
"\t(Missing semicolon on previous line?)\n");
else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
const char *t;
- for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
+ for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
+ NOOP;
if (t < PL_bufptr && isSPACE(*t))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\t(Do you need to predeclare %.*s?)\n",
/*
* S_missingterm
* Complain about missing quote/regexp/heredoc terminator.
- * If it's called with (char *)NULL then it cauterizes the line buffer.
+ * If it's called with NULL then it cauterizes the line buffer.
* If we're in a delimited string and the delimiter is a control
* character, it's reformatted into a two-char sequence like ^C.
* This is fatal.
* Check whether the named feature is enabled.
*/
STATIC bool
-S_feature_is_enabled(pTHX_ char *name, STRLEN namelen)
+S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
{
dVAR;
HV * const hinthv = GvHV(PL_hintgv);
char he_name[32] = "feature_";
- (void) strncpy(&he_name[8], name, 24);
-
+ (void) my_strlcpy(&he_name[8], name, 24);
+
return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
}
SAVEI32(PL_lex_state);
SAVEVPTR(PL_lex_inpat);
SAVEI32(PL_lex_inwhat);
+#ifdef PERL_MAD
+ if (PL_lex_state == LEX_KNOWNEXT) {
+ I32 toke = PL_lasttoke;
+ while (--toke >= 0) {
+ SAVEI32(PL_nexttoke[toke].next_type);
+ SAVEVPTR(PL_nexttoke[toke].next_val);
+ if (PL_madskills)
+ SAVEVPTR(PL_nexttoke[toke].next_mad);
+ }
+ SAVEI32(PL_lasttoke);
+ }
+ if (PL_madskills) {
+ SAVESPTR(PL_thistoken);
+ SAVESPTR(PL_thiswhite);
+ SAVESPTR(PL_nextwhite);
+ SAVESPTR(PL_thisopen);
+ SAVESPTR(PL_thisclose);
+ SAVESPTR(PL_thisstuff);
+ SAVEVPTR(PL_thismad);
+ SAVEI32(PL_realtokenstart);
+ SAVEI32(PL_faketokens);
+ }
+ SAVEI32(PL_curforce);
+#else
if (PL_lex_state == LEX_KNOWNEXT) {
I32 toke = PL_nexttoke;
while (--toke >= 0) {
}
SAVEI32(PL_nexttoke);
}
+#endif
SAVECOPLINE(PL_curcop);
SAVEPPTR(PL_bufptr);
SAVEPPTR(PL_bufend);
PL_lex_stuff = NULL;
PL_lex_repl = NULL;
PL_lex_inpat = 0;
+#ifdef PERL_MAD
+ PL_lasttoke = 0;
+#else
PL_nexttoke = 0;
+#endif
PL_lex_inwhat = 0;
PL_sublex_info.sub_inwhat = 0;
PL_linestr = line;
- if (SvREADONLY(PL_linestr))
- PL_linestr = sv_2mortal(newSVsv(PL_linestr));
s = SvPV_const(PL_linestr, len);
- if (!len || s[len-1] != ';') {
- if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
- PL_linestr = sv_2mortal(newSVsv(PL_linestr));
- sv_catpvs(PL_linestr, "\n;");
+ if (SvREADONLY(PL_linestr) || !len || s[len-1] != ';') {
+ PL_linestr = sv_2mortal(len ? newSVsv(PL_linestr) : newSVpvn(s, 0));
+ if (!len || s[len-1] != ';')
+ sv_catpvs(PL_linestr, "\n;");
}
SvTEMP_off(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
CopLINE_inc(PL_curcop);
if (*s++ != '#')
return;
- while (SPACE_OR_TAB(*s)) s++;
+ while (SPACE_OR_TAB(*s))
+ s++;
if (strnEQ(s, "line", 4))
s += 4;
else
s++;
else
return;
- while (SPACE_OR_TAB(*s)) s++;
+ while (SPACE_OR_TAB(*s))
+ s++;
if (!isDIGIT(*s))
return;
+
n = s;
while (isDIGIT(*s))
s++;
e = t + 1;
}
else {
- for (t = s; !isSPACE(*t); t++) ;
+ t = s;
+ while (!isSPACE(*t))
+ t++;
e = t;
}
while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
if (gvp) {
gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
- if (!isGV(gv2))
+ if (!isGV(gv2)) {
gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
- /* adjust ${"::_<newfilename"} to store the new file name */
- GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
- GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
- GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ /* adjust ${"::_<newfilename"} to store the new file name */
+ GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
+ GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
+ GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ }
}
if (tmpbuf != smallbuf) Safefree(tmpbuf);
if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
CopLINE_set(PL_curcop, atoi(n)-1);
}
+#ifdef PERL_MAD
+/* skip space before PL_thistoken */
+
+STATIC char *
+S_skipspace0(pTHX_ register char *s)
+{
+ 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_ register char *s)
+{
+ const char *start = s;
+ I32 startoff = start - SvPVX(PL_linestr);
+
+ 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_ register char *s, SV **svp)
+{
+ char *start;
+ const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
+ const I32 startoff = s - SvPVX(PL_linestr);
+
+ s = skipspace(s);
+ PL_bufptr = SvPVX(PL_linestr) + bufptroff;
+ 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_pv(pTHX_ const char *buf, STRLEN len)
+{
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const sv = newSV(0);
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setpvn(sv, buf, len);
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, 0);
+ av_store(av, (I32)CopLINE(PL_curcop), sv);
+ }
+}
+
+STATIC void
+S_update_debugger_info_sv(pTHX_ SV *orig_sv)
+{
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const sv = newSV(0);
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setsv(sv, orig_sv);
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, 0);
+ av_store(av, (I32)CopLINE(PL_curcop), sv);
+ }
+}
+
/*
* S_skipspace
* Called to gobble the appropriate amount and type of whitespace.
S_skipspace(pTHX_ register char *s)
{
dVAR;
+#ifdef PERL_MAD
+ int curoff;
+ int startoff = s - SvPVX(PL_linestr);
+
+ if (PL_skipwhite) {
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
+ }
+#endif
+
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
+#ifdef PERL_MAD
+ goto done;
+#else
return s;
+#endif
}
for (;;) {
STRLEN prevlen;
*/
if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
PL_lex_state == LEX_FORMLINE)
+#ifdef PERL_MAD
+ goto done;
+#else
return s;
+#endif
/* try to recharge the buffer */
+#ifdef PERL_MAD
+ curoff = s - SvPVX(PL_linestr);
+#endif
+
if ((s = filter_gets(PL_linestr, PL_rsfp,
(prevlen = SvCUR(PL_linestr)))) == NULL)
{
+#ifdef PERL_MAD
+ if (PL_madskills && curoff != startoff) {
+ if (!PL_skipwhite)
+ PL_skipwhite = newSVpvs("");
+ sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
+ curoff - startoff);
+ }
+
+ /* mustn't throw out old stuff yet if madpropping */
+ SvCUR(PL_linestr) = curoff;
+ s = SvPVX(PL_linestr) + curoff;
+ *s = 0;
+ if (curoff && s[-1] == '\n')
+ s[-1] = ' ';
+#endif
+
/* end of file. Add on the -p or -n magic */
+ /* XXX these shouldn't really be added here, can't set PL_faketokens */
if (PL_minus_p) {
+#ifdef PERL_MAD
+ sv_catpv(PL_linestr,
+ ";}continue{print or die qq(-p destination: $!\\n);}");
+#else
sv_setpv(PL_linestr,
";}continue{print or die qq(-p destination: $!\\n);}");
+#endif
PL_minus_n = PL_minus_p = 0;
}
else if (PL_minus_n) {
+#ifdef PERL_MAD
+ sv_catpvn(PL_linestr, ";}", 2);
+#else
sv_setpvn(PL_linestr, ";}", 2);
+#endif
PL_minus_n = 0;
}
else
+#ifdef PERL_MAD
+ sv_catpvn(PL_linestr,";", 1);
+#else
sv_setpvn(PL_linestr,";", 1);
+#endif
/* reset variables for next time we lex */
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
- = SvPVX(PL_linestr);
+ = SvPVX(PL_linestr)
+#ifdef PERL_MAD
+ + curoff
+#endif
+ ;
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
/* debugger active and we're not compiling the debugger code,
* so store the line into the debugger's array of lines
*/
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_pv(PL_bufptr, PL_bufend - PL_bufptr);
+ }
- sv_upgrade(sv, SVt_PVMG);
- sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+#ifdef PERL_MAD
+ done:
+ if (PL_madskills) {
+ if (!PL_skipwhite)
+ PL_skipwhite = newSVpvs("");
+ curoff = s - SvPVX(PL_linestr);
+ if (curoff - startoff)
+ sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
+ curoff - startoff);
}
+ return s;
+#endif
}
/*
S_check_uni(pTHX)
{
dVAR;
- char *s;
- char *t;
+ const char *s;
+ const char *t;
if (PL_oldoldbufptr != PL_last_uni)
return;
while (isSPACE(*PL_last_uni))
PL_last_uni++;
- for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
+ s = PL_last_uni;
+ while (isALNUM_lazy_if(s,UTF) || *s == '-')
+ s++;
if ((t = strchr(s, '(')) && t < PL_bufptr)
return;
- /* XXX Things like this are just so nasty. We shouldn't be modifying
- source code, even if we realquick set it back. */
if (ckWARN_d(WARN_AMBIGUOUS)){
- const char ch = *s;
- *s = '\0';
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Warning: Use of \"%s\" without parentheses is ambiguous",
- PL_last_uni);
- *s = ch;
+ "Warning: Use of \"%.*s\" without parentheses is ambiguous",
+ (int)(s - PL_last_uni), PL_last_uni);
}
}
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = (OPCODE)f;
+#ifdef PERL_MAD
+ if (PL_lasttoke)
+ return REPORT(LSTOP);
+#else
if (PL_nexttoke)
return REPORT(LSTOP);
+#endif
if (*s == '(')
return REPORT(FUNC);
- s = skipspace(s);
+ s = PEEKSPACE(s);
if (*s == '(')
return REPORT(FUNC);
else
return REPORT(LSTOP);
}
+#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_setpvn(sv, "", 0);
+ 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((*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[], and possibly PL_expect to ensure the lexer
- * handles the token correctly.
+ * 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.
*/
STATIC void
S_force_next(pTHX_ I32 type)
{
dVAR;
+#ifdef PERL_MAD
+ if (PL_curforce < 0)
+ start_force(PL_lasttoke);
+ PL_nexttoke[PL_curforce].next_type = type;
+ if (PL_lex_state != LEX_KNOWNEXT)
+ PL_lex_defer = PL_lex_state;
+ PL_lex_state = LEX_KNOWNEXT;
+ PL_lex_expect = PL_expect;
+ PL_curforce = -1;
+#else
PL_nexttype[PL_nexttoke] = type;
PL_nexttoke++;
if (PL_lex_state != LEX_KNOWNEXT) {
PL_lex_expect = PL_expect;
PL_lex_state = LEX_KNOWNEXT;
}
+#endif
}
STATIC SV *
register char *s;
STRLEN len;
- start = skipspace(start);
+ start = SKIPSPACE1(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF) ||
(allow_pack && *s == ':') ||
(allow_initial_tick && *s == '\'') )
{
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
- if (check_keyword && keyword(PL_tokenbuf, len))
+ if (check_keyword && keyword(PL_tokenbuf, len, 0))
return start;
+ start_force(PL_curforce);
+ if (PL_madskills)
+ curmad('X', newSVpvn(start,s-start));
if (token == METHOD) {
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '(')
PL_expect = XTERM;
else {
PL_expect = XOPERATOR;
}
}
- PL_nextval[PL_nexttoke].opval
+ NEXTVAL_NEXTTOKE.opval
= (OP*)newSVOP(OP_CONST,0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
- PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
+ NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
force_next(token);
}
return s;
S_force_ident(pTHX_ register const char *s, int kind)
{
dVAR;
- if (s && *s) {
+ if (*s) {
const STRLEN len = strlen(s);
OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
- PL_nextval[PL_nexttoke].opval = o;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = o;
force_next(WORD);
if (kind) {
o->op_private = OPpCONST_ENTERED;
dVAR;
OP *version = NULL;
char *d;
+#ifdef PERL_MAD
+ I32 startoff = s - SvPVX(PL_linestr);
+#endif
- s = skipspace(s);
+ s = SKIPSPACE1(s);
d = s;
if (*d == 'v')
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) {
SV *ver;
s = scan_num(s, &yylval);
SvNOK_on(ver); /* hint that it is a version */
}
}
- else if (guessing)
+ 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 */
- PL_nextval[PL_nexttoke].opval = version;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = version;
force_next(WORD);
return s;
PL_expect = XTERMORDORDOR;
return THING;
}
+ else if (op_type == OP_BACKTICK && PL_lex_op) {
+ /* readpipe() vas overriden */
+ cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
+ yylval.opval = PL_lex_op;
+ PL_lex_op = NULL;
+ PL_lex_stuff = NULL;
+ return THING;
+ }
PL_sublex_info.super_state = PL_lex_state;
PL_sublex_info.sub_inwhat = op_type;
return ',';
}
else {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thiswhite) {
+ if (!PL_endwhite)
+ PL_endwhite = newSVpvs("");
+ sv_catsv(PL_endwhite, PL_thiswhite);
+ PL_thiswhite = 0;
+ }
+ if (PL_thistoken)
+ sv_setpvn(PL_thistoken,"",0);
+ else
+ PL_realtokenstart = -1;
+ }
+#endif
LEAVE;
PL_bufend = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
Extracts a pattern, double-quoted string, or transliteration. This
is terrifying code.
- It looks at lex_inwhat and PL_lex_inpat to find out whether it's
+ It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
processing a pattern (PL_lex_inpat is true), a transliteration
- (lex_inwhat & OP_TRANS is true), or a double-quoted string.
+ (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
- Returns a pointer to the character scanned up to. Iff this is
- advanced from the start pointer supplied (ie if anything was
+ Returns a pointer to the character scanned up to. If this is
+ advanced from the start pointer supplied (i.e. if anything was
successfully parsed), will leave an OP for the substring scanned
in yylval. Caller must intuit reason for not parsing further
by looking at the next characters herself.
backslashes:
double-quoted style: \r and \n
regexp special ones: \D \s
- constants: \x3
- backrefs: \1 (deprecated in substitution replacements)
+ constants: \x31
+ backrefs: \1
case and quoting: \U \Q \E
stops on @ and $, but not for $ as tail anchor
In transliterations:
characters are VERY literal, except for - not at the start or end
- of the string, which indicates a range. scan_const expands the
- range to the full set of intermediate characters.
+ of the string, which indicates a range. If the range is in bytes,
+ scan_const expands the range to the full set of intermediate
+ characters. If the range is in utf8, the hyphen is replaced with
+ a certain range mark which will be handled by pmtrans() in op.c.
In double-quoted strings:
backslashes:
double-quoted style: \r and \n
- constants: \x3
- backrefs: \1 (deprecated)
+ constants: \x31
+ deprecated backrefs: \1 (in substitution replacements)
case and quoting: \U \Q \E
stops on @ and $
It stops processing as soon as it finds an embedded $ or @ variable
and leaves it to the caller to work out what's going on.
- @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
+ embedded arrays (whether in pattern or not) could be:
+ @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
+
+ $ in double-quoted strings must be the symbol of an embedded scalar.
$ in pattern could be $foo or could be tail anchor. Assumption:
it's a tail anchor if $ is the last thing in the string, or if it's
- followed by one of ")| \n\t"
+ followed by one of "()| \r\n\t"
\1 (backreferences) are turned into $1
The structure of the code is
while (there's a character to process) {
- handle transliteration ranges
- skip regexp comments
- skip # initiated comments in //x patterns
- check for embedded @foo
+ handle transliteration ranges
+ skip regexp comments /(?#comment)/ and codes /(?{code})/
+ skip #-initiated comments in //x patterns
+ check for embedded arrays
check for embedded scalars
if (backslash) {
- leave intact backslashes from leave (below)
- deprecate \1 in strings and sub replacements
+ leave intact backslashes from leaveit (below)
+ deprecate \1 in substitution replacements
handle string-changing backslashes \l \U \Q \E, etc.
switch (what was escaped) {
- handle - in a transliteration (becomes a literal -)
- handle \132 octal characters
- handle 0x15 hex characters
- handle \cV (control V)
- handle printf backslashes (\f, \r, \n, etc)
+ handle \- in a transliteration (becomes a literal -)
+ handle \132 (octal characters)
+ handle \x15 and \x{1234} (hex characters)
+ handle \N{name} (named characters)
+ handle \cV (control characters)
+ handle printf-style backslashes (\f, \r, \n, etc)
} (end switch)
} (end if backslash)
} (end while character to read)
UV uv;
#ifdef EBCDIC
UV literal_endpoint = 0;
+ bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
#endif
- const char *leaveit = /* set of acceptably-backslashed characters */
- PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
- : "";
-
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
/* If we are doing a trans and we know we want UTF8 set expectation */
has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
I32 min; /* first character in range */
I32 max; /* last character in range */
- if (has_utf8) {
+#ifdef EBCDIC
+ UV uvmax = 0;
+#endif
+
+ if (has_utf8
+#ifdef EBCDIC
+ && !native_range
+#endif
+ ) {
char * const c = (char*)utf8_hop((U8*)d, -1);
char *e = d++;
while (e-- > c)
}
i = d - SvPVX_const(sv); /* remember current offset */
+#ifdef EBCDIC
+ SvGROW(sv,
+ 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. */
+#else
SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
+#endif
d = SvPVX(sv) + i; /* refresh d after realloc */
- d -= 2; /* eat the first char and the - */
-
- min = (U8)*d; /* first char in range */
- max = (U8)d[1]; /* last char in range */
+#ifdef EBCDIC
+ if (has_utf8) {
+ int j;
+ for (j = 0; j <= 1; j++) {
+ char * const c = (char*)utf8_hop((U8*)d, -1);
+ const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
+ if (j)
+ min = (U8)uv;
+ else if (uv < 256)
+ max = (U8)uv;
+ else {
+ max = (U8)0xff; /* only to \xff */
+ uvmax = uv; /* \x{100} to uvmax */
+ }
+ d = c; /* eat endpoint chars */
+ }
+ }
+ else {
+#endif
+ d -= 2; /* eat the first char and the - */
+ min = (U8)*d; /* first char in range */
+ max = (U8)d[1]; /* last char in range */
+#ifdef EBCDIC
+ }
+#endif
if (min > max) {
Perl_croak(aTHX_
else
#endif
for (i = min; i <= max; i++)
- *d++ = (char)i;
+#ifdef EBCDIC
+ if (has_utf8) {
+ const U8 ch = (U8)NATIVE_TO_UTF(i);
+ if (UNI_IS_INVARIANT(ch))
+ *d++ = (U8)i;
+ else {
+ *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
+ *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
+ }
+ }
+ else
+#endif
+ *d++ = (char)i;
+
+#ifdef EBCDIC
+ if (uvmax) {
+ d = (char*)uvchr_to_utf8((U8*)d, 0x100);
+ if (uvmax > 0x101)
+ *d++ = (char)UTF_TO_NATIVE(0xff);
+ if (uvmax > 0x100)
+ d = (char*)uvchr_to_utf8((U8*)d, uvmax);
+ }
+#endif
/* mark the range as done, and continue */
dorange = FALSE;
if (didrange) {
Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
}
- if (has_utf8) {
+ if (has_utf8
+#ifdef EBCDIC
+ && !native_range
+#endif
+ ) {
*d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
s++;
continue;
didrange = FALSE;
#ifdef EBCDIC
literal_endpoint = 0;
+ native_range = TRUE;
#endif
}
}
/* check for embedded arrays
(@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
*/
- else if (*s == '@' && s[1]
- && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
- break;
+ else if (*s == '@' && s[1]) {
+ if (isALNUM_lazy_if(s+1,UTF))
+ break;
+ if (strchr(":'{$", s[1]))
+ break;
+ if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
+ break; /* in regexp, neither @+ nor @- are interpolated */
+ }
/* check for embedded scalars. only stop if we're sure it's a
variable.
if (*s == '\\' && s+1 < send) {
s++;
- /* some backslashes we leave behind */
- if (*leaveit && *s && strchr(leaveit, *s)) {
- *d++ = NATIVE_TO_NEED(has_utf8,'\\');
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
- continue;
- }
-
/* deprecate \1 in strings and substitution replacements */
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
--s;
break;
}
+ /* skip any other backslash escapes in a pattern */
+ else if (PL_lex_inpat) {
+ *d++ = NATIVE_TO_NEED(has_utf8,'\\');
+ goto default_action;
+ }
/* if we get here, it's either a quoted -, or a digit */
switch (*s) {
/* FALL THROUGH */
default:
{
- if (isALNUM(*s) &&
- *s != '_' &&
+ if ((isALPHA(*s) || isDIGIT(*s)) &&
ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Unrecognized escape \\%c passed through",
- *s);
+ "Unrecognized escape \\%c passed through",
+ *s);
/* default action is to copy the quoted character */
goto default_action;
}
(PL_lex_repl ? OPpTRANS_FROM_UTF
: OPpTRANS_TO_UTF);
}
+#ifdef EBCDIC
+ if (uv > 255 && !dorange)
+ native_range = FALSE;
+#endif
}
else {
*d++ = (char)uv;
SV *res;
STRLEN len;
const char *str;
+ SV *type;
if (!e) {
yyerror("Missing right brace on \\N{}");
s += 3;
len = e - s;
uv = grok_hex(s, &len, &flags, NULL);
+ if ( e > s && len != (STRLEN)(e - s) ) {
+ uv = 0xFFFD;
+ }
s = e + 1;
goto NUM_ESCAPE_INSERT;
}
res = newSVpvn(s + 1, e - s - 1);
+ type = newSVpvn(s - 2,e - s + 3);
res = new_constant( NULL, 0, "charnames",
- res, NULL, "\\N{...}" );
+ res, NULL, SvPVX(type) );
+ SvREFCNT_dec(type);
if (has_utf8)
sv_utf8_upgrade(res);
str = SvPV_const(res,len);
SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
d = SvPVX(sv) + (d - odest);
}
+#ifdef EBCDIC
+ if (!dorange)
+ native_range = FALSE; /* \N{} is guessed to be Unicode */
+#endif
Copy(str, d, len, char);
d += len;
SvREFCNT_dec(res);
}
d = (char*)uvchr_to_utf8((U8*)d, nextuv);
has_utf8 = TRUE;
+#ifdef EBCDIC
+ if (uv > 255 && !dorange)
+ native_range = FALSE;
+#endif
}
else {
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
/* return the substring (via yylval) only if we parsed anything */
if (s > PL_bufptr) {
if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
- sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
+ sv = new_constant(start, s - start,
+ (const char *)(PL_lex_inpat ? "qr" : "q"),
sv, NULL,
- ( PL_lex_inwhat == OP_TRANS
- ? "tr"
- : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
- ? "s"
- : "qq")));
+ (const char *)
+ (( PL_lex_inwhat == OP_TRANS
+ ? "tr"
+ : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
+ ? "s"
+ : "qq"))));
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
} else
SvREFCNT_dec(sv);
if (s[1]) {
if (strchr("wds]",s[1]))
weight += 100;
- else if (seen['\''] || seen['"'])
+ else if (seen[(U8)'\''] || seen[(U8)'"'])
weight += 1;
else if (strchr("rnftbxcav",s[1]))
weight += 40;
while (isALPHA(*s))
*d++ = *s++;
*d = '\0';
- if (keyword(tmpbuf, d - tmpbuf))
+ if (keyword(tmpbuf, d - tmpbuf, 0))
weight -= 150;
}
if (un_char == last_un_char + 1)
char tmpbuf[sizeof PL_tokenbuf];
STRLEN len;
GV* indirgv;
+#ifdef PERL_MAD
+ int soff;
+#endif
if (gv) {
if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
}
}
} else
- gv = 0;
+ gv = NULL;
}
s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
/* start is the beginning of the possible filehandle/object,
if (*start == '$') {
if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
return 0;
- s = skipspace(s);
+#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 (!keyword(tmpbuf, len)) {
+ if (!keyword(tmpbuf, len, 0)) {
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, 0, SVt_PVCV);
return 0;
/* filehandle or package name makes it a method */
if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
- s = skipspace(s);
+#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 bearword */
bare_package:
- PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
newSVpvn(tmpbuf,len));
- PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
+ NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
+ if (PL_madskills)
+ curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
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;
}
}
IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
IoFLAGS(datasv) |= IOf_FAKE_DIRP;
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
- IoANY(datasv), SvPV_nolen(datasv)));
+ FPTR2DPTR(void *, IoANY(datasv)),
+ SvPV_nolen(datasv)));
av_unshift(PL_rsfp_filters, 1);
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
SV *datasv;
#ifdef DEBUGGING
- DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
+ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
+ FPTR2DPTR(void*, funcp)));
#endif
if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
dVAR;
filter_t funcp;
SV *datasv = NULL;
+ /* This API is bad. It should have been using unsigned int for maxlen.
+ Not sure if we want to change the API, but if not we should sanity
+ check the value here. */
+ const unsigned int correct_length
+ = maxlen < 0 ?
+#ifdef PERL_MICRO
+ 0x7FFFFFFF
+#else
+ INT_MAX
+#endif
+ : maxlen;
if (!PL_rsfp_filters)
return -1;
/* Note that we append to the line. This is handy. */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: from rsfp\n", idx));
- if (maxlen) {
+ if (correct_length) {
/* Want a block */
int len ;
const int old_len = SvCUR(buf_sv);
/* ensure buf_sv is large enough */
- SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
- if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
+ SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
+ if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
+ correct_length)) <= 0) {
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: skipped (filter deleted)\n",
idx));
- return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
+ return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
}
/* Get function pointer hidden within datasv */
funcp = DPTR2FPTR(filter_t, IoANY(datasv));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
- idx, datasv, SvPV_nolen_const(datasv)));
+ idx, (void*)datasv, SvPV_nolen_const(datasv)));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
- return (*funcp)(aTHX_ idx, buf_sv, maxlen);
+ return (*funcp)(aTHX_ idx, buf_sv, correct_length);
}
STATIC char *
}
/* use constant CLASS => 'MyClass' */
- if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) {
- SV *sv;
- if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
+ gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
+ if (gv && GvCV(gv)) {
+ SV * const sv = cv_const_sv(GvCV(gv));
+ if (sv)
pkgname = SvPV_nolen_const(sv);
- }
}
return gv_stashpv(pkgname, FALSE);
}
+/*
+ * S_readpipe_override
+ * Check whether readpipe() is overriden, 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);
+ 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) != (GV*)&PL_sv_undef
+ && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
+ {
+ PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
+ newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
+ }
+ else {
+ set_csh();
+ }
+}
+
+#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;
+
+ /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
+ if (PL_pending_ident)
+ return S_pending_ident(aTHX);
+
+ /* 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_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 (yylval.opval)
+ append_madprops(PL_thismad, 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;
+
+ 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;
+
+ /* pval */
+ case LABEL:
+ break;
+
+ /* ival */
+ default:
+ break;
+
+ }
+
+ /* Create new token struct. Note: opvals return early above. */
+ yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
+ PL_thismad = 0;
+ return optype;
+}
+#endif
+
STATIC char *
S_tokenize_use(pTHX_ int is_use, char *s) {
dVAR;
if (PL_expect != XSTATE)
yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
is_use ? "use" : "no"));
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
s = force_version(s, TRUE);
- if (*s == ';' || (s = skipspace(s), *s == ';')) {
- PL_nextval[PL_nexttoke].opval = NULL;
+ if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = NULL;
force_next(WORD);
}
else if (*s == 'v') {
STRLEN len;
bool bof = FALSE;
+ /* orig_keyword, gvp, and gv are initialized here because
+ * jump to the label just_a_word_zero can bypass their
+ * initialization later. */
+ I32 orig_keyword = 0;
+ GV *gv = NULL;
+ GV **gvp = NULL;
+
DEBUG_T( {
SV* tmp = newSVpvs("");
PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
/* when we've already built the next token, just pull it out of the queue */
case LEX_KNOWNEXT:
+#ifdef PERL_MAD
+ PL_lasttoke--;
+ 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 = (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--;
yylval = PL_nextval[PL_nexttoke];
if (!PL_nexttoke) {
PL_expect = PL_lex_expect;
PL_lex_defer = LEX_NORMAL;
}
+#endif
+#ifdef PERL_MAD
+ /* FIXME - can these be merged? */
+ return(PL_nexttoke[PL_lasttoke].next_type);
+#else
return REPORT(PL_nexttype[PL_nexttoke]);
+#endif
/* interpolated case modifiers like \L \U, including \Q and \E.
when we get here, PL_bufptr is at the \
&& (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
PL_bufptr += 2;
PL_lex_state = LEX_INTERPCONCAT;
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_thistoken = newSVpvs("\\E");
+#endif
}
return REPORT(')');
}
+#ifdef PERL_MAD
+ while (PL_bufptr != PL_bufend &&
+ PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
+ 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_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 (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
- tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
+ 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 ((*s == 'L' || *s == 'U') &&
(strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
PL_lex_casestack[--PL_lex_casemods] = '\0';
PL_lex_casestack[PL_lex_casemods++] = *s;
PL_lex_casestack[PL_lex_casemods] = '\0';
PL_lex_state = LEX_INTERPCONCAT;
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next('(');
+ start_force(PL_curforce);
if (*s == 'l')
- PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
+ NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
else if (*s == 'u')
- PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
+ NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
else if (*s == 'L')
- PL_nextval[PL_nexttoke].ival = OP_LC;
+ NEXTVAL_NEXTTOKE.ival = OP_LC;
else if (*s == 'U')
- PL_nextval[PL_nexttoke].ival = OP_UC;
+ NEXTVAL_NEXTTOKE.ival = OP_UC;
else if (*s == 'Q')
- PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
+ NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
else
Perl_croak(aTHX_ "panic: yylex");
+ if (PL_madskills) {
+ SV* const tmpsv = newSVpvs("");
+ Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
+ curmad('_', tmpsv);
+ }
PL_bufptr = s + 1;
}
force_next(FUNC);
if (PL_lex_starts) {
s = PL_bufptr;
PL_lex_starts = 0;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_lex_casemods == 1 && PL_lex_inpat)
OPERATOR(',');
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
if (PL_lex_dojoin) {
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next(',');
+ start_force(PL_curforce);
force_ident("\"", '$');
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next('$');
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next('(');
- PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
}
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(',');
if (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
return REPORT(')');
}
if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
}
if (s != PL_bufptr) {
- PL_nextval[PL_nexttoke] = yylval;
+ start_force(PL_curforce);
+ if (PL_madskills) {
+ curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
+ }
+ NEXTVAL_NEXTTOKE = yylval;
PL_expect = XTERM;
force_next(THING);
if (PL_lex_starts++) {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
OPERATOR(',');
PL_oldbufptr = s;
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 (isIDFIRST_lazy_if(s,UTF))
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_last_uni = 0;
PL_last_lop = 0;
if (PL_lex_brackets) {
- yyerror(PL_lex_formbrack
- ? "Format not terminated"
- : "Missing right curly or square bracket");
+ yyerror((const char *)
+ (PL_lex_formbrack
+ ? "Format not terminated"
+ : "Missing right curly or square bracket"));
}
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Tokener got EOF\n");
PL_last_lop = 0;
if (!PL_in_eval && !PL_preambled) {
PL_preambled = TRUE;
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_faketokens = 1;
+#endif
sv_setpv(PL_linestr,incl_perldb());
if (SvCUR(PL_linestr))
sv_catpvs(PL_linestr,";");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_sv(PL_linestr);
goto retry;
}
do {
bof = PL_rsfp ? TRUE : FALSE;
if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
fake_eof:
+#ifdef PERL_MAD
+ PL_realtokenstart = -1;
+#endif
if (PL_rsfp) {
if (PL_preprocess && !PL_in_eval)
(void)PerlProc_pclose(PL_rsfp);
PL_doextract = FALSE;
}
if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
- sv_setpv(PL_linestr,PL_minus_p
- ? ";}continue{print;}" : ";}");
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_faketokens = 1;
+#endif
+ sv_setpv(PL_linestr,
+ (const char *)
+ (PL_minus_p
+ ? ";}continue{print;}" : ";}"));
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
}
if (PL_doextract) {
/* Incest with pod. */
+#ifdef PERL_MAD
+ if (PL_madskills)
+ sv_catsv(PL_thiswhite, PL_linestr);
+#endif
if (*s == '=' && strnEQ(s, "=cut", 4)) {
sv_setpvn(PL_linestr, "", 0);
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
incline(s);
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_sv(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
if (CopLINE(PL_curcop) == 1) {
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) == '!')
}
#endif
if (d) {
- while (*d && !isSPACE(*d)) d++;
- while (SPACE_OR_TAB(*d)) d++;
+ while (*d && !isSPACE(*d))
+ d++;
+ while (SPACE_OR_TAB(*d))
+ d++;
if (*d++ == '-') {
const bool switches_done = PL_doswitches;
do {
if (*d == 'M' || *d == 'm' || *d == 'C') {
const char * const m = d;
- while (*d && !isSPACE(*d)) d++;
+ while (*d && !isSPACE(*d))
+ d++;
Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
(int)(d - m), m);
}
#ifdef MACOS_TRADITIONAL
case '\312':
#endif
+#ifdef PERL_MAD
+ PL_realtokenstart = -1;
+ s = SKIPSPACE0(s);
+#else
s++;
+#endif
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)) {
if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
/* handle eval qq[#line 1 "foo"\n ...] */
CopLINE_dec(PL_curcop);
incline(s);
}
- d = PL_bufend;
- while (s < d && *s != '\n')
- s++;
- if (s < d)
- s++;
- else if (s > d) /* Found by Ilya: feed random input to Perl. */
- Perl_croak(aTHX_ "panic: input overflow");
- incline(s);
+ if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
+ s = SKIPSPACE0(s);
+ if (!PL_in_eval || PL_rsfp)
+ incline(s);
+ }
+ else {
+ 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");
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_thiswhite = newSVpvn(s, d - s);
+#endif
+ s = d;
+ incline(s);
+ }
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
PL_bufptr = s;
PL_lex_state = LEX_FORMLINE;
}
}
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 {
+/* if (PL_madskills && PL_lex_formbrack) { */
+ 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");
+ if (PL_madskills && CopLINE(PL_curcop) >= 1) {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ if (CopLINE(PL_curcop) == 1) {
+ sv_setpvn(PL_thiswhite, "", 0);
+ PL_faketokens = 0;
+ }
+ sv_catpvn(PL_thiswhite, s, d - s);
+ }
+ s = d;
+/* }
+ *s = '\0';
+ PL_bufend = s; */
+ }
+#else
*s = '\0';
PL_bufend = s;
+#endif
}
goto retry;
case '-':
if (strnEQ(s,"=>",2)) {
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_
- "### Saw unary minus before =>, forcing word %s\n", s);
- } );
+ DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
}
else if (*s == '>') {
s++;
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
s = force_word(s,METHOD,FALSE,TRUE,FALSE);
TOKEN(ARROW);
s++;
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:
- s = skipspace(s);
+#ifdef PERL_MAD
+ stuffstart = s - SvPVX(PL_linestr) - 1;
+#endif
+ s = PEEKSPACE(s);
attrs = NULL;
while (isIDFIRST_lazy_if(s,UTF)) {
I32 tmp;
+ SV *sv;
d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
+ if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
if (tmp < 0) tmp = -tmp;
switch (tmp) {
case KEY_or:
break;
}
}
+ sv = newSVpvn(s, len);
if (*d == '(') {
d = scan_str(d,TRUE,TRUE);
if (!d) {
yyerror("Unterminated attribute parameter in attribute list");
if (attrs)
op_free(attrs);
+ sv_free(sv);
return REPORT(0); /* EOF indicator */
}
}
if (PL_lex_stuff) {
- SV *sv = newSVpvn(s, len);
sv_catsv(sv, PL_lex_stuff);
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0, sv));
PL_lex_stuff = NULL;
}
else {
- if (len == 6 && strnEQ(s, "unique", len)) {
- if (PL_in_my == KEY_our)
+ if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
+ sv_free(sv);
+ if (PL_in_my == KEY_our) {
#ifdef USE_ITHREADS
GvUNIQUE_on(cGVOPx_gv(yylval.opval));
#else
- /*EMPTY*/; /* skip to avoid loading attributes.pm */
+ /* skip to avoid loading attributes.pm */
#endif
+ deprecate(":unique");
+ }
else
Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
}
/* NOTE: any CV attrs applied here need to be part of
the CVf_BUILTIN_ATTRS define in cv.h! */
- else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
+ sv_free(sv);
CvLVALUE_on(PL_compcv);
- else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
+ }
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
+ sv_free(sv);
CvLOCKED_on(PL_compcv);
- else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
+ }
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
+ sv_free(sv);
CvMETHOD_on(PL_compcv);
- else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
+ }
+ else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
+ sv_free(sv);
CvASSERTION_on(PL_compcv);
+ }
/* After we've set the flags, it could be argued that
we don't need to do the attributes.pm-based setting
process, and shouldn't bother appending recognized
else
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0,
- newSVpvn(s, len)));
+ sv));
}
- s = skipspace(d);
+ s = PEEKSPACE(d);
if (*s == ':' && s[1] != ':')
- s = skipspace(s+1);
+ s = PEEKSPACE(s+1);
else if (s == d)
break; /* require real whitespace or :'s */
+ /* XXX losing whitespace on sequential attributes here */
}
{
const char tmp
context messages from yyerror().
*/
PL_bufptr = s;
- yyerror( *s
- ? Perl_form(aTHX_ "Invalid separator character "
- "%c%c%c in attribute list", q, *s, q)
- : "Unterminated attribute list" );
+ yyerror( (const char *)
+ (*s
+ ? Perl_form(aTHX_ "Invalid separator character "
+ "%c%c%c in attribute list", q, *s, q)
+ : "Unterminated attribute list" ) );
if (attrs)
op_free(attrs);
OPERATOR(':');
}
got_attrs:
if (attrs) {
- PL_nextval[PL_nexttoke].opval = 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);
}
OPERATOR(':');
PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
else
PL_expect = XTERM;
- s = skipspace(s);
+ s = SKIPSPACE1(s);
TOKEN('(');
case ';':
CLINE;
case ')':
{
const char tmp = *s++;
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '{')
PREBLOCK(tmp);
TERM(tmp);
PL_lex_brackstack[PL_lex_brackets++] = XTERM;
else
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '}') {
if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
PL_expect = XTERM;
PL_expect &= XENUMMASK;
PL_lex_state = LEX_INTERPEND;
PL_bufptr = s;
+#if 0
+ if (PL_madskills) {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite,"}",1);
+ }
+#endif
return yylex(); /* ignore fake brackets */
}
if (*s == '-' && s[1] == '>')
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('}');
+#ifdef PERL_MAD
+ if (!PL_thistoken)
+ PL_thistoken = newSVpvs("");
+#endif
TOKEN(';');
case '&':
s++;
}
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_doextract = TRUE;
goto retry;
}
}
if (PL_lex_brackets < PL_lex_formbrack) {
- const char *t;
+ const char *t = s;
#ifdef PERL_STRICT_CR
- for (t = s; SPACE_OR_TAB(*t); t++) ;
+ while (SPACE_OR_TAB(*t))
#else
- for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
+ while (SPACE_OR_TAB(*t) || *t == '\r')
#endif
+ t++;
if (*t == '\n' || *t == '#') {
s--;
PL_expect = XBLOCK;
const char tmp = *s++;
if (tmp == '>')
SHop(OP_RIGHT_SHIFT);
- if (tmp == '=')
+ else if (tmp == '=')
Rop(OP_GE);
}
s--;
/* This kludge not intended to be bulletproof. */
if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
yylval.opval = newSVOP(OP_CONST, 0,
- newSViv(PL_compiling.cop_arybase));
+ newSViv(CopARYBASE_get(&PL_compiling)));
yylval.opval->op_private = OPpCONST_ARYBASE;
TERM(THING);
}
{
const char tmp = *s;
if (PL_lex_state == LEX_NORMAL)
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
&& intuit_more(s)) {
if (*s == '[') {
PL_tokenbuf[0] = '@';
if (ckWARN(WARN_SYNTAX)) {
- char *t;
- for(t = s + 1;
- isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
- t++) ;
+ char *t = s+1;
+
+ while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
+ t++;
if (*t++ == ',') {
- PL_bufptr = skipspace(PL_bufptr);
+ PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
while (t < PL_bufend && *t != ']')
t++;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
&& (t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof PL_tokenbuf];
- for (t++; isSPACE(*t); t++) ;
+ do {
+ t++;
+ } while (isSPACE(*t));
if (isIDFIRST_lazy_if(t,UTF)) {
STRLEN dummylen;
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
&dummylen);
- for (; isSPACE(*t); t++) ;
+ while (isSPACE(*t))
+ t++;
if (*t == ';' && get_cv(tmpbuf, FALSE))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"You need to quote \"%s\"",
char tmpbuf[sizeof PL_tokenbuf];
int t2;
scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
- if ((t2 = keyword(tmpbuf, len))) {
+ if ((t2 = keyword(tmpbuf, len, 0))) {
/* binary operators exclude handle interpretations */
switch (t2) {
case -KEY_x:
PREREF('@');
}
if (PL_lex_state == LEX_NORMAL)
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
if (*s == '{')
PL_tokenbuf[0] = '%';
t++;
if (*t == '}' || *t == ']') {
t++;
- PL_bufptr = skipspace(PL_bufptr);
+ PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Scalar value %.*s better written as $%.*s",
(int)(t-PL_bufptr), PL_bufptr,
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
s = scan_num(s, &yylval);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
+ DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
case '\'':
- s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
+ s = scan_str(s,!!PL_madskills,FALSE);
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
no_op("String",s);
}
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
yylval.ival = OP_CONST;
TERM(sublex_start());
case '"':
- s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
+ s = scan_str(s,!!PL_madskills,FALSE);
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
no_op("String",s);
}
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
yylval.ival = OP_CONST;
/* FIXME. I think that this can be const if char *d is replaced by
more localised variables. */
TERM(sublex_start());
case '`':
- s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
+ s = scan_str(s,!!PL_madskills,FALSE);
+ DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ missingterm(NULL);
+ readpipe_override();
TERM(sublex_start());
case '\\':
else if (!isALPHA(*start) && (PL_expect == XTERM
|| PL_expect == XREF || PL_expect == XSTATE
|| PL_expect == XTERMORDORDOR)) {
+ /* XXX Use gv_fetchpvn rather than stomping on a const string */
const char c = *start;
GV *gv;
*start = '\0';
keylookup: {
I32 tmp;
- I32 orig_keyword = 0;
- GV *gv = NULL;
- GV **gvp = NULL;
+
+ orig_keyword = 0;
+ gv = NULL;
+ gvp = NULL;
PL_bufptr = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
}
/* Check for keywords */
- tmp = keyword(PL_tokenbuf, len);
+ tmp = keyword(PL_tokenbuf, len, 0);
/* Is this a word before a => operator? */
if (*d == '=' && d[1] == '>') {
int pkgname = 0;
const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
CV *cv;
+#ifdef PERL_MAD
+ SV *nextPL_nextwhite = 0;
+#endif
+
/* Get the rest if it looks like a package qualifier */
unless name is "Foo::", in which case Foo is a bearword
(and a package name). */
- if (len > 2 &&
+ if (len > 2 && !PL_madskills &&
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
if (ckWARN(WARN_BAREWORD)
and so the scalar will be created correctly. */
sv = newSVpv(PL_tokenbuf,len);
}
+#ifdef PERL_MAD
+ if (PL_madskills && !PL_thistoken) {
+ char *start = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpv(start,s - start);
+ PL_realtokenstart = s - SvPVX(PL_linestr);
+ }
+#endif
/* Presume this is going to be a bareword of some sort. */
bool immediate_paren = *s == '(';
/* (Now we can afford to cross potential line boundary.) */
- s = skipspace(s);
+ s = SKIPSPACE2(s,nextPL_nextwhite);
+#ifdef PERL_MAD
+ PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
+#endif
/* Two barewords in a row may indicate method call. */
}
PL_expect = XOPERATOR;
+#ifdef PERL_MAD
+ if (isSPACE(*s))
+ s = SKIPSPACE2(s,nextPL_nextwhite);
+ PL_nextwhite = nextPL_nextwhite;
+#else
s = skipspace(s);
+#endif
/* Is this a word before a => operator? */
if (*s == '=' && s[1] == '>' && !pkgname) {
if (*s == '(') {
CLINE;
if (cv) {
- for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
+ d = s + 1;
+ while (SPACE_OR_TAB(*d))
+ d++;
if (*d == ')' && (sv = gv_const_sv(gv))) {
s = d + 1;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ char *par = SvPVX(PL_linestr) + PL_realtokenstart;
+ sv_catpvn(PL_thistoken, par, s - par);
+ if (PL_nextwhite) {
+ sv_free(PL_nextwhite);
+ PL_nextwhite = 0;
+ }
+ }
+#endif
goto its_constant;
}
}
- PL_nextval[PL_nexttoke].opval = yylval.opval;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ }
+ start_force(PL_curforce);
+#endif
+ NEXTVAL_NEXTTOKE.opval = yylval.opval;
PL_expect = XOPERATOR;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+#endif
force_next(WORD);
yylval.ival = 0;
TOKEN('&');
if ((sv = gv_const_sv(gv))) {
its_constant:
SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
- ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
+ ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
yylval.opval->op_private = 0;
TOKEN(WORD);
}
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
/* Is there a prototype? */
- if (SvPOK(cv)) {
+ if (
+#ifdef PERL_MAD
+ cv &&
+#endif
+ SvPOK(cv))
+ {
STRLEN protolen;
const char *proto = SvPV_const((SV*)cv, protolen);
if (!protolen)
TERM(FUNC0SUB);
- if (*proto == '$' && proto[1] == '\0')
+ if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
OPERATOR(UNIOPSUB);
while (*proto == ';')
proto++;
if (*proto == '&' && *s == '{') {
- sv_setpv(PL_subname, PL_curstash ?
- "__ANON__" : "__ANON__::__ANON__");
+ sv_setpv(PL_subname,
+ (const char *)
+ (PL_curstash ?
+ "__ANON__" : "__ANON__::__ANON__"));
PREBLOCK(LSTOPSUB);
}
}
- PL_nextval[PL_nexttoke].opval = yylval.opval;
+#ifdef PERL_MAD
+ {
+ if (PL_madskills) {
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ }
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = yylval.opval;
+ PL_expect = XTERM;
+ if (PL_madskills) {
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+ force_next(WORD);
+ 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, TRUE, SVt_PVCV);
+ op_free(yylval.opval);
+ yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+ 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 = yylval.opval;
+ PL_expect = XTERM;
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ force_next(WORD);
+ TOKEN(NOAMP);
+ }
+#else
+ NEXTVAL_NEXTTOKE.opval = yylval.opval;
PL_expect = XTERM;
force_next(WORD);
TOKEN(NOAMP);
+#endif
}
/* Call it a bare word */
bareword:
if (lastchar != '-') {
if (ckWARN(WARN_RESERVED)) {
- for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
+ d = PL_tokenbuf;
+ while (isLOWER(*d))
+ d++;
if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
PUTBACK;
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
Perl_form(aTHX_ ":encoding(%"SVf")",
- name));
+ (void*)name));
FREETMPS;
LEAVE;
}
}
#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, PL_rsfp,
+ SvCUR(PL_endwhite))) != Nullch) ;
+ }
+#endif
PL_rsfp = NULL;
}
goto fake_eof;
case KEY_AUTOLOAD:
case KEY_DESTROY:
case KEY_BEGIN:
+ case KEY_UNITCHECK:
case KEY_CHECK:
case KEY_INIT:
case KEY_END:
s += 2;
d = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (!(tmp = keyword(PL_tokenbuf, len)))
+ if (!(tmp = keyword(PL_tokenbuf, len, 0)))
Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
if (tmp < 0)
tmp = -tmp;
PREBLOCK(DEFAULT);
case KEY_do:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '{')
PRETERMBLOCK(DO);
if (*s != '\'')
UNI(OP_EXISTS);
case KEY_exit:
+ if (PL_madskills)
+ UNI(OP_INT);
UNI(OP_EXIT);
case KEY_eval:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
UNIBRACK(OP_ENTEREVAL);
case KEY_for:
case KEY_foreach:
yylval.ival = CopLINE(PL_curcop);
- s = skipspace(s);
+ 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)))
p += 2;
else if ((PL_bufend - p) >= 4 &&
strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
p += 3;
- p = skipspace(p);
+ p = PEEKSPACE(p);
if (isIDFIRST_lazy_if(p,UTF)) {
p = scan_ident(p, PL_bufend,
PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
- p = skipspace(p);
+ p = PEEKSPACE(p);
}
if (*p != '$')
Perl_croak(aTHX_ "Missing $ on loop variable");
+#ifdef PERL_MAD
+ s = SvPVX(PL_linestr) + soff;
+#endif
}
OPERATOR(FOR);
case KEY_our:
case KEY_my:
+ case KEY_state:
PL_in_my = tmp;
- s = skipspace(s);
+ 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))
goto really_sub;
if (!PL_in_my_stash) {
char tmpbuf[1024];
PL_bufptr = s;
- sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
+ my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
yyerror(tmpbuf);
}
+#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
}
yylval.ival = 1;
OPERATOR(MY);
OPERATOR(USE);
case KEY_not:
- if (*s == '(' || (s = skipspace(s), *s == '('))
+ if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
FUN1(OP_NOT);
else
OPERATOR(NOTOP);
case KEY_open:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
const char *t;
- for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
- for (t=d; *t && isSPACE(*t); t++) ;
+ for (d = s; isALNUM_lazy_if(d,UTF);)
+ d++;
+ for (t=d; isSPACE(*t);)
+ t++;
if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
/* [perl #16184] */
&& !(t[0] == '=' && t[1] == '>')
LOP(OP_PIPE_OP,XTERM);
case KEY_q:
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
yylval.ival = OP_CONST;
TERM(sublex_start());
UNI(OP_QUOTEMETA);
case KEY_qw:
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
PL_expect = XOPERATOR;
force_next(')');
if (SvCUR(PL_lex_stuff)) {
int warned = 0;
d = SvPV_force(PL_lex_stuff, len);
while (len) {
- SV *sv;
- for (; isSPACE(*d) && len; --len, ++d) ;
+ for (; isSPACE(*d) && len; --len, ++d)
+ /**/;
if (len) {
+ SV *sv;
const char *b = d;
if (!warned && ckWARN(WARN_QW)) {
for (; !isSPACE(*d) && len; --len, ++d) {
}
}
else {
- for (; !isSPACE(*d) && len; --len, ++d) ;
+ for (; !isSPACE(*d) && len; --len, ++d)
+ /**/;
}
sv = newSVpvn(b, d-b);
if (DO_UTF8(PL_lex_stuff))
}
}
if (words) {
- PL_nextval[PL_nexttoke].opval = words;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = words;
force_next(THING);
}
}
TOKEN('(');
case KEY_qq:
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
yylval.ival = OP_STRINGIFY;
if (SvIVX(PL_lex_stuff) == '\'')
SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
TERM(sublex_start());
case KEY_qx:
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ missingterm(NULL);
+ readpipe_override();
TERM(sublex_start());
case KEY_return:
OLDLOP(OP_RETURN);
case KEY_require:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (isDIGIT(*s)) {
s = force_version(s, FALSE);
}
case KEY_sort:
checkcomma(s,PL_tokenbuf,"subroutine name");
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == ';' || *s == ')') /* probably a close */
Perl_croak(aTHX_ "sort is now a reserved word");
PL_expect = XTERM;
char tmpbuf[sizeof PL_tokenbuf];
SSize_t tboffset = 0;
expectation attrful;
- bool have_name, have_proto, bad_proto;
+ bool have_name, have_proto;
const int key = tmp;
+#ifdef PERL_MAD
+ SV *tmpwhite = 0;
+
+ char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ SV *subtoken = newSVpvn(tstart, s - tstart);
+ PL_thistoken = 0;
+
+ d = s;
+ s = SKIPSPACE2(s,tmpwhite);
+#else
s = skipspace(s);
+#endif
if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
(*s == ':' && s[1] == ':'))
{
+#ifdef PERL_MAD
+ SV *nametoke;
+#endif
+
PL_expect = XBLOCK;
attrful = XATTRBLOCK;
/* remember buffer pos'n for later force_word */
tboffset = s - PL_oldbufptr;
d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+#ifdef PERL_MAD
+ if (PL_madskills)
+ nametoke = newSVpvn(s, d - s);
+#endif
if (strchr(tmpbuf, ':'))
sv_setpv(PL_subname, tmpbuf);
else {
sv_catpvs(PL_subname,"::");
sv_catpvn(PL_subname,tmpbuf,len);
}
- s = skipspace(d);
have_name = TRUE;
+
+#ifdef PERL_MAD
+
+ start_force(0);
+ CURMAD('X', nametoke);
+ CURMAD('_', tmpwhite);
+ (void) force_word(PL_oldbufptr + tboffset, WORD,
+ FALSE, TRUE, TRUE);
+
+ s = SKIPSPACE2(d,tmpwhite);
+#else
+ s = skipspace(d);
+#endif
}
else {
if (key == KEY_my)
if (key == KEY_format) {
if (*s == '=')
PL_lex_formbrack = PL_lex_brackets + 1;
+#ifdef PERL_MAD
+ PL_thistoken = subtoken;
+ s = d;
+#else
if (have_name)
(void) force_word(PL_oldbufptr + tboffset, WORD,
FALSE, TRUE, TRUE);
+#endif
OPERATOR(FORMAT);
}
/* Look for a prototype */
if (*s == '(') {
char *p;
+ bool bad_proto = FALSE;
+ const bool warnsyntax = ckWARN(WARN_SYNTAX);
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
/* strip spaces and check for bad characters */
d = SvPVX(PL_lex_stuff);
tmp = 0;
- bad_proto = FALSE;
for (p = d; *p; ++p) {
if (!isSPACE(*p)) {
d[tmp++] = *p;
- if (!strchr("$@%*;[]&\\", *p))
+ if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
bad_proto = TRUE;
}
}
d[tmp] = '\0';
- if (bad_proto && ckWARN(WARN_SYNTAX))
+ if (bad_proto)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Illegal character in prototype for %"SVf" : %s",
- PL_subname, d);
+ (void*)PL_subname, d);
SvCUR_set(PL_lex_stuff, tmp);
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 = Nullsv;
+ force_next(THING);
+
+ s = SKIPSPACE2(s,tmpwhite);
+#else
s = skipspace(s);
+#endif
}
else
have_proto = FALSE;
if (!have_name)
Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
else if (*s != ';')
- Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
+ Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, (void*)PL_subname);
+ }
+
+#ifdef PERL_MAD
+ start_force(0);
+ if (tmpwhite) {
+ if (PL_madskills)
+ curmad('^', newSVpvs(""));
+ CURMAD('_', tmpwhite);
}
+ force_next(0);
+ PL_thistoken = subtoken;
+#else
if (have_proto) {
- PL_nextval[PL_nexttoke].opval =
+ NEXTVAL_NEXTTOKE.opval =
(OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
PL_lex_stuff = NULL;
force_next(THING);
}
+#endif
if (!have_name) {
sv_setpv(PL_subname,
- PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
+ (const char *)
+ (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
TOKEN(ANONSUB);
}
+#ifndef PERL_MAD
(void) force_word(PL_oldbufptr + tboffset, WORD,
FALSE, TRUE, TRUE);
+#endif
if (key == KEY_my)
TOKEN(MYSUB);
TOKEN(SUB);
{
dVAR;
register char *d;
- register I32 tmp = 0;
+ PADOFFSET tmp = 0;
/* pit holds the identifier we read and pending_ident is reset */
char pit = PL_pending_ident;
PL_pending_ident = 0;
+ /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
DEBUG_T({ PerlIO_printf(Perl_debug_log,
"### Pending identifier '%s'\n", PL_tokenbuf); });
}
else {
if (strchr(PL_tokenbuf,':'))
- yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
+ yyerror(Perl_form(aTHX_ PL_no_myglob,
+ PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
yylval.opval = newOP(OP_PADANY, 0);
yylval.opval->op_targ = allocmy(PL_tokenbuf);
*/
I32
-Perl_keyword (pTHX_ const char *name, I32 len)
+Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
{
- dVAR;
+ dVAR;
switch (len)
{
case 1: /* 5 tokens of length 1 */
case 'r':
if (name[2] == 'r')
{ /* err */
- return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
}
goto unknown;
case 'a':
if (name[2] == 'y')
{ /* say */
- return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
}
goto unknown;
switch (name[1])
{
case 'a':
- switch (name[2])
- {
- case 'i':
- if (name[3] == 't')
- { /* wait */
- return -KEY_wait;
- }
+ switch (name[2])
+ {
+ case 'i':
+ if (name[3] == 't')
+ { /* wait */
+ return -KEY_wait;
+ }
- goto unknown;
+ goto unknown;
- case 'r':
- if (name[3] == 'n')
- { /* warn */
- return -KEY_warn;
- }
+ case 'r':
+ if (name[3] == 'n')
+ { /* warn */
+ return -KEY_warn;
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
case 'h':
if (name[2] == 'e' &&
name[3] == 'n')
{ /* when */
- return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
- }
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
default:
goto unknown;
}
- case 5: /* 38 tokens of length 5 */
+ case 5: /* 39 tokens of length 5 */
switch (name[0])
{
case 'B':
{
case 'l':
if (name[2] == 'e' &&
- name[3] == 's' &&
- name[4] == 's')
- { /* bless */
- return -KEY_bless;
- }
+ name[3] == 's' &&
+ name[4] == 's')
+ { /* bless */
+ return -KEY_bless;
+ }
- goto unknown;
+ goto unknown;
case 'r':
if (name[2] == 'e' &&
name[3] == 'a' &&
name[4] == 'k')
{ /* break */
- return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
}
goto unknown;
name[3] == 'e' &&
name[4] == 'n')
{ /* given */
- return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
}
goto unknown;
goto unknown;
case 't':
- if (name[2] == 'u' &&
- name[3] == 'd' &&
- name[4] == 'y')
- { /* study */
- return KEY_study;
- }
+ switch (name[2])
+ {
+ case 'a':
+ if (name[3] == 't' &&
+ name[4] == 'e')
+ { /* state */
+ return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
+ }
- goto unknown;
+ goto unknown;
+
+ case 'u':
+ if (name[3] == 'd' &&
+ name[4] == 'y')
+ { /* study */
+ return KEY_study;
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
default:
goto unknown;
name[5] == 'l' &&
name[6] == 't')
{ /* default */
- return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
}
goto unknown;
case 'i':
if (name[4] == 'n' &&
- name[5] == 'e' &&
- name[6] == 'd')
- { /* defined */
- return KEY_defined;
- }
+ name[5] == 'e' &&
+ name[6] == 'd')
+ { /* defined */
+ return KEY_defined;
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
}
goto unknown;
goto unknown;
}
- case 9: /* 8 tokens of length 9 */
+ case 9: /* 9 tokens of length 9 */
switch (name[0])
{
+ case 'U':
+ if (name[1] == 'N' &&
+ name[2] == 'I' &&
+ name[3] == 'T' &&
+ name[4] == 'C' &&
+ name[5] == 'H' &&
+ name[6] == 'E' &&
+ name[7] == 'C' &&
+ name[8] == 'K')
+ { /* UNITCHECK */
+ return KEY_UNITCHECK;
+ }
+
+ goto unknown;
+
case 'e':
if (name[1] == 'n' &&
name[2] == 'd' &&
}
STATIC void
-S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
+S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
{
dVAR;
- const char *w;
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
if (ckWARN(WARN_SYNTAX)) {
int level = 1;
+ const char *w;
for (w = s+2; *w && level; w++) {
if (*w == '(')
++level;
else if (*w == ')')
--level;
}
- if (*w)
- for (; *w && isSPACE(*w); w++) ;
+ while (isSPACE(*w))
+ ++w;
if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%s (...) interpreted as function",name);
while (s < PL_bufend && isSPACE(*s))
s++;
if (isIDFIRST_lazy_if(s,UTF)) {
- w = s++;
+ const char * const w = s++;
while (isALNUM_lazy_if(s,UTF))
s++;
while (s < PL_bufend && isSPACE(*s))
s++;
if (*s == ',') {
- I32 kw;
- *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
- kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
- *s = ',';
- if (kw)
+ GV* gv;
+ if (keyword(w, s - w, 0))
+ return;
+
+ gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
+ if (gv && GvCVu(gv))
return;
Perl_croak(aTHX_ "No comma allowed after %s", what);
}
if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
SV *msg;
- why2 = strEQ(key,"charnames")
- ? "(possibly a missing \"use charnames ...\")"
- : "";
+ why2 = (const char *)
+ (strEQ(key,"charnames")
+ ? "(possibly a missing \"use charnames ...\")"
+ : "");
msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
(type ? type: "undef"), why2);
sv_catpvs(ERRSV, "Propagated");
yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
(void)POPs;
- res = SvREFCNT_inc(sv);
+ res = SvREFCNT_inc_simple(sv);
}
else {
res = POPs;
- (void)SvREFCNT_inc(res);
+ SvREFCNT_inc_simple_void(res);
}
PUTBACK ;
Perl_croak(aTHX_ ident_too_long);
if (isALNUM(*s)) /* UTF handled below */
*d++ = *s++;
- else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
+ else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
*d++ = ':';
*d++ = ':';
s++;
}
- else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
+ else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
*d++ = *s++;
*d++ = *s++;
}
else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
char *t = s + UTF8SKIP(s);
+ size_t len;
while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
t += UTF8SKIP(t);
- if (d + (t - s) > e)
+ len = t - s;
+ if (d + len > e)
Perl_croak(aTHX_ ident_too_long);
- Copy(s, d, t - s, char);
- d += t - s;
+ Copy(s, d, len, char);
+ d += len;
s = t;
}
else {
register char * const e = d + destlen + 3; /* two-character token, ending NUL */
if (isSPACE(*s))
- s = skipspace(s);
+ s = PEEKSPACE(s);
if (isDIGIT(*s)) {
while (isDIGIT(*s)) {
if (d >= e)
Perl_croak(aTHX_ ident_too_long);
}
*d = '\0';
- while (s < send && SPACE_OR_TAB(*s)) s++;
+ while (s < send && SPACE_OR_TAB(*s))
+ s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
- const char *brack = *s == '[' ? "[...]" : "{...}";
+ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
+ const char * const brack =
+ (const char *)
+ ((*s == '[') ? "[...]" : "{...}");
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
PL_lex_state = LEX_INTERPEND;
PL_expect = XREF;
}
- if (funny == '#')
- funny = '@';
if (PL_lex_state == LEX_NORMAL) {
if (ckWARN(WARN_AMBIGUOUS) &&
- (keyword(dest, d - dest) || get_cv(dest, FALSE)))
+ (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
{
+ if (funny == '#')
+ funny = '@';
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
{
dVAR;
PMOP *pm;
- char *s = scan_str(start,FALSE,FALSE);
- const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx";
+ char *s = scan_str(start,!!PL_madskills,FALSE);
+ const char * const valid_flags =
+ (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
+#ifdef PERL_MAD
+ char *modstart;
+#endif
+
if (!s) {
const char * const delimiter = skipspace(start);
- Perl_croak(aTHX_ *delimiter == '?'
- ? "Search pattern not terminated or ternary operator parsed as search pattern"
- : "Search pattern not terminated" );
+ Perl_croak(aTHX_
+ (const char *)
+ (*delimiter == '?'
+ ? "Search pattern not terminated or ternary operator parsed as search pattern"
+ : "Search pattern not terminated" ));
}
pm = (PMOP*)newPMOP(type, 0);
if (PL_multi_open == '?')
pm->op_pmflags |= PMf_ONCE;
+#ifdef PERL_MAD
+ modstart = s;
+#endif
while (*s && strchr(valid_flags, *s))
pmflag(&pm->op_pmflags,*s++);
+#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)
&& ckWARN(WARN_REGEXP))
register PMOP *pm;
I32 first_start;
I32 es = 0;
+#ifdef PERL_MAD
+ char *modstart;
+#endif
yylval.ival = OP_NULL;
- s = scan_str(start,FALSE,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE);
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
first_start = PL_multi_start;
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
PL_multi_start = first_start; /* so whole substitution is taken together */
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 == 'e') {
s++;
break;
}
+#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) && ckWARN(WARN_REGEXP)) {
Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
}
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
while (es-- > 0)
- sv_catpv(repl, es ? "eval " : "do ");
- sv_catpvs(repl, "{ ");
+ sv_catpv(repl, (const char *)(es ? "eval " : "do "));
+ sv_catpvs(repl, "{");
sv_catsv(repl, PL_lex_repl);
- sv_catpvs(repl, " }");
+ if (strchr(SvPVX(PL_lex_repl), '#'))
+ sv_catpvs(repl, "\n");
+ sv_catpvs(repl, "}");
SvEVALED_on(repl);
SvREFCNT_dec(PL_lex_repl);
PL_lex_repl = repl;
I32 squash;
I32 del;
I32 complement;
+#ifdef PERL_MAD
+ char *modstart;
+#endif
yylval.ival = OP_NULL;
- s = scan_str(start,FALSE,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE);
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 = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
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;
yylval.ival = 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;
}
register char *e;
char *peek;
const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
+#ifdef PERL_MAD
+ I32 stuffstart = s - SvPVX(PL_linestr);
+ char *tstart;
+
+ PL_realtokenstart = -1;
+#endif
s += 2;
d = PL_tokenbuf;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
if (!outer)
*d++ = '\n';
- for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
+ peek = s;
+ while (SPACE_OR_TAB(*peek))
+ peek++;
if (*peek == '`' || *peek == '\'' || *peek =='"') {
s = peek;
term = *s++;
*d++ = '\n';
*d = '\0';
len = d - PL_tokenbuf;
+
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ tstart = PL_tokenbuf + !outer;
+ PL_thisclose = newSVpvn(tstart, len - !outer);
+ 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
- if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) {
+#ifdef PERL_MAD
+ found_newline = 0;
+#endif
+ if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
herewas = newSVpvn(s,PL_bufend-s);
}
else {
+#ifdef PERL_MAD
+ herewas = newSVpvn(s-1,found_newline-s+1);
+#else
s--;
herewas = newSVpvn(s,found_newline-s);
+#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);
+ }
+#endif
s += SvCUR(herewas);
+#ifdef PERL_MAD
+ stuffstart = s - SvPVX(PL_linestr);
+
+ if (found_newline)
+ s--;
+#endif
+
tmpstr = newSV(79);
sv_upgrade(tmpstr, SVt_PVIV);
if (term == '\'') {
missingterm(PL_tokenbuf);
}
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;
CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
else
sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
while (s >= PL_bufend) { /* multiple line string? */
+#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
if (!outer ||
!(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
missingterm(PL_tokenbuf);
}
+#ifdef PERL_MAD
+ stuffstart = s - SvPVX(PL_linestr);
+#endif
CopLINE_inc(PL_curcop);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
PL_bufend[-1] = '\n';
#endif
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_sv(PL_linestr);
if (*s == term && memEQ(s,PL_tokenbuf,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
*(SvPVX(PL_linestr) + off ) = ' ';
or if it didn't end, or if we see a newline
*/
- if (len >= sizeof PL_tokenbuf)
+ if (len >= (I32)sizeof PL_tokenbuf)
Perl_croak(aTHX_ "Excessively long <> operator");
if (s >= end)
Perl_croak(aTHX_ "Unterminated <> operator");
if (d - PL_tokenbuf != len) {
yylval.ival = OP_GLOB;
set_csh();
- s = scan_str(start,FALSE,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE);
if (!s)
Perl_croak(aTHX_ "Glob not terminated");
return s;
filehandle
*/
if (*d == '$') {
- I32 tmp;
-
/* try to find it in the pad for this block, otherwise find
add symbol table ops
*/
- if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
+ const PADOFFSET tmp = pad_findmy(d);
+ if (tmp != NOT_IN_PAD) {
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
HEK * const stashname = HvNAME_HEK(stash);
{
dVAR;
SV *sv; /* scalar value: string */
- char *tmps; /* temp string, used for delimiter matching */
+ const char *tmps; /* temp string, used for delimiter matching */
register char *s = start; /* current position in the buffer */
register char term; /* terminating character */
register char *to; /* current position in the sv's data */
I32 termcode; /* terminating char. code */
U8 termstr[UTF8_MAXBYTES]; /* terminating string */
STRLEN termlen; /* length of terminating string */
- char *last = NULL; /* last position for nesting bracket */
+ int last_off = 0; /* last position for nesting bracket */
+#ifdef PERL_MAD
+ int stuffstart;
+ char *tstart;
+#endif
/* skip space before the delimiter */
- if (isSPACE(*s))
- s = skipspace(s);
+ if (isSPACE(*s)) {
+ 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;
if (keep_delims)
sv_catpvn(sv, s, termlen);
s += termlen;
+#ifdef PERL_MAD
+ tstart = SvPVX(PL_linestr) + stuffstart;
+ if (!PL_thisopen && !keep_delims) {
+ PL_thisopen = newSVpvn(tstart, s - tstart);
+ stuffstart = s - SvPVX(PL_linestr);
+ }
+#endif
for (;;) {
if (PL_encoding && !UTF) {
bool cont = TRUE;
else {
const char *t;
char *w;
- if (!last)
- last = SvPVX(sv);
- for (t = w = last; t < svlast; w++, t++) {
+ for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
/* At here, all closes are "was quoted" one,
so we don't check PL_multi_close. */
if (*t == '\\') {
*w = '\0';
SvCUR_set(sv, w - SvPVX_const(sv));
}
- last = w;
+ last_off = w - SvPVX(sv);
if (--brackets <= 0)
cont = FALSE;
}
/* 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
if (!PL_rsfp ||
!(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
sv_free(sv);
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
return NULL;
}
+#ifdef PERL_MAD
+ stuffstart = 0;
+#endif
/* we read a line, so increment our line counter */
CopLINE_inc(PL_curcop);
/* update debugger info */
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const line_sv = newSV(0);
-
- sv_upgrade(line_sv, SVt_PVMG);
- sv_setsv(line_sv,PL_linestr);
- (void)SvIOK_on(line_sv);
- SvIV_set(line_sv, 0);
- av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_sv(PL_linestr);
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
/* at this point, we have successfully read the delimited string */
if (!PL_encoding || UTF) {
+#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)
SvUTF8_on(sv);
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
(PL_hints & HINT_NEW_INTEGER) )
- sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
+ sv = new_constant(PL_tokenbuf,
+ d - PL_tokenbuf,
+ (const char *)
(floatit ? "float" : "integer"),
sv, NULL, NULL);
break;
SV * const stuff = newSVpvs("");
bool needargs = FALSE;
bool eofmt = FALSE;
+#ifdef PERL_MAD
+ char *tokenstart = s;
+ SV* savewhite;
+
+ if (PL_madskills) {
+ savewhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ }
+#endif
while (!needargs) {
if (*s == '.') {
+ t = s+1;
#ifdef PERL_STRICT_CR
- for (t = s+1;SPACE_OR_TAB(*t); t++) ;
+ while (SPACE_OR_TAB(*t))
+ t++;
#else
- for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
+ while (SPACE_OR_TAB(*t) || *t == '\r')
+ t++;
#endif
if (*t == '\n' || t == PL_bufend) {
eofmt = TRUE;
}
s = (char*)eol;
if (PL_rsfp) {
+#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
s = filter_gets(PL_linestr, PL_rsfp, 0);
+#ifdef PERL_MAD
+ tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
+#else
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
+#endif
PL_bufend = PL_bufptr + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
if (!s) {
PL_expect = XTERM;
if (needargs) {
PL_lex_state = LEX_NORMAL;
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next(',');
}
else
else if (PL_encoding)
sv_recode_to_utf8(stuff, PL_encoding);
}
- PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
force_next(THING);
- PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
force_next(LSTOP);
}
else {
PL_lex_formbrack = 0;
PL_bufptr = s;
}
+#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;
}
PL_subline = CopLINE(PL_curcop);
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
return oldsavestack_ix;
const char *context = NULL;
int contlen = -1;
SV *msg;
+ int yychar = PL_parser->yychar;
if (!yychar || (yychar == ';' && !PL_rsfp))
where = "at EOF";
PL_multi_end = 0;
}
if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, (void*)msg);
else
qerror(msg);
if (PL_error_count >= 10) {
if (PL_in_eval && SvCUR(ERRSV))
Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
- ERRSV, OutCopFILE(PL_curcop));
+ (void*)ERRSV, OutCopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
OutCopFILE(PL_curcop));
PL_bufend - (char*)s - 1,
&newlen);
sv_setpvn(PL_linestr, (const char*)news, newlen);
+#ifdef PERL_MAD
+ s = (U8*)SvPVX(PL_linestr);
+ Copy(news, s, newlen, U8);
+ s[newlen] = '\0';
+#endif
Safefree(news);
SvUTF8_on(PL_linestr);
s = (U8*)SvPVX(PL_linestr);
+#ifdef PERL_MAD
+ /* FIXME - is this a general bug fix? */
+ s[newlen] = '\0';
+#endif
PL_bufend = SvPVX(PL_linestr) + newlen;
}
#else
goto utf16be;
}
}
+#ifdef EBCDIC
+ case 0xDD:
+ if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
+ if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
+ s += 4; /* UTF-8 */
+ }
+ break;
+#endif
+
default:
if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
/* Leading bytes
const I32 count = FILTER_READ(idx+1, sv, maxlen);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"utf16_textfilter(%p): %d %d (%d)\n",
- utf16_textfilter, idx, maxlen, (int) count));
+ FPTR2DPTR(void *, utf16_textfilter),
+ idx, maxlen, (int) count));
if (count) {
U8* tmps;
I32 newlen;
const I32 count = FILTER_READ(idx+1, sv, maxlen);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"utf16rev_textfilter(%p): %d %d (%d)\n",
- utf16rev_textfilter, idx, maxlen, (int) count));
+ FPTR2DPTR(void *, utf16rev_textfilter),
+ idx, maxlen, (int) count));
if (count) {
U8* tmps;
I32 newlen;
if (!isALPHA(*pos)) {
U8 tmpbuf[UTF8_MAXBYTES+1];
- if (*s == 'v') s++; /* get past 'v' */
+ if (*s == 'v')
+ s++; /* get past 'v' */
sv_setpvn(sv, "", 0);
for (;;) {
+ /* this is atoi() that tolerates underscores */
U8 *tmpend;
UV rev = 0;
- {
- /* this is atoi() that tolerates underscores */
- const char *end = pos;
- UV mult = 1;
- while (--end >= s) {
- UV orev;
- if (*end == '_')
- continue;
- orev = rev;
+ const char *end = pos;
+ UV mult = 1;
+ while (--end >= s) {
+ if (*end != '_') {
+ const UV orev = rev;
rev += (*end - '0') * mult;
mult *= 10;
if (orev > rev && ckWARN_d(WARN_OVERFLOW))
https://perl5.git.perl.org / perl5.git / blobdiff