* Also see LOP and lop() below.
*/
-#define TOKEN(retval) return (PL_bufptr = s,(int)retval)
-#define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
-#define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
-#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
-#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
-#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
-#define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
-#define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
-#define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
-#define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
-#define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
-#define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
-#define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
-#define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
-#define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
-#define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
-#define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
-#define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
-#define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
-#define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
+#ifdef DEBUGGING /* Serve -DT. */
+# 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
+#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)
/* 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), \
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), \
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)
+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);
+
+ if (s - PL_bufptr > 0)
+ sv_catpvn(report, PL_bufptr, s - PL_bufptr);
+ else {
+ if (PL_oldbufptr && *PL_oldbufptr)
+ sv_catpv(report, PL_tokenbuf);
+ }
+ PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
+ })
+}
+
/*
* S_ao
*
{
yylval.ival = f;
CLINE;
+ REPORT("lop", f);
PL_expect = x;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
S_sublex_done(pTHX)
{
if (!PL_lex_starts++) {
+ SV *sv = newSVpvn("",0);
+ if (SvUTF8(PL_linestr))
+ SvUTF8_on(sv);
PL_expect = XOPERATOR;
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
return THING;
}
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 = FALSE; /* embedded \x{} */
+ bool has_utf8 = (PL_linestr && SvUTF8(PL_linestr));
+ /* the constant is UTF8 */
UV uv;
I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
/* backslashes */
if (*s == '\\' && s+1 < send) {
- bool to_be_utf8 = FALSE;
-
s++;
/* some backslashes we leave behind */
"Unrecognized escape \\%c passed through",
*s);
/* default action is to copy the quoted character */
- *d++ = *s++;
- continue;
+ goto default_action;
}
/* \132 indicates an octal constant */
else {
STRLEN len = 1; /* allow underscores */
uv = (UV)scan_hex(s + 1, e - s - 1, &len);
- to_be_utf8 = TRUE;
}
s = e + 1;
}
NUM_ESCAPE_INSERT:
/* Insert oct or hex escaped character.
- * There will always enough room in sv since such escapes will
- * be longer than any utf8 sequence they can end up as
- */
+ * There will always enough room in sv since such
+ * escapes will be longer than any UT-F8 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) {
- if (!has_utf8 && (to_be_utf8 || uv > 255)) {
- /* might need to recode whatever we have accumulated so far
- * if it contains any hibit chars
+ if (!has_utf8 && uv > 255) {
+ /* Might need to recode whatever we have
+ * accumulated so far if it contains any
+ * hibit chars.
+ *
+ * (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))
hicount++;
if (hicount) {
char *old_pvx = SvPVX(sv);
char *src, *dst;
- d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
+
+ d = SvGROW(sv,
+ SvCUR(sv) + hicount + 1) +
+ (d - old_pvx);
src = d - 1;
d += hicount;
while (src < dst) {
if (UTF8_IS_CONTINUED(*src)) {
- dst--;
- uv_to_utf8((U8*)dst, (U8)*src--);
- dst--;
+ *dst-- = UTF8_EIGHT_BIT_LO(*src);
+ *dst-- = UTF8_EIGHT_BIT_HI(*src--);
}
else {
*dst-- = *src--;
}
}
- if (to_be_utf8 || uv > 255) {
+ if (has_utf8 || uv > 255) {
d = (char*)uv_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 {
*d++ = (char)uv;
res = newSVpvn(s + 1, e - s - 1);
res = new_constant( Nullch, 0, "charnames",
res, Nullsv, "\\N{...}" );
+ if (has_utf8)
+ sv_utf8_upgrade(res);
str = SvPV(res,len);
if (!has_utf8 && SvUTF8(res)) {
char *ostart = SvPVX(sv);
continue;
} /* end if (backslash) */
- /* (now in tr/// code again) */
-
+ default_action:
if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) {
STRLEN len = (STRLEN) -1;
UV uv;
*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++;
+ *d++ = *s++;
} /* while loop to process each character */
/* terminate the string and set up the sv */
r = Perl_yylex(aTHX);
- yyactlevel--;
+ if (yyactlevel > 0)
+ yyactlevel--;
return r;
}
STRLEN len;
GV *gv = Nullgv;
GV **gvp = 0;
+ bool bof = FALSE;
/* check if there's an identifier for us to look at */
if (PL_pending_ident) {
goto retry;
}
do {
- bool bof = PL_rsfp ? TRUE : FALSE;
- if (bof) {
+ bof = PL_rsfp ? TRUE : FALSE;
+ if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+ fake_eof:
+ if (PL_rsfp) {
+ if (PL_preprocess && !PL_in_eval)
+ (void)PerlProc_pclose(PL_rsfp);
+ else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
+ PerlIO_clearerr(PL_rsfp);
+ else
+ (void)PerlIO_close(PL_rsfp);
+ PL_rsfp = Nullfp;
+ PL_doextract = FALSE;
+ }
+ if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
+ sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
+ sv_catpv(PL_linestr,";}");
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_minus_n = PL_minus_p = 0;
+ goto retry;
+ }
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ sv_setpv(PL_linestr,"");
+ TOKEN(';'); /* not infinite loop because rsfp is NULL now */
+ }
+ /* if it looks like the start of a BOM, check if it in fact is */
+ else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
#ifdef PERLIO_IS_STDIO
# ifdef __GNU_LIBRARY__
# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
* Workaround? Maybe attach some extra state to PL_rsfp?
*/
if (!PL_preprocess)
- bof = PerlIO_tell(PL_rsfp) == 0;
+ bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
#else
- bof = PerlIO_tell(PL_rsfp) == 0;
+ bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
#endif
- }
- s = filter_gets(PL_linestr, PL_rsfp, 0);
- if (s == Nullch) {
- fake_eof:
- if (PL_rsfp) {
- if (PL_preprocess && !PL_in_eval)
- (void)PerlProc_pclose(PL_rsfp);
- else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
- PerlIO_clearerr(PL_rsfp);
- else
- (void)PerlIO_close(PL_rsfp);
- PL_rsfp = Nullfp;
- PL_doextract = FALSE;
- }
- if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
- sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
- sv_catpv(PL_linestr,";}");
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ if (bof) {
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_minus_n = PL_minus_p = 0;
- goto retry;
+ s = swallow_bom((U8*)s);
}
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- sv_setpv(PL_linestr,"");
- TOKEN(';'); /* not infinite loop because rsfp is NULL now */
- } else if (bof) {
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- s = swallow_bom((U8*)s);
}
if (PL_doextract) {
if (*s == '#' && s[1] == '!' && instr(s,"perl"))
if (ftst) {
PL_last_lop_op = ftst;
DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw file test %c\n", ftst);
+ "### Saw file test %c\n", (int)ftst);
} )
FTST(ftst);
}
/* Assume it was a minus followed by a one-letter named
* subroutine call (or a -bareword), then. */
DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### %c looked like a file test but was not\n", ftst);
+ "### %c looked like a file test but was not\n",
+ (int)ftst);
} )
s -= 2;
}
PL_lex_stuff = Nullsv;
}
else {
- attrs = append_elem(OP_LIST, attrs,
- newSVOP(OP_CONST, 0,
- newSVpvn(s, len)));
+ if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
+ CvLVALUE_on(PL_compcv);
+ else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
+ CvLOCKED_on(PL_compcv);
+ else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
+ CvMETHOD_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
+ flags. To experiment with that, uncomment the
+ following "else": */
+ /* else */
+ attrs = append_elem(OP_LIST, attrs,
+ newSVOP(OP_CONST, 0,
+ newSVpvn(s, len)));
}
s = skipspace(d);
if (*s == ':' && s[1] != ':')
(void)PerlIO_seek(PL_rsfp, 0L, 0);
}
if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
-#if defined(__BORLANDC__)
- /* XXX see note in do_binmode() */
- ((FILE*)PL_rsfp)->flags |= _F_BIN;
-#endif
if (loc > 0)
PerlIO_seek(PL_rsfp, loc, 0);
}
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;
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;
}
while (isDIGIT(*pos) || *pos == '_')
pos++;
if (!isALPHA(*pos)) {
- UV rev;
+ UV rev, revmax = 0;
U8 tmpbuf[UTF8_MAXLEN+1];
U8 *tmpend;
- bool utf8 = FALSE;
s++; /* get past 'v' */
sv = NEWSV(92,5);
}
}
tmpend = uv_to_utf8(tmpbuf, rev);
- utf8 = utf8 || rev > 127;
+ if (rev > revmax)
+ revmax = rev;
sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
if (*pos == '.' && isDIGIT(pos[1]))
s = ++pos;
SvPOK_on(sv);
SvREADONLY_on(sv);
- if (utf8) {
+ if (revmax > 127) {
SvUTF8_on(sv);
- if (!UTF||IN_BYTE)
+ if (revmax < 256)
sv_utf8_downgrade(sv, TRUE);
}
}
projects / p5sagit/p5-mst-13.2.git / blobdiff