/* toke.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define yychar (*PL_yycharp)
#define yylval (*PL_yylvalp)
-static const char ident_too_long[] =
- "Identifier too long";
-static const char c_without_g[] =
- "Use of /c modifier is meaningless without /g";
-static const char c_in_subst[] =
- "Use of /c modifier is meaningless in s///";
+static const char ident_too_long[] = "Identifier too long";
+static const char commaless_variable_list[] = "comma-less variable list";
static void restore_rsfp(pTHX_ void *f);
#ifndef PERL_NO_UTF16_FILTER
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" },
{ BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
{ COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
{ CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
+ { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
{ DO, TOKENTYPE_NONE, "DO" },
{ DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
{ DORDOR, TOKENTYPE_NONE, "DORDOR" },
{ FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
{ FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
{ FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
+ { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
{ HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
{ IF, TOKENTYPE_IVAL, "IF" },
{ LABEL, TOKENTYPE_PVAL, "LABEL" },
{ UNLESS, TOKENTYPE_IVAL, "UNLESS" },
{ UNTIL, TOKENTYPE_IVAL, "UNTIL" },
{ USE, TOKENTYPE_IVAL, "USE" },
+ { 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 */
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 = newSVpvn("<== ", 4);
+ SV* const report = newSVpvs("<== ");
for (p = debug_tokens; p->token; p++) {
if (p->token == (int)rv) {
else if ((char)rv > ' ' && (char)rv < '~')
Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
else if (!rv)
- Perl_sv_catpv(aTHX_ report, "EOF");
+ sv_catpvs(report, "EOF");
else
Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
switch (type) {
}
else
- Perl_sv_catpv(aTHX_ report, "(opval=null)");
+ sv_catpvs(report, "(opval=null)");
break;
}
PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
STATIC void
S_printbuf(pTHX_ const char* fmt, const char* s)
{
- SV* const tmp = newSVpvn("", 0);
+ SV* const tmp = newSVpvs("");
PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
SvREFCNT_dec(tmp);
}
STATIC int
S_ao(pTHX_ int toketype)
{
+ dVAR;
if (*PL_bufptr == '=') {
PL_bufptr++;
if (toketype == ANDAND)
STATIC void
S_no_op(pTHX_ const char *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; (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.
STATIC void
S_missingterm(pTHX_ char *s)
{
+ dVAR;
char tmpbuf[3];
char q;
if (s) {
Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
}
+#define FEATURE_IS_ENABLED(name) \
+ ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
+ && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
+/*
+ * S_feature_is_enabled
+ * Check whether the named feature is enabled.
+ */
+STATIC bool
+S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
+{
+ dVAR;
+ HV * const hinthv = GvHV(PL_hintgv);
+ char he_name[32] = "feature_";
+ (void) my_strlcpy(&he_name[8], name, 24);
+
+ return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
+}
+
/*
* Perl_deprecate
*/
}
/*
- * depcom
- * Deprecate a comma-less variable list.
- */
-
-STATIC void
-S_depcom(pTHX)
-{
- deprecate_old("comma-less variable list");
-}
-
-/*
* experimental text filters for win32 carriage-returns, utf16-to-utf8 and
* utf16-to-utf8-reversed.
*/
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;
if (!len || s[len-1] != ';') {
if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
PL_linestr = sv_2mortal(newSVsv(PL_linestr));
- sv_catpvn(PL_linestr, "\n;", 2);
+ sv_catpvs(PL_linestr, "\n;");
}
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++;
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')
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;
+ 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 = 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);
(void)SvIOK_on(sv);
SvIV_set(sv, 0);
- av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
+ 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++) ;
+ s = PL_last_uni;
+ while (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) 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 *
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)
{
- if (s && *s) {
- OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
- PL_nextval[PL_nexttoke].opval = o;
+ dVAR;
+ if (*s) {
+ 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) : TRUE,
- 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 '(';
}
{
dVAR;
if (!PL_lex_starts++) {
- SV * const sv = newSVpvn("",0);
+ SV * const sv = newSVpvs("");
if (SvUTF8(PL_linestr))
SvUTF8_on(sv);
PL_expect = XOPERATOR;
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);
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)
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 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#"
- : "";
+ const char * const leaveit = /* set of acceptably-backslashed characters */
+ (const char *)
+ (PL_lex_inpat
+ ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-Nnrtfeaxcz0123456789[{]} \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 */
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.
/* 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 ( len != e - s ) {
+ uv=0xFFFD;
+ }
s = e + 1;
goto NUM_ESCAPE_INSERT;
}
res = newSVpvn(s + 1, e - s - 1);
- res = new_constant( Nullch, 0, "charnames",
- res, Nullsv, "\\N{...}" );
+ type = newSVpvn(s - 2,e - s + 3);
+ res = new_constant( NULL, 0, "charnames",
+ 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);
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;
+#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, Nullsv,
- ( PL_lex_inwhat == OP_TRANS
- ? "tr"
- : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
- ? "s"
- : "qq")));
+ sv = new_constant(start, s - start,
+ (const char *)(PL_lex_inpat ? "qr" : "q"),
+ sv, NULL,
+ (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);
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,FALSE, SVt_PV))
+ len = (int)strlen(tmpbuf);
+ if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
weight -= 100;
else
weight -= 10;
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;
*/
STATIC int
-S_intuit_method(pTHX_ char *start, GV *gv)
+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) {
- CV *cv;
- if (GvIO(gv))
+ if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
return 0;
- if ((cv = GvCVu(gv))) {
- const char *proto = SvPVX_const(cv);
- if (proto) {
- if (*proto == ';')
- proto++;
- if (*proto == '*')
- return 0;
+ if (cv) {
+ if (SvPOK(cv)) {
+ const char *proto = SvPVX_const(cv);
+ if (proto) {
+ if (*proto == ';')
+ proto++;
+ if (*proto == '*')
+ return 0;
+ }
}
} 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 (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, FALSE, 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;
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);
void
Perl_filter_del(pTHX_ filter_t funcp)
{
+ dVAR;
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;
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
+ dVAR;
filter_t funcp;
SV *datasv = NULL;
+ /* This API is bad. It should have been using unsigned int for maxlen.
+ Not sure if we want to change the API, but if not we should sanity
+ check the value here. */
+ 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 *
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, FALSE, SVt_PVHV)))
+ (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
{
return GvHV(gv); /* Foo:: */
}
/* use constant CLASS => 'MyClass' */
- if ((gv = gv_fetchpv(pkgname, FALSE, 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);
}
-STATIC char *
-S_tokenize_use(pTHX_ int is_use, char *s) {
- if (PL_expect != XSTATE)
- yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
- is_use ? "use" : "no"));
- s = skipspace(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;
- force_next(WORD);
- }
- else if (*s == 'v') {
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, 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 * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpvn(tstart, s - tstart);
+ }
}
+ if (PL_thismad) /* install head */
+ CURMAD('X', PL_thistoken);
}
- else {
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, FALSE);
+
+ /* last whitespace of a sublex? */
+ if (optype == ')' && PL_endwhite) {
+ CURMAD('X', PL_endwhite);
}
- yylval.ival = is_use;
- return s;
-}
-#ifdef DEBUGGING
- static const char* const exp_name[] =
- { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
- "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
- };
-#endif
-/*
- yylex
+ if (!PL_thismad) {
- Works out what to call the token just pulled out of the input
- stream. The yacc parser takes care of taking the ops we return and
+ /* 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 = SKIPSPACE1(s);
+ if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
+ s = force_version(s, TRUE);
+ if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = NULL;
+ force_next(WORD);
+ }
+ else if (*s == 'v') {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s, FALSE);
+ }
+ }
+ else {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s, FALSE);
+ }
+ yylval.ival = is_use;
+ return s;
+}
+#ifdef DEBUGGING
+ static const char* const exp_name[] =
+ { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
+ "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
+ };
+#endif
+
+/*
+ yylex
+
+ Works out what to call the token just pulled out of the input
+ stream. The yacc parser takes care of taking the ops we return and
stitching them into a tree.
Returns:
int
Perl_yylex(pTHX)
{
+ dVAR;
register char *s = PL_bufptr;
register char *d;
- register I32 tmp;
STRLEN len;
- GV *gv = Nullgv;
- GV **gvp = 0;
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 = newSVpvn("", 0);
+ SV* tmp = newSVpvs("");
PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
(IV)CopLINE(PL_curcop),
lex_state_names[PL_lex_state],
/* 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 {
- if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
- tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
+ I32 tmp;
+ if (!PL_madskills) /* when just compiling don't need correct */
+ if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
+ tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
if ((*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;
if (PL_lex_brackets) {
- if (PL_lex_formbrack)
- yyerror("Format not terminated");
- else
- yyerror("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_catpvn(PL_linestr,";", 1);
+ sv_catpvs(PL_linestr,";");
if (PL_preambleav){
while(AvFILLp(PL_preambleav) >= 0) {
SV *tmpsv = av_shift(PL_preambleav);
sv_catsv(PL_linestr, tmpsv);
- sv_catpvn(PL_linestr, ";", 1);
+ sv_catpvs(PL_linestr, ";");
sv_free(tmpsv);
}
sv_free((SV*)PL_preambleav);
PL_preambleav = NULL;
}
if (PL_minus_n || PL_minus_p) {
- sv_catpv(PL_linestr, "LINE: while (<>) {");
+ sv_catpvs(PL_linestr, "LINE: while (<>) {");
if (PL_minus_l)
- sv_catpv(PL_linestr,"chomp;");
+ sv_catpvs(PL_linestr,"chomp;");
if (PL_minus_a) {
if (PL_minus_F) {
if ((*PL_splitstr == '/' || *PL_splitstr == '\''
else {
/* "q\0${splitstr}\0" is legal perl. Yes, even NUL
bytes can be used as quoting characters. :-) */
- /* The count here deliberately includes the NUL
- that terminates the C string constant. This
- embeds the opening NUL into the string. */
const char *splits = PL_splitstr;
- sv_catpvn(PL_linestr, "our @F=split(q", 15);
+ sv_catpvs(PL_linestr, "our @F=split(q\0");
do {
/* Need to \ \s */
if (*splits == '\\')
/* This loop will embed the trailing NUL of
PL_linestr as the last thing it does before
terminating. */
- sv_catpvn(PL_linestr, ");", 2);
+ sv_catpvs(PL_linestr, ");");
}
}
else
- sv_catpv(PL_linestr,"our @F=split(' ');");
+ sv_catpvs(PL_linestr,"our @F=split(' ');");
}
}
- sv_catpvn(PL_linestr, "\n", 1);
+ if (PL_minus_E)
+ sv_catpvs(PL_linestr,"use feature ':5.10';");
+ 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);
(void)SvIOK_on(sv);
SvIV_set(sv, 0);
- av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
+ av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
}
goto retry;
}
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)) {
- 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 = 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);
(void)SvIOK_on(sv);
SvIV_set(sv, 0);
- av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
+ 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", TRUE, 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++;
+ 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 '-':
if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
I32 ftst = 0;
+ char tmp;
s++;
PL_bufptr = s;
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;
case 'T': ftst = OP_FTTEXT; break;
case 'B': ftst = OP_FTBINARY; break;
case 'M': case 'A': case 'C':
- gv_fetchpv("\024",TRUE, 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;
s = --PL_bufptr;
}
}
- tmp = *s++;
- if (*s == tmp) {
- s++;
+ {
+ const char tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ if (PL_expect == XOPERATOR)
+ TERM(POSTDEC);
+ else
+ OPERATOR(PREDEC);
+ }
+ else if (*s == '>') {
+ s++;
+ s = SKIPSPACE1(s);
+ if (isIDFIRST_lazy_if(s,UTF)) {
+ s = force_word(s,METHOD,FALSE,TRUE,FALSE);
+ TOKEN(ARROW);
+ }
+ else if (*s == '$')
+ OPERATOR(ARROW);
+ else
+ TERM(ARROW);
+ }
if (PL_expect == XOPERATOR)
- TERM(POSTDEC);
- else
- OPERATOR(PREDEC);
- }
- else if (*s == '>') {
- s++;
- s = skipspace(s);
- if (isIDFIRST_lazy_if(s,UTF)) {
- s = force_word(s,METHOD,FALSE,TRUE,FALSE);
- TOKEN(ARROW);
+ Aop(OP_SUBTRACT);
+ else {
+ if (isSPACE(*s) || !isSPACE(*PL_bufptr))
+ check_uni();
+ OPERATOR('-'); /* unary minus */
}
- else if (*s == '$')
- OPERATOR(ARROW);
- else
- TERM(ARROW);
- }
- if (PL_expect == XOPERATOR)
- Aop(OP_SUBTRACT);
- else {
- if (isSPACE(*s) || !isSPACE(*PL_bufptr))
- check_uni();
- OPERATOR('-'); /* unary minus */
}
case '+':
- tmp = *s++;
- if (*s == tmp) {
- s++;
+ {
+ const char tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ if (PL_expect == XOPERATOR)
+ TERM(POSTINC);
+ else
+ OPERATOR(PREINC);
+ }
if (PL_expect == XOPERATOR)
- TERM(POSTINC);
- else
- OPERATOR(PREINC);
- }
- if (PL_expect == XOPERATOR)
- Aop(OP_ADD);
- else {
- if (isSPACE(*s) || !isSPACE(*PL_bufptr))
- check_uni();
- OPERATOR('+');
+ Aop(OP_ADD);
+ else {
+ if (isSPACE(*s) || !isSPACE(*PL_bufptr))
+ check_uni();
+ OPERATOR('+');
+ }
}
case '*':
PL_lex_brackets++;
/* FALL THROUGH */
case '~':
+ if (s[1] == '~'
+ && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
+ && FEATURE_IS_ENABLED("~~"))
+ {
+ s += 2;
+ Eop(OP_SMARTMATCH);
+ }
case ',':
- tmp = *s++;
- OPERATOR(tmp);
+ {
+ const char tmp = *s++;
+ OPERATOR(tmp);
+ }
case ':':
if (s[1] == ':') {
len = 0;
- goto just_a_word;
+ goto just_a_word_zero_gv;
}
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;
+ SV *sv;
d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
if (tmp < 0) tmp = -tmp;
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));
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 (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
- ; /* 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 */
}
- tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
- if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
- const char q = ((*s == '\'') ? '"' : '\'');
- /* If here for an expression, and parsed no attrs, back off. */
- if (tmp == '=' && !attrs) {
- s = PL_bufptr;
- break;
+ {
+ const char tmp
+ = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
+ if (*s != ';' && *s != '}' && *s != tmp
+ && (tmp != '=' || *s != ')')) {
+ const char q = ((*s == '\'') ? '"' : '\'');
+ /* If here for an expression, and parsed no attrs, back
+ off. */
+ if (tmp == '=' && !attrs) {
+ s = PL_bufptr;
+ break;
+ }
+ /* MUST advance bufptr here to avoid bogus "at end of line"
+ context messages from yyerror().
+ */
+ PL_bufptr = s;
+ 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(':');
}
- /* MUST advance bufptr here to avoid bogus "at end of line"
- context messages from yyerror().
- */
- PL_bufptr = s;
- if (!*s)
- yyerror("Unterminated attribute list");
- else
- yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
- q, *s, q));
- 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;
- tmp = *s++;
- OPERATOR(tmp);
+ {
+ const char tmp = *s++;
+ OPERATOR(tmp);
+ }
case ')':
- tmp = *s++;
- s = skipspace(s);
- if (*s == '{')
- PREBLOCK(tmp);
- TERM(tmp);
+ {
+ const char tmp = *s++;
+ s = SKIPSPACE1(s);
+ if (*s == '{')
+ PREBLOCK(tmp);
+ TERM(tmp);
+ }
case ']':
s++;
if (PL_lex_brackets <= 0)
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++;
- tmp = *s++;
- if (tmp == '&')
+ if (*s++ == '&')
AOPERATOR(ANDAND);
s--;
if (PL_expect == XOPERATOR) {
case '|':
s++;
- tmp = *s++;
- if (tmp == '|')
+ if (*s++ == '|')
AOPERATOR(OROR);
s--;
BOop(OP_BIT_OR);
case '=':
s++;
- tmp = *s++;
- if (tmp == '=')
- Eop(OP_EQ);
- if (tmp == '>')
- OPERATOR(',');
- if (tmp == '~')
- PMop(OP_MATCH);
- if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
- s--;
- if (PL_expect == XSTATE && isALPHA(tmp) &&
- (s == PL_linestart+1 || s[-2] == '\n') )
{
- if (PL_in_eval && !PL_rsfp) {
- d = PL_bufend;
- while (s < d) {
- if (*s++ == '\n') {
- incline(s);
- if (strnEQ(s,"=cut",4)) {
- s = strchr(s,'\n');
- if (s)
- s++;
- else
- s = d;
- incline(s);
- goto retry;
+ const char tmp = *s++;
+ if (tmp == '=')
+ Eop(OP_EQ);
+ if (tmp == '>')
+ OPERATOR(',');
+ if (tmp == '~')
+ PMop(OP_MATCH);
+ if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
+ && strchr("+-*/%.^&|<",tmp))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Reversed %c= operator",(int)tmp);
+ s--;
+ if (PL_expect == XSTATE && isALPHA(tmp) &&
+ (s == PL_linestart+1 || s[-2] == '\n') )
+ {
+ if (PL_in_eval && !PL_rsfp) {
+ d = PL_bufend;
+ while (s < d) {
+ if (*s++ == '\n') {
+ incline(s);
+ if (strnEQ(s,"=cut",4)) {
+ s = strchr(s,'\n');
+ if (s)
+ s++;
+ else
+ s = d;
+ incline(s);
+ goto retry;
+ }
+ }
}
+ 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;
}
- goto retry;
- }
- 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;
OPERATOR(ASSIGNOP);
case '!':
s++;
- tmp = *s++;
- if (tmp == '=') {
- /* was this !=~ where !~ was meant?
- * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
-
- if (*s == '~' && ckWARN(WARN_SYNTAX)) {
- const char *t = s+1;
-
- while (t < PL_bufend && isSPACE(*t))
- ++t;
-
- if (*t == '/' || *t == '?' ||
- ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
- (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "!=~ should be !~");
- }
- Eop(OP_NE);
- }
- if (tmp == '~')
- PMop(OP_NOT);
+ {
+ const char tmp = *s++;
+ if (tmp == '=') {
+ /* was this !=~ where !~ was meant?
+ * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
+
+ if (*s == '~' && ckWARN(WARN_SYNTAX)) {
+ const char *t = s+1;
+
+ while (t < PL_bufend && isSPACE(*t))
+ ++t;
+
+ if (*t == '/' || *t == '?' ||
+ ((*t == 'm' || *t == 's' || *t == 'y')
+ && !isALNUM(t[1])) ||
+ (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "!=~ should be !~");
+ }
+ Eop(OP_NE);
+ }
+ if (tmp == '~')
+ PMop(OP_NOT);
+ }
s--;
OPERATOR('!');
case '<':
TERM(sublex_start());
}
s++;
- tmp = *s++;
- if (tmp == '<')
- SHop(OP_LEFT_SHIFT);
- if (tmp == '=') {
- tmp = *s++;
- if (tmp == '>')
- Eop(OP_NCMP);
- s--;
- Rop(OP_LE);
+ {
+ char tmp = *s++;
+ if (tmp == '<')
+ SHop(OP_LEFT_SHIFT);
+ if (tmp == '=') {
+ tmp = *s++;
+ if (tmp == '>')
+ Eop(OP_NCMP);
+ s--;
+ Rop(OP_LE);
+ }
}
s--;
Rop(OP_LT);
case '>':
s++;
- tmp = *s++;
- if (tmp == '>')
- SHop(OP_RIGHT_SHIFT);
- if (tmp == '=')
- Rop(OP_GE);
+ {
+ const char tmp = *s++;
+ if (tmp == '>')
+ SHop(OP_RIGHT_SHIFT);
+ else if (tmp == '=')
+ Rop(OP_GE);
+ }
s--;
Rop(OP_GT);
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
- depcom();
+ deprecate_old(commaless_variable_list);
return REPORT(','); /* grandfather non-comma-format format */
}
}
/* 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);
}
d = s;
- tmp = (I32)*s;
- if (PL_lex_state == LEX_NORMAL)
- s = skipspace(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++) ;
- if (*t++ == ',') {
- PL_bufptr = skipspace(PL_bufptr);
- while (t < PL_bufend && *t != ']')
+ {
+ const char tmp = *s;
+ if (PL_lex_state == LEX_NORMAL)
+ 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 = s+1;
+
+ while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
t++;
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Multidimensional syntax %.*s not supported",
- (t - PL_bufptr) + 1, PL_bufptr);
- }
- }
- }
- else if (*s == '{') {
- char *t;
- PL_tokenbuf[0] = '%';
- if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
- && (t = strchr(s, '}')) && (t = strchr(t, '=')))
- {
- char tmpbuf[sizeof PL_tokenbuf];
- for (t++; isSPACE(*t); t++) ;
- if (isIDFIRST_lazy_if(t,UTF)) {
- STRLEN len;
- t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
- for (; isSPACE(*t); t++) ;
- if (*t == ';' && get_cv(tmpbuf, FALSE))
+ if (*t++ == ',') {
+ PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
+ while (t < PL_bufend && *t != ']')
+ t++;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "You need to quote \"%s\"", tmpbuf);
+ "Multidimensional syntax %.*s not supported",
+ (int)((t - PL_bufptr) + 1), PL_bufptr);
+ }
}
}
+ else if (*s == '{') {
+ char *t;
+ PL_tokenbuf[0] = '%';
+ if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
+ && (t = strchr(s, '}')) && (t = strchr(t, '=')))
+ {
+ char tmpbuf[sizeof PL_tokenbuf];
+ do {
+ t++;
+ } while (isSPACE(*t));
+ if (isIDFIRST_lazy_if(t,UTF)) {
+ STRLEN dummylen;
+ t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
+ &dummylen);
+ while (isSPACE(*t))
+ t++;
+ if (*t == ';' && get_cv(tmpbuf, FALSE))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "You need to quote \"%s\"",
+ tmpbuf);
+ }
+ }
+ }
}
- }
- PL_expect = XOPERATOR;
- if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
- const bool islop = (PL_last_lop == PL_oldoldbufptr);
- if (!islop || PL_last_lop_op == OP_GREPSTART)
- PL_expect = XOPERATOR;
- else if (strchr("$@\"'`q", *s))
- PL_expect = XTERM; /* e.g. print $fh "foo" */
- else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
- PL_expect = XTERM; /* e.g. print $fh &sub */
- else if (isIDFIRST_lazy_if(s,UTF)) {
- char tmpbuf[sizeof PL_tokenbuf];
- scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
- if ((tmp = keyword(tmpbuf, len))) {
- /* binary operators exclude handle interpretations */
- switch (tmp) {
- case -KEY_x:
- case -KEY_eq:
- case -KEY_ne:
- case -KEY_gt:
- case -KEY_lt:
- case -KEY_ge:
- case -KEY_le:
- case -KEY_cmp:
- break;
- default:
- PL_expect = XTERM; /* e.g. print $fh length() */
- break;
+ PL_expect = XOPERATOR;
+ if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
+ const bool islop = (PL_last_lop == PL_oldoldbufptr);
+ if (!islop || PL_last_lop_op == OP_GREPSTART)
+ PL_expect = XOPERATOR;
+ else if (strchr("$@\"'`q", *s))
+ PL_expect = XTERM; /* e.g. print $fh "foo" */
+ else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
+ PL_expect = XTERM; /* e.g. print $fh &sub */
+ else if (isIDFIRST_lazy_if(s,UTF)) {
+ char tmpbuf[sizeof PL_tokenbuf];
+ int t2;
+ scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+ if ((t2 = keyword(tmpbuf, len))) {
+ /* binary operators exclude handle interpretations */
+ switch (t2) {
+ case -KEY_x:
+ case -KEY_eq:
+ case -KEY_ne:
+ case -KEY_gt:
+ case -KEY_lt:
+ case -KEY_ge:
+ case -KEY_le:
+ case -KEY_cmp:
+ break;
+ default:
+ PL_expect = XTERM; /* e.g. print $fh length() */
+ break;
+ }
+ }
+ else {
+ PL_expect = XTERM; /* e.g. print $fh subr() */
}
}
- else {
- PL_expect = XTERM; /* e.g. print $fh subr() */
- }
+ else if (isDIGIT(*s))
+ PL_expect = XTERM; /* e.g. print $fh 3 */
+ else if (*s == '.' && isDIGIT(s[1]))
+ PL_expect = XTERM; /* e.g. print $fh .3 */
+ else if ((*s == '?' || *s == '-' || *s == '+')
+ && !isSPACE(s[1]) && s[1] != '=')
+ PL_expect = XTERM; /* e.g. print $fh -1 */
+ else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
+ && s[1] != '/')
+ PL_expect = XTERM; /* e.g. print $fh /.../
+ XXX except DORDOR operator
+ */
+ else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
+ && s[2] != '=')
+ PL_expect = XTERM; /* print $fh <<"EOF" */
}
- else if (isDIGIT(*s))
- PL_expect = XTERM; /* e.g. print $fh 3 */
- else if (*s == '.' && isDIGIT(s[1]))
- PL_expect = XTERM; /* e.g. print $fh .3 */
- else if ((*s == '?' || *s == '-' || *s == '+')
- && !isSPACE(s[1]) && s[1] != '=')
- PL_expect = XTERM; /* e.g. print $fh -1 */
- else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
- PL_expect = XTERM; /* e.g. print $fh /.../
- XXX except DORDOR operator */
- else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
- PL_expect = XTERM; /* print $fh <<"EOF" */
}
PL_pending_ident = '$';
TOKEN('$');
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",
- t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
+ (int)(t-PL_bufptr), PL_bufptr,
+ (int)(t-PL_bufptr-1), PL_bufptr+1);
}
}
}
}
case '?': /* may either be conditional or pattern */
if(PL_expect == XOPERATOR) {
- tmp = *s++;
+ char tmp = *s++;
if(tmp == '?') {
OPERATOR('?');
}
goto rightbracket;
}
if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
- tmp = *s++;
+ char tmp = *s++;
if (*s == tmp) {
s++;
if (*s == tmp) {
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;
- depcom();
+ deprecate_old(commaless_variable_list);
return REPORT(','); /* grandfather non-comma-format format */
}
else
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;
- depcom();
+ deprecate_old(commaless_variable_list);
return REPORT(','); /* grandfather non-comma-format format */
}
else
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);
+ 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 = gv_fetchpv(s, FALSE, SVt_PVCV);
+ gv = gv_fetchpv(s, 0, SVt_PVCV);
*start = c;
if (!gv) {
s = scan_num(s, &yylval);
case 'z': case 'Z':
keylookup: {
+ I32 tmp;
+
orig_keyword = 0;
- gv = Nullgv;
- gvp = 0;
+ gv = NULL;
+ gvp = NULL;
PL_bufptr = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
}
if (tmp < 0) { /* second-class keyword? */
- GV *ogv = Nullgv; /* override (winner) */
- GV *hgv = Nullgv; /* hidden (loser) */
+ GV *ogv = NULL; /* override (winner) */
+ GV *hgv = NULL; /* hidden (loser) */
if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
CV *cv;
- if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, 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 */
}
- else if (gv && !gvp
- && tmp == -KEY_err
- && GvCVu(gv)
- && PL_expect != XOPERATOR
- && PL_expect != XTERMORDORDOR)
- {
- /* any sub overrides the "err" keyword, except when really an
- * operator is expected */
- tmp = 0;
- }
else { /* no override */
tmp = -tmp;
if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
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 */
switch (tmp) {
default: /* not a keyword */
+ /* Trade off - by using this evil construction we can pull the
+ variable gv into the block labelled keylookup. If not, then
+ we have to give it function scope so that the goto from the
+ earlier ':' case doesn't bypass the initialisation. */
+ if (0) {
+ 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, FALSE, SVt_PVHV))
+ if (ckWARN(WARN_BAREWORD)
+ && ! 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 {
+ 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_fetchpvn_flags(PL_tokenbuf, len,
+ GV_NOADD_NOINIT, SVt_PVCV);
+ }
len = 0;
- if (!gv)
- gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
}
/* if we saw a global override before, get the right name */
if (gvp) {
- sv = newSVpvn("CORE::GLOBAL::",14);
+ sv = newSVpvs("CORE::GLOBAL::");
sv_catpv(sv,PL_tokenbuf);
}
else {
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. */
if (len)
goto safe_bareword;
+ /* Do the explicit type check so that we don't need to force
+ the initialisation of the symbol table to have a real GV.
+ Beware - gv may not really be a PVGV, cv may not really be
+ a PVCV, (because of the space optimisations that gv_init
+ understands) But they're true if for this symbol there is
+ respectively a typeglob and a subroutine.
+ */
+ cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
+ /* Real typeglob, so get the real subroutine: */
+ ? GvCVu(gv)
+ /* A proxy for a subroutine in this package? */
+ : SvOK(gv) ? (CV *) gv : NULL)
+ : NULL;
+
/* See if it's the indirect object for a list operator. */
if (PL_oldoldbufptr &&
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. */
- if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
+ if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
+ (tmp = intuit_method(s, gv, cv)))
return REPORT(tmp);
/* If not a declared subroutine, it's an indirect object. */
if (
( !immediate_paren && (PL_last_lop_op == OP_SORT ||
- ((!gv || !GvCVu(gv)) &&
+ ((!gv || !cv) &&
(PL_last_lop_op != OP_MAPSTART &&
PL_last_lop_op != OP_GREPSTART))))
|| (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
}
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 followed by a paren, it's certainly a subroutine. */
if (*s == '(') {
CLINE;
- if (gv && GvCVu(gv)) {
- for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
- if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
+ if (cv) {
+ 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 = newSVpvn("",0);
+ }
+#endif
force_next(WORD);
yylval.ival = 0;
TOKEN('&');
/* If followed by var or block, call it a method (unless sub) */
- if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
+ if ((*s == '$' || *s == '{') && (!gv || !cv)) {
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_METHOD;
PREBLOCK(METHOD);
if (!orig_keyword
&& (isIDFIRST_lazy_if(s,UTF) || *s == '$')
- && (tmp = intuit_method(s,gv)))
+ && (tmp = intuit_method(s, gv, cv)))
return REPORT(tmp);
/* Not a method, so call it a subroutine (if defined) */
- if (gv && GvCVu(gv)) {
- CV* cv;
+ if (cv) {
if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of -%s resolved as -&%s()",
PL_tokenbuf, PL_tokenbuf);
/* Check for a constant sub */
- cv = GvCV(gv);
- if ((sv = cv_const_sv(cv))) {
+ 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);
}
/* Resolve to GV now. */
+ if (SvTYPE(gv) != SVt_PVGV) {
+ gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
+ assert (SvTYPE(gv) == SVt_PVGV);
+ /* cv must have been some sort of placeholder, so
+ now needs replacing with a real code reference. */
+ cv = GvCV(gv);
+ }
+
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;
/* 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);
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 = 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 */
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);
const char *pname = "main";
if (PL_tokenbuf[2] == 'D')
pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
- gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
+ gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
+ SVt_PVIO);
GvMULTI_on(gv);
if (!GvIO(gv))
GvIOp(gv) = newIO();
PUTBACK;
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
Perl_form(aTHX_ ":encoding(%"SVf")",
- name));
+ (void*)name));
FREETMPS;
LEAVE;
}
}
#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_bless:
LOP(OP_BLESS,XTERM);
+ case KEY_break:
+ FUN0(OP_BREAK);
+
case KEY_chop:
UNI(OP_CHOP);
case KEY_continue:
+ /* When 'use switch' is in effect, continue has a dual
+ life as a control operator. */
+ {
+ if (!FEATURE_IS_ENABLED("switch"))
+ PREBLOCK(CONTINUE);
+ else {
+ /* We have to disambiguate the two senses of
+ "continue". If the next token is a '{' then
+ treat it as the start of a continue block;
+ otherwise treat it as a control operator.
+ */
+ s = skipspace(s);
+ if (*s == '{')
PREBLOCK(CONTINUE);
+ else
+ FUN0(OP_CONTINUE);
+ }
+ }
case KEY_chdir:
- (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
+ /* may use HOME */
+ (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
UNI(OP_CHDIR);
case KEY_close:
case KEY_chroot:
UNI(OP_CHROOT);
+ case KEY_default:
+ 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_getlogin:
FUN0(OP_GETLOGIN);
+ case KEY_given:
+ yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(GIVEN);
+
case KEY_glob:
set_csh();
LOP(OP_GLOB,XTERM);
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] == '>')
) {
- 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);
}
else
TOKEN(1); /* force error */
+ case KEY_say:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_SAY,XREF);
+
case KEY_chomp:
UNI(OP_CHOMP);
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_setsv(PL_subname,PL_curstname);
- sv_catpvn(PL_subname,"::",2);
+ 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 */
if (bad_proto && ckWARN(WARN_SYNTAX))
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('^', 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__");
+ (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);
case KEY_vec:
LOP(OP_VEC,XTERM);
+ case KEY_when:
+ yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(WHEN);
+
case KEY_while:
yylval.ival = CopLINE(PL_curcop);
OPERATOR(WHILE);
char ctl_l[2];
ctl_l[0] = toCTRL('L');
ctl_l[1] = '\0';
- gv_fetchpv(ctl_l,TRUE, SVt_PV);
+ gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
}
#else
- gv_fetchpv("\f",TRUE, 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;
+ 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);
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);
SV * const sym = newSVhek(stashname);
- sv_catpvn(sym, "::", 2);
+ sv_catpvs(sym, "::");
sv_catpv(sym, PL_tokenbuf+1);
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
yylval.opval->op_private = OPpCONST_ENTERED;
table.
*/
if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
- GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
+ GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
&& ckWARN(WARN_AMBIGUOUS))
{
/* build ops for a bareword */
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
- ((PL_tokenbuf[0] == '$') ? SVt_PV
- : (PL_tokenbuf[0] == '@') ? SVt_PVAV
- : SVt_PVHV));
+ gv_fetchpv(
+ PL_tokenbuf+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));
return WORD;
}
I32
Perl_keyword (pTHX_ const char *name, I32 len)
{
+ dVAR;
switch (len)
{
case 1: /* 5 tokens of length 1 */
goto unknown;
}
- case 3: /* 28 tokens of length 3 */
+ case 3: /* 29 tokens of length 3 */
switch (name[0])
{
case 'E':
case 'r':
if (name[2] == 'r')
{ /* err */
- return -KEY_err;
+ return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
}
goto unknown;
case 's':
switch (name[1])
{
+ case 'a':
+ if (name[2] == 'y')
+ { /* say */
+ return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
+ }
+
+ goto unknown;
+
case 'i':
if (name[2] == 'n')
{ /* sin */
goto unknown;
}
- case 4: /* 40 tokens of length 4 */
+ case 4: /* 41 tokens of length 4 */
switch (name[0])
{
case 'C':
}
case 'w':
- if (name[1] == 'a')
+ switch (name[1])
{
- switch (name[2])
- {
- case 'i':
- if (name[3] == 't')
- { /* wait */
- return -KEY_wait;
- }
+ case 'a':
+ 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;
+ }
- goto unknown;
+ case 'h':
+ if (name[2] == 'e' &&
+ name[3] == 'n')
+ { /* when */
+ return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
default:
goto unknown;
}
- case 5: /* 36 tokens of length 5 */
+ case 5: /* 39 tokens of length 5 */
switch (name[0])
{
case 'B':
}
case 'b':
- if (name[1] == 'l' &&
- name[2] == 'e' &&
- name[3] == 's' &&
- name[4] == 's')
- { /* bless */
- return -KEY_bless;
- }
+ switch (name[1])
+ {
+ case 'l':
+ if (name[2] == 'e' &&
+ 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);
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
case 'c':
switch (name[1])
goto unknown;
}
+ case 'g':
+ if (name[1] == 'i' &&
+ name[2] == 'v' &&
+ name[3] == 'e' &&
+ name[4] == 'n')
+ { /* given */
+ return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
+ }
+
+ goto unknown;
+
case 'i':
switch (name[1])
{
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 (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;
goto unknown;
}
- case 7: /* 28 tokens of length 7 */
+ case 7: /* 29 tokens of length 7 */
switch (name[0])
{
case 'D':
goto unknown;
case 'e':
- if (name[2] == 'f' &&
- name[3] == 'i' &&
- name[4] == 'n' &&
- name[5] == 'e' &&
- name[6] == 'd')
- { /* defined */
- return KEY_defined;
+ if (name[2] == 'f')
+ {
+ switch (name[3])
+ {
+ case 'a':
+ if (name[4] == 'u' &&
+ name[5] == 'l' &&
+ name[6] == 't')
+ { /* default */
+ return (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;
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
}
goto unknown;
}
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 == ',') {
- int 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);
}
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);
/* Check the eval first */
if (!PL_in_eval && SvTRUE(ERRSV)) {
- sv_catpv(ERRSV, "Propagated");
+ 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 (;;) {
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 {
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)
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 == '[' ? "[...]" : "{...}";
+ 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)))
{
+ if (funny == '#')
+ funny = '@';
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
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 =
+ (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
+#ifdef PERL_MAD
+ char *modstart;
+#endif
+
if (!s) {
- char * const delimiter = skipspace(start);
- Perl_croak(aTHX_ *delimiter == '?'
- ? "Search pattern not terminated or ternary operator parsed as search pattern"
- : "Search pattern not terminated" );
+ const char * const delimiter = skipspace(start);
+ Perl_croak(aTHX_
+ (const char *)
+ (*delimiter == '?'
+ ? "Search pattern not terminated or ternary operator parsed as search pattern"
+ : "Search pattern not terminated" ));
}
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))
{
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
}
pm->op_pmpermflags = pm->op_pmflags;
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;
}
- /* /c is not meaningful with s/// */
- if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
- {
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
+#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 = newSVpvn("",0);
while (es-- > 0)
- sv_catpv(repl, es ? "eval " : "do ");
- sv_catpvn(repl, "{ ", 2);
+ sv_catpv(repl, (const char *)(es ? "eval " : "do "));
+ sv_catpvs(repl, "{");
sv_catsv(repl, PL_lex_repl);
- sv_catpvn(repl, " };", 2);
+ 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;
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;
SV *tmpstr;
char term;
- const char newline[] = "\n";
const char *found_newline;
register char *d;
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 = ninstr(s,PL_bufend,newline,newline+1)) ) {
+#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);
- 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);
(void)SvIOK_on(sv);
SvIV_set(sv, 0);
- av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
+ av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
}
if (*s == term && memEQ(s,PL_tokenbuf,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(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;
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;
}
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", FALSE, 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;
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) {
- if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
- HV *stash = PAD_COMPNAME_OURSTASH(tmp);
- HEK *stashname = HvNAME_HEK(stash);
- SV *sym = sv_2mortal(newSVhek(stashname));
- sv_catpvn(sym, "::", 2);
+ 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);
+ 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,TRUE, 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 */
+ 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 */
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 * 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 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 *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(CopFILEAV(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 * const tstart = SvPVX(PL_linestr) + stuffstart;
+ const int len = s - start;
+ 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);
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 = 0; /* position of last underbar */
+ const char *lastub = NULL; /* position of last underbar */
static char const number_too_long[] = "Number too long";
/* We use the first character to decide what type of number this is */
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)
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, 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 = newSVpvn("",0);
+ 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 = 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(newSVpvn("next char ", 10));
+ 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))
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_in_my = 0;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
return 0;
}
#ifdef __SC__
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
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
static void
restore_rsfp(pTHX_ void *f)
{
- PerlIO *fp = (PerlIO*)f;
+ dVAR;
+ PerlIO * const fp = (PerlIO*)f;
if (PL_rsfp == PerlIO_stdin())
PerlIO_clearerr(PL_rsfp);
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,
"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;
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,
"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;
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)) {
- UV rev;
U8 tmpbuf[UTF8_MAXBYTES+1];
- U8 *tmpend;
- if (*s == 'v') s++; /* get past 'v' */
+ if (*s == 'v')
+ s++; /* get past 'v' */
sv_setpvn(sv, "", 0);
for (;;) {
- 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;
+ /* this is atoi() that tolerates underscores */
+ U8 *tmpend;
+ UV rev = 0;
+ 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