#define XFAKEBRACK 128
#define XENUMMASK 127
-/*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
-#define UTF (PL_hints & HINT_UTF8)
+#ifdef EBCDIC
+/* For now 'use utf8' does not affect tokenizer on EBCDIC */
+#define UTF (PL_linestr && DO_UTF8(PL_linestr))
+#else
+#define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
+#endif
/* In variables name $^X, these are the legal values for X.
* 1999-02-27 mjd-perl-patch@plover.com */
* Also see LOP and lop() below.
*/
+/* Note that REPORT() and REPORT2() will be expressions that supply
+ * their own trailing comma, not suitable for statements as such. */
#ifdef DEBUGGING /* Serve -DT. */
-# define REPORT(x,retval) tokereport(x,s,(int)retval)
-# define REPORT2(x,retval) tokereport(x,s, yylval.ival)
+# define REPORT(x,retval) tokereport(x,s,(int)retval),
+# define REPORT2(x,retval) tokereport(x,s, yylval.ival),
#else
-# define REPORT(x,retval) 1
-# define REPORT2(x,retval) 1
+# define REPORT(x,retval)
+# define REPORT2(x,retval)
#endif
-#define TOKEN(retval) return (REPORT2("token",retval), PL_bufptr = s,(int)retval)
-#define OPERATOR(retval) return (REPORT2("operator",retval), PL_expect = XTERM, PL_bufptr = s,(int)retval)
-#define AOPERATOR(retval) return ao((REPORT2("aop",retval), PL_expect = XTERM, PL_bufptr = s,(int)retval))
-#define PREBLOCK(retval) return (REPORT2("preblock",retval), PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
-#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval), PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
-#define PREREF(retval) return (REPORT2("preref",retval), PL_expect = XREF,PL_bufptr = s,(int)retval)
-#define TERM(retval) return (CLINE, REPORT2("term",retval), PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
-#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f), PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
-#define FTST(f) return(yylval.ival=f, REPORT("ftst",f), PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
-#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f), PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
-#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f), PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
-#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f), PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
-#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f), PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
-#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f), PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
-#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f), PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
-#define PMop(f) return(yylval.ival=f, REPORT("matchop",f), PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
-#define Aop(f) return ao((yylval.ival=f, REPORT("add",f), PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
-#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f), PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
-#define Eop(f) return(yylval.ival=f, REPORT("eq",f), PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
-#define Rop(f) return(yylval.ival=f, REPORT("rel",f), PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
+#define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
+#define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
+#define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
+#define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
+#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
+#define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
+#define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
+#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
+#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
+#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
+#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
+#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
+#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
+#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
+#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
+#define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
+#define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
+#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
+#define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
+#define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
/* This bit of chicanery makes a unary function followed by
* a parenthesis into a function with one argument, highest precedence.
*/
#define UNI(f) return(yylval.ival = f, \
- REPORT("uni",f), \
+ REPORT("uni",f) \
PL_expect = XTERM, \
PL_bufptr = s, \
PL_last_uni = PL_oldbufptr, \
(*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
#define UNIBRACK(f) return(yylval.ival = f, \
- REPORT("uni",f), \
+ REPORT("uni",f) \
PL_bufptr = s, \
PL_last_uni = PL_oldbufptr, \
(*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
+#ifdef DEBUGGING
+
STATIC void
S_tokereport(pTHX_ char *thing, char* s, I32 rv)
-{
- SV *report;
+{
DEBUG_T({
- report = newSVpv(thing, 0);
- Perl_sv_catpvf(aTHX_ report, ":line %i:%i:", CopLINE(PL_curcop), rv);
+ SV* report = newSVpv(thing, 0);
+ Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
+ (IV)rv);
if (s - PL_bufptr > 0)
sv_catpvn(report, PL_bufptr, s - PL_bufptr);
sv_catpv(report, PL_tokenbuf);
}
PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
- })
+ });
}
+#endif
+
/*
* S_ao
*
SAVEPPTR(PL_bufend);
SAVEPPTR(PL_oldbufptr);
SAVEPPTR(PL_oldoldbufptr);
+ SAVEPPTR(PL_last_lop);
+ SAVEPPTR(PL_last_uni);
SAVEPPTR(PL_linestart);
SAVESPTR(PL_linestr);
SAVEPPTR(PL_lex_brackstack);
SvTEMP_off(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend = PL_bufptr + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
SvREFCNT_dec(PL_rs);
PL_rs = newSVpvn("\n", 1);
PL_rsfp = 0;
for (;;) {
STRLEN prevlen;
SSize_t oldprevlen, oldoldprevlen;
- SSize_t oldloplen, oldunilen;
+ SSize_t oldloplen = 0, oldunilen = 0;
while (s < PL_bufend && isSPACE(*s)) {
if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
incline(s);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
= SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
/* Close the filehandle. Could be from -P preprocessor,
* STDIN, or a regular file. If we were reading code from
{
yylval.ival = f;
CLINE;
- REPORT("lop", f);
+ REPORT("lop", f)
PL_expect = x;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
STRLEN skip;
UV n;
if (utf)
- n = utf8_to_uv((U8*)start, len, &skip, 0);
+ n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
else {
n = *(U8*)start;
skip = 1;
if (s == send)
goto finish;
d = s;
- if ( PL_hints & HINT_NEW_STRING )
+ if ( PL_hints & HINT_NEW_STRING ) {
pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
+ if (SvUTF8(sv))
+ SvUTF8_on(pv);
+ }
while (s < send) {
if (*s == '\\') {
if (s + 1 < send && (s[1] == '\\'))
SAVEI32(PL_lex_inwhat);
SAVECOPLINE(PL_curcop);
SAVEPPTR(PL_bufptr);
+ SAVEPPTR(PL_bufend);
SAVEPPTR(PL_oldbufptr);
SAVEPPTR(PL_oldoldbufptr);
+ SAVEPPTR(PL_last_lop);
+ SAVEPPTR(PL_last_uni);
SAVEPPTR(PL_linestart);
SAVESPTR(PL_linestr);
SAVEPPTR(PL_lex_brackstack);
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
= SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
PL_lex_inpat = 0;
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
PL_lex_brackets = 0;
register char *d = SvPVX(sv); /* destination for copies */
bool dorange = FALSE; /* are we in a translit range? */
bool didrange = FALSE; /* did we just finish a range? */
- bool has_utf8 = (PL_linestr && SvUTF8(PL_linestr));
- /* the constant is UTF8 */
+ I32 has_utf8 = FALSE; /* Output constant is UTF8 */
+ I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
UV uv;
- I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
- ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
- : UTF;
- I32 this_utf8 = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
- ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
- OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
- : UTF;
const char *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);
+ this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
+ }
+
+
while (s < send || dorange) {
/* get transliterations out of the way (they're most literal) */
if (PL_lex_inwhat == OP_TRANS) {
I32 min; /* first character in range */
I32 max; /* last character in range */
+ if (has_utf8) {
+ char *c = (char*)utf8_hop((U8*)d, -1);
+ char *e = d++;
+ while (e-- > c)
+ *(e + 1) = *e;
+ *c = UTF_TO_NATIVE(0xff);
+ /* mark the range as done, and continue */
+ dorange = FALSE;
+ didrange = TRUE;
+ continue;
+ }
+
i = d - SvPVX(sv); /* remember current offset */
SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
d = SvPVX(sv) + i; /* refresh d after realloc */
(char)min, (char)max);
}
-#ifndef ASCIIish
+#ifdef EBCDIC
if ((isLOWER(min) && isLOWER(max)) ||
(isUPPER(min) && isUPPER(max))) {
if (isLOWER(min)) {
for (i = min; i <= max; i++)
if (isLOWER(i))
- *d++ = i;
+ *d++ = NATIVE_TO_NEED(has_utf8,i);
} else {
for (i = min; i <= max; i++)
if (isUPPER(i))
- *d++ = i;
+ *d++ = NATIVE_TO_NEED(has_utf8,i);
}
}
else
if (didrange) {
Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
}
- if (utf) {
- *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
+ if (has_utf8) {
+ *d++ = UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
s++;
continue;
}
else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
if (s[2] == '#') {
while (s < send && *s != ')')
- *d++ = *s++;
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
else if (s[2] == '{' /* This should match regcomp.c */
|| ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
yyerror("Sequence (?{...}) not terminated or not {}-balanced");
}
while (s < regparse)
- *d++ = *s++;
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
}
else if (*s == '#' && PL_lex_inpat &&
((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
while (s+1 < send && *s != '\n')
- *d++ = *s++;
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
/* check for embedded arrays
break; /* in regexp, $ might be tail anchor */
}
+ /* End of else if chain - OP_TRANS rejoin rest */
+
/* backslashes */
if (*s == '\\' && s+1 < send) {
s++;
/* some backslashes we leave behind */
if (*leaveit && *s && strchr(leaveit, *s)) {
- *d++ = '\\';
- *d++ = *s++;
+ *d++ = NATIVE_TO_NEED(has_utf8,'\\');
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
continue;
}
++s;
if (*s == '{') {
char* e = strchr(s, '}');
+ STRLEN len = 1; /* allow underscores */
+
if (!e) {
yyerror("Missing right brace on \\x{}");
- e = s;
- }
- else {
- STRLEN len = 1; /* allow underscores */
- uv = (UV)scan_hex(s + 1, e - s - 1, &len);
+ ++s;
+ continue;
}
+ uv = (UV)scan_hex(s + 1, e - s - 1, &len);
s = e + 1;
}
else {
NUM_ESCAPE_INSERT:
/* Insert oct or hex escaped character.
* There will always enough room in sv since such
- * escapes will be longer than any UT-F8 sequence
+ * escapes will be longer than any UTF-8 sequence
* they can end up as. */
-
- /* This spot is wrong for EBCDIC. Characters like
- * the lowercase letters and digits are >127 in EBCDIC,
- * so here they would need to be mapped to the Unicode
- * repertoire. --jhi */
- if (uv > 127) {
+ /* We need to map to chars to ASCII before doing the tests
+ to cover EBCDIC
+ */
+ if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
if (!has_utf8 && uv > 255) {
/* Might need to recode whatever we have
* accumulated so far if it contains any
* (Can't we keep track of that and avoid
* this rescan? --jhi)
*/
- int hicount = 0;
- char *c;
-
- for (c = SvPVX(sv); c < d; c++) {
- if (UTF8_IS_CONTINUED(*c))
+ int hicount = 0;
+ U8 *c;
+ for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
+ if (!NATIVE_IS_INVARIANT(*c)) {
hicount++;
+ }
}
if (hicount) {
- char *old_pvx = SvPVX(sv);
- char *src, *dst;
-
- d = SvGROW(sv,
- SvCUR(sv) + hicount + 1) +
- (d - old_pvx);
-
- src = d - 1;
- d += hicount;
- dst = d - 1;
-
- while (src < dst) {
- if (UTF8_IS_CONTINUED(*src)) {
- *dst-- = UTF8_EIGHT_BIT_LO(*src);
- *dst-- = UTF8_EIGHT_BIT_HI(*src--);
+ STRLEN offset = d - SvPVX(sv);
+ U8 *src, *dst;
+ d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
+ src = (U8 *)d - 1;
+ dst = src+hicount;
+ d += hicount;
+ while (src >= (U8 *)SvPVX(sv)) {
+ if (!NATIVE_IS_INVARIANT(*src)) {
+ U8 ch = NATIVE_TO_ASCII(*src);
+ *dst-- = UTF8_EIGHT_BIT_LO(ch);
+ *dst-- = UTF8_EIGHT_BIT_HI(ch);
}
else {
- *dst-- = *src--;
+ *dst-- = *src;
}
+ src--;
}
}
}
if (has_utf8 || uv > 255) {
- d = (char*)uv_to_utf8((U8*)d, uv);
+ d = (char*)uvchr_to_utf8((U8*)d, uv);
has_utf8 = TRUE;
if (PL_lex_inwhat == OP_TRANS &&
PL_sublex_info.sub_op) {
PL_sublex_info.sub_op->op_private |=
(PL_lex_repl ? OPpTRANS_FROM_UTF
: OPpTRANS_TO_UTF);
- utf = TRUE;
}
}
else {
}
}
else {
- *d++ = (char)uv;
+ *d++ = (char) uv;
}
continue;
if (len > e - s + 4) {
char *odest = SvPVX(sv);
- SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
+ SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
d = SvPVX(sv) + (d - odest);
}
Copy(str, d, len, char);
/* \c is a control character */
case 'c':
s++;
-#ifdef EBCDIC
- *d = *s++;
- if (isLOWER(*d))
- *d = toUPPER(*d);
- *d = toCTRL(*d);
- d++;
-#else
{
U8 c = *s++;
- *d++ = toCTRL(c);
- }
+#ifdef EBCDIC
+ if (isLOWER(c))
+ c = toUPPER(c);
#endif
+ *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
+ }
continue;
/* printf-style backslashes, formfeeds, newlines, etc */
case 'b':
- *d++ = '\b';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\b');
break;
case 'n':
- *d++ = '\n';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\n');
break;
case 'r':
- *d++ = '\r';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\r');
break;
case 'f':
- *d++ = '\f';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\f');
break;
case 't':
- *d++ = '\t';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\t');
break;
-#ifdef EBCDIC
- case 'e':
- *d++ = '\047'; /* CP 1047 */
- break;
- case 'a':
- *d++ = '\057'; /* CP 1047 */
- break;
-#else
case 'e':
- *d++ = '\033';
+ *d++ = ASCII_TO_NEED(has_utf8,'\033');
break;
case 'a':
- *d++ = '\007';
+ *d++ = ASCII_TO_NEED(has_utf8,'\007');
break;
-#endif
} /* end switch */
s++;
} /* end if (backslash) */
default_action:
- if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) {
- STRLEN len = (STRLEN) -1;
- UV uv;
- if (this_utf8) {
- uv = utf8_to_uv((U8*)s, send - s, &len, 0);
- }
- if (len == (STRLEN)-1) {
- /* Illegal UTF8 (a high-bit byte), make it valid. */
- char *old_pvx = SvPVX(sv);
- /* need space for one extra char (NOTE: SvCUR() not set here) */
- d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
- d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
- }
- else {
- while (len--)
- *d++ = *s++;
- }
- has_utf8 = TRUE;
- if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
- PL_sublex_info.sub_op->op_private |=
- (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
- utf = TRUE;
- }
- continue;
- }
-
- *d++ = *s++;
+ /* If we started with encoded form, or already know we want it
+ and then encode the next character */
+ if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
+ STRLEN len = 1;
+ UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
+ STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
+ s += len;
+ if (need > len) {
+ /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
+ STRLEN off = d - SvPVX(sv);
+ d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
+ }
+ d = (char*)uvchr_to_utf8((U8*)d, uv);
+ has_utf8 = TRUE;
+ }
+ else {
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
+ }
} /* while loop to process each character */
/* terminate the string and set up the sv */
*d = '\0';
SvCUR_set(sv, d - SvPVX(sv));
+ if (SvCUR(sv) >= SvLEN(sv))
+ Perl_croak(aTHX_ "panic: constant overflowed allocated space");
+
SvPOK_on(sv);
- if (has_utf8)
+ if (has_utf8) {
SvUTF8_on(sv);
+ if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
+ PL_sublex_info.sub_op->op_private |=
+ (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
+ }
+ }
/* shrink the sv if we allocated more than we used */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
PL_pending_ident = 0;
DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Tokener saw identifier '%s'\n", PL_tokenbuf); })
+ "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
/* if we're in a my(), we can't allow dynamics here.
$foo'bar has already been turned into $foo::bar, so
}
DEBUG_T({ PerlIO_printf(Perl_debug_log,
"### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
- (IV)PL_nexttype[PL_nexttoke]); })
+ (IV)PL_nexttype[PL_nexttoke]); });
return(PL_nexttype[PL_nexttoke]);
}
else {
DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Saw case modifier at '%s'\n", PL_bufptr); })
+ "### Saw case modifier at '%s'\n", PL_bufptr); });
s = PL_bufptr + 1;
if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
if (PL_bufptr == PL_bufend)
return sublex_done();
DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Interpolated variable at '%s'\n", PL_bufptr); })
+ "### Interpolated variable at '%s'\n", PL_bufptr); });
PL_expect = XTERM;
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
DEBUG_T( {
PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
exp_name[PL_expect], s);
- } )
+ } );
retry:
switch (*s) {
yyerror("Missing right curly or square bracket");
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Tokener got EOF\n");
- } )
+ } );
TOKEN(0);
}
if (s++ < PL_bufend)
sv_catpv(PL_linestr, "\n");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
if (PERLDB_LINE && PL_curstash != PL_debstash) {
SV *sv = NEWSV(85,0);
sv_catpv(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 = Nullch;
PL_minus_n = PL_minus_p = 0;
goto retry;
}
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
sv_setpv(PL_linestr,"");
TOKEN(';'); /* not infinite loop because rsfp is NULL now */
}
sv_setpv(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 = Nullch;
PL_doextract = FALSE;
}
}
av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
}
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
if (CopLINE(PL_curcop) == 1) {
while (s < PL_bufend && isSPACE(*s))
s++;
sv_setpv(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 = Nullch;
PL_preambled = FALSE;
if (PERLDB_LINE)
(void)gv_fetchfile(PL_origfilename);
s++;
if (s < d)
s++;
+ else if (s > d) /* Found by Ilya: feed random input to Perl. */
+ Perl_croak(aTHX_ "panic: input overflow");
incline(s);
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
PL_bufptr = s;
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw unary minus before =>, forcing word '%s'\n", s);
- } )
+ } );
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
PL_last_lop_op = ftst;
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw file test %c\n", (int)ftst);
- } )
+ } );
FTST(ftst);
}
else {
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### %c looked like a file test but was not\n",
(int)ftst);
- } )
+ } );
s -= 2;
}
}
else
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
s = skipspace(s);
- if (*s == '}')
+ if (*s == '}') {
+ if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
+ PL_expect = XTERM;
+ /* This hack is to get the ${} in the message. */
+ PL_bufptr = s+1;
+ yyerror("syntax error");
+ break;
+ }
OPERATOR(HASHBRACK);
+ }
/* This hack serves to disambiguate a pair of curlies
* as being a block or an anon hash. Normally, expectation
* determines that, but in cases where we're not in a
s = scan_num(s, &yylval);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw number in '%s'\n", s);
- } )
+ } );
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
case '\'':
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw string in '%s'\n", s);
- } )
+ "### Saw string before '%s'\n", s);
+ } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
case '"':
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw string in '%s'\n", s);
- } )
+ "### Saw string before '%s'\n", s);
+ } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
missingterm((char*)0);
yylval.ival = OP_CONST;
for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
- if (*d == '$' || *d == '@' || *d == '\\' || UTF8_IS_CONTINUED(*d)) {
+ if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
yylval.ival = OP_STRINGIFY;
break;
}
case '`':
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw backtick string in '%s'\n", s);
- } )
+ "### Saw backtick string before '%s'\n", s);
+ } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
TERM(THING);
}
/* avoid v123abc() or $h{v1}, allow C<print v10;> */
- else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
+ else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
char c = *start;
GV *gv;
*start = '\0';
CLINE;
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
yylval.opval->op_private = OPpCONST_BARE;
- if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
+ if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
TERM(WORD);
}
if (*s == '=' && s[1] == '>') {
CLINE;
sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
- if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
+ if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
TERM(WORD);
}
(void)PerlIO_seek(PL_rsfp, 0L, 0);
}
if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
+#ifdef PERLIO_IS_STDIO /* really? */
+# if defined(__BORLANDC__)
+ /* XXX see note in do_binmode() */
+ ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
+# endif
+#endif
if (loc > 0)
PerlIO_seek(PL_rsfp, loc, 0);
}
}
#endif
#ifdef PERLIO_LAYERS
- if (UTF && !IN_BYTE)
+ if (UTF && !IN_BYTES)
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
#endif
PL_rsfp = Nullfp;
TOKEN('(');
case KEY_qq:
- case KEY_qu:
s = scan_str(s,FALSE,FALSE);
- if (tmp == KEY_qu &&
- is_utf8_string((U8*)SvPVX(PL_lex_stuff), SvCUR(PL_lex_stuff)))
- SvUTF8_on(PL_lex_stuff);
if (!s)
missingterm((char*)0);
yylval.ival = OP_STRINGIFY;
really_sub:
{
char tmpbuf[sizeof PL_tokenbuf];
- SSize_t tboffset;
+ SSize_t tboffset = 0;
expectation attrful;
bool have_name, have_proto;
int key = tmp;
if (strEQ(d,"q")) return KEY_q;
if (strEQ(d,"qr")) return KEY_qr;
if (strEQ(d,"qq")) return KEY_qq;
- if (strEQ(d,"qu")) return KEY_qu;
if (strEQ(d,"qw")) return KEY_qw;
if (strEQ(d,"qx")) return KEY_qx;
}
if (strEQ(d,"rindex")) return -KEY_rindex;
break;
case 7:
- if (strEQ(d,"require")) return -KEY_require;
+ if (strEQ(d,"require")) return KEY_require;
if (strEQ(d,"reverse")) return -KEY_reverse;
if (strEQ(d,"readdir")) return -KEY_readdir;
break;
Perl_croak(aTHX_ "Transliteration replacement not terminated");
}
- New(803,tbl,256,short);
- o = newPVOP(OP_TRANS, 0, (char*)tbl);
-
complement = del = squash = 0;
while (strchr("cds", *s)) {
if (*s == 'c')
squash = OPpTRANS_SQUASH;
s++;
}
+
+ New(803, tbl, complement&&!del?258:256, short);
+ o = newPVOP(OP_TRANS, 0, (char*)tbl);
o->op_private = del|squash|complement|
(DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
(DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
sv_setsv(PL_linestr,herewas);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
}
else
sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
}
CopLINE_inc(PL_curcop);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
#ifndef PERL_STRICT_CR
if (PL_bufend - PL_linestart >= 2) {
if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
}
SvREFCNT_dec(herewas);
- if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
+ if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
SvUTF8_on(tmpstr);
PL_lex_stuff = tmpstr;
yylval.ival = op_type;
/* after skipping whitespace, the next character is the terminator */
term = *s;
- if (UTF8_IS_CONTINUED(term) && UTF)
+ if (!UTF8_IS_INVARIANT((U8)term) && UTF)
has_utf8 = TRUE;
/* mark where we are */
have found the terminator */
else if (*s == term)
break;
- else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF)
+ else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
has_utf8 = TRUE;
*to = *s;
}
break;
else if (*s == PL_multi_open)
brackets++;
- else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF)
+ else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
has_utf8 = TRUE;
*to = *s;
}
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
}
/* at this point, we have successfully read the delimited string */
Read a number in any of the formats that Perl accepts:
- 0(x[0-7A-F]+)|([0-7]+)|(b[01])
- [\d_]+(\.[\d_]*)?[Ee](\d+)
-
- Underbars (_) are allowed in decimal numbers. If -w is on,
- underbars before a decimal point must be at three digit intervals.
+ \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
+ \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
+ 0b[01](_?[01])*
+ 0[0-7](_?[0-7])*
+ 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
thing it reads.
else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
goto decimal;
/* so it must be octal */
- else
+ else {
shift = 3;
+ s++;
+ }
+
+ if (*s == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
+ }
base = bases[shift];
Base = Bases[shift];
default:
goto out;
- /* _ are ignored */
+ /* _ are ignored -- but warned about if consecutive */
case '_':
- s++;
+ if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
break;
/* 8 and 9 are not octal */
the number.
*/
out:
+
+ /* final misplaced underbar check */
+ if (s[-1] == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
+ }
+
sv = NEWSV(92,0);
if (overflowed) {
if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
if -w is on
*/
if (*s == '_') {
- if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
- Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
- lastub = ++s;
+ if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
}
else {
/* check for end of fixed-length buffer */
}
/* final misplaced underbar check */
- if (lastub && s - lastub != 3) {
+ if (lastub && s == lastub + 1) {
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
}
floatit = TRUE;
*d++ = *s++;
- /* copy, ignoring underbars, until we run out of
- digits. Note: no misplaced underbar checks!
+ if (*s == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s;
+ }
+
+ /* copy, ignoring underbars, until we run out of digits.
*/
for (; isDIGIT(*s) || *s == '_'; s++) {
/* fixed length buffer check */
if (d >= e)
Perl_croak(aTHX_ number_too_long);
- if (*s != '_')
+ if (*s == '_') {
+ if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s;
+ }
+ else
*d++ = *s;
}
+ /* fractional part ending in underbar? */
+ if (s[-1] == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ }
if (*s == '.' && isDIGIT(s[1])) {
/* oops, it's really a v-string, but without the "v" */
s = start - 1;
}
/* read exponent part, if present */
- if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
+ if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
floatit = TRUE;
s++;
/* regardless of whether user said 3E5 or 3e5, use lower 'e' */
*d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
+ /* stray preinitial _ */
+ if (*s == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
+ }
+
/* allow positive or negative exponent */
if (*s == '+' || *s == '-')
*d++ = *s++;
- /* read digits of exponent (no underbars :-) */
- while (isDIGIT(*s)) {
- if (d >= e)
- Perl_croak(aTHX_ number_too_long);
- *d++ = *s++;
+ /* stray initial _ */
+ if (*s == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
+ }
+
+ /* read digits of exponent */
+ while (isDIGIT(*s) || *s == '_') {
+ if (isDIGIT(*s)) {
+ if (d >= e)
+ Perl_croak(aTHX_ number_too_long);
+ *d++ = *s++;
+ }
+ else {
+ if (ckWARN(WARN_SYNTAX) &&
+ ((lastub && s == lastub + 1) ||
+ (!isDIGIT(s[1]) && s[1] != '_')))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
+ }
}
}
*/
if (!floatit) {
- IV iv;
- UV uv;
+ IV iv = 0;
+ UV uv = 0;
errno = 0;
if (*PL_tokenbuf == '-')
iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
while (isDIGIT(*pos) || *pos == '_')
pos++;
if (!isALPHA(*pos)) {
- UV rev, revmax = 0;
+ UV rev;
U8 tmpbuf[UTF8_MAXLEN+1];
U8 *tmpend;
s++; /* get past 'v' */
"Integer overflow in decimal number");
}
}
- tmpend = uv_to_utf8(tmpbuf, rev);
- if (rev > revmax)
- revmax = rev;
+ /* Append native character for the rev point */
+ tmpend = uvchr_to_utf8(tmpbuf, rev);
sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
+ if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
+ SvUTF8_on(sv);
if (*pos == '.' && isDIGIT(pos[1]))
s = ++pos;
else {
while (isDIGIT(*pos) || *pos == '_')
pos++;
}
-
SvPOK_on(sv);
SvREADONLY_on(sv);
- if (revmax > 127) {
- SvUTF8_on(sv);
- if (revmax < 256)
- sv_utf8_downgrade(sv, TRUE);
- }
}
}
break;
s = filter_gets(PL_linestr, PL_rsfp, 0);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend = PL_bufptr + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
if (!s) {
s = PL_bufptr;
yyerror("Format not terminated");
projects / p5sagit/p5-mst-13.2.git / blobdiff