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 ); \
}
TOKENTYPE_GVVAL
};
-static struct debug_tokens { const int token, type; const char *name; }
- const debug_tokens[] =
+static struct debug_tokens {
+ const int token;
+ enum token_type type;
+ const char *name;
+} const debug_tokens[] =
{
{ ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
{ ANDAND, TOKENTYPE_NONE, "ANDAND" },
STATIC int
S_tokereport(pTHX_ I32 rv)
{
+ dVAR;
if (DEBUG_T_TEST) {
- const char *name = Nullch;
+ const char *name = NULL;
enum token_type type = TOKENTYPE_NONE;
const struct debug_tokens *p;
SV* const report = newSVpvs("<== ");
STATIC int
S_ao(pTHX_ int toketype)
{
+ dVAR;
if (*PL_bufptr == '=') {
PL_bufptr++;
if (toketype == ANDAND)
STATIC void
S_no_op(pTHX_ const char *what, char *s)
{
+ dVAR;
char * const oldbp = PL_bufptr;
const bool is_first = (PL_oldbufptr == PL_linestart);
"\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; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
+ /**/;
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.
STATIC void
S_missingterm(pTHX_ char *s)
{
+ dVAR;
char tmpbuf[3];
char q;
if (s) {
* 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);
-
+
return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
}
void
Perl_lex_start(pTHX_ SV *line)
{
+ dVAR;
const char *s;
STRLEN len;
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_casestack = '\0';
PL_lex_dojoin = 0;
PL_lex_starts = 0;
- PL_lex_stuff = Nullsv;
- PL_lex_repl = Nullsv;
+ 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;
SvTEMP_off(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend = PL_bufptr + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
PL_rsfp = 0;
}
void
Perl_lex_end(pTHX)
{
+ dVAR;
PL_doextract = FALSE;
}
STATIC void
S_incline(pTHX_ char *s)
{
+ dVAR;
char *t;
char *n;
char *e;
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++;
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 = newSVpvn("",0);
+ 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 = newSVpvn("",0);
+ 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 = s;
+ I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
+ I32 startoff = start - 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 = newSVpvn("",0);
+ sv_setsv(*svp, PL_skipwhite);
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
+ }
+
+ return s;
+}
+#endif
+
/*
* S_skipspace
* Called to gobble the appropriate amount and type of whitespace.
STATIC char *
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)))) == Nullch)
+ (prevlen = SvCUR(PL_linestr)))) == NULL)
{
+#ifdef PERL_MAD
+ if (PL_madskills && curoff != startoff) {
+ if (!PL_skipwhite)
+ PL_skipwhite = newSVpvn("",0);
+ 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 = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
/* Close the filehandle. Could be from -P preprocessor,
* STDIN, or a regular file. If we were reading code from
PerlIO_clearerr(PL_rsfp);
else
(void)PerlIO_close(PL_rsfp);
- PL_rsfp = Nullfp;
+ PL_rsfp = NULL;
return s;
}
* so store the line into the debugger's array of lines
*/
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = NEWSV(85,0);
+ SV * const sv = newSV(0);
sv_upgrade(sv, SVt_PVMG);
sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
}
}
+
+#ifdef PERL_MAD
+ done:
+ if (PL_madskills) {
+ if (!PL_skipwhite)
+ PL_skipwhite = newSVpvn("",0);
+ curoff = s - SvPVX(PL_linestr);
+ if (curoff - startoff)
+ sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
+ curoff - startoff);
+ }
+ return s;
+#endif
}
/*
STATIC void
S_check_uni(pTHX)
{
- char *s;
- char *t;
+ dVAR;
+ 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++) ;
+ for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++)
+ /**/;
if ((t = strchr(s, '(')) && t < PL_bufptr)
return;
+
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);
}
}
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
+ dVAR;
yylval.ival = f;
CLINE;
PL_expect = x;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = (OPCODE)f;
+#ifdef PERL_MAD
+ if (PL_lasttoke)
+ 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('^', newSVpvn("",0));
+ 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) /*EMPTY*/
+# define curmad(slot, sv) /*EMPTY*/
+#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 *
S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
{
+ dVAR;
SV * const sv = newSVpvn(start,len);
if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
SvUTF8_on(sv);
STATIC char *
S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
{
+ dVAR;
register char *s;
STRLEN len;
- start = skipspace(start);
+ start = SKIPSPACE1(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF) ||
(allow_pack && *s == ':') ||
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
if (check_keyword && keyword(PL_tokenbuf, len))
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;
STATIC void
S_force_ident(pTHX_ register const char *s, int kind)
{
+ dVAR;
if (s && *s) {
- OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
- PL_nextval[PL_nexttoke].opval = o;
+ const STRLEN len = strlen(s);
+ OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = o;
force_next(WORD);
if (kind) {
o->op_private = OPpCONST_ENTERED;
/* XXX see note in pp_entereval() for why we forgo typo
warnings if the symbol must be introduced in an eval.
GSAR 96-10-12 */
- gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD,
- kind == '$' ? SVt_PV :
- kind == '@' ? SVt_PVAV :
- kind == '%' ? SVt_PVHV :
+ gv_fetchpvn_flags(s, len,
+ PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
+ : GV_ADD,
+ kind == '$' ? SVt_PV :
+ kind == '@' ? SVt_PVAV :
+ kind == '%' ? SVt_PVHV :
SVt_PVGV
- );
+ );
}
}
}
STATIC char *
S_force_version(pTHX_ char *s, int guessing)
{
- OP *version = Nullop;
+ 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;
STATIC SV *
S_tokeq(pTHX_ SV *sv)
{
+ dVAR;
register char *s;
register char *send;
register char *d;
STATIC I32
S_sublex_start(pTHX)
{
+ dVAR;
register const I32 op_type = yylval.ival;
if (op_type == OP_NULL) {
yylval.opval = PL_lex_op;
- PL_lex_op = Nullop;
+ PL_lex_op = NULL;
return THING;
}
if (op_type == OP_CONST || op_type == OP_READLINE) {
if (SvTYPE(sv) == SVt_PVIV) {
/* Overloaded constants, nothing fancy: Convert to SVt_PV: */
STRLEN len;
- const char *p = SvPV_const(sv, len);
+ const char * const p = SvPV_const(sv, len);
SV * const nsv = newSVpvn(p, len);
if (SvUTF8(sv))
SvUTF8_on(nsv);
sv = nsv;
}
yylval.opval = (OP*)newSVOP(op_type, 0, sv);
- PL_lex_stuff = Nullsv;
+ PL_lex_stuff = NULL;
/* Allow <FH> // "foo" */
if (op_type == OP_READLINE)
PL_expect = XTERMORDORDOR;
PL_expect = XTERM;
if (PL_lex_op) {
yylval.opval = PL_lex_op;
- PL_lex_op = Nullop;
+ PL_lex_op = NULL;
return PMFUNC;
}
else
SAVEGENERICPV(PL_lex_casestack);
PL_linestr = PL_lex_stuff;
- PL_lex_stuff = Nullsv;
+ PL_lex_stuff = NULL;
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
= SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
PL_lex_inpat = PL_sublex_info.sub_op;
else
- PL_lex_inpat = Nullop;
+ PL_lex_inpat = NULL;
return '(';
}
PL_lex_inpat = 0;
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
PL_lex_brackets = 0;
}
else {
PL_lex_state = LEX_INTERPCONCAT;
- PL_lex_repl = Nullsv;
+ PL_lex_repl = NULL;
}
return ',';
}
else {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thiswhite) {
+ if (!PL_endwhite)
+ PL_endwhite = newSVpvn("",0);
+ 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);
STATIC char *
S_scan_const(pTHX_ char *start)
{
+ dVAR;
register char *send = PL_bufend; /* end of the constant */
- SV *sv = NEWSV(93, send - start); /* sv for the constant */
+ SV *sv = newSV(send - start); /* sv for the constant */
register char *s = start; /* start of the constant */
register char *d = SvPVX(sv); /* destination for copies */
bool dorange = FALSE; /* are we in a translit range? */
UV literal_endpoint = 0;
#endif
- const char *leaveit = /* set of acceptably-backslashed characters */
+ const char * const leaveit = /* set of acceptably-backslashed characters */
PL_lex_inpat
? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
: "";
goto NUM_ESCAPE_INSERT;
}
res = newSVpvn(s + 1, e - s - 1);
- res = new_constant( Nullch, 0, "charnames",
- res, Nullsv, "\\N{...}" );
+ res = new_constant( NULL, 0, "charnames",
+ res, NULL, "\\N{...}" );
if (has_utf8)
sv_utf8_upgrade(res);
str = SvPV_const(res,len);
and then encode the next character */
if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
STRLEN len = 1;
- const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
- const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
+ const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
+ const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
s += len;
if (need > len) {
/* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
const STRLEN off = d - SvPVX_const(sv);
d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
}
- d = (char*)uvchr_to_utf8((U8*)d, uv);
+ d = (char*)uvchr_to_utf8((U8*)d, nextuv);
has_utf8 = TRUE;
}
else {
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, Nullsv,
+ sv, NULL,
( PL_lex_inwhat == OP_TRANS
? "tr"
: ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
STATIC int
S_intuit_more(pTHX_ register char *s)
{
+ dVAR;
if (PL_lex_brackets)
return TRUE;
if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
case '$':
weight -= seen[un_char] * 10;
if (isALNUM_lazy_if(s+1,UTF)) {
+ int len;
scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
- if ((int)strlen(tmpbuf) > 1
- && gv_fetchpv(tmpbuf, 0, SVt_PV))
+ len = (int)strlen(tmpbuf);
+ if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
weight -= 100;
else
weight -= 10;
STATIC int
S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
{
+ dVAR;
char *s = start + (*start == '$');
char tmpbuf[sizeof PL_tokenbuf];
STRLEN len;
GV* indirgv;
+#ifdef PERL_MAD
+ int soff;
+#endif
if (gv) {
if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
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 PERLMAD
+ start = SvPVX(PL_linestr) + len;
+#endif
PL_bufptr = start;
PL_expect = XREF;
return *s == '(' ? FUNCMETH : METHOD;
if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
len -= 2;
tmpbuf[len] = '\0';
+#ifdef PERL_MAD
+ soff = s - SvPVX(PL_linestr);
+#endif
goto bare_package;
}
- indirgv = gv_fetchpv(tmpbuf, 0, SVt_PVCV);
+ indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
if (indirgv && GvCVu(indirgv))
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;
}
}
STATIC const char*
S_incl_perldb(pTHX)
{
+ dVAR;
if (PL_perldb) {
const char * const pdb = PerlEnv_getenv("PERL5DB");
SV *
Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
{
+ dVAR;
if (!funcp)
- return Nullsv;
+ return NULL;
if (!PL_rsfp_filters)
PL_rsfp_filters = newAV();
if (!datasv)
- datasv = NEWSV(255,0);
+ datasv = newSV(0);
SvUPGRADE(datasv, SVt_PVIO);
IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
IoFLAGS(datasv) |= IOf_FAKE_DIRP;
void
Perl_filter_del(pTHX_ filter_t funcp)
{
+ dVAR;
SV *datasv;
#ifdef DEBUGGING
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
+ dVAR;
filter_t funcp;
SV *datasv = NULL;
STATIC char *
S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
{
+ dVAR;
#ifdef PERL_CR_FILTER
if (!PL_rsfp_filters) {
filter_add(S_cr_textfilter,NULL);
if (FILTER_READ(0, sv, 0) > 0)
return ( SvPVX(sv) ) ;
else
- return Nullch ;
+ return NULL ;
}
else
return (sv_gets(sv, fp, append));
STATIC HV *
S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
{
+ dVAR;
GV *gv;
if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
if (len > 2 &&
(pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
- (gv = gv_fetchpv(pkgname, 0, SVt_PVHV)))
+ (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
{
return GvHV(gv); /* Foo:: */
}
/* use constant CLASS => 'MyClass' */
- if ((gv = gv_fetchpv(pkgname, 0, SVt_PVCV))) {
+ if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) {
SV *sv;
if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
pkgname = SvPV_nolen_const(sv);
return gv_stashpv(pkgname, FALSE);
}
+#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 = newSVpvn("",0);
+ else {
+ char *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 = Nullop;
+ if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = NULL;
force_next(WORD);
}
else if (*s == 'v') {
int
Perl_yylex(pTHX)
{
+ dVAR;
register char *s = PL_bufptr;
register char *d;
STRLEN len;
/* 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 = newSVpvn("\\E",2);
+#endif
}
return REPORT(')');
}
+#ifdef PERL_MAD
+ while (PL_bufptr != PL_bufend &&
+ PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvn("",0);
+ 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 = newSVpvn("",0);
+ 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 = newSVpvn("",0);
+ 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 = newSVpvn("",0);
+ }
+#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 = newSVpvn("",0);
+ }
+#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 = newSVpvn("",0);
+ }
+#endif
return REPORT(')');
}
if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
{
if (PL_bufptr != PL_bufend)
Perl_croak(aTHX_ "Bad evalled substitution pattern");
- PL_lex_repl = Nullsv;
+ PL_lex_repl = NULL;
}
/* FALLTHROUGH */
case LEX_INTERPCONCAT:
}
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 = newSVpvn("",0);
+ }
+#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;
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,";");
sv_catpvs(PL_linestr, "\n");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = NEWSV(85,0);
+ SV * const sv = newSV(0);
sv_upgrade(sv, SVt_PVMG);
sv_setsv(sv,PL_linestr);
}
do {
bof = PL_rsfp ? TRUE : FALSE;
- if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+ 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);
PerlIO_clearerr(PL_rsfp);
else
(void)PerlIO_close(PL_rsfp);
- PL_rsfp = Nullfp;
+ PL_rsfp = NULL;
PL_doextract = FALSE;
}
if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_faketokens = 1;
+#endif
sv_setpv(PL_linestr,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 = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
PL_minus_n = PL_minus_p = 0;
goto retry;
}
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
sv_setpvn(PL_linestr,"",0);
TOKEN(';'); /* not infinite loop because rsfp is NULL now */
}
}
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);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
PL_doextract = FALSE;
}
}
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = NEWSV(85,0);
+ SV * const sv = newSV(0);
sv_upgrade(sv, SVt_PVMG);
sv_setsv(sv,PL_linestr);
av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
}
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
if (CopLINE(PL_curcop) == 1) {
while (s < PL_bufend && isSPACE(*s))
s++;
if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
s++;
- d = Nullch;
+#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) == '!')
d = s + 2;
* at least, set argv[0] to the basename of the Perl
* interpreter. So, having found "#!", we'll set it right.
*/
- SV * const x
- = GvSV(gv_fetchpv("\030", GV_ADD, SVt_PV)); /* $^X */
+ SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
+ SVt_PV)); /* $^X */
assert(SvPOK(x) || SvGMAGICAL(x));
if (sv_eq(x, CopFILESV(PL_curcop))) {
sv_setpvn(x, ipath, ipathend - ipath);
}
}
if (d < ipath)
- d = Nullch;
+ d = NULL;
}
#endif
}
while (*c && !strchr("; \t\r\n\f\v#", *c))
c++;
if (c < d)
- d = Nullch; /* "perl" not in first word; ignore */
+ d = NULL; /* "perl" not in first word; ignore */
else
*s = '#'; /* Don't try to parse shebang line */
}
}
#endif
if (d) {
- const U32 oldpdb = PL_perldb;
- const bool oldn = PL_minus_n;
- const bool oldp = PL_minus_p;
-
while (*d && !isSPACE(*d)) d++;
while (SPACE_OR_TAB(*d)) d++;
if (*d++ == '-') {
const bool switches_done = PL_doswitches;
+ const U32 oldpdb = PL_perldb;
+ const bool oldn = PL_minus_n;
+ const bool oldp = PL_minus_p;
+
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);
}
sv_setpvn(PL_linestr, "", 0);
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
PL_preambled = FALSE;
if (PERLDB_LINE)
(void)gv_fetchfile(PL_origfilename);
goto retry;
}
- if (PL_doswitches && !switches_done) {
- int argc = PL_origargc;
- char **argv = PL_origargv;
- do {
- argc--,argv++;
- } while (argc && argv[0][0] == '-' && argv[0][1]);
- init_argv_symbols(argc,argv);
- }
}
}
}
#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 = newSVpvn("",0);
+ 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 '-':
case 'T': ftst = OP_FTTEXT; break;
case 'B': ftst = OP_FTBINARY; break;
case 'M': case 'A': case 'C':
- gv_fetchpv("\024",GV_ADD, SVt_PV);
+ gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
switch (tmp) {
case 'M': ftst = OP_FTMTIME; break;
case 'A': ftst = OP_FTATIME; break;
}
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);
- attrs = Nullop;
+#ifdef PERL_MAD
+ stuffstart = s - SvPVX(PL_linestr) - 1;
+#endif
+ s = PEEKSPACE(s);
+ attrs = NULL;
while (isIDFIRST_lazy_if(s,UTF)) {
I32 tmp;
d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0, sv));
SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
+ PL_lex_stuff = NULL;
}
else {
if (len == 6 && strnEQ(s, "unique", len)) {
- if (PL_in_my == KEY_our)
+ if (PL_in_my == KEY_our) {
#ifdef USE_ITHREADS
GvUNIQUE_on(cGVOPx_gv(yylval.opval));
#else
- ; /* 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");
}
newSVOP(OP_CONST, 0,
newSVpvn(s, len)));
}
- 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
}
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 = newSVpvn("",0);
+ 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 = newSVpvn("",0);
+#endif
TOKEN(';');
case '&':
s++;
}
goto retry;
}
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvn("",0);
+ sv_catpvn(PL_thiswhite, PL_linestart,
+ PL_bufend - PL_linestart);
+ }
+#endif
s = PL_bufend;
PL_doextract = TRUE;
goto retry;
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)) {
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),
char tmpbuf[sizeof PL_tokenbuf];
for (t++; isSPACE(*t); t++) ;
if (isIDFIRST_lazy_if(t,UTF)) {
- STRLEN len;
+ STRLEN dummylen;
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
- &len);
+ &dummylen);
for (; isSPACE(*t); t++) ;
if (*t == ';' && get_cv(tmpbuf, FALSE))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
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,
TERM(THING);
case '\'':
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
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);
+ s = scan_str(s,!!PL_madskills,FALSE);
DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
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);
+ s = scan_str(s,!!PL_madskills,FALSE);
DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
yylval.ival = OP_BACKTICK;
set_csh();
TERM(sublex_start());
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';
GV *hgv = NULL; /* hidden (loser) */
if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
CV *cv;
- if ((gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV)) &&
+ if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
(cv = GvCVu(gv)))
{
if (GvIMPORTED_CV(gv))
else if (gv && !gvp
&& -tmp==KEY_lock /* XXX generalizable kludge */
&& GvCVu(gv)
- && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
+ && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
{
tmp = 0; /* any sub overrides "weak" keyword */
}
Perl_warner(aTHX_ packWARN(WARN_MISC),
"dump() better written as CORE::dump()");
}
- gv = Nullgv;
+ gv = NULL;
gvp = 0;
if (hgv && tmp != KEY_x && tmp != KEY_CORE
&& ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
just_a_word_zero_gv:
gv = NULL;
gvp = NULL;
+ orig_keyword = 0;
}
just_a_word: {
SV *sv;
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)
- && ! gv_fetchpv(PL_tokenbuf, 0, SVt_PVHV))
+ && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
"Bareword \"%s\" refers to nonexistent package",
PL_tokenbuf);
len -= 2;
PL_tokenbuf[len] = '\0';
- gv = Nullgv;
+ gv = NULL;
gvp = 0;
}
else {
- len = 0;
if (!gv) {
/* Mustn't actually add anything to a symbol table.
But also don't want to "initialise" any placeholder
constants that might already be there into full
blown PVGVs with attached PVCV. */
- gv = gv_fetchpv(PL_tokenbuf, GV_NOADD_NOINIT,
- SVt_PVCV);
+ gv = gv_fetchpvn_flags(PL_tokenbuf, len,
+ GV_NOADD_NOINIT, SVt_PVCV);
}
+ len = 0;
}
/* if we saw a global override before, get the right name */
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) {
for (d = s + 1; 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 = newSVpvn("",0);
+ }
+#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)) {
- STRLEN len;
- const char *proto = SvPV_const((SV*)cv, len);
- if (!len)
+ 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')
OPERATOR(UNIOPSUB);
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 = newSVpvn("",0);
+ }
+ 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))
+ 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 = newSVpvn("",0);
+ 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 */
}
}
#endif
- PL_rsfp = Nullfp;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_realtokenstart >= 0) {
+ char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ if (!PL_endwhite)
+ PL_endwhite = newSVpvn("",0);
+ 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_chdir:
- (void)gv_fetchpv("ENV", GV_ADD, SVt_PVHV); /* may use HOME */
+ /* may use HOME */
+ (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
UNI(OP_CHDIR);
case KEY_close:
PREBLOCK(DEFAULT);
case KEY_do:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '{')
PRETERMBLOCK(DO);
if (*s != '\'')
UNI(OP_DELETE);
case KEY_dbmopen:
- gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
+ gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
LOP(OP_DBMOPEN,XTERM);
case KEY_dbmclose:
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:
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;
sprintf(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++) ;
/* [perl #16184] */
&& !(t[0] == '=' && t[1] == '>')
) {
- int len = (int)(d-s);
+ int parms_len = (int)(d-s);
Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
"Precedence problem: open %.*s should be open(%.*s)",
- len, s, len, s);
+ parms_len, s, parms_len, s);
}
}
LOP(OP_OPEN,XTERM);
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)) {
- OP *words = Nullop;
+ OP *words = NULL;
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);
}
}
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
+ PL_lex_stuff = NULL;
}
PL_expect = XTERM;
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);
+ missingterm(NULL);
yylval.ival = OP_BACKTICK;
set_csh();
TERM(sublex_start());
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;
bool have_name, have_proto, bad_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);
}
if (*s == '(') {
char *p;
- 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 */
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;
Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
}
+#ifdef PERL_MAD
+ start_force(0);
+ if (tmpwhite) {
+ if (PL_madskills)
+ curmad('^', newSVpvn("",0));
+ 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 = Nullsv;
+ PL_lex_stuff = NULL;
force_next(THING);
}
+#endif
if (!have_name) {
sv_setpv(PL_subname,
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);
char ctl_l[2];
ctl_l[0] = toCTRL('L');
ctl_l[1] = '\0';
- gv_fetchpv(ctl_l, GV_ADD, SVt_PV);
+ gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
}
#else
- gv_fetchpv("\f", GV_ADD, SVt_PV); /* Make sure $^L is defined */
+ /* Make sure $^L is defined */
+ gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
#endif
UNI(OP_ENTERWRITE);
static int
S_pending_ident(pTHX)
{
+ dVAR;
register char *d;
register I32 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); });
tmp = pad_findmy(PL_tokenbuf);
if (tmp != NOT_IN_PAD) {
/* might be an "our" variable" */
- if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
+ if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
/* build ops for a bareword */
HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
HEK * const stashname = HvNAME_HEK(stash);
yylval.opval->op_private = OPpCONST_ENTERED;
gv_fetchpv(
PL_tokenbuf+1,
- PL_in_eval
- ? (GV_ADDMULTI | GV_ADDINEVAL)
- /* If the identifier refers to a stash, don't autovivify it.
- * Change 24660 had the side effect of causing symbol table
- * hashes to always be defined, even if they were freshly
- * created and the only reference in the entire program was
- * the single statement with the defined %foo::bar:: test.
- * It appears that all code in the wild doing this actually
- * wants to know whether sub-packages have been loaded, so
- * by avoiding auto-vivifying symbol tables, we ensure that
- * defined %foo::bar:: continues to be false, and the existing
- * tests still give the expected answers, even though what
- * they're actually testing has now changed subtly.
- */
- : !(*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'),
+ /* If the identifier refers to a stash, don't autovivify it.
+ * Change 24660 had the side effect of causing symbol table
+ * hashes to always be defined, even if they were freshly
+ * created and the only reference in the entire program was
+ * the single statement with the defined %foo::bar:: test.
+ * It appears that all code in the wild doing this actually
+ * wants to know whether sub-packages have been loaded, so
+ * by avoiding auto-vivifying symbol tables, we ensure that
+ * defined %foo::bar:: continues to be false, and the existing
+ * tests still give the expected answers, even though what
+ * they're actually testing has now changed subtly.
+ */
+ (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
+ ? 0
+ : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
: SVt_PVHV));
I32
Perl_keyword (pTHX_ const char *name, I32 len)
{
+ dVAR;
switch (len)
{
case 1: /* 5 tokens of length 1 */
}
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)
{
- const char *w;
+ dVAR;
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))
+ 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);
}
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 ;
STATIC char *
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
+ dVAR;
register char *d = dest;
register char * const e = d + destlen - 3; /* two-character token, ending NUL */
for (;;) {
STATIC char *
S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
{
- register char *d;
- register char *e;
- char *bracket = Nullch;
+ dVAR;
+ char *bracket = NULL;
char funny = *s++;
+ register char *d = dest;
+ register char * const e = d + destlen + 3; /* two-character token, ending NUL */
if (isSPACE(*s))
- s = skipspace(s);
- d = dest;
- e = d + destlen - 3; /* two-character token, ending NUL */
+ s = PEEKSPACE(s);
if (isDIGIT(*s)) {
while (isDIGIT(*s)) {
if (d >= e)
if (isIDFIRST_lazy_if(d,UTF)) {
d++;
if (UTF) {
- e = s;
- while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
- e += UTF8SKIP(e);
- while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
- e += UTF8SKIP(e);
+ char *end = s;
+ while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
+ end += UTF8SKIP(end);
+ while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
+ end += UTF8SKIP(end);
}
- Copy(s, d, e - s, char);
- d += e - s;
- s = e;
+ Copy(s, d, end - s, char);
+ d += end - s;
+ s = end;
}
else {
while ((isALNUM(*s) || *s == ':') && d < e)
void
Perl_pmflag(pTHX_ U32* pmfl, int ch)
{
+ PERL_UNUSED_CONTEXT;
if (ch == 'i')
*pmfl |= PMf_FOLD;
else if (ch == 'g')
STATIC char *
S_scan_pat(pTHX_ char *start, I32 type)
{
+ dVAR;
PMOP *pm;
- char *s = scan_str(start,FALSE,FALSE);
+ char *s = scan_str(start,!!PL_madskills,FALSE);
+ const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx";
+#ifdef PERL_MAD
+ char *modstart;
+#endif
+
if (!s) {
- char * const delimiter = skipspace(start);
+ 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" );
pm = (PMOP*)newPMOP(type, 0);
if (PL_multi_open == '?')
pm->op_pmflags |= PMf_ONCE;
- if(type == OP_QR) {
- while (*s && strchr("iomsx", *s))
- pmflag(&pm->op_pmflags,*s++);
- }
- else {
- while (*s && strchr("iogcmsx", *s))
- pmflag(&pm->op_pmflags,*s++);
+#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_lex_stuff = Nullsv;
+ PL_lex_stuff = NULL;
}
Perl_croak(aTHX_ "Substitution replacement not terminated");
}
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///" );
}
if (es) {
- SV *repl;
+ SV * const repl = newSVpvs("");
+
PL_sublex_info.super_bufptr = s;
PL_sublex_info.super_bufend = PL_bufend;
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
- repl = newSVpvs("");
while (es-- > 0)
sv_catpv(repl, es ? "eval " : "do ");
- sv_catpvs(repl, "{ ");
+ sv_catpvs(repl, "{");
sv_catsv(repl, PL_lex_repl);
- sv_catpvs(repl, " }");
+ sv_catpvs(repl, "}");
SvEVALED_on(repl);
SvREFCNT_dec(PL_lex_repl);
PL_lex_repl = repl;
STATIC char *
S_scan_trans(pTHX_ char *start)
{
+ dVAR;
register char* s;
OP *o;
short *tbl;
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);
- PL_lex_stuff = Nullsv;
+ PL_lex_stuff = NULL;
}
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;
}
STATIC char *
S_scan_heredoc(pTHX_ register char *s)
{
+ dVAR;
SV *herewas;
I32 op_type = OP_SCALAR;
I32 len;
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;
*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
+#ifdef PERL_MAD
+ found_newline = 0;
+#endif
if ( outer || !(found_newline = memchr(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);
- tmpstr = NEWSV(87,79);
+#ifdef PERL_MAD
+ stuffstart = s - SvPVX(PL_linestr);
+
+ if (found_newline)
+ s--;
+#endif
+
+ tmpstr = newSV(79);
sv_upgrade(tmpstr, SVt_PVIV);
if (term == '\'') {
op_type = OP_CONST;
PL_multi_open = PL_multi_close = '<';
term = *PL_tokenbuf;
if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
- char *bufptr = PL_sublex_info.super_bufptr;
- char *bufend = PL_sublex_info.super_bufend;
+ char * const bufptr = PL_sublex_info.super_bufptr;
+ char * const bufend = PL_sublex_info.super_bufend;
char * const olds = s - SvCUR(herewas);
s = strchr(bufptr, '\n');
if (!s)
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 */
sv_setsv(PL_linestr,herewas);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
}
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 = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
#ifndef PERL_STRICT_CR
if (PL_bufend - PL_linestart >= 2) {
if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
PL_bufend[-1] = '\n';
#endif
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV *sv = NEWSV(88,0);
+ SV * const sv = newSV(0);
sv_upgrade(sv, SVt_PVMG);
sv_setsv(sv,PL_linestr);
STATIC char *
S_scan_inputsymbol(pTHX_ char *start)
{
+ dVAR;
register char *s = start; /* current position in buffer */
- register char *d;
- const char *e;
char *end;
I32 len;
- d = PL_tokenbuf; /* start of temp holding space */
- e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
+ char *d = PL_tokenbuf; /* start of temp holding space */
+ const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
+
end = strchr(s, '\n');
if (!end)
end = PL_bufend;
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;
}
else {
bool readline_overriden = FALSE;
- GV *gv_readline = Nullgv;
+ GV *gv_readline;
GV **gvp;
/* we're in a filehandle read situation */
d = PL_tokenbuf;
Copy("ARGV",d,5,char);
/* Check whether readline() is overriden */
- if (((gv_readline = gv_fetchpv("readline", 0, SVt_PVCV))
+ gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
+ if ((gv_readline
&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
||
- ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
+ ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
&& (gv_readline = *gvp) != (GV*)&PL_sv_undef
&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
readline_overriden = TRUE;
add symbol table ops
*/
if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
- if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
- HV *stash = PAD_COMPNAME_OURSTASH(tmp);
- HEK *stashname = HvNAME_HEK(stash);
- SV *sym = sv_2mortal(newSVhek(stashname));
+ if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
+ HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
+ HEK * const stashname = HvNAME_HEK(stash);
+ SV * const sym = sv_2mortal(newSVhek(stashname));
sv_catpvs(sym, "::");
sv_catpv(sym, d+1);
d = SvPVX(sym);
goto intro_sym;
}
else {
- OP *o = newOP(OP_PADSV, 0);
+ OP * const o = newOP(OP_PADSV, 0);
o->op_targ = tmp;
PL_lex_op = readline_overriden
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
/* If it's none of the above, it must be a literal filehandle
(<Foo::BAR> or <FOO>) so build a simple readline OP */
else {
- GV *gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
+ GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
PL_lex_op = readline_overriden
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
STATIC char *
S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
{
+ dVAR;
SV *sv; /* scalar value: string */
char *tmps; /* temp string, used for delimiter matching */
register char *s = start; /* current position in the buffer */
U8 termstr[UTF8_MAXBYTES]; /* terminating string */
STRLEN termlen; /* length of terminating string */
char *last = NULL; /* 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;
PL_multi_close = term;
- /* create a new SV to hold the contents. 87 is leak category, I'm
- assuming. 79 is the SV's initial length. What a random number. */
- sv = NEWSV(87,79);
+ /* create a new SV to hold the contents. 79 is the SV's initial length.
+ What a random number. */
+ sv = newSV(79);
sv_upgrade(sv, SVt_PVIV);
SvIV_set(sv, termcode);
(void)SvPOK_only(sv); /* validate pointer */
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;
int offset = s - SvPVX_const(PL_linestr);
const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
&offset, (char*)termstr, termlen);
- const char *ns = SvPVX_const(PL_linestr) + offset;
- char *svlast = SvEND(sv) - 1;
+ const char * const ns = SvPVX_const(PL_linestr) + offset;
+ char * const svlast = SvEND(sv) - 1;
for (; s < ns; s++) {
if (*s == '\n' && !PL_rsfp)
/* 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 *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 Nullch;
+ 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 sv = NEWSV(88,0);
+ SV * const line_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);
+ 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);
}
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
}
/* at this point, we have successfully read the delimited string */
if (!PL_encoding || UTF) {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ char *tstart = SvPVX(PL_linestr) + stuffstart;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, s - tstart);
+ else
+ PL_thisstuff = newSVpvn(tstart, s - tstart);
+ 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 *tstart = SvPVX(PL_linestr) + stuffstart;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, s - tstart - termlen);
+ else
+ PL_thisstuff = newSVpvn(tstart, s - tstart - termlen);
+ if (!PL_thisclose && !keep_delims)
+ PL_thisclose = newSVpvn(s - termlen,termlen);
+ }
+ }
+#endif
if (has_utf8 || PL_encoding)
SvUTF8_on(sv);
char *
Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
{
+ dVAR;
register const char *s = start; /* current position in buffer */
register char *d; /* destination in temp buffer */
register char *e; /* end of temp buffer */
NV nv; /* number read, as a double */
- SV *sv = Nullsv; /* place to put the converted number */
+ SV *sv = NULL; /* place to put the converted number */
bool floatit; /* boolean: int or float? */
const char *lastub = NULL; /* position of last underbar */
static char const number_too_long[] = "Number too long";
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
}
- sv = NEWSV(92,0);
+ sv = newSV(0);
if (overflowed) {
if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
}
if (just_zero && (PL_hints & HINT_NEW_INTEGER))
sv = new_constant(start, s - start, "integer",
- sv, Nullsv, NULL);
+ sv, NULL, NULL);
else if (PL_hints & HINT_NEW_BINARY)
- sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
+ sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
}
break;
/* make an sv from the string */
- sv = NEWSV(92,0);
+ sv = newSV(0);
/*
We try to do an integer conversion first if no characters
if (!floatit) {
UV uv;
- int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
+ const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
if (flags == IS_NUMBER_IN_UV) {
if (uv <= IV_MAX)
(PL_hints & HINT_NEW_INTEGER) )
sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
(floatit ? "float" : "integer"),
- sv, Nullsv, NULL);
+ sv, NULL, NULL);
break;
/* if it starts with a v, it could be a v-string */
case 'v':
vstring:
- sv = NEWSV(92,5); /* preallocate storage space */
+ sv = newSV(5); /* preallocate storage space */
s = scan_vstring(s,sv);
break;
}
if (sv)
lvalp->opval = newSVOP(OP_CONST, 0, sv);
else
- lvalp->opval = Nullop;
+ lvalp->opval = NULL;
return (char *)s;
}
STATIC char *
S_scan_formline(pTHX_ register char *s)
{
+ dVAR;
register char *eol;
register char *t;
- SV *stuff = newSVpvs("");
+ 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 == '.') {
}
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 = Nullch;
+ PL_last_lop = PL_last_uni = NULL;
if (!s) {
s = PL_bufptr;
break;
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;
}
S_set_csh(pTHX)
{
#ifdef CSH
+ dVAR;
if (!PL_cshlen)
PL_cshlen = strlen(PL_cshname);
+#else
+#if defined(USE_ITHREADS)
+ PERL_UNUSED_CONTEXT;
+#endif
#endif
}
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
+ dVAR;
const I32 oldsavestack_ix = PL_savestack_ix;
- CV* outsidecv = PL_compcv;
+ CV* const outsidecv = PL_compcv;
if (PL_compcv) {
assert(SvTYPE(PL_compcv) == SVt_PVCV);
save_item(PL_subname);
SAVESPTR(PL_compcv);
- PL_compcv = (CV*)NEWSV(1104,0);
+ PL_compcv = (CV*)newSV(0);
sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
CvFLAGS(PL_compcv) |= flags;
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;
int
Perl_yywarn(pTHX_ const char *s)
{
+ dVAR;
PL_in_eval |= EVAL_WARNONLY;
yyerror(s);
PL_in_eval &= ~EVAL_WARNONLY;
int
Perl_yyerror(pTHX_ const char *s)
{
+ dVAR;
const char *where = NULL;
const char *context = NULL;
int contlen = -1;
where = "within string";
}
else {
- SV *where_sv = sv_2mortal(newSVpvs("next char "));
+ SV * const where_sv = sv_2mortal(newSVpvs("next char "));
if (yychar < 32)
Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
else if (isPRINT_LC(yychar))
STATIC char*
S_swallow_bom(pTHX_ U8 *s)
{
+ dVAR;
const STRLEN slen = SvCUR(PL_linestr);
switch (s[0]) {
case 0xFF:
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
static void
restore_rsfp(pTHX_ void *f)
{
+ dVAR;
PerlIO * const fp = (PerlIO*)f;
if (PL_rsfp == PerlIO_stdin())
static I32
utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
{
+ dVAR;
const STRLEN old = SvCUR(sv);
const I32 count = FILTER_READ(idx+1, sv, maxlen);
DEBUG_P(PerlIO_printf(Perl_debug_log,
static I32
utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
{
+ dVAR;
const STRLEN old = SvCUR(sv);
const I32 count = FILTER_READ(idx+1, sv, maxlen);
DEBUG_P(PerlIO_printf(Perl_debug_log,
Function must be called like
- sv = NEWSV(92,5);
+ sv = newSV(5);
s = scan_vstring(s,sv);
The sv should already be large enough to store the vstring
char *
Perl_scan_vstring(pTHX_ const char *s, SV *sv)
{
+ dVAR;
const char *pos = s;
const char *start = s;
if (*pos == 'v') pos++; /* get past 'v' */
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