X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=b0a5f5aa99a23a009ce82f1fca707155f146c40a;hb=f5dcdc4e9ffdc2db40dd34016d49d8d34c7ffcb9;hp=901ebd93ee3ba09548a0a041c952d71a302b0a45;hpb=f1f8f8925a02a6ca4f9ef21b150b369edc63630d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 901ebd9..b0a5f5a 100644 --- a/toke.c +++ b/toke.c @@ -1,6 +1,6 @@ /* 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. @@ -319,6 +319,22 @@ Perl_deprecate(pTHX_ char *s) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s); } +void +Perl_deprecate_old(pTHX_ char *s) +{ + /* This function should NOT be called for any new deprecated warnings */ + /* Use Perl_deprecate instead */ + /* */ + /* It is here to maintain backward compatibility with the pre-5.8 */ + /* warnings category hierarchy. The "deprecated" category used to */ + /* live under the "syntax" category. It is now a top-level category */ + /* in its own right. */ + + if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "Use of %s is deprecated", s); +} + /* * depcom * Deprecate a comma-less variable list. @@ -327,7 +343,7 @@ Perl_deprecate(pTHX_ char *s) STATIC void S_depcom(pTHX) { - deprecate("comma-less variable list"); + deprecate_old("comma-less variable list"); } /* @@ -1424,7 +1440,9 @@ S_scan_const(pTHX_ char *start) /* 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); @@ -1555,6 +1573,26 @@ S_scan_const(pTHX_ char *start) 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); @@ -1652,7 +1690,7 @@ S_scan_const(pTHX_ char *start) SvPOK_on(sv); if (PL_encoding && !has_utf8) { - Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding); + sv_recode_to_utf8(sv, PL_encoding); has_utf8 = TRUE; } if (has_utf8) { @@ -2180,7 +2218,7 @@ Perl_yylex(pTHX) 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 */ @@ -4005,7 +4043,8 @@ Perl_yylex(pTHX) if (strEQ(proto, "$")) OPERATOR(UNIOPSUB); if (*proto == '&' && *s == '{') { - sv_setpv(PL_subname,"__ANON__"); + sv_setpv(PL_subname, PL_curstash ? + "__ANON__" : "__ANON__::__ANON__"); PREBLOCK(LSTOPSUB); } } @@ -4986,7 +5025,8 @@ Perl_yylex(pTHX) 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, @@ -6421,7 +6461,7 @@ S_scan_heredoc(pTHX_ register char *s) else term = '"'; if (!isALNUM_lazy_if(s,UTF)) - deprecate("bare << to mean <<\"\""); + deprecate_old("bare << to mean <<\"\""); for (; isALNUM_lazy_if(s,UTF); s++) { if (d < e) *d++ = *s; @@ -6668,12 +6708,12 @@ S_scan_inputsymbol(pTHX_ char *start) (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) + 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)) + ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE)) && (gv_readline = *gvp) != (GV*)&PL_sv_undef - && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) + && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))) readline_overriden = TRUE; /* if <$fh>, create the ops to turn the variable into a @@ -6722,7 +6762,8 @@ intro_sym: newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv))); } - PL_lex_op->op_flags |= OPf_SPECIAL; + 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; } @@ -7579,7 +7620,7 @@ Perl_yyerror(pTHX_ char *s) } 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 @@ -7597,10 +7638,10 @@ Perl_yyerror(pTHX_ char *s) 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;