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 (!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);
#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:
s++;
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++;
/* This kludge not intended to be bulletproof. */
if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
yylval.opval = newSVOP(OP_CONST, 0,
- newSViv((IV)PL_compiling.cop_arybase));
+ newSViv(PL_compiling.cop_arybase));
yylval.opval->op_private = OPpCONST_ARYBASE;
TERM(THING);
}
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)) {
s += 2;
d = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- tmp = keyword(PL_tokenbuf, len);
+ if (!(tmp = keyword(PL_tokenbuf, len)))
+ Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
if (tmp < 0)
tmp = -tmp;
goto reserved_word;
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) {
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 (!floatit) {
- char *tp;
IV iv;
UV uv;
errno = 0;
-#ifdef USE_64_BIT_INT
if (*PL_tokenbuf == '-')
- iv = strtoll(PL_tokenbuf,&tp,10);
+ iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
else
- uv = strtoull(PL_tokenbuf,&tp,10);
-#else
- if (*PL_tokenbuf == '-')
- iv = strtol(PL_tokenbuf,&tp,10);
- else
- uv = strtoul(PL_tokenbuf,&tp,10);
-#endif
- if (*tp || errno)
+ uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
+ if (errno)
floatit = TRUE; /* probably just too large */
else if (*PL_tokenbuf == '-')
sv_setiv(sv, iv);
sv_setuv(sv, uv);
}
if (floatit) {
- char *tp;
- errno = 0;
-/* For some reason VMS doesn't have strrold at the moment. Dunno why */
-#if defined(USE_LONG_DOUBLE) && (defined(HAS_STRTOLD) || !defined(VMS))
- value = strtold(PL_tokenbuf,&tp);
-#else
- value = strtod(PL_tokenbuf,&tp);
-#endif
- if (*tp || errno)
- Perl_die(aTHX_ "unparseable float");
- else
- sv_setnv(sv, value);
- }
+ value = Atof(PL_tokenbuf);
+ sv_setnv(sv, value);
+ }
#endif
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
(PL_hints & HINT_NEW_INTEGER) )
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff