* 1999-02-27 mjd-perl-patch@plover.com */
#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
+/* On MacOS, respect nonbreaking spaces */
+#ifdef MACOS_TRADITIONAL
+#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
+#else
+#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
+#endif
+
/* LEX_* are values for PL_lex_state, the state of the lexer.
* They are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
CopLINE_inc(PL_curcop);
if (*s++ != '#')
return;
- while (*s == ' ' || *s == '\t') s++;
+ while (SPACE_OR_TAB(*s)) s++;
if (strnEQ(s, "line", 4))
s += 4;
else
s++;
else
return;
- while (*s == ' ' || *s == '\t') s++;
+ while (SPACE_OR_TAB(*s)) s++;
if (!isDIGIT(*s))
return;
n = s;
while (isDIGIT(*s))
s++;
- while (*s == ' ' || *s == '\t')
+ while (SPACE_OR_TAB(*s))
s++;
if (*s == '"' && (t = strchr(s+1, '"'))) {
s++;
for (t = s; !isSPACE(*t); t++) ;
e = t;
}
- while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f')
+ while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
e++;
if (*e != '\n' && *e != '\0')
return; /* false alarm */
ch = *t;
*t = '\0';
- if (t - s > 0)
+ if (t - s > 0) {
+#ifdef USE_ITHREADS
+ Safefree(CopFILE(PL_curcop));
+#else
+ SvREFCNT_dec(CopFILEGV(PL_curcop));
+#endif
CopFILE_set(PL_curcop, s);
+ }
*t = ch;
CopLINE_set(PL_curcop, atoi(n)-1);
}
{
dTHR;
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
return s;
}
NV nshift = 1.0;
STRLEN len;
char *start = SvPVx(sv,len);
- bool utf = SvUTF8(sv);
+ bool utf = SvUTF8(sv) ? TRUE : FALSE;
char *end = start + len;
while (start < end) {
I32 skip;
goto finish;
s = SvPV_force(sv, len);
- if (SvIVX(sv) == -1)
+ if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
goto finish;
send = s + len;
while (s < send && *s != '\\')
p = SvPV(sv, len);
nsv = newSVpvn(p, len);
+ if (SvUTF8(sv))
+ SvUTF8_on(nsv);
SvREFCNT_dec(sv);
sv = nsv;
}
default:
{
dTHR;
- if (ckWARN(WARN_MISC) && isALPHA(*s))
+ if (ckWARN(WARN_MISC) && isALNUM(*s))
Perl_warner(aTHX_ WARN_MISC,
"Unrecognized escape \\%c passed through",
*s);
/* \132 indicates an octal constant */
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
+ len = 0; /* disallow underscores */
uv = (UV)scan_oct(s, 3, &len);
s += len;
goto NUM_ESCAPE_INSERT;
yyerror("Missing right brace on \\x{}");
e = s;
}
+ len = 1; /* allow underscores */
uv = (UV)scan_hex(s + 1, e - s - 1, &len);
s = e + 1;
}
else {
+ len = 0; /* disallow underscores */
uv = (UV)scan_hex(s, 2, &len);
s += len;
}
res = new_constant( Nullch, 0, "charnames",
res, Nullsv, "\\N{...}" );
str = SvPV(res,len);
- if (len > 1)
+ if (!has_utf && SvUTF8(res)) {
+ char *ostart = SvPVX(sv);
+ SvCUR_set(sv, d - ostart);
+ SvPOK_on(sv);
+ sv_utf8_upgrade(sv);
+ d = SvPVX(sv) + SvCUR(sv);
has_utf = TRUE;
+ }
if (len > e - s + 4) {
char *odest = SvPVX(sv);
*d = *s++;
if (isLOWER(*d))
*d = toUPPER(*d);
- *d++ = toCTRL(*d);
+ *d = toCTRL(*d);
+ d++;
#else
len = *s++;
*d++ = toCTRL(len);
if we already built the token before, use it.
*/
+#ifdef __SC__
+#pragma segment Perl_yylex
+#endif
int
#ifdef USE_PURE_BISON
Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
*/
if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
- if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
- yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
- PL_tokenbuf, PL_tokenbuf));
+ if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
+ && ckWARN(WARN_AMBIGUOUS))
+ {
+ /* Downgraded from fatal to warning 20000522 mjd */
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Possible unintended interpolation of %s in string",
+ PL_tokenbuf);
+ }
}
/* build ops for a bareword */
*s = '#'; /* Don't try to parse shebang line */
}
#endif /* ALTERNATE_SHEBANG */
+#ifndef MACOS_TRADITIONAL
if (!d &&
*s == '#' &&
ipathend > ipath &&
PerlProc_execv(ipath, newargv);
Perl_croak(aTHX_ "Can't exec %s", ipath);
}
+#endif
if (d) {
U32 oldpdb = PL_perldb;
bool oldn = PL_minus_n;
bool oldp = PL_minus_p;
while (*d && !isSPACE(*d)) d++;
- while (*d == ' ' || *d == '\t') d++;
+ while (SPACE_OR_TAB(*d)) d++;
if (*d++ == '-') {
do {
#ifdef PERL_STRICT_CR
Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
Perl_croak(aTHX_
- "(Maybe you didn't strip carriage returns after a network transfer?)\n");
+ "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
#endif
case ' ': case '\t': case '\f': case 013:
+#ifdef MACOS_TRADITIONAL
+ case '\312':
+#endif
s++;
goto retry;
case '#':
case '\n':
if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
+ if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
+ /* handle eval qq[#line 1 "foo"\n ...] */
+ CopLINE_dec(PL_curcop);
+ incline(s);
+ }
d = PL_bufend;
while (s < d && *s != '\n')
s++;
PL_bufptr = s;
tmp = *s++;
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
if (strnEQ(s,"=>",2)) {
PL_expect = XTERM;
TOKEN('(');
case ';':
- if (CopLINE(PL_curcop) < PL_copline)
- PL_copline = CopLINE(PL_curcop);
+ CLINE;
tmp = *s++;
OPERATOR(tmp);
case ')':
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
OPERATOR(HASHBRACK);
case XOPERATOR:
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
d = s;
PL_tokenbuf[0] = '\0';
if (d < PL_bufend && *d == '-') {
PL_tokenbuf[0] = '-';
d++;
- while (d < PL_bufend && (*d == ' ' || *d == '\t'))
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
d++;
}
if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
FALSE, &len);
- while (d < PL_bufend && (*d == ' ' || *d == '\t'))
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
d++;
if (*d == '}') {
char minus = (PL_tokenbuf[0] == '-');
if (PL_lex_brackets < PL_lex_formbrack) {
char *t;
#ifdef PERL_STRICT_CR
- for (t = s; *t == ' ' || *t == '\t'; t++) ;
+ for (t = s; SPACE_OR_TAB(*t); t++) ;
#else
- for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
+ for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
#endif
if (*t == '\n' || *t == '#') {
s--;
tmp = keyword(PL_tokenbuf, len);
/* Is this a word before a => operator? */
- if (strnEQ(d,"=>",2)) {
+ if (*d == '=' && d[1] == '>') {
CLINE;
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
yylval.opval->op_private = OPpCONST_BARE;
}
}
- /* If followed by a paren, it's certainly a subroutine. */
PL_expect = XOPERATOR;
s = skipspace(s);
+
+ /* Is this a word before a => operator? */
+ if (*s == '=' && s[1] == '>') {
+ CLINE;
+ sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
+ TERM(WORD);
+ }
+
+ /* If followed by a paren, it's certainly a subroutine. */
if (*s == '(') {
CLINE;
if (gv && GvCVu(gv)) {
- for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
+ for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
s = d + 1;
goto its_constant;
for (; !isSPACE(*d) && len; --len, ++d) ;
}
words = append_elem(OP_LIST, words,
- newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
+ newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b))));
}
}
if (words) {
}
}}
}
+#ifdef __SC__
+#pragma segment Main
+#endif
I32
Perl_keyword(pTHX_ register char *d, I32 len)
SV *res;
SV **cvp;
SV *cv, *typesv;
- const char *why, *why1, *why2;
+ const char *why1, *why2, *why3;
- if (!(PL_hints & HINT_LOCALIZE_HH)) {
+ if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
SV *msg;
- why = "%^H is not localized";
- report_short:
- why1 = why2 = "";
+ why1 = "%^H is not consistent";
+ why2 = strEQ(key,"charnames")
+ ? " (missing \"use charnames ...\"?)"
+ : "";
+ why3 = "";
report:
msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
- (type ? type: "undef"), why1, why2, why);
+ (type ? type: "undef"), why1, why2, why3);
yyerror(SvPVX(msg));
SvREFCNT_dec(msg);
return sv;
}
- if (!table) {
- why = "%^H is not defined";
- goto report_short;
- }
cvp = hv_fetch(table, key, strlen(key), FALSE);
if (!cvp || !SvOK(*cvp)) {
- why = "} is not defined";
why1 = "$^H{";
why2 = key;
+ why3 = "} is not defined";
goto report;
}
sv_2mortal(sv); /* Parent created it permanently */
POPSTACK;
if (!SvOK(res)) {
- why = "}} did not return a defined value";
why1 = "Call to &{$^H{";
why2 = key;
+ why3 = "}} did not return a defined value";
sv = res;
goto report;
}
if (isSPACE(s[-1])) {
while (s < send) {
char ch = *s++;
- if (ch != ' ' && ch != '\t') {
+ if (!SPACE_OR_TAB(ch)) {
*d = ch;
break;
}
Perl_croak(aTHX_ ident_too_long);
}
*d = '\0';
- while (s < send && (*s == ' ' || *s == '\t')) s++;
+ while (s < send && SPACE_OR_TAB(*s)) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
dTHR; /* only for ckWARN */
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
if (!outer)
*d++ = '\n';
- for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
+ for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
if (*peek && strchr("`'\"",*peek)) {
s = peek;
term = *s++;
register char *s = start; /* current position in buffer */
register char *d; /* destination in temp buffer */
register char *e; /* end of temp buffer */
- NV value; /* number read, as a double */
+ NV nv; /* number read, as a double */
SV *sv = Nullsv; /* place to put the converted number */
bool floatit; /* boolean: int or float? */
char *lastub = 0; /* position of last underbar */
/* make an sv from the string */
sv = NEWSV(92,0);
- /* unfortunately this monster needs to be on one line or
- makedepend will be confused. */
-#if (defined(USE_64_BIT_INT) && (!defined(HAS_STRTOLL)|| !defined(HAS_STRTOULL))) || (!defined(USE_64_BIT_INT) && (!defined(HAS_STRTOL) || !defined(HAS_STRTOUL)))
+#if defined(Strtol) && defined(Strtoul)
/*
- No working strto[u]l[l]. Since atoi() doesn't do range checks,
- we need to do this the hard way.
- */
-
- value = Atof(PL_tokenbuf);
-
- /*
- See if we can make do with an integer value without loss of
- precision. We use I_V to cast to an int, because some
- compilers have issues. Then we try casting it back and see
- if it was the same. We only do this if we know we
- specifically read an integer.
-
- Note: if floatit is true, then we don't need to do the
- conversion at all.
- */
- {
- UV tryuv = U_V(value);
- if (!floatit && (NV)tryuv == value) {
- if (tryuv <= IV_MAX)
- sv_setiv(sv, (IV)tryuv);
- else
- sv_setuv(sv, tryuv);
- }
- else
- sv_setnv(sv, value);
- }
-#else
- /*
strtol/strtoll sets errno to ERANGE if the number is too big
for an integer. We try to do an integer conversion first
if no characters indicating "float" have been found.
else
uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
if (errno)
- floatit = TRUE; /* probably just too large */
+ floatit = TRUE; /* Probably just too large. */
else if (*PL_tokenbuf == '-')
sv_setiv(sv, iv);
+ else if (uv <= IV_MAX)
+ sv_setiv(sv, uv); /* Prefer IVs over UVs. */
else
sv_setuv(sv, uv);
}
if (floatit) {
- value = Atof(PL_tokenbuf);
- sv_setnv(sv, value);
+ nv = Atof(PL_tokenbuf);
+ sv_setnv(sv, nv);
+ }
+#else
+ /*
+ No working strtou?ll?.
+
+ Unfortunately atol() doesn't do range checks (returning
+ LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
+ everywhere [1], so we cannot use use atol() (or atoll()).
+ If we could, they would be used, as Atol(), very much like
+ Strtol() and Strtoul() are used above.
+
+ [1] XXX Configure test needed to check for atol()
+ (and atoll()) overflow behaviour XXX
+
+ --jhi
+
+ We need to do this the hard way. */
+
+ nv = Atof(PL_tokenbuf);
+
+ /* See if we can make do with an integer value without loss of
+ precision. We use U_V to cast to a UV, because some
+ compilers have issues. Then we try casting it back and see
+ if it was the same [1]. We only do this if we know we
+ specifically read an integer. If floatit is true, then we
+ don't need to do the conversion at all.
+
+ [1] Note that this is lossy if our NVs cannot preserve our
+ UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
+ and NV_PRESERVES_UV_BITS (a number), but in general we really
+ do hope all such potentially lossy platforms have strtou?ll?
+ to do a lossless IV/UV conversion.
+
+ Maybe could do some tricks with DBL_DIG, LDBL_DIG and
+ DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
+ as NV_DIG and NV_MANT_DIG)?
+
+ --jhi
+ */
+ {
+ UV uv = U_V(nv);
+ if (!floatit && (NV)uv == nv) {
+ if (uv <= IV_MAX)
+ sv_setiv(sv, uv); /* Prefer IVs over UVs. */
+ else
+ sv_setuv(sv, uv);
+ }
+ else
+ sv_setnv(sv, nv);
}
#endif
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
if (*s == '.' || *s == '}') {
/*SUPPRESS 530*/
#ifdef PERL_STRICT_CR
- for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
+ for (t = s+1;SPACE_OR_TAB(*t); t++) ;
#else
- for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
+ for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
#endif
if (*t == '\n' || t == PL_bufend)
break;
Perl_warn(aTHX_ "%"SVf, msg);
else
qerror(msg);
- if (PL_error_count >= 10)
- Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
+ if (PL_error_count >= 10) {
+ if (PL_in_eval && SvCUR(ERRSV))
+ Perl_croak(aTHX_ "%_%s has too many errors.\n",
+ ERRSV, CopFILE(PL_curcop));
+ else
+ Perl_croak(aTHX_ "%s has too many errors.\n",
+ CopFILE(PL_curcop));
+ }
PL_in_my = 0;
PL_in_my_stash = Nullhv;
return 0;