X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=b0a5f5aa99a23a009ce82f1fca707155f146c40a;hb=f5dcdc4e9ffdc2db40dd34016d49d8d34c7ffcb9;hp=46f87dd047d19782fcfc2cfc6b0042eacfa19f23;hpb=b239daa517b7055c05115178e7b786d4d4679731;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 46f87dd..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"); } /* @@ -514,11 +530,7 @@ S_incline(pTHX_ char *s) 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; @@ -634,6 +646,8 @@ S_skipspace(pTHX_ register char *s) sv_upgrade(sv, SVt_PVMG); sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } } @@ -1426,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); @@ -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) { @@ -1978,7 +2014,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) 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); @@ -1990,7 +2026,7 @@ void 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 */ @@ -2060,7 +2096,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) 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 */ @@ -2182,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 */ @@ -2440,7 +2476,7 @@ Perl_yylex(pTHX) 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...*/ @@ -2469,6 +2505,8 @@ Perl_yylex(pTHX) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } goto retry; @@ -2552,6 +2590,8 @@ Perl_yylex(pTHX) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -2592,7 +2632,7 @@ Perl_yylex(pTHX) * at least, set argv[0] to the basename of the Perl * interpreter. So, having found "#!", we'll set it right. */ - SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); + SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */ assert(SvPOK(x) || SvGMAGICAL(x)); if (sv_eq(x, CopFILESV(PL_curcop))) { sv_setpvn(x, ipath, ipathend - ipath); @@ -2682,6 +2722,7 @@ Perl_yylex(pTHX) while (SPACE_OR_TAB(*d)) d++; if (*d++ == '-') { + bool switches_done = PL_doswitches; do { if (*d == 'M' || *d == 'm') { char *m = d; @@ -2705,6 +2746,14 @@ Perl_yylex(pTHX) (void)gv_fetchfile(PL_origfilename); goto retry; } + if (PL_doswitches && !switches_done) { + int argc = PL_origargc; + char **argv = PL_origargv; + do { + argc--,argv++; + } while (argc && argv[0][0] == '-' && argv[0][1]); + init_argv_symbols(argc,argv); + } } } } @@ -3798,6 +3847,10 @@ Perl_yylex(pTHX) } 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 @@ -3990,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); } } @@ -4889,7 +4943,7 @@ Perl_yylex(pTHX) 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); @@ -4937,14 +4991,22 @@ Perl_yylex(pTHX) 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; @@ -4963,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, @@ -5206,7 +5269,7 @@ S_pending_ident(pTHX) gv_fetchpv(SvPVX(sym), (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) - : TRUE + : GV_ADDMULTI ), ((PL_tokenbuf[0] == '$') ? SVt_PV : (PL_tokenbuf[0] == '@') ? SVt_PVAV @@ -6398,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; @@ -6533,6 +6596,8 @@ S_scan_heredoc(pTHX_ register char *s) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv); } if (*s == term && memEQ(s,PL_tokenbuf,len)) { @@ -6632,6 +6697,9 @@ S_scan_inputsymbol(pTHX_ char *start) return s; } else { + bool readline_overriden = FALSE; + GV *gv_readline = Nullgv; + GV **gvp; /* we're in a filehandle read situation */ d = PL_tokenbuf; @@ -6639,6 +6707,15 @@ S_scan_inputsymbol(pTHX_ char *start) 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 */ @@ -6660,7 +6737,11 @@ S_scan_inputsymbol(pTHX_ char *start) 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 { @@ -6670,13 +6751,19 @@ intro_sym: 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; } @@ -6685,7 +6772,12 @@ intro_sym: ( or ) 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; } } @@ -6883,6 +6975,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv); } @@ -7203,7 +7297,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } if (*s == '.' && isDIGIT(s[1])) { /* oops, it's really a v-string, but without the "v" */ - s = start - 1; + s = start; goto vstring; } } @@ -7297,58 +7391,8 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* if it starts with a v, it could be a v-string */ case 'v': vstring: - { - char *pos = s; - pos++; - while (isDIGIT(*pos) || *pos == '_') - pos++; - if (!isALPHA(*pos)) { - UV rev; - U8 tmpbuf[UTF8_MAXLEN+1]; - U8 *tmpend; - s++; /* get past 'v' */ - - sv = NEWSV(92,5); - sv_setpvn(sv, "", 0); - - for (;;) { - if (*s == '0' && isDIGIT(s[1])) - yyerror("Octal number in vector unsupported"); - rev = 0; - { - /* this is atoi() that tolerates underscores */ - char *end = pos; - UV mult = 1; - while (--end >= s) { - UV orev; - if (*end == '_') - continue; - orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if (orev > rev && ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in decimal number"); - } - } - /* Append native character for the rev point */ - tmpend = uvchr_to_utf8(tmpbuf, rev); - sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) - SvUTF8_on(sv); - if (*pos == '.' && isDIGIT(pos[1])) - s = ++pos; - else { - s = pos; - break; - } - while (isDIGIT(*pos) || *pos == '_') - pos++; - } - SvPOK_on(sv); - SvREADONLY_on(sv); - } - } + sv = NEWSV(92,5); /* preallocate storage space */ + s = new_vstring(s,sv); break; } @@ -7576,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 @@ -7594,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;