#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";
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);
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);
return s;
if (PL_skipwhite) {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catsv(PL_thiswhite, PL_skipwhite);
sv_free(PL_skipwhite);
PL_skipwhite = 0;
PL_realtokenstart = -1;
if (PL_skipwhite) {
if (!PL_nextwhite)
- PL_nextwhite = newSVpvn("",0);
+ PL_nextwhite = newSVpvs("");
sv_catsv(PL_nextwhite, PL_skipwhite);
sv_free(PL_skipwhite);
PL_skipwhite = 0;
}
if (PL_skipwhite) {
if (!*svp)
- *svp = newSVpvn("",0);
+ *svp = newSVpvs("");
sv_setsv(*svp, PL_skipwhite);
sv_free(PL_skipwhite);
PL_skipwhite = 0;
}
#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.
#ifdef PERL_MAD
if (PL_madskills && curoff != startoff) {
if (!PL_skipwhite)
- PL_skipwhite = newSVpvn("",0);
+ PL_skipwhite = newSVpvs("");
sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
curoff - startoff);
}
/* 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 (!PL_skipwhite)
- PL_skipwhite = newSVpvn("",0);
+ PL_skipwhite = newSVpvs("");
curoff = s - SvPVX(PL_linestr);
if (curoff - startoff)
sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
PL_curforce = where;
if (PL_nextwhite) {
if (PL_madskills)
- curmad('^', newSVpvn("",0));
+ curmad('^', newSVpvs(""));
CURMAD('_', PL_nextwhite);
}
}
(allow_initial_tick && *s == '\'') )
{
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
- if (check_keyword && keyword(PL_tokenbuf, len))
+ if (check_keyword && keyword(PL_tokenbuf, len, 0))
return start;
start_force(PL_curforce);
if (PL_madskills)
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;
if (PL_madskills) {
if (PL_thiswhite) {
if (!PL_endwhite)
- PL_endwhite = newSVpvn("",0);
+ PL_endwhite = newSVpvs("");
sv_catsv(PL_endwhite, PL_thiswhite);
PL_thiswhite = 0;
}
UV uv;
#ifdef EBCDIC
UV literal_endpoint = 0;
+ bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
#endif
- const char * const leaveit = /* set of acceptably-backslashed characters */
- PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \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) {
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)
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';
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
if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
if (!PL_thistoken) {
if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
else {
char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
PL_thistoken = newSVpvn(tstart, s - tstart);
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_lex_state = LEX_INTERPCONCAT;
#ifdef PERL_MAD
if (PL_madskills)
- PL_thistoken = newSVpvn("\\E",2);
+ PL_thistoken = newSVpvs("\\E");
#endif
}
return REPORT(')');
while (PL_bufptr != PL_bufend &&
PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catpvn(PL_thiswhite, PL_bufptr, 2);
PL_bufptr += 2;
}
if (s[1] == '\\' && s[2] == 'E') {
#ifdef PERL_MAD
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catpvn(PL_thiswhite, PL_bufptr, 4);
#endif
PL_bufptr = s + 3;
else
Perl_croak(aTHX_ "panic: yylex");
if (PL_madskills) {
- SV* const tmpsv = newSVpvn("",0);
+ SV* const tmpsv = newSVpvs("");
Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
curmad('_', tmpsv);
}
if (PL_madskills) {
if (PL_thistoken)
sv_free(PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_madskills) {
if (PL_thistoken)
sv_free(PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_madskills) {
if (PL_thistoken)
sv_free(PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
return REPORT(')');
if (PL_madskills) {
if (PL_thistoken)
sv_free(PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
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_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 (PL_madskills)
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;
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) {
Perl_croak(aTHX_ "panic: input overflow");
if (PL_madskills && CopLINE(PL_curcop) >= 1) {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
if (CopLINE(PL_curcop) == 1) {
sv_setpvn(PL_thiswhite, "", 0);
PL_faketokens = 0;
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:
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(':');
#if 0
if (PL_madskills) {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catpvn(PL_thiswhite,"}",1);
}
#endif
force_next('}');
#ifdef PERL_MAD
if (!PL_thistoken)
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
#endif
TOKEN(';');
case '&':
#ifdef PERL_MAD
if (PL_madskills) {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catpvn(PL_thiswhite, PL_linestart,
PL_bufend - PL_linestart);
}
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:
no_op("Backticks",s);
if (!s)
missingterm(NULL);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ readpipe_override();
TERM(sublex_start());
case '\\':
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);
if (!tmp && PL_expect == XSTATE
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') {
s = d + 1;
- yylval.pval = savepv(PL_tokenbuf);
+ yylval.pval = CopLABEL_alloc(PL_tokenbuf);
CLINE;
TOKEN(LABEL);
}
/* 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] == '>') {
if (PL_madskills) {
PL_nextwhite = nextPL_nextwhite;
curmad('X', PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ 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);
}
}
if (PL_madskills) {
PL_nextwhite = nextPL_nextwhite;
curmad('X', PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ 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))
PL_expect = XTERM;
PL_nextwhite = nextPL_nextwhite;
curmad('X', PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
force_next(WORD);
TOKEN(NOAMP);
}
if (PL_realtokenstart >= 0) {
char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
if (!PL_endwhite)
- PL_endwhite = newSVpvn("",0);
+ PL_endwhite = newSVpvs("");
sv_catsv(PL_endwhite, PL_thiswhite);
PL_thiswhite = 0;
sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
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;
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
missingterm(NULL);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ 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
/* 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",
(void*)PL_subname, d);
start_force(0);
if (tmpwhite) {
if (PL_madskills)
- curmad('^', newSVpvn("",0));
+ curmad('^', newSVpvs(""));
CURMAD('_', tmpwhite);
}
force_next(0);
#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
*/
I32
-Perl_keyword (pTHX_ const char *name, I32 len)
+Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
{
dVAR;
switch (len)
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;
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;
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;
if (name[3] == 't' &&
name[4] == 'e')
{ /* state */
- return (FEATURE_IS_ENABLED("state") ? KEY_state : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
}
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;
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++;
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);
while (s < send && SPACE_OR_TAB(*s))
s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
- const char * const 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);
}
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 = '@';
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);
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), '#'))
#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 {
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 ) = ' ';
{
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;
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;
}
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);
#ifdef PERL_MAD
if (PL_madskills) {
char * const tstart = SvPVX(PL_linestr) + stuffstart;
- const int len = s - start;
+ const int len = s - tstart;
if (PL_thisstuff)
sv_catpvn(PL_thisstuff, tstart, len);
else
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;
const char *context = NULL;
int contlen = -1;
SV *msg;
+ int yychar = PL_parser->yychar;
if (!yychar || (yychar == ';' && !PL_rsfp))
where = "at EOF";
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