/* toke.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
ch = *t;
*t = '\0';
if (t - s > 0) {
-#ifdef USE_ITHREADS
- Safefree(CopFILE(PL_curcop));
-#else
- SvREFCNT_dec(CopFILEGV(PL_curcop));
-#endif
+ CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, s);
}
*t = ch;
/* FALL THROUGH */
default:
{
- if (ckWARN(WARN_MISC) && isALNUM(*s))
+ if (ckWARN(WARN_MISC) &&
+ isALNUM(*s) &&
+ *s != '_')
Perl_warner(aTHX_ WARN_MISC,
"Unrecognized escape \\%c passed through",
*s);
if (has_utf8)
sv_utf8_upgrade(res);
str = SvPV(res,len);
+#ifdef EBCDIC_NEVER_MIND
+ /* charnames uses pack U and that has been
+ * recently changed to do the below uni->native
+ * mapping, so this would be redundant (and wrong,
+ * the code point would be doubly converted).
+ * But leave this in just in case the pack U change
+ * gets revoked, but the semantics is still
+ * desireable for charnames. --jhi */
+ {
+ UV uv = utf8_to_uvchr((U8*)str, 0);
+
+ if (uv < 0x100) {
+ U8 tmpbuf[UTF8_MAXLEN+1], *d;
+
+ d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
+ sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
+ str = SvPV(res, len);
+ }
+ }
+#endif
if (!has_utf8 && SvUTF8(res)) {
char *ostart = SvPVX(sv);
SvCUR_set(sv, d - ostart);
bool bof = FALSE;
/* check if there's an identifier for us to look at */
- if (PL_pending_ident)
+ if (PL_pending_ident)
return S_pending_ident(aTHX);
/* no identifier pending identification */
}
else { /* no override */
tmp = -tmp;
+ if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
+ Perl_warner(aTHX_ WARN_MISC,
+ "dump() better written as CORE::dump()");
+ }
gv = Nullgv;
gvp = 0;
if (ckWARN(WARN_AMBIGUOUS) && hgv
if (strEQ(proto, "$"))
OPERATOR(UNIOPSUB);
if (*proto == '&' && *s == '{') {
- sv_setpv(PL_subname,"__ANON__");
+ sv_setpv(PL_subname, PL_curstash ?
+ "__ANON__" : "__ANON__::__ANON__");
PREBLOCK(LSTOPSUB);
}
}
char tmpbuf[sizeof PL_tokenbuf];
SSize_t tboffset = 0;
expectation attrful;
- bool have_name, have_proto;
+ bool have_name, have_proto, bad_proto;
int key = tmp;
s = skipspace(s);
s = scan_str(s,FALSE,FALSE);
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
- /* strip spaces */
+ /* strip spaces and check for bad characters */
d = SvPVX(PL_lex_stuff);
tmp = 0;
+ bad_proto = FALSE;
for (p = d; *p; ++p) {
- if (!isSPACE(*p))
+ if (!isSPACE(*p)) {
d[tmp++] = *p;
+ if (!strchr("$@%*;[]&\\", *p))
+ bad_proto = TRUE;
+ }
}
d[tmp] = '\0';
+ if (bad_proto && ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Illegal character in prototype for %s : %s",
+ SvPVX(PL_subname), d);
SvCUR(PL_lex_stuff) = tmp;
have_proto = TRUE;
force_next(THING);
}
if (!have_name) {
- sv_setpv(PL_subname,"__ANON__");
+ sv_setpv(PL_subname,
+ PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
TOKEN(ANONSUB);
}
(void) force_word(PL_oldbufptr + tboffset, WORD,
gv_fetchpv(SvPVX(sym),
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
- : TRUE
+ : GV_ADDMULTI
),
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
return s;
}
else {
+ bool readline_overriden = FALSE;
+ GV *gv_readline = Nullgv;
+ GV **gvp;
/* we're in a filehandle read situation */
d = PL_tokenbuf;
if (!len)
(void)strcpy(d,"ARGV");
+ /* Check whether readline() is overriden */
+ if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
+ && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
+ ||
+ ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
+ && (gv_readline = *gvp) != (GV*)&PL_sv_undef
+ && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
+ readline_overriden = TRUE;
+
/* if <$fh>, create the ops to turn the variable into a
filehandle
*/
else {
OP *o = newOP(OP_PADSV, 0);
o->op_targ = tmp;
- PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
+ PL_lex_op = readline_overriden
+ ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, o,
+ newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
+ : (OP*)newUNOP(OP_READLINE, 0, o);
}
}
else {
gv = gv_fetchpv(d,
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
- : TRUE),
+ : GV_ADDMULTI),
SVt_PV);
- PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
- newUNOP(OP_RV2SV, 0,
- newGVOP(OP_GV, 0, gv)));
- }
- PL_lex_op->op_flags |= OPf_SPECIAL;
+ PL_lex_op = readline_overriden
+ ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
+ newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
+ : (OP*)newUNOP(OP_READLINE, 0,
+ newUNOP(OP_RV2SV, 0,
+ newGVOP(OP_GV, 0, gv)));
+ }
+ if (!readline_overriden)
+ PL_lex_op->op_flags |= OPf_SPECIAL;
/* we created the ops in PL_lex_op, so make yylval.ival a null op */
yylval.ival = OP_NULL;
}
(<Foo::BAR> or <FOO>) so build a simple readline OP */
else {
GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
- PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
+ PL_lex_op = readline_overriden
+ ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ newGVOP(OP_GV, 0, gv),
+ newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
+ : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
yylval.ival = OP_NULL;
}
}
}
msg = sv_2mortal(newSVpv(s, 0));
Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+ OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
if (context)
Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
else
if (PL_error_count >= 10) {
if (PL_in_eval && SvCUR(ERRSV))
Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
- ERRSV, CopFILE(PL_curcop));
+ ERRSV, OutCopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
- CopFILE(PL_curcop));
+ OutCopFILE(PL_curcop));
}
PL_in_my = 0;
PL_in_my_stash = Nullhv;