/* 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);
IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
IoFLAGS(datasv) |= IOf_FAKE_DIRP;
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
- funcp, SvPV_nolen(datasv)));
+ (void*)funcp, SvPV_nolen(datasv)));
av_unshift(PL_rsfp_filters, 1);
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
Perl_filter_del(pTHX_ filter_t funcp)
{
SV *datasv;
- DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
+ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
funcp = (filter_t)IoANY(datasv);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
- idx, funcp, SvPV_nolen(datasv)));
+ idx, (void*)funcp, SvPV_nolen(datasv)));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
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 */
if (PL_minus_F) {
if (strchr("/'\"", *PL_splitstr)
&& strchr(PL_splitstr + 1, *PL_splitstr))
- Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
+ Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
else {
char delim;
s = "'~#\200\1'"; /* surely one char is unused...*/
}
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
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;
gv_fetchpv(SvPVX(sym),
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
- : TRUE
+ : GV_ADDMULTI
),
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
if (strEQ(d,"cos")) return -KEY_cos;
break;
case 4:
- if (strEQ(d,"chop")) return KEY_chop;
+ if (strEQ(d,"chop")) return -KEY_chop;
break;
case 5:
if (strEQ(d,"close")) return -KEY_close;
if (strEQ(d,"chdir")) return -KEY_chdir;
- if (strEQ(d,"chomp")) return KEY_chomp;
+ if (strEQ(d,"chomp")) return -KEY_chomp;
if (strEQ(d,"chmod")) return -KEY_chmod;
if (strEQ(d,"chown")) return -KEY_chown;
if (strEQ(d,"crypt")) return -KEY_crypt;
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 = 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)));
}
PL_lex_op->op_flags |= OPf_SPECIAL;
/* we created the ops in PL_lex_op, so make yylval.ival a null op */
(<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;
https://perl5.git.perl.org / perl5.git / blobdiff