* "It all comes from here, the stench and the peril." --Frodo
*/
-#define TMP_CRLF_PATCH
-
#include "EXTERN.h"
#include "perl.h"
static char ident_too_long[] = "Identifier too long";
+#define UTF (PL_hints & HINT_UTF8)
+
/* The following are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
*/
if (nl)
*nl = '\0';
}
- else if (PL_multi_close < 32 || PL_multi_close == 127) {
+ else if (
+#ifdef EBCDIC
+ iscntrl(PL_multi_close)
+#else
+ PL_multi_close < 32 || PL_multi_close == 127
+#endif
+ ) {
*tmpbuf = '^';
tmpbuf[1] = toCTRL(PL_multi_close);
s = "\\n";
void
deprecate(char *s)
{
- if (PL_dowarn)
- warn("Use of %s is deprecated", s);
+ dTHR;
+ if (ckWARN(WARN_DEPRECATED))
+ warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
}
STATIC void
}
#endif
+#ifndef PERL_OBJECT
+
+STATIC I32
+utf16_textfilter(int idx, SV *sv, int maxlen)
+{
+ I32 count = FILTER_READ(idx+1, sv, maxlen);
+ if (count) {
+ U8* tmps;
+ U8* tend;
+ New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
+ tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
+ sv_usepvn(sv, (char*)tmps, tend - tmps);
+
+ }
+ return count;
+}
+
+STATIC I32
+utf16rev_textfilter(int idx, SV *sv, int maxlen)
+{
+ I32 count = FILTER_READ(idx+1, sv, maxlen);
+ if (count) {
+ U8* tmps;
+ U8* tend;
+ New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
+ tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
+ sv_usepvn(sv, (char*)tmps, tend - tmps);
+
+ }
+ return count;
+}
+
+#endif
void
lex_start(SV *line)
register char *d = SvPVX(sv); /* destination for copies */
bool dorange = FALSE; /* are we in a translit range? */
I32 len; /* ? */
+ I32 utf = PL_lex_inwhat == OP_TRANS
+ ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
+ : UTF;
+ I32 thisutf = PL_lex_inwhat == OP_TRANS
+ ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
+ : UTF;
/* leaveit is the set of acceptably-backslashed characters */
char *leaveit =
PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
+ ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
: "";
while (s < send || dorange) {
/* range begins (ignore - as first or last char) */
else if (*s == '-' && s+1 < send && s != start) {
+ if (utf) {
+ *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
+ s++;
+ continue;
+ }
dorange = TRUE;
s++;
}
break; /* in regexp, $ might be tail anchor */
}
+ /* (now in tr/// code again) */
+
+ if (*s & 0x80 && thisutf) {
+ dTHR; /* only for ckWARN */
+ if (ckWARN(WARN_UTF8)) {
+ (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
+ if (len) {
+ while (len--)
+ *d++ = *s++;
+ continue;
+ }
+ }
+ }
+
/* backslashes */
if (*s == '\\' && s+1 < send) {
s++;
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
- if (PL_dowarn)
- warn("\\%c better written as $%c", *s, *s);
+ dTHR; /* only for ckWARN */
+ if (ckWARN(WARN_SYNTAX))
+ warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
*--s = '$';
break;
}
/* \x24 indicates a hex constant */
case 'x':
- *d++ = scan_hex(++s, 2, &len);
- s += len;
+ ++s;
+ if (*s == '{') {
+ char* e = strchr(s, '}');
+
+ if (!e)
+ yyerror("Missing right brace on \\x{}");
+ if (!utf) {
+ dTHR;
+ if (ckWARN(WARN_UTF8))
+ warner(WARN_UTF8,
+ "Use of \\x{} without utf8 declaration");
+ }
+ /* note: utf always shorter than hex */
+ d = (char*)uv_to_utf8((U8*)d,
+ scan_hex(s + 1, e - s - 1, &len));
+ s = e + 1;
+
+ }
+ else {
+ UV uv = (UV)scan_hex(s, 2, &len);
+ if (utf && PL_lex_inwhat == OP_TRANS &&
+ utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
+ {
+ d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
+ }
+ else {
+ if (uv >= 127 && UTF) {
+ dTHR;
+ if (ckWARN(WARN_UTF8))
+ warner(WARN_UTF8,
+ "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
+ len,s,len,s);
+ }
+ *d++ = (char)uv;
+ }
+ s += len;
+ }
continue;
/* \c is a control character */
case 'c':
s++;
+#ifdef EBCDIC
+ *d = *s++;
+ if (isLOWER(*d))
+ *d = toUPPER(*d);
+ *d++ = toCTRL(*d);
+#else
len = *s++;
*d++ = toCTRL(len);
+#endif
continue;
/* printf-style backslashes, formfeeds, newlines, etc */
else
return Nullch ;
}
- else
+ else
return (sv_gets(sv, fp, append));
}
retry:
switch (*s) {
default:
- croak("Unrecognized character \\%03o", *s & 255);
+ /*
+ * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
+ * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
+ * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
+ * routines unnecessarily. You will see this not just here but throughout this file.
+ */
+ if (UTF && (*s & 0xc0) == 0x80) {
+ if (isIDFIRST_utf8((U8*)s))
+ goto keylookup;
+ }
+ croak("Unrecognized character \\x%02X", *s & 255);
case 4:
case 26:
goto fake_eof; /* emulate EOF on ^D or ^Z */
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 *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
assert(SvPOK(x) || SvGMAGICAL(x));
- if (sv_eq(x, GvSV(curcop->cop_filegv))) {
+ if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
sv_setpvn(x, ipath, ipathend - ipath);
SvSETMAGIC(x);
}
}
goto retry;
case '\r':
-#ifndef TMP_CRLF_PATCH
+#ifdef PERL_STRICT_CR
warn("Illegal character \\%03o (carriage return)", '\r');
croak(
"(Maybe you didn't strip carriage returns after a network transfer?)\n");
AOPERATOR(ANDAND);
s--;
if (PL_expect == XOPERATOR) {
- if (PL_dowarn && isALPHA(*s) && PL_bufptr == PL_linestart) {
+ if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
PL_curcop->cop_line--;
- warn(warn_nosemi);
+ warner(WARN_SEMICOLON, warn_nosemi);
PL_curcop->cop_line++;
}
BAop(OP_BIT_AND);
OPERATOR(',');
if (tmp == '~')
PMop(OP_MATCH);
- if (PL_dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
- warn("Reversed %c= operator",(int)tmp);
+ if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
+ warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
s--;
if (PL_expect == XSTATE && isALPHA(tmp) &&
(s == PL_linestart+1 || s[-2] == '\n') )
char *t;
if (*s == '[') {
PL_tokenbuf[0] = '@';
- if (PL_dowarn) {
+ if (ckWARN(WARN_SYNTAX)) {
for(t = s + 1;
isSPACE(*t) || isALNUM(*t) || *t == '$';
t++) ;
PL_bufptr = skipspace(PL_bufptr);
while (t < PL_bufend && *t != ']')
t++;
- warn("Multidimensional syntax %.*s not supported",
- (t - PL_bufptr) + 1, PL_bufptr);
+ warner(WARN_SYNTAX,
+ "Multidimensional syntax %.*s not supported",
+ (t - PL_bufptr) + 1, PL_bufptr);
}
}
}
else if (*s == '{') {
PL_tokenbuf[0] = '%';
- if (PL_dowarn && strEQ(PL_tokenbuf+1, "SIG") &&
+ if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
(t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof PL_tokenbuf];
if (isIDFIRST(*t)) {
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
- warn("You need to quote \"%s\"", tmpbuf);
+ warner(WARN_SYNTAX,
+ "You need to quote \"%s\"", tmpbuf);
}
}
}
PL_tokenbuf[0] = '%';
/* Warn about @ where they meant $. */
- if (PL_dowarn) {
+ if (ckWARN(WARN_SYNTAX)) {
if (*s == '[' || *s == '{') {
char *t = s + 1;
while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
if (*t == '}' || *t == ']') {
t++;
PL_bufptr = skipspace(PL_bufptr);
- warn("Scalar value %.*s better written as $%.*s",
+ warner(WARN_SYNTAX,
+ "Scalar value %.*s better written as $%.*s",
t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
}
}
missingterm((char*)0);
yylval.ival = OP_CONST;
for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
- if (*d == '$' || *d == '@' || *d == '\\') {
+ if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
yylval.ival = OP_STRINGIFY;
break;
}
case '\\':
s++;
- if (PL_dowarn && PL_lex_inwhat && isDIGIT(*s))
- warn("Can't use \\%c to mean $%c in expression", *s, *s);
+ if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
+ warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
+ *s, *s);
if (PL_expect == XOPERATOR)
no_op("Backslash",s);
OPERATOR(REFGEN);
tmp = -tmp;
gv = Nullgv;
gvp = 0;
- if (PL_dowarn && hgv)
- warn("Ambiguous call resolved as CORE::%s(), "
- "qualify as such or use &", GvENAME(hgv));
+ if (ckWARN(WARN_AMBIGUOUS) && hgv)
+ warner(WARN_AMBIGUOUS,
+ "Ambiguous call resolved as CORE::%s(), %s",
+ GvENAME(hgv), "qualify as such or use &");
}
}
if (PL_expect == XOPERATOR) {
if (PL_bufptr == PL_linestart) {
PL_curcop->cop_line--;
- warn(warn_nosemi);
+ warner(WARN_SEMICOLON, warn_nosemi);
PL_curcop->cop_line++;
}
else
if (len > 2 &&
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
- if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
- warn("Bareword \"%s\" refers to nonexistent package",
+ if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
+ warner(WARN_UNSAFE,
+ "Bareword \"%s\" refers to nonexistent package",
PL_tokenbuf);
len -= 2;
PL_tokenbuf[len] = '\0';
/* Call it a bare word */
bareword:
- if (PL_dowarn) {
+ if (ckWARN(WARN_RESERVED)) {
if (lastchar != '-') {
for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
if (!*d)
- warn(warn_reserved, PL_tokenbuf);
+ warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
}
}
case KEY_crypt:
#ifdef FCRYPT
- if (!cryptseen++)
+ if (!PL_cryptseen++)
init_des();
#endif
LOP(OP_CRYPT,XTERM);
case KEY_chmod:
- if (PL_dowarn) {
+ if (ckWARN(WARN_OCTAL)) {
for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
if (*d != '0' && isDIGIT(*d))
yywarn("chmod: mode argument is missing initial 0");
s = scan_str(s);
if (!s)
missingterm((char*)0);
- if (PL_dowarn && SvLEN(PL_lex_stuff)) {
+ if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
d = SvPV_force(PL_lex_stuff, len);
for (; len; --len, ++d) {
if (*d == ',') {
- warn("Possible attempt to separate words with commas");
+ warner(WARN_SYNTAX,
+ "Possible attempt to separate words with commas");
break;
}
if (*d == '#') {
- warn("Possible attempt to put comments in qw() list");
+ warner(WARN_SYNTAX,
+ "Possible attempt to put comments in qw() list");
break;
}
}
LOP(OP_UTIME,XTERM);
case KEY_umask:
- if (PL_dowarn) {
+ if (ckWARN(WARN_OCTAL)) {
for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
if (*d != '0' && isDIGIT(*d))
yywarn("umask: argument is missing initial 0");
FUN0(OP_WANTARRAY);
case KEY_write:
- gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
+#ifdef EBCDIC
+ {
+ static char ctl_l[2];
+
+ if (ctl_l[0] == '\0')
+ ctl_l[0] = toCTRL('L');
+ gv_fetchpv(ctl_l,TRUE, SVt_PV);
+ }
+#else
+ gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
+#endif
UNI(OP_ENTERWRITE);
case KEY_x:
{
char *w;
- if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
- int level = 1;
- for (w = s+2; *w && level; w++) {
- if (*w == '(')
- ++level;
- else if (*w == ')')
- --level;
- }
- if (*w)
- for (; *w && isSPACE(*w); w++) ;
- if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
- warn("%s (...) interpreted as function",name);
+ if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
+ dTHR; /* only for ckWARN */
+ if (ckWARN(WARN_SYNTAX)) {
+ int level = 1;
+ for (w = s+2; *w && level; w++) {
+ if (*w == '(')
+ ++level;
+ else if (*w == ')')
+ --level;
+ }
+ if (*w)
+ for (; *w && isSPACE(*w); w++) ;
+ if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
+ warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
+ }
}
while (s < PL_bufend && isSPACE(*s))
s++;
*d++ = *s++;
*d++ = *s++;
}
+ else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
+ char *t = s + UTF8SKIP(s);
+ while (*t & 0x80 && is_utf8_mark((U8*)t))
+ t += UTF8SKIP(t);
+ if (d + (t - s) > e)
+ croak(ident_too_long);
+ Copy(s, d, t - s, char);
+ d += t - s;
+ s = t;
+ }
else {
*d = '\0';
*slp = d - dest;
*d++ = *s++;
*d++ = *s++;
}
+ else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
+ char *t = s + UTF8SKIP(s);
+ while (*t & 0x80 && is_utf8_mark((U8*)t))
+ t += UTF8SKIP(t);
+ if (d + (t - s) > e)
+ croak(ident_too_long);
+ Copy(s, d, t - s, char);
+ d += t - s;
+ s = t;
+ }
else
break;
}
}
}
}
- if (isIDFIRST(*d)) {
+ if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8((U8*)d))) {
d++;
- while (isALNUM(*s) || *s == ':')
- *d++ = *s++;
+ if (UTF) {
+ e = s;
+ while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
+ e += UTF8SKIP(e);
+ while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
+ e += UTF8SKIP(e);
+ }
+ Copy(s, d, e - s, char);
+ d += e - s;
+ s = e;
+ }
+ else {
+ while (isALNUM(*s) || *s == ':')
+ *d++ = *s++;
+ }
*d = '\0';
while (s < send && (*s == ' ' || *s == '\t')) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- if (PL_dowarn && keyword(dest, d - dest)) {
+ dTHR; /* only for ckWARN */
+ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
char *brack = *s == '[' ? "[...]" : "{...}";
- warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
+ warner(WARN_AMBIGUOUS,
+ "Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
}
PL_lex_fakebrack = PL_lex_brackets+1;
PL_lex_state = LEX_INTERPEND;
if (funny == '#')
funny = '@';
- if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
- (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
- warn("Ambiguous use of %c{%s} resolved to %c%s",
- funny, dest, funny, dest);
+ if (PL_lex_state == LEX_NORMAL) {
+ dTHR; /* only for ckWARN */
+ if (ckWARN(WARN_AMBIGUOUS) &&
+ (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
+ {
+ warner(WARN_AMBIGUOUS,
+ "Ambiguous use of %c{%s} resolved to %c%s",
+ funny, dest, funny, dest);
+ }
+ }
}
else {
s = bracket; /* let the parser handle it */
OP *o;
short *tbl;
I32 squash;
- I32 Delete;
+ I32 del;
I32 complement;
+ I32 utf8;
+ I32 count = 0;
yylval.ival = OP_NULL;
croak("Transliteration replacement not terminated");
}
- New(803,tbl,256,short);
- o = newPVOP(OP_TRANS, 0, (char*)tbl);
+ if (UTF) {
+ o = newSVOP(OP_TRANS, 0, 0);
+ utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
+ }
+ else {
+ New(803,tbl,256,short);
+ o = newPVOP(OP_TRANS, 0, (char*)tbl);
+ utf8 = 0;
+ }
- complement = Delete = squash = 0;
- while (*s == 'c' || *s == 'd' || *s == 's') {
+ complement = del = squash = 0;
+ while (strchr("cdsCU", *s)) {
if (*s == 'c')
complement = OPpTRANS_COMPLEMENT;
else if (*s == 'd')
- Delete = OPpTRANS_DELETE;
- else
+ del = OPpTRANS_DELETE;
+ else if (*s == 's')
squash = OPpTRANS_SQUASH;
+ else {
+ switch (count++) {
+ case 0:
+ if (*s == 'C')
+ utf8 &= ~OPpTRANS_FROM_UTF;
+ else
+ utf8 |= OPpTRANS_FROM_UTF;
+ break;
+ case 1:
+ if (*s == 'C')
+ utf8 &= ~OPpTRANS_TO_UTF;
+ else
+ utf8 |= OPpTRANS_TO_UTF;
+ break;
+ default:
+ croak("Too many /C and /U options");
+ }
+ }
s++;
}
- o->op_private = Delete|squash|complement;
+ o->op_private = del|squash|complement|utf8;
PL_lex_op = o;
yylval.ival = OP_TRANS;
*d++ = '\n';
*d = '\0';
len = d - PL_tokenbuf;
-#ifdef TMP_CRLF_PATCH
+#ifndef PERL_STRICT_CR
d = strchr(s, '\r');
if (d) {
char *olds = s;
}
PL_curcop->cop_line++;
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
-#ifdef TMP_CRLF_PATCH
+#ifndef PERL_STRICT_CR
if (PL_bufend - PL_linestart >= 2) {
if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
(PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
if (s < PL_bufend) break; /* handle case where we are done yet :-) */
-#ifdef TMP_CRLF_PATCH
+#ifndef PERL_STRICT_CR
if (to - SvPVX(sv) >= 2) {
if ((to[-2] == '\r' && to[-1] == '\n') ||
(to[-2] == '\n' && to[-1] == '\r'))
}
/* we read a line, so increment our line counter */
PL_curcop->cop_line++;
-
+
/* update debugger info */
if (PERLDB_LINE && PL_curstash != PL_debstash) {
SV *sv = NEWSV(88,0);
av_store(GvAV(PL_curcop->cop_filegv),
(I32)PL_curcop->cop_line, sv);
}
-
+
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
}
if -w is on
*/
if (*s == '_') {
- if (PL_dowarn && lastub && s - lastub != 3)
- warn("Misplaced _ in number");
+ dTHR; /* only for ckWARN */
+ if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
+ warner(WARN_SYNTAX, "Misplaced _ in number");
lastub = ++s;
}
else {
}
/* final misplaced underbar check */
- if (PL_dowarn && lastub && s - lastub != 3)
- warn("Misplaced _ in number");
+ if (lastub && s - lastub != 3) {
+ dTHR;
+ if (ckWARN(WARN_SYNTAX))
+ warner(WARN_SYNTAX, "Misplaced _ in number");
+ }
/* read a decimal portion if there is one. avoid
3..5 being interpreted as the number 3. followed
projects / p5sagit/p5-mst-13.2.git / blobdiff