#include "EXTERN.h"
#include "perl.h"
+#define yychar PL_yychar
+#define yylval PL_yylval
+
#ifndef PERL_OBJECT
static void check_uni _((void));
static void force_next _((I32 type));
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) {
- char* tmps;
- char* tend;
- New(898, tmps, SvCUR(sv) * 3 / 2 + 1, char);
+ 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, tmps, tend - tmps);
+ sv_usepvn(sv, (char*)tmps, tend - tmps);
}
return count;
{
I32 count = FILTER_READ(idx+1, sv, maxlen);
if (count) {
- char* tmps;
- char* tend;
- New(898, tmps, SvCUR(sv) * 3 / 2 + 1, char);
+ 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, tmps, tend - tmps);
+ sv_usepvn(sv, (char*)tmps, tend - tmps);
}
return count;
}
+#endif
+
void
lex_start(SV *line)
{
/* expand a range A-Z to the full set of characters. AIE! */
if (dorange) {
I32 i; /* current expanded character */
+ I32 min; /* first character in range */
I32 max; /* last character in range */
i = d - SvPVX(sv); /* remember current offset */
d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
d -= 2; /* eat the first char and the - */
- max = (U8)d[1]; /* last char in range */
-
- for (i = (U8)*d; i <= max; i++)
- *d++ = i;
+ min = (U8)*d; /* first char in range */
+ max = (U8)d[1]; /* last char in range */
+
+#ifndef ASCIIish
+ if ((isLOWER(min) && isLOWER(max)) ||
+ (isUPPER(min) && isUPPER(max))) {
+ if (isLOWER(min)) {
+ for (i = min; i <= max; i++)
+ if (isLOWER(i))
+ *d++ = i;
+ } else {
+ for (i = min; i <= max; i++)
+ if (isUPPER(i))
+ *d++ = i;
+ }
+ }
+ else
+#endif
+ for (i = min; i <= max; i++)
+ *d++ = i;
/* mark the range as done, and continue */
dorange = FALSE;
/* if we get here, we're not doing a transliteration */
- /* skip for regexp comments /(?#comment)/ */
+ /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
+ except for the last char, which will be done separately. */
else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
if (s[2] == '#') {
while (s < send && *s != ')')
*d++ = *s++;
- } else if (s[2] == '{') { /* This should march regcomp.c */
+ } else if (s[2] == '{'
+ || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
I32 count = 1;
- char *regparse = s + 3;
+ char *regparse = s + (s[2] == '{' ? 3 : 4);
char c;
while (count && (c = *regparse)) {
count--;
regparse++;
}
- if (*regparse == ')')
- regparse++;
- else
+ if (*regparse != ')') {
+ regparse--; /* Leave one char for continuation. */
yyerror("Sequence (?{...}) not terminated or not {}-balanced");
- while (s < regparse && *s != ')')
+ }
+ while (s < regparse)
*d++ = *s++;
}
}
/* (now in tr/// code again) */
- if (*s & 0x80 && dowarn && thisutf) {
- (void)utf8_to_uv(s, &len); /* could cvt latin-1 to utf8 here... */
- if (len) {
- while (len--)
- *d++ = *s++;
- continue;
+ 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;
+ }
}
}
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;
}
if (!e)
yyerror("Missing right brace on \\x{}");
- if (dowarn && !utf)
- warn("Use of \\x{} without utf8 declaration");
+ if (!utf) {
+ dTHR;
+ if (ckWARN(WARN_UTF8))
+ warner(WARN_UTF8,
+ "Use of \\x{} without utf8 declaration");
+ }
/* note: utf always shorter than hex */
- d = uv_to_utf8(d, scan_hex(s + 1, e - s, &len));
+ d = (char*)uv_to_utf8((U8*)d,
+ scan_hex(s + 1, e - s - 1, &len));
s = e + 1;
}
if (utf && PL_lex_inwhat == OP_TRANS &&
utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
{
- d = uv_to_utf8(d, uv); /* doing a CU or UC */
+ d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
}
else {
- if (dowarn && uv >= 127 && UTF)
- warn(
- "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
- len,s,len,s);
+ 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;
if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
- if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){
+ if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
sv_free(av_pop(PL_rsfp_filters));
return;
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
#endif
-EXT int yychar; /* last token */
-
/*
yylex
* routines unnecessarily. You will see this not just here but throughout this file.
*/
if (UTF && (*s & 0xc0) == 0x80) {
- if (isIDFIRST_utf8(s))
+ if (isIDFIRST_utf8((U8*)s))
goto keylookup;
}
croak("Unrecognized character \\x%02X", *s & 255);
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') )
}
if (PL_lex_brackets < PL_lex_formbrack) {
char *t;
+#ifdef PERL_STRICT_CR
for (t = s; *t == ' ' || *t == '\t'; t++) ;
+#else
+ for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
+#endif
if (*t == '\n' || *t == '#') {
s--;
PL_expect = XBLOCK;
}
}
- if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
+ if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:+-", s[2]))) {
if (PL_expect == XOPERATOR)
no_op("Array length", PL_bufptr);
PL_tokenbuf[0] = '@';
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);
}
}
OPERATOR(tmp);
case '.':
- if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
- (s == PL_linestart || s[-1] == '\n') ) {
+ if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
+#ifdef PERL_STRICT_CR
+ && s[1] == '\n'
+#else
+ && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
+#endif
+ && (s == PL_linestart || s[-1] == '\n') )
+ {
PL_lex_formbrack = 0;
PL_expect = XSTATE;
goto rightbracket;
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(), %s",
+ if (ckWARN(WARN_AMBIGUOUS) && hgv
+ && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
+ 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);
}
}
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");
{
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(s)) {
+ else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
char *t = s + UTF8SKIP(s);
- while (*t & 0x80 && is_utf8_mark(t))
+ while (*t & 0x80 && is_utf8_mark((U8*)t))
t += UTF8SKIP(t);
if (d + (t - s) > e)
croak(ident_too_long);
*d++ = *s++;
*d++ = *s++;
}
- else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
+ else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
char *t = s + UTF8SKIP(s);
- while (*t & 0x80 && is_utf8_mark(t))
+ while (*t & 0x80 && is_utf8_mark((U8*)t))
t += UTF8SKIP(t);
if (d + (t - s) > e)
croak(ident_too_long);
return s;
}
if (*s == '$' && s[1] &&
- (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
+ (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
{
- if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
- deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
- else
- return s;
+ return s;
}
if (*s == '{') {
bracket = s;
}
}
}
- if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8(d))) {
+ if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8((U8*)d))) {
d++;
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(e))
+ while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
e += UTF8SKIP(e);
}
Copy(s, d, e - s, char);
*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 */
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
while (!needargs) {
if (*s == '.' || *s == '}') {
/*SUPPRESS 530*/
- for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
+#ifdef PERL_STRICT_CR
+ for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
+#else
+ for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
+#endif
if (*t == '\n')
break;
}