#define PERL_IN_TOKE_C
#include "perl.h"
-#define yychar (*PL_yycharp)
-#define yylval (*PL_yylvalp)
+#define yylval (PL_parser->yylval)
static const char ident_too_long[] = "Identifier too long";
static const char commaless_variable_list[] = "comma-less variable list";
#endif
#ifdef PERL_MAD
-/* XXX these probably need to be made into PL vars */
-static I32 realtokenstart;
-static I32 faketokens = 0;
-static MADPROP *thismad;
-static SV *thistoken;
-static SV *thisopen;
-static SV *thisstuff;
-static SV *thisclose;
-static SV *thiswhite;
-static SV *nextwhite;
-static SV *skipwhite;
-static SV *endwhite;
-static I32 curforce = -1;
-
# define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
-# define NEXTVAL_NEXTTOKE PL_nexttoke[curforce].next_val
+# define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
#else
# define CURMAD(slot,sv)
# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
{ WHEN, TOKENTYPE_IVAL, "WHEN" },
{ WHILE, TOKENTYPE_IVAL, "WHILE" },
{ WORD, TOKENTYPE_OPVAL, "WORD" },
- { 0, TOKENTYPE_NONE, 0 }
+ { 0, TOKENTYPE_NONE, NULL }
};
/* dump the returned token in rv, plus any optional arg in yylval */
"\t(Missing semicolon on previous line?)\n");
else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
const char *t;
- for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
+ for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
+ NOOP;
if (t < PL_bufptr && isSPACE(*t))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\t(Do you need to predeclare %.*s?)\n",
/*
* S_missingterm
* Complain about missing quote/regexp/heredoc terminator.
- * If it's called with (char *)NULL then it cauterizes the line buffer.
+ * If it's called with NULL then it cauterizes the line buffer.
* If we're in a delimited string and the delimiter is a control
* character, it's reformatted into a two-char sequence like ^C.
* This is fatal.
* Check whether the named feature is enabled.
*/
STATIC bool
-S_feature_is_enabled(pTHX_ char *name, STRLEN namelen)
+S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
{
dVAR;
HV * const hinthv = GvHV(PL_hintgv);
char he_name[32] = "feature_";
- (void) strncpy(&he_name[8], name, 24);
-
+ (void) my_strlcpy(&he_name[8], name, 24);
+
return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
}
SAVEI32(PL_lasttoke);
}
if (PL_madskills) {
- SAVESPTR(thistoken);
- SAVESPTR(thiswhite);
- SAVESPTR(nextwhite);
- SAVESPTR(thisopen);
- SAVESPTR(thisclose);
- SAVESPTR(thisstuff);
- SAVEVPTR(thismad);
- SAVEI32(realtokenstart);
- SAVEI32(faketokens);
- }
- SAVEI32(curforce);
+ 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;
PL_lex_inwhat = 0;
PL_sublex_info.sub_inwhat = 0;
PL_linestr = line;
- if (SvREADONLY(PL_linestr))
- PL_linestr = sv_2mortal(newSVsv(PL_linestr));
s = SvPV_const(PL_linestr, len);
- if (!len || s[len-1] != ';') {
- if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
- PL_linestr = sv_2mortal(newSVsv(PL_linestr));
- sv_catpvs(PL_linestr, "\n;");
+ if (SvREADONLY(PL_linestr) || !len || s[len-1] != ';') {
+ PL_linestr = sv_2mortal(len ? newSVsv(PL_linestr) : newSVpvn(s, 0));
+ if (!len || s[len-1] != ';')
+ sv_catpvs(PL_linestr, "\n;");
}
SvTEMP_off(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
CopLINE_inc(PL_curcop);
if (*s++ != '#')
return;
- while (SPACE_OR_TAB(*s)) s++;
+ while (SPACE_OR_TAB(*s))
+ s++;
if (strnEQ(s, "line", 4))
s += 4;
else
s++;
else
return;
- while (SPACE_OR_TAB(*s)) s++;
+ while (SPACE_OR_TAB(*s))
+ s++;
if (!isDIGIT(*s))
return;
+
n = s;
while (isDIGIT(*s))
s++;
e = t + 1;
}
else {
- for (t = s; !isSPACE(*t); t++) ;
+ t = s;
+ while (!isSPACE(*t))
+ t++;
e = t;
}
while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
if (gvp) {
gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
- if (!isGV(gv2))
+ if (!isGV(gv2)) {
gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
- /* adjust ${"::_<newfilename"} to store the new file name */
- GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
- GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
- GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ /* adjust ${"::_<newfilename"} to store the new file name */
+ GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
+ GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
+ GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ }
}
if (tmpbuf != smallbuf) Safefree(tmpbuf);
if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
}
#ifdef PERL_MAD
-/* skip space before thistoken */
+/* skip space before PL_thistoken */
STATIC char *
S_skipspace0(pTHX_ register char *s)
s = skipspace(s);
if (!PL_madskills)
return s;
- if (skipwhite) {
- if (!thiswhite)
- thiswhite = newSVpvn("",0);
- sv_catsv(thiswhite, skipwhite);
- sv_free(skipwhite);
- skipwhite = 0;
- }
- realtokenstart = s - SvPVX(PL_linestr);
+ if (PL_skipwhite) {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catsv(PL_thiswhite, PL_skipwhite);
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
+ }
+ PL_realtokenstart = s - SvPVX(PL_linestr);
return s;
}
-/* skip space after thistoken */
+/* skip space after PL_thistoken */
STATIC char *
S_skipspace1(pTHX_ register char *s)
{
- char *start = 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 (!thistoken && realtokenstart >= 0) {
- char *tstart = SvPVX(PL_linestr) + realtokenstart;
- thistoken = newSVpvn(tstart, start - tstart);
- }
- realtokenstart = -1;
- if (skipwhite) {
- if (!nextwhite)
- nextwhite = newSVpvn("",0);
- sv_catsv(nextwhite, skipwhite);
- sv_free(skipwhite);
- skipwhite = 0;
+ if (!PL_thistoken && PL_realtokenstart >= 0) {
+ const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpvn(tstart, start - tstart);
+ }
+ PL_realtokenstart = -1;
+ if (PL_skipwhite) {
+ if (!PL_nextwhite)
+ PL_nextwhite = newSVpvs("");
+ sv_catsv(PL_nextwhite, PL_skipwhite);
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
}
return s;
}
STATIC char *
S_skipspace2(pTHX_ register char *s, SV **svp)
{
- char *start = s;
- I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
- I32 startoff = start - SvPVX(PL_linestr);
+ 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 (!thistoken && realtokenstart >= 0) {
- char *tstart = SvPVX(PL_linestr) + realtokenstart;
- thistoken = newSVpvn(tstart, start - tstart);
- realtokenstart = -1;
+ if (!PL_thistoken && PL_realtokenstart >= 0) {
+ char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpvn(tstart, start - tstart);
+ PL_realtokenstart = -1;
}
- if (skipwhite) {
+ if (PL_skipwhite) {
if (!*svp)
- *svp = newSVpvn("",0);
- sv_setsv(*svp, skipwhite);
- sv_free(skipwhite);
- skipwhite = 0;
+ *svp = newSVpvs("");
+ sv_setsv(*svp, PL_skipwhite);
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
}
return s;
}
#endif
+STATIC void
+S_update_debugger_info_pv(pTHX_ const char *buf, STRLEN len)
+{
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const sv = newSV(0);
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setpvn(sv, buf, len);
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, 0);
+ av_store(av, (I32)CopLINE(PL_curcop), sv);
+ }
+}
+
+STATIC void
+S_update_debugger_info_sv(pTHX_ SV *orig_sv)
+{
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const sv = newSV(0);
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setsv(sv, orig_sv);
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, 0);
+ av_store(av, (I32)CopLINE(PL_curcop), sv);
+ }
+}
+
/*
* S_skipspace
* Called to gobble the appropriate amount and type of whitespace.
int curoff;
int startoff = s - SvPVX(PL_linestr);
- if (skipwhite) {
- sv_free(skipwhite);
- skipwhite = 0;
+ if (PL_skipwhite) {
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
}
#endif
{
#ifdef PERL_MAD
if (PL_madskills && curoff != startoff) {
- if (!skipwhite)
- skipwhite = newSVpvn("",0);
- sv_catpvn(skipwhite, SvPVX(PL_linestr) + startoff,
+ if (!PL_skipwhite)
+ PL_skipwhite = newSVpvs("");
+ sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
curoff - startoff);
}
#endif
/* end of file. Add on the -p or -n magic */
- /* XXX these shouldn't really be added here, can't set faketokens */
+ /* XXX these shouldn't really be added here, can't set PL_faketokens */
if (PL_minus_p) {
#ifdef PERL_MAD
sv_catpv(PL_linestr,
/* debugger active and we're not compiling the debugger code,
* so store the line into the debugger's array of lines
*/
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_pv(PL_bufptr, PL_bufend - PL_bufptr);
}
#ifdef PERL_MAD
done:
if (PL_madskills) {
- if (!skipwhite)
- skipwhite = newSVpvn("",0);
+ if (!PL_skipwhite)
+ PL_skipwhite = newSVpvs("");
curoff = s - SvPVX(PL_linestr);
if (curoff - startoff)
- sv_catpvn(skipwhite, SvPVX(PL_linestr) + startoff,
+ sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
curoff - startoff);
}
return s;
S_check_uni(pTHX)
{
dVAR;
- char *s;
- char *t;
+ const char *s;
+ const char *t;
if (PL_oldoldbufptr != PL_last_uni)
return;
while (isSPACE(*PL_last_uni))
PL_last_uni++;
- for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
+ s = PL_last_uni;
+ while (isALNUM_lazy_if(s,UTF) || *s == '-')
+ s++;
if ((t = strchr(s, '(')) && t < PL_bufptr)
return;
{
int i;
- if (where < 0) /* so people can duplicate start_force(curforce) */
+ if (where < 0) /* so people can duplicate start_force(PL_curforce) */
where = PL_lasttoke;
- assert(curforce < 0 || curforce == where);
- if (curforce != where) {
+ 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 (curforce < 0) /* in case of duplicate start_force() */
+ if (PL_curforce < 0) /* in case of duplicate start_force() */
Zero(&PL_nexttoke[where], 1, NEXTTOKE);
- curforce = where;
- if (nextwhite) {
+ PL_curforce = where;
+ if (PL_nextwhite) {
if (PL_madskills)
- curmad('^', newSVpvn("",0));
- CURMAD('_', nextwhite);
+ curmad('^', newSVpvs(""));
+ CURMAD('_', PL_nextwhite);
}
}
if (!sv)
return;
- if (curforce < 0)
- where = &thismad;
+ if (PL_curforce < 0)
+ where = &PL_thismad;
else
- where = &PL_nexttoke[curforce].next_mad;
+ where = &PL_nexttoke[PL_curforce].next_mad;
- if (faketokens)
+ if (PL_faketokens)
sv_setpvn(sv, "", 0);
else {
if (!IN_BYTES) {
addmad(newMADsv(slot, sv), where, 0);
}
#else
-# define start_force(where)
-# define curmad(slot, sv)
+# define start_force(where) NOOP
+# define curmad(slot, sv) NOOP
#endif
/*
{
dVAR;
#ifdef PERL_MAD
- if (curforce < 0)
+ if (PL_curforce < 0)
start_force(PL_lasttoke);
- PL_nexttoke[curforce].next_type = type;
+ 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;
- curforce = -1;
+ PL_curforce = -1;
#else
PL_nexttype[PL_nexttoke] = type;
PL_nexttoke++;
(allow_initial_tick && *s == '\'') )
{
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
- if (check_keyword && keyword(PL_tokenbuf, len))
+ if (check_keyword && keyword(PL_tokenbuf, len, 0))
return start;
- start_force(curforce);
+ start_force(PL_curforce);
if (PL_madskills)
curmad('X', newSVpvn(start,s-start));
if (token == METHOD) {
S_force_ident(pTHX_ register const char *s, int kind)
{
dVAR;
- if (s && *s) {
+ if (*s) {
const STRLEN len = strlen(s);
OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = o;
force_next(WORD);
if (kind) {
d++;
#ifdef PERL_MAD
if (PL_madskills) {
- start_force(curforce);
+ start_force(PL_curforce);
curmad('X', newSVpvn(s,d-s));
}
#endif
else if (guessing) {
#ifdef PERL_MAD
if (PL_madskills) {
- sv_free(nextwhite); /* let next token collect whitespace */
- nextwhite = 0;
+ sv_free(PL_nextwhite); /* let next token collect whitespace */
+ PL_nextwhite = 0;
s = SvPVX(PL_linestr) + startoff;
}
#endif
#ifdef PERL_MAD
if (PL_madskills && !version) {
- sv_free(nextwhite); /* let next token collect whitespace */
- nextwhite = 0;
+ sv_free(PL_nextwhite); /* let next token collect whitespace */
+ PL_nextwhite = 0;
s = SvPVX(PL_linestr) + startoff;
}
#endif
/* NOTE: The parser sees the package name and the VERSION swapped */
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = version;
force_next(WORD);
PL_expect = XTERMORDORDOR;
return THING;
}
+ else if (op_type == OP_BACKTICK && PL_lex_op) {
+ /* readpipe() vas overriden */
+ cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
+ yylval.opval = PL_lex_op;
+ PL_lex_op = NULL;
+ PL_lex_stuff = NULL;
+ return THING;
+ }
PL_sublex_info.super_state = PL_lex_state;
PL_sublex_info.sub_inwhat = op_type;
else {
#ifdef PERL_MAD
if (PL_madskills) {
- if (thiswhite) {
- if (!endwhite)
- endwhite = newSVpvn("",0);
- sv_catsv(endwhite, thiswhite);
- thiswhite = 0;
- }
- if (thistoken)
- sv_setpvn(thistoken,"",0);
+ if (PL_thiswhite) {
+ if (!PL_endwhite)
+ PL_endwhite = newSVpvs("");
+ sv_catsv(PL_endwhite, PL_thiswhite);
+ PL_thiswhite = 0;
+ }
+ if (PL_thistoken)
+ sv_setpvn(PL_thistoken,"",0);
else
- realtokenstart = -1;
+ PL_realtokenstart = -1;
}
#endif
LEAVE;
Extracts a pattern, double-quoted string, or transliteration. This
is terrifying code.
- It looks at lex_inwhat and PL_lex_inpat to find out whether it's
+ It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
processing a pattern (PL_lex_inpat is true), a transliteration
- (lex_inwhat & OP_TRANS is true), or a double-quoted string.
+ (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
- Returns a pointer to the character scanned up to. Iff this is
- advanced from the start pointer supplied (ie if anything was
+ Returns a pointer to the character scanned up to. If this is
+ advanced from the start pointer supplied (i.e. if anything was
successfully parsed), will leave an OP for the substring scanned
in yylval. Caller must intuit reason for not parsing further
by looking at the next characters herself.
backslashes:
double-quoted style: \r and \n
regexp special ones: \D \s
- constants: \x3
- backrefs: \1 (deprecated in substitution replacements)
+ constants: \x31
+ backrefs: \1
case and quoting: \U \Q \E
stops on @ and $, but not for $ as tail anchor
In transliterations:
characters are VERY literal, except for - not at the start or end
- of the string, which indicates a range. scan_const expands the
- range to the full set of intermediate characters.
+ of the string, which indicates a range. If the range is in bytes,
+ scan_const expands the range to the full set of intermediate
+ characters. If the range is in utf8, the hyphen is replaced with
+ a certain range mark which will be handled by pmtrans() in op.c.
In double-quoted strings:
backslashes:
double-quoted style: \r and \n
- constants: \x3
- backrefs: \1 (deprecated)
+ constants: \x31
+ deprecated backrefs: \1 (in substitution replacements)
case and quoting: \U \Q \E
stops on @ and $
It stops processing as soon as it finds an embedded $ or @ variable
and leaves it to the caller to work out what's going on.
- @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
+ embedded arrays (whether in pattern or not) could be:
+ @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
+
+ $ in double-quoted strings must be the symbol of an embedded scalar.
$ in pattern could be $foo or could be tail anchor. Assumption:
it's a tail anchor if $ is the last thing in the string, or if it's
- followed by one of ")| \n\t"
+ followed by one of "()| \r\n\t"
\1 (backreferences) are turned into $1
The structure of the code is
while (there's a character to process) {
- handle transliteration ranges
- skip regexp comments
- skip # initiated comments in //x patterns
- check for embedded @foo
+ handle transliteration ranges
+ skip regexp comments /(?#comment)/ and codes /(?{code})/
+ skip #-initiated comments in //x patterns
+ check for embedded arrays
check for embedded scalars
if (backslash) {
- leave intact backslashes from leave (below)
- deprecate \1 in strings and sub replacements
+ leave intact backslashes from leaveit (below)
+ deprecate \1 in substitution replacements
handle string-changing backslashes \l \U \Q \E, etc.
switch (what was escaped) {
- handle - in a transliteration (becomes a literal -)
- handle \132 octal characters
- handle 0x15 hex characters
- handle \cV (control V)
- handle printf backslashes (\f, \r, \n, etc)
+ handle \- in a transliteration (becomes a literal -)
+ handle \132 (octal characters)
+ handle \x15 and \x{1234} (hex characters)
+ handle \N{name} (named characters)
+ handle \cV (control characters)
+ handle printf-style backslashes (\f, \r, \n, etc)
} (end switch)
} (end if backslash)
} (end while character to read)
UV uv;
#ifdef EBCDIC
UV literal_endpoint = 0;
+ bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
#endif
- const char *leaveit = /* set of acceptably-backslashed characters */
- PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
- : "";
-
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
/* If we are doing a trans and we know we want UTF8 set expectation */
has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
I32 min; /* first character in range */
I32 max; /* last character in range */
- if (has_utf8) {
+#ifdef EBCDIC
+ UV uvmax = 0;
+#endif
+
+ if (has_utf8
+#ifdef EBCDIC
+ && !native_range
+#endif
+ ) {
char * const c = (char*)utf8_hop((U8*)d, -1);
char *e = d++;
while (e-- > c)
}
i = d - SvPVX_const(sv); /* remember current offset */
+#ifdef EBCDIC
+ SvGROW(sv,
+ SvLEN(sv) + (has_utf8 ?
+ (512 - UTF_CONTINUATION_MARK +
+ UNISKIP(0x100))
+ : 256));
+ /* How many two-byte within 0..255: 128 in UTF-8,
+ * 96 in UTF-8-mod. */
+#else
SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
+#endif
d = SvPVX(sv) + i; /* refresh d after realloc */
- d -= 2; /* eat the first char and the - */
-
- min = (U8)*d; /* first char in range */
- max = (U8)d[1]; /* last char in range */
+#ifdef EBCDIC
+ if (has_utf8) {
+ int j;
+ for (j = 0; j <= 1; j++) {
+ char * const c = (char*)utf8_hop((U8*)d, -1);
+ const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
+ if (j)
+ min = (U8)uv;
+ else if (uv < 256)
+ max = (U8)uv;
+ else {
+ max = (U8)0xff; /* only to \xff */
+ uvmax = uv; /* \x{100} to uvmax */
+ }
+ d = c; /* eat endpoint chars */
+ }
+ }
+ else {
+#endif
+ d -= 2; /* eat the first char and the - */
+ min = (U8)*d; /* first char in range */
+ max = (U8)d[1]; /* last char in range */
+#ifdef EBCDIC
+ }
+#endif
if (min > max) {
Perl_croak(aTHX_
else
#endif
for (i = min; i <= max; i++)
- *d++ = (char)i;
+#ifdef EBCDIC
+ if (has_utf8) {
+ const U8 ch = (U8)NATIVE_TO_UTF(i);
+ if (UNI_IS_INVARIANT(ch))
+ *d++ = (U8)i;
+ else {
+ *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
+ *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
+ }
+ }
+ else
+#endif
+ *d++ = (char)i;
+
+#ifdef EBCDIC
+ if (uvmax) {
+ d = (char*)uvchr_to_utf8((U8*)d, 0x100);
+ if (uvmax > 0x101)
+ *d++ = (char)UTF_TO_NATIVE(0xff);
+ if (uvmax > 0x100)
+ d = (char*)uvchr_to_utf8((U8*)d, uvmax);
+ }
+#endif
/* mark the range as done, and continue */
dorange = FALSE;
if (didrange) {
Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
}
- if (has_utf8) {
+ if (has_utf8
+#ifdef EBCDIC
+ && !native_range
+#endif
+ ) {
*d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
s++;
continue;
didrange = FALSE;
#ifdef EBCDIC
literal_endpoint = 0;
+ native_range = TRUE;
#endif
}
}
/* check for embedded arrays
(@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
*/
- else if (*s == '@' && s[1]
- && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
- break;
+ else if (*s == '@' && s[1]) {
+ if (isALNUM_lazy_if(s+1,UTF))
+ break;
+ if (strchr(":'{$", s[1]))
+ break;
+ if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
+ break; /* in regexp, neither @+ nor @- are interpolated */
+ }
/* check for embedded scalars. only stop if we're sure it's a
variable.
if (*s == '\\' && s+1 < send) {
s++;
- /* some backslashes we leave behind */
- if (*leaveit && *s && strchr(leaveit, *s)) {
- *d++ = NATIVE_TO_NEED(has_utf8,'\\');
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
- continue;
- }
-
/* deprecate \1 in strings and substitution replacements */
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
--s;
break;
}
+ /* skip any other backslash escapes in a pattern */
+ else if (PL_lex_inpat) {
+ *d++ = NATIVE_TO_NEED(has_utf8,'\\');
+ goto default_action;
+ }
/* if we get here, it's either a quoted -, or a digit */
switch (*s) {
/* FALL THROUGH */
default:
{
- if (isALNUM(*s) &&
- *s != '_' &&
+ if ((isALPHA(*s) || isDIGIT(*s)) &&
ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Unrecognized escape \\%c passed through",
- *s);
+ "Unrecognized escape \\%c passed through",
+ *s);
/* default action is to copy the quoted character */
goto default_action;
}
(PL_lex_repl ? OPpTRANS_FROM_UTF
: OPpTRANS_TO_UTF);
}
+#ifdef EBCDIC
+ if (uv > 255 && !dorange)
+ native_range = FALSE;
+#endif
}
else {
*d++ = (char)uv;
SV *res;
STRLEN len;
const char *str;
+ SV *type;
if (!e) {
yyerror("Missing right brace on \\N{}");
s += 3;
len = e - s;
uv = grok_hex(s, &len, &flags, NULL);
+ if ( e > s && len != (STRLEN)(e - s) ) {
+ uv = 0xFFFD;
+ }
s = e + 1;
goto NUM_ESCAPE_INSERT;
}
res = newSVpvn(s + 1, e - s - 1);
+ type = newSVpvn(s - 2,e - s + 3);
res = new_constant( NULL, 0, "charnames",
- res, NULL, "\\N{...}" );
+ res, NULL, SvPVX(type) );
+ SvREFCNT_dec(type);
if (has_utf8)
sv_utf8_upgrade(res);
str = SvPV_const(res,len);
SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
d = SvPVX(sv) + (d - odest);
}
+#ifdef EBCDIC
+ if (!dorange)
+ native_range = FALSE; /* \N{} is guessed to be Unicode */
+#endif
Copy(str, d, len, char);
d += len;
SvREFCNT_dec(res);
}
d = (char*)uvchr_to_utf8((U8*)d, nextuv);
has_utf8 = TRUE;
+#ifdef EBCDIC
+ if (uv > 255 && !dorange)
+ native_range = FALSE;
+#endif
}
else {
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
/* return the substring (via yylval) only if we parsed anything */
if (s > PL_bufptr) {
if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
- sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
+ sv = new_constant(start, s - start,
+ (const char *)(PL_lex_inpat ? "qr" : "q"),
sv, NULL,
- ( PL_lex_inwhat == OP_TRANS
- ? "tr"
- : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
- ? "s"
- : "qq")));
+ (const char *)
+ (( PL_lex_inwhat == OP_TRANS
+ ? "tr"
+ : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
+ ? "s"
+ : "qq"))));
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
} else
SvREFCNT_dec(sv);
if (s[1]) {
if (strchr("wds]",s[1]))
weight += 100;
- else if (seen['\''] || seen['"'])
+ else if (seen[(U8)'\''] || seen[(U8)'"'])
weight += 1;
else if (strchr("rnftbxcav",s[1]))
weight += 40;
while (isALPHA(*s))
*d++ = *s++;
*d = '\0';
- if (keyword(tmpbuf, d - tmpbuf))
+ if (keyword(tmpbuf, d - tmpbuf, 0))
weight -= 150;
}
if (un_char == last_un_char + 1)
}
}
} else
- gv = 0;
+ gv = NULL;
}
s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
/* start is the beginning of the possible filehandle/object,
len = start - SvPVX(PL_linestr);
#endif
s = PEEKSPACE(s);
-#ifdef PERLMAD
+#ifdef PERL_MAD
start = SvPVX(PL_linestr) + len;
#endif
PL_bufptr = start;
PL_expect = XREF;
return *s == '(' ? FUNCMETH : METHOD;
}
- if (!keyword(tmpbuf, len)) {
+ if (!keyword(tmpbuf, len, 0)) {
if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
len -= 2;
tmpbuf[len] = '\0';
if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
return 0; /* no assumptions -- "=>" quotes bearword */
bare_package:
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
newSVpvn(tmpbuf,len));
NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
IoFLAGS(datasv) |= IOf_FAKE_DIRP;
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
- IoANY(datasv), SvPV_nolen(datasv)));
+ FPTR2DPTR(void *, IoANY(datasv)),
+ SvPV_nolen(datasv)));
av_unshift(PL_rsfp_filters, 1);
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
SV *datasv;
#ifdef DEBUGGING
- DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
+ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
+ FPTR2DPTR(void*, funcp)));
#endif
if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
dVAR;
filter_t funcp;
SV *datasv = NULL;
+ /* This API is bad. It should have been using unsigned int for maxlen.
+ Not sure if we want to change the API, but if not we should sanity
+ check the value here. */
+ const unsigned int correct_length
+ = maxlen < 0 ?
+#ifdef PERL_MICRO
+ 0x7FFFFFFF
+#else
+ INT_MAX
+#endif
+ : maxlen;
if (!PL_rsfp_filters)
return -1;
/* Note that we append to the line. This is handy. */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: from rsfp\n", idx));
- if (maxlen) {
+ if (correct_length) {
/* Want a block */
int len ;
const int old_len = SvCUR(buf_sv);
/* ensure buf_sv is large enough */
- SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
- if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
+ SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
+ if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
+ correct_length)) <= 0) {
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: skipped (filter deleted)\n",
idx));
- return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
+ return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
}
/* Get function pointer hidden within datasv */
funcp = DPTR2FPTR(filter_t, IoANY(datasv));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
- idx, datasv, SvPV_nolen_const(datasv)));
+ idx, (void*)datasv, SvPV_nolen_const(datasv)));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
- return (*funcp)(aTHX_ idx, buf_sv, maxlen);
+ return (*funcp)(aTHX_ idx, buf_sv, correct_length);
}
STATIC char *
}
/* use constant CLASS => 'MyClass' */
- if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) {
- SV *sv;
- if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
+ gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
+ if (gv && GvCV(gv)) {
+ SV * const sv = cv_const_sv(GvCV(gv));
+ if (sv)
pkgname = SvPV_nolen_const(sv);
- }
}
return gv_stashpv(pkgname, FALSE);
}
+/*
+ * S_readpipe_override
+ * Check whether readpipe() is overriden, and generates the appropriate
+ * optree, provided sublex_start() is called afterwards.
+ */
+STATIC void
+S_readpipe_override(pTHX)
+{
+ GV **gvp;
+ GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
+ yylval.ival = OP_BACKTICK;
+ if ((gv_readpipe
+ && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
+ ||
+ ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
+ && (gv_readpipe = *gvp) != (GV*)&PL_sv_undef
+ && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
+ {
+ PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
+ newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
+ }
+ else {
+ set_csh();
+ }
+}
+
#ifdef PERL_MAD
/*
* Perl_madlex
int optype;
char *s = PL_bufptr;
- /* make sure thiswhite is initialized */
- thiswhite = 0;
- thismad = 0;
+ /* make sure PL_thiswhite is initialized */
+ PL_thiswhite = 0;
+ PL_thismad = 0;
- /* just do what yylex would do on pending identifier; leave thiswhite alone */
+ /* 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 && nextwhite) {
- thiswhite = nextwhite;
- nextwhite = 0;
+ if (!PL_lasttoke && PL_nextwhite) {
+ PL_thiswhite = PL_nextwhite;
+ PL_nextwhite = 0;
}
/* isolate the token, and figure out where it is without whitespace */
- realtokenstart = -1;
- thistoken = 0;
+ PL_realtokenstart = -1;
+ PL_thistoken = 0;
optype = yylex();
s = PL_bufptr;
- assert(curforce < 0);
+ assert(PL_curforce < 0);
- if (!thismad || thismad->mad_key == '^') { /* not forced already? */
- if (!thistoken) {
- if (realtokenstart < 0 || !CopLINE(PL_curcop))
- thistoken = newSVpvn("",0);
+ if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
+ if (!PL_thistoken) {
+ if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
+ PL_thistoken = newSVpvs("");
else {
- char *tstart = SvPVX(PL_linestr) + realtokenstart;
- thistoken = newSVpvn(tstart, s - tstart);
+ char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpvn(tstart, s - tstart);
}
}
- if (thismad) /* install head */
- CURMAD('X', thistoken);
+ if (PL_thismad) /* install head */
+ CURMAD('X', PL_thistoken);
}
/* last whitespace of a sublex? */
- if (optype == ')' && endwhite) {
- CURMAD('X', endwhite);
+ if (optype == ')' && PL_endwhite) {
+ CURMAD('X', PL_endwhite);
}
- if (!thismad) {
+ if (!PL_thismad) {
/* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
- if (!thiswhite && !endwhite && !optype) {
- sv_free(thistoken);
- thistoken = 0;
+ 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) {
- nextwhite = thiswhite;
- thiswhite = 0;
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
}
- else if (thisopen) {
- CURMAD('q', thisopen);
- if (thistoken)
- sv_free(thistoken);
- thistoken = 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', thistoken);
+ CURMAD('X', PL_thistoken);
}
- if (thiswhite) {
+ if (PL_thiswhite) {
/* add preceding whitespace as madprop _ */
- CURMAD('_', thiswhite);
+ CURMAD('_', PL_thiswhite);
}
- if (thisstuff) {
+ if (PL_thisstuff) {
/* add quoted material as madprop = */
- CURMAD('=', thisstuff);
+ CURMAD('=', PL_thisstuff);
}
- if (thisclose) {
+ if (PL_thisclose) {
/* add terminating quote as madprop Q */
- CURMAD('Q', thisclose);
+ CURMAD('Q', PL_thisclose);
}
}
case UNIOPSUB:
case LSTOPSUB:
if (yylval.opval)
- append_madprops(thismad, yylval.opval, 0);
- thismad = 0;
+ append_madprops(PL_thismad, yylval.opval, 0);
+ PL_thismad = 0;
return optype;
/* fake EOF */
case 0:
optype = PEG;
- if (endwhite) {
- addmad(newMADsv('p', endwhite), &thismad, 0);
- endwhite = 0;
+ if (PL_endwhite) {
+ addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
+ PL_endwhite = 0;
}
break;
case ']':
case '}':
- if (faketokens)
+ if (PL_faketokens)
break;
/* remember any fake bracket that lexer is about to discard */
if (PL_lex_brackets == 1 &&
while (s < PL_bufend && (*s == ' ' || *s == '\t'))
s++;
if (*s == '}') {
- thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
- addmad(newMADsv('#', thiswhite), &thismad, 0);
- thiswhite = 0;
+ 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 */
}
/* attach a trailing comment to its statement instead of next token */
case ';':
- if (faketokens)
+ if (PL_faketokens)
break;
if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
s = PL_bufptr;
s++;
if (s < PL_bufend)
s++;
- thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
- addmad(newMADsv('#', thiswhite), &thismad, 0);
- thiswhite = 0;
+ PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
+ addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
+ PL_thiswhite = 0;
PL_bufptr = s;
}
}
}
/* Create new token struct. Note: opvals return early above. */
- yylval.tkval = newTOKEN(optype, yylval, thismad);
- thismad = 0;
+ yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
+ PL_thismad = 0;
return optype;
}
#endif
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
s = force_version(s, TRUE);
if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = NULL;
force_next(WORD);
}
STRLEN len;
bool bof = FALSE;
+ /* orig_keyword, gvp, and gv are initialized here because
+ * jump to the label just_a_word_zero can bypass their
+ * initialization later. */
+ I32 orig_keyword = 0;
+ GV *gv = NULL;
+ GV **gvp = NULL;
+
DEBUG_T( {
SV* tmp = newSVpvs("");
PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
PL_lasttoke--;
yylval = PL_nexttoke[PL_lasttoke].next_val;
if (PL_madskills) {
- thismad = PL_nexttoke[PL_lasttoke].next_mad;
+ PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
PL_nexttoke[PL_lasttoke].next_mad = 0;
- if (thismad && thismad->mad_key == '_') {
- thiswhite = (SV*)thismad->mad_val;
- thismad->mad_val = 0;
- mad_free(thismad);
- thismad = 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 = LEX_INTERPCONCAT;
#ifdef PERL_MAD
if (PL_madskills)
- thistoken = newSVpvn("\\E",2);
+ PL_thistoken = newSVpvs("\\E");
#endif
}
return REPORT(')');
#ifdef PERL_MAD
while (PL_bufptr != PL_bufend &&
PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
- if (!thiswhite)
- thiswhite = newSVpvn("",0);
- sv_catpvn(thiswhite, PL_bufptr, 2);
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, PL_bufptr, 2);
PL_bufptr += 2;
}
#else
s = PL_bufptr + 1;
if (s[1] == '\\' && s[2] == 'E') {
#ifdef PERL_MAD
- if (!thiswhite)
- thiswhite = newSVpvn("",0);
- sv_catpvn(thiswhite, PL_bufptr, 4);
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, PL_bufptr, 4);
#endif
PL_bufptr = s + 3;
PL_lex_state = LEX_INTERPCONCAT;
PL_lex_casestack[PL_lex_casemods++] = *s;
PL_lex_casestack[PL_lex_casemods] = '\0';
PL_lex_state = LEX_INTERPCONCAT;
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next('(');
- start_force(curforce);
+ start_force(PL_curforce);
if (*s == 'l')
NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
else if (*s == 'u')
else
Perl_croak(aTHX_ "panic: yylex");
if (PL_madskills) {
- SV* tmpsv = newSVpvn("",0);
+ SV* const tmpsv = newSVpvs("");
Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
curmad('_', tmpsv);
}
PL_lex_starts = 0;
#ifdef PERL_MAD
if (PL_madskills) {
- if (thistoken)
- sv_free(thistoken);
- thistoken = newSVpvn("",0);
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
if (PL_lex_dojoin) {
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next(',');
- start_force(curforce);
+ start_force(PL_curforce);
force_ident("\"", '$');
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next('$');
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next('(');
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
}
s = PL_bufptr;
#ifdef PERL_MAD
if (PL_madskills) {
- if (thistoken)
- sv_free(thistoken);
- thistoken = newSVpvn("",0);
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
PL_lex_state = LEX_INTERPCONCAT;
#ifdef PERL_MAD
if (PL_madskills) {
- if (thistoken)
- sv_free(thistoken);
- thistoken = newSVpvn("",0);
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
}
#endif
return REPORT(')');
}
if (s != PL_bufptr) {
- start_force(curforce);
+ start_force(PL_curforce);
if (PL_madskills) {
curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
}
if (PL_lex_starts++) {
#ifdef PERL_MAD
if (PL_madskills) {
- if (thistoken)
- sv_free(thistoken);
- thistoken = newSVpvn("",0);
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
retry:
#ifdef PERL_MAD
- if (thistoken) {
- sv_free(thistoken);
- thistoken = 0;
+ if (PL_thistoken) {
+ sv_free(PL_thistoken);
+ PL_thistoken = 0;
}
- realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
+ PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
#endif
switch (*s) {
default:
case 0:
#ifdef PERL_MAD
if (PL_madskills)
- faketokens = 0;
+ PL_faketokens = 0;
#endif
if (!PL_rsfp) {
PL_last_uni = 0;
PL_last_lop = 0;
if (PL_lex_brackets) {
- yyerror(PL_lex_formbrack
- ? "Format not terminated"
- : "Missing right curly or square bracket");
+ yyerror((const char *)
+ (PL_lex_formbrack
+ ? "Format not terminated"
+ : "Missing right curly or square bracket"));
}
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Tokener got EOF\n");
PL_preambled = TRUE;
#ifdef PERL_MAD
if (PL_madskills)
- faketokens = 1;
+ PL_faketokens = 1;
#endif
sv_setpv(PL_linestr,incl_perldb());
if (SvCUR(PL_linestr))
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_sv(PL_linestr);
goto retry;
}
do {
if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
fake_eof:
#ifdef PERL_MAD
- realtokenstart = -1;
+ PL_realtokenstart = -1;
#endif
if (PL_rsfp) {
if (PL_preprocess && !PL_in_eval)
if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
#ifdef PERL_MAD
if (PL_madskills)
- faketokens = 1;
+ PL_faketokens = 1;
#endif
- sv_setpv(PL_linestr,PL_minus_p
- ? ";}continue{print;}" : ";}");
+ sv_setpv(PL_linestr,
+ (const char *)
+ (PL_minus_p
+ ? ";}continue{print;}" : ";}"));
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
/* Incest with pod. */
#ifdef PERL_MAD
if (PL_madskills)
- sv_catsv(thiswhite, PL_linestr);
+ sv_catsv(PL_thiswhite, PL_linestr);
#endif
if (*s == '=' && strnEQ(s, "=cut", 4)) {
sv_setpvn(PL_linestr, "", 0);
incline(s);
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_sv(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
if (CopLINE(PL_curcop) == 1) {
s++;
#ifdef PERL_MAD
if (PL_madskills)
- thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
+ PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
#endif
d = NULL;
if (!PL_in_eval) {
}
#endif
if (d) {
- while (*d && !isSPACE(*d)) d++;
- while (SPACE_OR_TAB(*d)) d++;
+ while (*d && !isSPACE(*d))
+ d++;
+ while (SPACE_OR_TAB(*d))
+ d++;
if (*d++ == '-') {
const bool switches_done = PL_doswitches;
do {
if (*d == 'M' || *d == 'm' || *d == 'C') {
const char * const m = d;
- while (*d && !isSPACE(*d)) d++;
+ while (*d && !isSPACE(*d))
+ d++;
Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
(int)(d - m), m);
}
case '\312':
#endif
#ifdef PERL_MAD
- realtokenstart = -1;
+ PL_realtokenstart = -1;
s = SKIPSPACE0(s);
#else
s++;
case '#':
case '\n':
#ifdef PERL_MAD
- realtokenstart = -1;
+ PL_realtokenstart = -1;
if (PL_madskills)
- faketokens = 0;
+ 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) {
Perl_croak(aTHX_ "panic: input overflow");
#ifdef PERL_MAD
if (PL_madskills)
- thiswhite = newSVpvn(s, d - s);
+ PL_thiswhite = newSVpvn(s, d - s);
#endif
s = d;
incline(s);
#ifdef PERL_MAD
if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
- faketokens = 0;
+ PL_faketokens = 0;
s = SKIPSPACE0(s);
TOKEN(PEG); /* make sure any #! line is accessible */
}
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 (!thiswhite)
- thiswhite = newSVpvn("",0);
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
if (CopLINE(PL_curcop) == 1) {
- sv_setpvn(thiswhite, "", 0);
- faketokens = 0;
+ sv_setpvn(PL_thiswhite, "", 0);
+ PL_faketokens = 0;
}
- sv_catpvn(thiswhite, s, d - s);
+ sv_catpvn(PL_thiswhite, s, d - s);
}
s = d;
/* }
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;
attrs = NULL;
while (isIDFIRST_lazy_if(s,UTF)) {
I32 tmp;
+ SV *sv;
d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
+ if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
if (tmp < 0) tmp = -tmp;
switch (tmp) {
case KEY_or:
break;
}
}
+ sv = newSVpvn(s, len);
if (*d == '(') {
d = scan_str(d,TRUE,TRUE);
if (!d) {
yyerror("Unterminated attribute parameter in attribute list");
if (attrs)
op_free(attrs);
+ sv_free(sv);
return REPORT(0); /* EOF indicator */
}
}
if (PL_lex_stuff) {
- SV *sv = newSVpvn(s, len);
sv_catsv(sv, PL_lex_stuff);
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0, sv));
PL_lex_stuff = NULL;
}
else {
- if (len == 6 && strnEQ(s, "unique", len)) {
- if (PL_in_my == KEY_our)
+ if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
+ sv_free(sv);
+ if (PL_in_my == KEY_our) {
#ifdef USE_ITHREADS
GvUNIQUE_on(cGVOPx_gv(yylval.opval));
#else
- /*EMPTY*/; /* skip to avoid loading attributes.pm */
+ /* skip to avoid loading attributes.pm */
#endif
+ deprecate(":unique");
+ }
else
Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
}
/* NOTE: any CV attrs applied here need to be part of
the CVf_BUILTIN_ATTRS define in cv.h! */
- else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
+ sv_free(sv);
CvLVALUE_on(PL_compcv);
- else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
+ }
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
+ sv_free(sv);
CvLOCKED_on(PL_compcv);
- else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
+ }
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
+ sv_free(sv);
CvMETHOD_on(PL_compcv);
- else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
+ }
+ else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
+ sv_free(sv);
CvASSERTION_on(PL_compcv);
+ }
/* After we've set the flags, it could be argued that
we don't need to do the attributes.pm-based setting
process, and shouldn't bother appending recognized
else
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0,
- newSVpvn(s, len)));
+ sv));
}
s = PEEKSPACE(d);
if (*s == ':' && s[1] != ':')
context messages from yyerror().
*/
PL_bufptr = s;
- yyerror( *s
- ? Perl_form(aTHX_ "Invalid separator character "
- "%c%c%c in attribute list", q, *s, q)
- : "Unterminated attribute list" );
+ yyerror( (const char *)
+ (*s
+ ? Perl_form(aTHX_ "Invalid separator character "
+ "%c%c%c in attribute list", q, *s, q)
+ : "Unterminated attribute list" ) );
if (attrs)
op_free(attrs);
OPERATOR(':');
}
got_attrs:
if (attrs) {
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = attrs;
- CURMAD('_', nextwhite);
+ CURMAD('_', PL_nextwhite);
force_next(THING);
}
#ifdef PERL_MAD
if (PL_madskills) {
- thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
+ PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
(s - SvPVX(PL_linestr)) - stuffstart);
}
#endif
PL_bufptr = s;
#if 0
if (PL_madskills) {
- if (!thiswhite)
- thiswhite = newSVpvn("",0);
- sv_catpvn(thiswhite,"}",1);
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite,"}",1);
}
#endif
return yylex(); /* ignore fake brackets */
PL_bufptr = s;
return yylex(); /* ignore fake brackets */
}
- start_force(curforce);
+ start_force(PL_curforce);
if (PL_madskills) {
curmad('X', newSVpvn(s-1,1));
- CURMAD('_', thiswhite);
+ CURMAD('_', PL_thiswhite);
}
force_next('}');
#ifdef PERL_MAD
- if (!thistoken)
- thistoken = newSVpvn("",0);
+ if (!PL_thistoken)
+ PL_thistoken = newSVpvs("");
#endif
TOKEN(';');
case '&':
}
#ifdef PERL_MAD
if (PL_madskills) {
- if (!thiswhite)
- thiswhite = newSVpvn("",0);
- sv_catpvn(thiswhite, PL_linestart,
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, PL_linestart,
PL_bufend - PL_linestart);
}
#endif
}
}
if (PL_lex_brackets < PL_lex_formbrack) {
- const char *t;
+ const char *t = s;
#ifdef PERL_STRICT_CR
- for (t = s; SPACE_OR_TAB(*t); t++) ;
+ while (SPACE_OR_TAB(*t))
#else
- for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
+ while (SPACE_OR_TAB(*t) || *t == '\r')
#endif
+ t++;
if (*t == '\n' || *t == '#') {
s--;
PL_expect = XBLOCK;
const char tmp = *s++;
if (tmp == '>')
SHop(OP_RIGHT_SHIFT);
- if (tmp == '=')
+ else if (tmp == '=')
Rop(OP_GE);
}
s--;
/* This kludge not intended to be bulletproof. */
if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
yylval.opval = newSVOP(OP_CONST, 0,
- newSViv(PL_compiling.cop_arybase));
+ newSViv(CopARYBASE_get(&PL_compiling)));
yylval.opval->op_private = OPpCONST_ARYBASE;
TERM(THING);
}
if (*s == '[') {
PL_tokenbuf[0] = '@';
if (ckWARN(WARN_SYNTAX)) {
- char *t;
- for(t = s + 1;
- isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
- t++) ;
+ char *t = s+1;
+
+ while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
+ t++;
if (*t++ == ',') {
PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
while (t < PL_bufend && *t != ']')
&& (t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof PL_tokenbuf];
- for (t++; isSPACE(*t); t++) ;
+ do {
+ t++;
+ } while (isSPACE(*t));
if (isIDFIRST_lazy_if(t,UTF)) {
STRLEN dummylen;
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
&dummylen);
- for (; isSPACE(*t); t++) ;
+ while (isSPACE(*t))
+ t++;
if (*t == ';' && get_cv(tmpbuf, FALSE))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"You need to quote \"%s\"",
char tmpbuf[sizeof PL_tokenbuf];
int t2;
scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
- if ((t2 = keyword(tmpbuf, len))) {
+ if ((t2 = keyword(tmpbuf, len, 0))) {
/* binary operators exclude handle interpretations */
switch (t2) {
case -KEY_x:
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,!!PL_madskills,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
no_op("String",s);
}
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
yylval.ival = OP_CONST;
TERM(sublex_start());
case '"':
s = scan_str(s,!!PL_madskills,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
no_op("String",s);
}
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
yylval.ival = OP_CONST;
/* FIXME. I think that this can be const if char *d is replaced by
more localised variables. */
case '`':
s = scan_str(s,!!PL_madskills,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
+ DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ missingterm(NULL);
+ readpipe_override();
TERM(sublex_start());
case '\\':
else if (!isALPHA(*start) && (PL_expect == XTERM
|| PL_expect == XREF || PL_expect == XSTATE
|| PL_expect == XTERMORDORDOR)) {
+ /* XXX Use gv_fetchpvn rather than stomping on a const string */
const char c = *start;
GV *gv;
*start = '\0';
keylookup: {
I32 tmp;
- I32 orig_keyword = 0;
- GV *gv = NULL;
- GV **gvp = NULL;
+
+ orig_keyword = 0;
+ gv = NULL;
+ gvp = NULL;
PL_bufptr = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
}
/* Check for keywords */
- tmp = keyword(PL_tokenbuf, len);
+ tmp = keyword(PL_tokenbuf, len, 0);
/* Is this a word before a => operator? */
if (*d == '=' && d[1] == '>') {
const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
CV *cv;
#ifdef PERL_MAD
- SV *nextnextwhite = 0;
+ SV *nextPL_nextwhite = 0;
#endif
sv = newSVpv(PL_tokenbuf,len);
}
#ifdef PERL_MAD
- if (PL_madskills && !thistoken) {
- char *start = SvPVX(PL_linestr) + realtokenstart;
- thistoken = newSVpv(start,s - start);
- realtokenstart = s - SvPVX(PL_linestr);
+ 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
bool immediate_paren = *s == '(';
/* (Now we can afford to cross potential line boundary.) */
- s = SKIPSPACE2(s,nextnextwhite);
+ s = SKIPSPACE2(s,nextPL_nextwhite);
#ifdef PERL_MAD
- nextwhite = nextnextwhite; /* assume no & deception */
+ PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
#endif
/* Two barewords in a row may indicate method call. */
PL_expect = XOPERATOR;
#ifdef PERL_MAD
if (isSPACE(*s))
- s = SKIPSPACE2(s,nextnextwhite);
- nextwhite = nextnextwhite;
+ s = SKIPSPACE2(s,nextPL_nextwhite);
+ PL_nextwhite = nextPL_nextwhite;
#else
s = skipspace(s);
#endif
if (*s == '(') {
CLINE;
if (cv) {
- for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
+ d = s + 1;
+ while (SPACE_OR_TAB(*d))
+ d++;
if (*d == ')' && (sv = gv_const_sv(gv))) {
s = d + 1;
#ifdef PERL_MAD
if (PL_madskills) {
- char *par = SvPVX(PL_linestr) + realtokenstart;
- sv_catpvn(thistoken, par, s - par);
- if (nextwhite) {
- sv_free(nextwhite);
- nextwhite = 0;
+ 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
}
#ifdef PERL_MAD
if (PL_madskills) {
- nextwhite = thiswhite;
- thiswhite = 0;
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
}
- start_force(curforce);
+ start_force(PL_curforce);
#endif
NEXTVAL_NEXTTOKE.opval = yylval.opval;
PL_expect = XOPERATOR;
#ifdef PERL_MAD
if (PL_madskills) {
- nextwhite = nextnextwhite;
- curmad('X', thistoken);
- thistoken = newSVpvn("",0);
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
}
#endif
force_next(WORD);
#ifdef PERL_MAD
cv &&
#endif
- SvPOK(cv)) {
+ SvPOK(cv))
+ {
STRLEN protolen;
const char *proto = SvPV_const((SV*)cv, protolen);
if (!protolen)
TERM(FUNC0SUB);
- if (*proto == '$' && proto[1] == '\0')
+ if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
OPERATOR(UNIOPSUB);
while (*proto == ';')
proto++;
if (*proto == '&' && *s == '{') {
- sv_setpv(PL_subname, PL_curstash ?
- "__ANON__" : "__ANON__::__ANON__");
+ sv_setpv(PL_subname,
+ (const char *)
+ (PL_curstash ?
+ "__ANON__" : "__ANON__::__ANON__"));
PREBLOCK(LSTOPSUB);
}
}
#ifdef PERL_MAD
{
if (PL_madskills) {
- nextwhite = thiswhite;
- thiswhite = 0;
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
}
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = yylval.opval;
PL_expect = XTERM;
if (PL_madskills) {
- nextwhite = nextnextwhite;
- curmad('X', thistoken);
- thistoken = newSVpvn("",0);
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
}
force_next(WORD);
TOKEN(NOAMP);
STRLEN tmplen;
d = s;
d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
- if (!keyword(tmpbuf,tmplen))
+ if (!keyword(tmpbuf, tmplen, 0))
probable_sub = 1;
else {
while (d < PL_bufend && isSPACE(*d))
yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
- nextwhite = thiswhite;
- thiswhite = 0;
- start_force(curforce);
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = yylval.opval;
PL_expect = XTERM;
- nextwhite = nextnextwhite;
- curmad('X', thistoken);
- thistoken = newSVpvn("",0);
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
force_next(WORD);
TOKEN(NOAMP);
}
bareword:
if (lastchar != '-') {
if (ckWARN(WARN_RESERVED)) {
- for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
+ d = PL_tokenbuf;
+ while (isLOWER(*d))
+ d++;
if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
PUTBACK;
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
Perl_form(aTHX_ ":encoding(%"SVf")",
- name));
+ (void*)name));
FREETMPS;
LEAVE;
}
#endif
#ifdef PERL_MAD
if (PL_madskills) {
- if (realtokenstart >= 0) {
- char *tstart = SvPVX(PL_linestr) + realtokenstart;
- if (!endwhite)
- endwhite = newSVpvn("",0);
- sv_catsv(endwhite, thiswhite);
- thiswhite = 0;
- sv_catpvn(endwhite, tstart, PL_bufend - tstart);
- realtokenstart = -1;
+ if (PL_realtokenstart >= 0) {
+ char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ if (!PL_endwhite)
+ PL_endwhite = newSVpvs("");
+ sv_catsv(PL_endwhite, PL_thiswhite);
+ PL_thiswhite = 0;
+ sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
+ PL_realtokenstart = -1;
}
- while ((s = filter_gets(endwhite, PL_rsfp,
- SvCUR(endwhite))) != Nullch) ;
+ while ((s = filter_gets(PL_endwhite, PL_rsfp,
+ SvCUR(PL_endwhite))) != Nullch) ;
}
#endif
PL_rsfp = NULL;
case KEY_AUTOLOAD:
case KEY_DESTROY:
case KEY_BEGIN:
+ case KEY_UNITCHECK:
case KEY_CHECK:
case KEY_INIT:
case KEY_END:
s += 2;
d = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (!(tmp = keyword(PL_tokenbuf, len)))
+ if (!(tmp = keyword(PL_tokenbuf, len, 0)))
Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
if (tmp < 0)
tmp = -tmp;
case KEY_our:
case KEY_my:
+ case KEY_state:
PL_in_my = tmp;
s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
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(thistoken, nextwhite);
- nextwhite = 0;
- sv_catpvn(thistoken, start, s - start);
+ sv_catsv(PL_thistoken, PL_nextwhite);
+ PL_nextwhite = 0;
+ sv_catpvn(PL_thistoken, start, s - start);
}
#endif
}
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] == '>')
case KEY_q:
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
yylval.ival = OP_CONST;
TERM(sublex_start());
case KEY_qw:
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
PL_expect = XOPERATOR;
force_next(')');
if (SvCUR(PL_lex_stuff)) {
int warned = 0;
d = SvPV_force(PL_lex_stuff, len);
while (len) {
- SV *sv;
- for (; isSPACE(*d) && len; --len, ++d) ;
+ for (; isSPACE(*d) && len; --len, ++d)
+ /**/;
if (len) {
+ SV *sv;
const char *b = d;
if (!warned && ckWARN(WARN_QW)) {
for (; !isSPACE(*d) && len; --len, ++d) {
}
}
else {
- for (; !isSPACE(*d) && len; --len, ++d) ;
+ for (; !isSPACE(*d) && len; --len, ++d)
+ /**/;
}
sv = newSVpvn(b, d-b);
if (DO_UTF8(PL_lex_stuff))
}
}
if (words) {
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = words;
force_next(THING);
}
case KEY_qq:
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 */
case KEY_qx:
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ missingterm(NULL);
+ readpipe_override();
TERM(sublex_start());
case KEY_return:
char tmpbuf[sizeof PL_tokenbuf];
SSize_t tboffset = 0;
expectation attrful;
- bool have_name, have_proto, bad_proto;
+ bool have_name, have_proto;
const int key = tmp;
#ifdef PERL_MAD
SV *tmpwhite = 0;
- char *tstart = SvPVX(PL_linestr) + realtokenstart;
+ char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
SV *subtoken = newSVpvn(tstart, s - tstart);
- thistoken = 0;
+ PL_thistoken = 0;
d = s;
s = SKIPSPACE2(s,tmpwhite);
if (*s == '=')
PL_lex_formbrack = PL_lex_brackets + 1;
#ifdef PERL_MAD
- thistoken = subtoken;
+ PL_thistoken = subtoken;
s = d;
#else
if (have_name)
/* Look for a prototype */
if (*s == '(') {
char *p;
+ bool bad_proto = FALSE;
+ const bool warnsyntax = ckWARN(WARN_SYNTAX);
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
/* strip spaces and check for bad characters */
d = SvPVX(PL_lex_stuff);
tmp = 0;
- bad_proto = FALSE;
for (p = d; *p; ++p) {
if (!isSPACE(*p)) {
d[tmp++] = *p;
- if (!strchr("$@%*;[]&\\", *p))
+ if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
bad_proto = TRUE;
}
}
d[tmp] = '\0';
- if (bad_proto && ckWARN(WARN_SYNTAX))
+ if (bad_proto)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Illegal character in prototype for %"SVf" : %s",
- PL_subname, d);
+ (void*)PL_subname, d);
SvCUR_set(PL_lex_stuff, tmp);
have_proto = TRUE;
#ifdef PERL_MAD
start_force(0);
- CURMAD('q', thisopen);
+ CURMAD('q', PL_thisopen);
CURMAD('_', tmpwhite);
- CURMAD('=', thisstuff);
- CURMAD('Q', thisclose);
+ CURMAD('=', PL_thisstuff);
+ CURMAD('Q', PL_thisclose);
NEXTVAL_NEXTTOKE.opval =
(OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
PL_lex_stuff = Nullsv;
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('^', newSVpvs(""));
CURMAD('_', tmpwhite);
}
force_next(0);
- thistoken = subtoken;
+ PL_thistoken = subtoken;
#else
if (have_proto) {
NEXTVAL_NEXTTOKE.opval =
#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
{
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;
- /* realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
+ /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
DEBUG_T({ PerlIO_printf(Perl_debug_log,
"### Pending identifier '%s'\n", PL_tokenbuf); });
}
else {
if (strchr(PL_tokenbuf,':'))
- yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
+ yyerror(Perl_form(aTHX_ PL_no_myglob,
+ PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
yylval.opval = newOP(OP_PADANY, 0);
yylval.opval->op_targ = allocmy(PL_tokenbuf);
*/
I32
-Perl_keyword (pTHX_ const char *name, I32 len)
+Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
{
- dVAR;
+ dVAR;
switch (len)
{
case 1: /* 5 tokens of length 1 */
case 'r':
if (name[2] == 'r')
{ /* err */
- return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
}
goto unknown;
case 'a':
if (name[2] == 'y')
{ /* say */
- return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
}
goto unknown;
switch (name[1])
{
case 'a':
- switch (name[2])
- {
- case 'i':
- if (name[3] == 't')
- { /* wait */
- return -KEY_wait;
- }
+ switch (name[2])
+ {
+ case 'i':
+ if (name[3] == 't')
+ { /* wait */
+ return -KEY_wait;
+ }
- goto unknown;
+ goto unknown;
- case 'r':
- if (name[3] == 'n')
- { /* warn */
- return -KEY_warn;
- }
+ case 'r':
+ if (name[3] == 'n')
+ { /* warn */
+ return -KEY_warn;
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
case 'h':
if (name[2] == 'e' &&
name[3] == 'n')
{ /* when */
- return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
- }
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
default:
goto unknown;
}
- case 5: /* 38 tokens of length 5 */
+ case 5: /* 39 tokens of length 5 */
switch (name[0])
{
case 'B':
{
case 'l':
if (name[2] == 'e' &&
- name[3] == 's' &&
- name[4] == 's')
- { /* bless */
- return -KEY_bless;
- }
+ name[3] == 's' &&
+ name[4] == 's')
+ { /* bless */
+ return -KEY_bless;
+ }
- goto unknown;
+ goto unknown;
case 'r':
if (name[2] == 'e' &&
name[3] == 'a' &&
name[4] == 'k')
{ /* break */
- return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
}
goto unknown;
name[3] == 'e' &&
name[4] == 'n')
{ /* given */
- return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
}
goto unknown;
goto unknown;
case 't':
- if (name[2] == 'u' &&
- name[3] == 'd' &&
- name[4] == 'y')
- { /* study */
- return KEY_study;
- }
+ switch (name[2])
+ {
+ case 'a':
+ if (name[3] == 't' &&
+ name[4] == 'e')
+ { /* state */
+ return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
+ }
- goto unknown;
+ goto unknown;
+
+ case 'u':
+ if (name[3] == 'd' &&
+ name[4] == 'y')
+ { /* study */
+ return KEY_study;
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
default:
goto unknown;
name[5] == 'l' &&
name[6] == 't')
{ /* default */
- return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
}
goto unknown;
case 'i':
if (name[4] == 'n' &&
- name[5] == 'e' &&
- name[6] == 'd')
- { /* defined */
- return KEY_defined;
- }
+ name[5] == 'e' &&
+ name[6] == 'd')
+ { /* defined */
+ return KEY_defined;
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
}
goto unknown;
goto unknown;
}
- case 9: /* 8 tokens of length 9 */
+ case 9: /* 9 tokens of length 9 */
switch (name[0])
{
+ case 'U':
+ if (name[1] == 'N' &&
+ name[2] == 'I' &&
+ name[3] == 'T' &&
+ name[4] == 'C' &&
+ name[5] == 'H' &&
+ name[6] == 'E' &&
+ name[7] == 'C' &&
+ name[8] == 'K')
+ { /* UNITCHECK */
+ return KEY_UNITCHECK;
+ }
+
+ goto unknown;
+
case 'e':
if (name[1] == 'n' &&
name[2] == 'd' &&
S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
{
dVAR;
- const char *w;
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
if (ckWARN(WARN_SYNTAX)) {
int level = 1;
+ const char *w;
for (w = s+2; *w && level; w++) {
if (*w == '(')
++level;
else if (*w == ')')
--level;
}
- if (*w)
- for (; *w && isSPACE(*w); w++) ;
+ while (isSPACE(*w))
+ ++w;
if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%s (...) interpreted as function",name);
while (s < PL_bufend && isSPACE(*s))
s++;
if (isIDFIRST_lazy_if(s,UTF)) {
- w = s++;
+ const char * const w = s++;
while (isALNUM_lazy_if(s,UTF))
s++;
while (s < PL_bufend && isSPACE(*s))
s++;
if (*s == ',') {
GV* gv;
- if (keyword(w, s - w))
+ if (keyword(w, s - w, 0))
return;
gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
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);
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 {
Perl_croak(aTHX_ ident_too_long);
}
*d = '\0';
- while (s < send && SPACE_OR_TAB(*s)) s++;
+ while (s < send && SPACE_OR_TAB(*s))
+ s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
- const char *brack = *s == '[' ? "[...]" : "{...}";
+ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
+ const char * const brack =
+ (const char *)
+ ((*s == '[') ? "[...]" : "{...}");
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
PL_lex_state = LEX_INTERPEND;
PL_expect = XREF;
}
- if (funny == '#')
- funny = '@';
if (PL_lex_state == LEX_NORMAL) {
if (ckWARN(WARN_AMBIGUOUS) &&
- (keyword(dest, d - dest) || get_cv(dest, FALSE)))
+ (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
{
+ if (funny == '#')
+ funny = '@';
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
dVAR;
PMOP *pm;
char *s = scan_str(start,!!PL_madskills,FALSE);
- const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx";
+ const char * const valid_flags =
+ (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
#ifdef PERL_MAD
char *modstart;
#endif
if (!s) {
const char * const delimiter = skipspace(start);
- Perl_croak(aTHX_ *delimiter == '?'
- ? "Search pattern not terminated or ternary operator parsed as search pattern"
- : "Search pattern not terminated" );
+ Perl_croak(aTHX_
+ (const char *)
+ (*delimiter == '?'
+ ? "Search pattern not terminated or ternary operator parsed as search pattern"
+ : "Search pattern not terminated" ));
}
pm = (PMOP*)newPMOP(type, 0);
s--;
#ifdef PERL_MAD
if (PL_madskills) {
- CURMAD('q', thisopen);
- CURMAD('_', thiswhite);
- CURMAD('E', thisstuff);
- CURMAD('Q', thisclose);
- realtokenstart = s - SvPVX(PL_linestr);
+ CURMAD('q', PL_thisopen);
+ CURMAD('_', PL_thiswhite);
+ CURMAD('E', PL_thisstuff);
+ CURMAD('Q', PL_thisclose);
+ PL_realtokenstart = s - SvPVX(PL_linestr);
}
#endif
#ifdef PERL_MAD
if (PL_madskills) {
- CURMAD('z', thisopen);
- CURMAD('R', thisstuff);
- CURMAD('Z', thisclose);
+ CURMAD('z', PL_thisopen);
+ CURMAD('R', PL_thisstuff);
+ CURMAD('Z', PL_thisclose);
}
modstart = s;
#endif
if (PL_madskills) {
if (modstart != s)
curmad('m', newSVpvn(modstart, s - modstart));
- append_madprops(thismad, (OP*)pm, 0);
- thismad = 0;
+ append_madprops(PL_thismad, (OP*)pm, 0);
+ PL_thismad = 0;
}
#endif
if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
while (es-- > 0)
- sv_catpv(repl, es ? "eval " : "do ");
+ sv_catpv(repl, (const char *)(es ? "eval " : "do "));
sv_catpvs(repl, "{");
sv_catsv(repl, PL_lex_repl);
+ if (strchr(SvPVX(PL_lex_repl), '#'))
+ sv_catpvs(repl, "\n");
sv_catpvs(repl, "}");
SvEVALED_on(repl);
SvREFCNT_dec(PL_lex_repl);
s--;
#ifdef PERL_MAD
if (PL_madskills) {
- CURMAD('q', thisopen);
- CURMAD('_', thiswhite);
- CURMAD('E', thisstuff);
- CURMAD('Q', thisclose);
- realtokenstart = s - SvPVX(PL_linestr);
+ CURMAD('q', PL_thisopen);
+ CURMAD('_', PL_thiswhite);
+ CURMAD('E', PL_thisstuff);
+ CURMAD('Q', PL_thisclose);
+ PL_realtokenstart = s - SvPVX(PL_linestr);
}
#endif
Perl_croak(aTHX_ "Transliteration replacement not terminated");
}
if (PL_madskills) {
- CURMAD('z', thisopen);
- CURMAD('R', thisstuff);
- CURMAD('Z', thisclose);
+ CURMAD('z', PL_thisopen);
+ CURMAD('R', PL_thisstuff);
+ CURMAD('Z', PL_thisclose);
}
complement = del = squash = 0;
if (PL_madskills) {
if (modstart != s)
curmad('m', newSVpvn(modstart, s - modstart));
- append_madprops(thismad, o, 0);
- thismad = 0;
+ append_madprops(PL_thismad, o, 0);
+ PL_thismad = 0;
}
#endif
I32 stuffstart = s - SvPVX(PL_linestr);
char *tstart;
- realtokenstart = -1;
+ PL_realtokenstart = -1;
#endif
s += 2;
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++;
#ifdef PERL_MAD
if (PL_madskills) {
tstart = PL_tokenbuf + !outer;
- thisclose = newSVpvn(tstart, len - !outer);
+ PL_thisclose = newSVpvn(tstart, len - !outer);
tstart = SvPVX(PL_linestr) + stuffstart;
- thisopen = newSVpvn(tstart, s - tstart);
+ PL_thisopen = newSVpvn(tstart, s - tstart);
stuffstart = s - SvPVX(PL_linestr);
}
#endif
#ifdef PERL_MAD
found_newline = 0;
#endif
- if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) {
+ if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
herewas = newSVpvn(s,PL_bufend-s);
}
else {
#ifdef PERL_MAD
if (PL_madskills) {
tstart = SvPVX(PL_linestr) + stuffstart;
- if (thisstuff)
- sv_catpvn(thisstuff, tstart, s - tstart);
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, s - tstart);
else
- thisstuff = newSVpvn(tstart, s - tstart);
+ PL_thisstuff = newSVpvn(tstart, s - tstart);
}
#endif
s += SvCUR(herewas);
sv_setpvn(tmpstr,d+1,s-d);
#ifdef PERL_MAD
if (PL_madskills) {
- if (thisstuff)
- sv_catpvn(thisstuff, d + 1, s - d);
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, d + 1, s - d);
else
- thisstuff = newSVpvn(d + 1, s - d);
+ PL_thisstuff = newSVpvn(d + 1, s - d);
stuffstart = s - SvPVX(PL_linestr);
}
#endif
#ifdef PERL_MAD
if (PL_madskills) {
tstart = SvPVX(PL_linestr) + stuffstart;
- if (thisstuff)
- sv_catpvn(thisstuff, tstart, PL_bufend - tstart);
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
else
- thisstuff = newSVpvn(tstart, PL_bufend - tstart);
+ PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
}
#endif
if (!outer ||
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
PL_bufend[-1] = '\n';
#endif
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_sv(PL_linestr);
if (*s == term && memEQ(s,PL_tokenbuf,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
*(SvPVX(PL_linestr) + off ) = ' ';
or if it didn't end, or if we see a newline
*/
- if (len >= sizeof PL_tokenbuf)
+ if (len >= (I32)sizeof PL_tokenbuf)
Perl_croak(aTHX_ "Excessively long <> operator");
if (s >= end)
Perl_croak(aTHX_ "Unterminated <> operator");
filehandle
*/
if (*d == '$') {
- I32 tmp;
-
/* try to find it in the pad for this block, otherwise find
add symbol table ops
*/
- if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
+ const PADOFFSET tmp = pad_findmy(d);
+ if (tmp != NOT_IN_PAD) {
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
HEK * const stashname = HvNAME_HEK(stash);
{
dVAR;
SV *sv; /* scalar value: string */
- char *tmps; /* temp string, used for delimiter matching */
+ const char *tmps; /* temp string, used for delimiter matching */
register char *s = start; /* current position in the buffer */
register char term; /* terminating character */
register char *to; /* current position in the sv's data */
I32 termcode; /* terminating char. code */
U8 termstr[UTF8_MAXBYTES]; /* terminating string */
STRLEN termlen; /* length of terminating string */
- char *last = NULL; /* last position for nesting bracket */
+ int last_off = 0; /* last position for nesting bracket */
#ifdef PERL_MAD
int stuffstart;
char *tstart;
}
#ifdef PERL_MAD
- if (realtokenstart >= 0) {
- stuffstart = realtokenstart;
- realtokenstart = -1;
+ if (PL_realtokenstart >= 0) {
+ stuffstart = PL_realtokenstart;
+ PL_realtokenstart = -1;
}
else
stuffstart = start - SvPVX(PL_linestr);
s += termlen;
#ifdef PERL_MAD
tstart = SvPVX(PL_linestr) + stuffstart;
- if (!thisopen && !keep_delims) {
- thisopen = newSVpvn(tstart, s - tstart);
+ if (!PL_thisopen && !keep_delims) {
+ PL_thisopen = newSVpvn(tstart, s - tstart);
stuffstart = s - SvPVX(PL_linestr);
}
#endif
else {
const char *t;
char *w;
- if (!last)
- last = SvPVX(sv);
- for (t = w = last; t < svlast; w++, t++) {
+ for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
/* At here, all closes are "was quoted" one,
so we don't check PL_multi_close. */
if (*t == '\\') {
*w = '\0';
SvCUR_set(sv, w - SvPVX_const(sv));
}
- last = w;
+ last_off = w - SvPVX(sv);
if (--brackets <= 0)
cont = FALSE;
}
*/
#ifdef PERL_MAD
if (PL_madskills) {
- char *tstart = SvPVX(PL_linestr) + stuffstart;
- if (thisstuff)
- sv_catpvn(thisstuff, tstart, PL_bufend - tstart);
+ char * const tstart = SvPVX(PL_linestr) + stuffstart;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
else
- thisstuff = newSVpvn(tstart, PL_bufend - tstart);
+ PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
}
#endif
if (!PL_rsfp ||
CopLINE_inc(PL_curcop);
/* update debugger info */
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const line_sv = newSV(0);
-
- sv_upgrade(line_sv, SVt_PVMG);
- sv_setsv(line_sv,PL_linestr);
- (void)SvIOK_on(line_sv);
- SvIV_set(line_sv, 0);
- av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info_sv(PL_linestr);
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
if (!PL_encoding || UTF) {
#ifdef PERL_MAD
if (PL_madskills) {
- char *tstart = SvPVX(PL_linestr) + stuffstart;
- if (thisstuff)
- sv_catpvn(thisstuff, tstart, s - tstart);
+ char * const tstart = SvPVX(PL_linestr) + stuffstart;
+ const int len = s - tstart;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, len);
else
- thisstuff = newSVpvn(tstart, s - tstart);
- if (!thisclose && !keep_delims)
- thisclose = newSVpvn(s,termlen);
+ PL_thisstuff = newSVpvn(tstart, len);
+ if (!PL_thisclose && !keep_delims)
+ PL_thisclose = newSVpvn(s,termlen);
}
#endif
#ifdef PERL_MAD
else {
if (PL_madskills) {
- char *tstart = SvPVX(PL_linestr) + stuffstart;
- if (thisstuff)
- sv_catpvn(thisstuff, tstart, s - tstart - termlen);
+ char * const tstart = SvPVX(PL_linestr) + stuffstart;
+ const int len = s - tstart - termlen;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, len);
else
- thisstuff = newSVpvn(tstart, s - tstart - termlen);
- if (!thisclose && !keep_delims)
- thisclose = newSVpvn(s - termlen,termlen);
+ PL_thisstuff = newSVpvn(tstart, len);
+ if (!PL_thisclose && !keep_delims)
+ PL_thisclose = newSVpvn(s - termlen,termlen);
}
}
#endif
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
(PL_hints & HINT_NEW_INTEGER) )
- sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
+ sv = new_constant(PL_tokenbuf,
+ d - PL_tokenbuf,
+ (const char *)
(floatit ? "float" : "integer"),
sv, NULL, NULL);
break;
SV* savewhite;
if (PL_madskills) {
- savewhite = thiswhite;
- thiswhite = 0;
+ 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;
if (PL_rsfp) {
#ifdef PERL_MAD
if (PL_madskills) {
- if (thistoken)
- sv_catpvn(thistoken, tokenstart, PL_bufend - tokenstart);
+ if (PL_thistoken)
+ sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
else
- thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
+ PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
}
#endif
s = filter_gets(PL_linestr, PL_rsfp, 0);
PL_expect = XTERM;
if (needargs) {
PL_lex_state = LEX_NORMAL;
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next(',');
}
else if (PL_encoding)
sv_recode_to_utf8(stuff, PL_encoding);
}
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
force_next(THING);
- start_force(curforce);
+ start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
force_next(LSTOP);
}
}
#ifdef PERL_MAD
if (PL_madskills) {
- if (thistoken)
- sv_catpvn(thistoken, tokenstart, s - tokenstart);
+ if (PL_thistoken)
+ sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
else
- thistoken = newSVpvn(tokenstart, s - tokenstart);
- thiswhite = savewhite;
+ PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
+ PL_thiswhite = savewhite;
}
#endif
return s;
const char *context = NULL;
int contlen = -1;
SV *msg;
+ int yychar = PL_parser->yychar;
if (!yychar || (yychar == ';' && !PL_rsfp))
where = "at EOF";
PL_multi_end = 0;
}
if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, (void*)msg);
else
qerror(msg);
if (PL_error_count >= 10) {
if (PL_in_eval && SvCUR(ERRSV))
Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
- ERRSV, OutCopFILE(PL_curcop));
+ (void*)ERRSV, OutCopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
OutCopFILE(PL_curcop));
goto utf16be;
}
}
+#ifdef EBCDIC
+ case 0xDD:
+ if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
+ if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
+ s += 4; /* UTF-8 */
+ }
+ break;
+#endif
+
default:
if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
/* Leading bytes
const I32 count = FILTER_READ(idx+1, sv, maxlen);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"utf16_textfilter(%p): %d %d (%d)\n",
- utf16_textfilter, idx, maxlen, (int) count));
+ FPTR2DPTR(void *, utf16_textfilter),
+ idx, maxlen, (int) count));
if (count) {
U8* tmps;
I32 newlen;
const I32 count = FILTER_READ(idx+1, sv, maxlen);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"utf16rev_textfilter(%p): %d %d (%d)\n",
- utf16rev_textfilter, idx, maxlen, (int) count));
+ FPTR2DPTR(void *, utf16rev_textfilter),
+ idx, maxlen, (int) count));
if (count) {
U8* tmps;
I32 newlen;
if (!isALPHA(*pos)) {
U8 tmpbuf[UTF8_MAXBYTES+1];
- if (*s == 'v') s++; /* get past 'v' */
+ if (*s == 'v')
+ s++; /* get past 'v' */
sv_setpvn(sv, "", 0);
for (;;) {
+ /* this is atoi() that tolerates underscores */
U8 *tmpend;
UV rev = 0;
- {
- /* this is atoi() that tolerates underscores */
- const char *end = pos;
- UV mult = 1;
- while (--end >= s) {
- UV orev;
- if (*end == '_')
- continue;
- orev = rev;
+ const char *end = pos;
+ UV mult = 1;
+ while (--end >= s) {
+ if (*end != '_') {
+ const UV orev = rev;
rev += (*end - '0') * mult;
mult *= 10;
if (orev > rev && ckWARN_d(WARN_OVERFLOW))
projects / p5sagit/p5-mst-13.2.git / blobdiff