X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=82b7e0d651e214b352cfbe2671623810bfb61717;hb=03bfcac8f4be6db5e31d8e504887b86016c2bc4e;hp=9d3acd212a26235714a51af30ad114630f7541af;hpb=eb1102fcca2230364ceadea29bd8e87ee51b15fa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 9d3acd2..82b7e0d 100644 --- a/toke.c +++ b/toke.c @@ -316,7 +316,23 @@ void Perl_deprecate(pTHX_ char *s) { if (ckWARN(WARN_DEPRECATED)) - Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s); + Perl_warner(aTHX_ packWARN(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); } /* @@ -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"); } /* @@ -662,7 +678,7 @@ S_check_uni(pTHX) if (ckWARN_d(WARN_AMBIGUOUS)){ char ch = *s; *s = '\0'; - Perl_warner(aTHX_ WARN_AMBIGUOUS, + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni); *s = ch; @@ -1401,7 +1417,7 @@ S_scan_const(pTHX_ char *start) isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); *--s = '$'; break; } @@ -1427,7 +1443,7 @@ S_scan_const(pTHX_ char *start) if (ckWARN(WARN_MISC) && isALNUM(*s) && *s != '_') - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "Unrecognized escape \\%c passed through", *s); /* default action is to copy the quoted character */ @@ -1557,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); @@ -1654,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) { @@ -2534,9 +2570,6 @@ Perl_yylex(pTHX) } } if (PL_doextract) { - if (*s == '#' && s[1] == '!' && instr(s,"perl")) - PL_doextract = FALSE; - /* Incest with pod. */ if (*s == '=' && strnEQ(s, "=cut", 4)) { sv_setpv(PL_linestr, ""); @@ -3268,7 +3301,7 @@ Perl_yylex(pTHX) && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart) { CopLINE_dec(PL_curcop); - Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi); + Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); CopLINE_inc(PL_curcop); } BAop(OP_BIT_AND); @@ -3301,7 +3334,7 @@ Perl_yylex(pTHX) if (tmp == '~') PMop(OP_MATCH); if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) - Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp); s--; if (PL_expect == XSTATE && isALPHA(tmp) && (s == PL_linestart+1 || s[-2] == '\n') ) @@ -3445,7 +3478,7 @@ Perl_yylex(pTHX) PL_bufptr = skipspace(PL_bufptr); while (t < PL_bufend && *t != ']') t++; - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Multidimensional syntax %.*s not supported", (t - PL_bufptr) + 1, PL_bufptr); } @@ -3463,7 +3496,7 @@ Perl_yylex(pTHX) t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); for (; isSPACE(*t); t++) ; if (*t == ';' && get_cv(tmpbuf, FALSE)) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "You need to quote \"%s\"", tmpbuf); } } @@ -3542,7 +3575,7 @@ Perl_yylex(pTHX) if (*t == '}' || *t == ']') { t++; PL_bufptr = skipspace(PL_bufptr); - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Scalar value %.*s better written as $%.*s", t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1); } @@ -3669,7 +3702,7 @@ Perl_yylex(pTHX) case '\\': s++; if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s)) - Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression", + Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", *s, *s); if (PL_expect == XOPERATOR) no_op("Backslash",s); @@ -3812,14 +3845,14 @@ Perl_yylex(pTHX) else { /* no override */ tmp = -tmp; if (tmp == KEY_dump && ckWARN(WARN_MISC)) { - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "dump() better written as CORE::dump()"); } gv = Nullgv; gvp = 0; if (ckWARN(WARN_AMBIGUOUS) && hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ - Perl_warner(aTHX_ WARN_AMBIGUOUS, + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous call resolved as CORE::%s(), %s", GvENAME(hgv), "qualify as such or use &"); } @@ -3850,7 +3883,7 @@ Perl_yylex(pTHX) if (PL_expect == XOPERATOR) { if (PL_bufptr == PL_linestart) { CopLINE_dec(PL_curcop); - Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi); + Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); CopLINE_inc(PL_curcop); } else @@ -3865,7 +3898,7 @@ Perl_yylex(pTHX) PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) - Perl_warner(aTHX_ WARN_BAREWORD, + Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword \"%s\" refers to nonexistent package", PL_tokenbuf); len -= 2; @@ -3979,7 +4012,7 @@ Perl_yylex(pTHX) if (gv && GvCVu(gv)) { CV* cv; if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS)) - Perl_warner(aTHX_ WARN_AMBIGUOUS, + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ @@ -4007,7 +4040,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); } } @@ -4027,7 +4061,7 @@ Perl_yylex(pTHX) if (lastchar != '-') { for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; if (!*d && strNE(PL_tokenbuf,"main")) - Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved, + Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, PL_tokenbuf); } } @@ -4035,10 +4069,10 @@ Perl_yylex(pTHX) safe_bareword: if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) { - Perl_warner(aTHX_ WARN_AMBIGUOUS, + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Operator or semicolon missing before %c%s", lastchar, PL_tokenbuf); - Perl_warner(aTHX_ WARN_AMBIGUOUS, + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c resolved as operator %c", lastchar, lastchar); } @@ -4577,7 +4611,7 @@ Perl_yylex(pTHX) for (d = s; isALNUM_lazy_if(d,UTF); d++) ; t = skipspace(d); if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)) - Perl_warner(aTHX_ WARN_PRECEDENCE, + Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), "Precedence problem: open %.*s should be open(%.*s)", d-s,s, d-s,s); } @@ -4653,12 +4687,12 @@ Perl_yylex(pTHX) if (!warned && ckWARN(WARN_QW)) { for (; !isSPACE(*d) && len; --len, ++d) { if (*d == ',') { - Perl_warner(aTHX_ WARN_QW, + Perl_warner(aTHX_ packWARN(WARN_QW), "Possible attempt to separate words with commas"); ++warned; } else if (*d == '#') { - Perl_warner(aTHX_ WARN_QW, + Perl_warner(aTHX_ packWARN(WARN_QW), "Possible attempt to put comments in qw() list"); ++warned; } @@ -4967,7 +5001,7 @@ Perl_yylex(pTHX) } d[tmp] = '\0'; if (bad_proto && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Illegal character in prototype for %s : %s", SvPVX(PL_subname), d); SvCUR(PL_lex_stuff) = tmp; @@ -4988,7 +5022,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, @@ -5273,7 +5308,7 @@ S_pending_ident(pTHX) && ckWARN(WARN_AMBIGUOUS)) { /* Downgraded from fatal to warning 20000522 mjd */ - Perl_warner(aTHX_ WARN_AMBIGUOUS, + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Possible unintended interpolation of %s in string", PL_tokenbuf); } @@ -5909,7 +5944,7 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what) if (*w) for (; *w && isSPACE(*w); w++) ; if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (...) interpreted as function",name); } } @@ -6182,7 +6217,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { const char *brack = *s == '[' ? "[...]" : "{...}"; - Perl_warner(aTHX_ WARN_AMBIGUOUS, + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); } @@ -6214,7 +6249,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest) || get_cv(dest, FALSE))) { - Perl_warner(aTHX_ WARN_AMBIGUOUS, + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); } @@ -6423,7 +6458,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; @@ -6724,7 +6759,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; } @@ -7061,7 +7097,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if (*s == '_') { if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; } @@ -7085,7 +7121,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* _ are ignored -- but warned about if consecutive */ case '_': if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; break; @@ -7128,7 +7164,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) overflowed = TRUE; n = (NV) u; if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), "Integer overflow in %s number", base); } else @@ -7158,13 +7194,13 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* final misplaced underbar check */ if (s[-1] == '_') { if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } sv = NEWSV(92,0); if (overflowed) { if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) - Perl_warner(aTHX_ WARN_PORTABLE, + Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", Base, max); sv_setnv(sv, n); @@ -7172,7 +7208,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) else { #if UVSIZE > 4 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) - Perl_warner(aTHX_ WARN_PORTABLE, + Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", Base, max); #endif @@ -7201,7 +7237,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) */ if (*s == '_') { if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; } @@ -7217,7 +7253,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* final misplaced underbar check */ if (lastub && s == lastub + 1) { if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } /* read a decimal portion if there is one. avoid @@ -7230,7 +7266,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if (*s == '_') { if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s; } @@ -7243,7 +7279,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) Perl_croak(aTHX_ number_too_long); if (*s == '_') { if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s; } @@ -7253,7 +7289,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* fractional part ending in underbar? */ if (s[-1] == '_') { if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } if (*s == '.' && isDIGIT(s[1])) { @@ -7274,7 +7310,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* stray preinitial _ */ if (*s == '_') { if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; } @@ -7286,7 +7322,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* stray initial _ */ if (*s == '_') { if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; } @@ -7302,7 +7338,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if (ckWARN(WARN_SYNTAX) && ((lastub && s == lastub + 1) || (!isDIGIT(s[1]) && s[1] != '_'))) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; } @@ -7581,7 +7617,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 @@ -7599,10 +7635,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;