X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=77a213ed5f39588f2e65ae9966675dd2127198b8;hb=53273a086103cdbbf7ebdd5f1a18b2c0777cbc1b;hp=8a5c765bc70e74669fbd35c432c99af7583e7030;hpb=4026c95ac795414220d662f764bd6e993724505d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 8a5c765..77a213e 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -256,7 +256,8 @@ Perl_allocmy(pTHX_ char *name) off = pad_add_name(name, PL_in_my_stash, (PL_in_my == KEY_our - ? (PL_curstash ? PL_curstash : PL_defstash) + /* $_ is always in main::, even with our */ + ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : Nullhv ), 0 /* not fake */ @@ -2422,7 +2423,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) */ if (complement) { - U8 tmpbuf[UTF8_MAXLEN+1]; + U8 tmpbuf[UTF8_MAXBYTES+1]; UV *cp; UV nextmin = 0; New(1109, cp, 2*tlen, UV); @@ -2762,7 +2763,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) STRLEN plen; SV *pat = ((SVOP*)expr)->op_sv; char *p = SvPV(pat, plen); - if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) { + if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { sv_setpvn(pat, "\\s+", 3); p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; @@ -4044,7 +4045,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) if (SvPOK(cv)) Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv); else - Perl_sv_catpvf(aTHX_ msg, ": none"); + Perl_sv_catpv(aTHX_ msg, ": none"); sv_catpv(msg, " vs "); if (p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); @@ -4203,10 +4204,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } else aname = Nullch; - gv = gv_fetchpv(name ? name : (aname ? aname : - (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")), - GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), - SVt_PVCV); + gv = name ? gv_fetchsv(cSVOPo->op_sv, + GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), + SVt_PVCV) + : gv_fetchpv(aname ? aname + : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), + GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), + SVt_PVCV); if (o) SAVEFREEOP(o); @@ -4674,15 +4678,13 @@ void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { register CV *cv; - char *name; GV *gv; - STRLEN n_a; if (o) - name = SvPVx(cSVOPo->op_sv, n_a); + gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM); else - name = "STDOUT"; - gv = gv_fetchpv(name,TRUE, SVt_PVFM); + gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM); + #ifdef GV_UNIQUE_CHECK if (GvUNIQUE(gv)) { Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); @@ -4694,7 +4696,9 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + o ? "Format %"SVf" redefined" + : "Format STDOUT redefined" ,cSVOPo->op_sv); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -5108,11 +5112,9 @@ Perl_ck_rvconst(pTHX_ register OP *o) o->op_private |= (PL_hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { - char *name; int iscv; GV *gv; SV *kidsv = kid->op_sv; - STRLEN n_a; /* Is it a constant from cv_const_sv()? */ if (SvROK(kidsv) && SvREADONLY(kidsv)) { @@ -5142,7 +5144,6 @@ Perl_ck_rvconst(pTHX_ register OP *o) Perl_croak(aTHX_ "Constant is not %s reference", badtype); return o; } - name = SvPV(kidsv, n_a); if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { char *badthing = Nullch; switch (o->op_type) { @@ -5158,8 +5159,8 @@ Perl_ck_rvconst(pTHX_ register OP *o) } if (badthing) Perl_croak(aTHX_ - "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", - name, badthing); + "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", + kidsv, badthing); } /* * This is a little tricky. We only want to add the symbol if we @@ -5171,7 +5172,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) */ iscv = (o->op_type == OP_RV2CV) * 2; do { - gv = gv_fetchpv(name, + gv = gv_fetchsv(kidsv, iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV @@ -5214,9 +5215,8 @@ Perl_ck_ftst(pTHX_ OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - STRLEN n_a; OP *newop = newGVOP(type, OPf_REF, - gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO)); + gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO)); op_free(o); o = newop; return o; @@ -5258,7 +5258,6 @@ Perl_ck_fun(pTHX_ OP *o) } if (o->op_flags & OPf_KIDS) { - STRLEN n_a; tokid = &cLISTOPo->op_first; kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || @@ -5301,13 +5300,12 @@ Perl_ck_fun(pTHX_ OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newAVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE, SVt_PVAV) )); + gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) )); if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Array @%s missing the @ in argument %"IVdf" of %s()", - name, (IV)numargs, PL_op_desc[type]); + "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", + ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -5321,13 +5319,12 @@ Perl_ck_fun(pTHX_ OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newHVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE, SVt_PVHV) )); + gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) )); if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Hash %%%s missing the %% in argument %"IVdf" of %s()", - name, (IV)numargs, PL_op_desc[type]); + "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", + ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -5354,8 +5351,7 @@ Perl_ck_fun(pTHX_ OP *o) (kid->op_private & OPpCONST_BARE)) { OP *newop = newGVOP(OP_GV, 0, - gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, - SVt_PVIO) ); + gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) ); if (!(o->op_private & 1) && /* if not unop */ kid == cLISTOPo->op_last) cLISTOPo->op_last = newop; @@ -6028,6 +6024,7 @@ S_simplify_sort(pTHX_ OP *o) OP *k; int descending; GV *gv; + const char *gvname; if (!(o->op_flags & OPf_STACKED)) return; GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); @@ -6054,9 +6051,10 @@ S_simplify_sort(pTHX_ OP *o) gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) return; - if (strEQ(GvNAME(gv), "a")) + gvname = GvNAME(gv); + if (*gvname == 'a' && gvname[1] == '\0') descending = 0; - else if (strEQ(GvNAME(gv), "b")) + else if (*gvname == 'b' && gvname[1] == '\0') descending = 1; else return; @@ -6069,10 +6067,12 @@ S_simplify_sort(pTHX_ OP *o) return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; - if (GvSTASH(gv) != PL_curstash - || ( descending - ? strNE(GvNAME(gv), "a") - : strNE(GvNAME(gv), "b"))) + if (GvSTASH(gv) != PL_curstash) + return; + gvname = GvNAME(gv); + if ( descending + ? !(*gvname == 'a' && gvname[1] == '\0') + : !(*gvname == 'b' && gvname[1] == '\0')) return; o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); if (descending) @@ -6272,9 +6272,7 @@ Perl_ck_subr(pTHX_ OP *o) OP *sibling = o2->op_sibling; SV *n = newSVpvn("",0); op_free(o2); - gv_fullname3(n, gv, ""); - if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6)) - sv_chop(n, SvPVX(n)+6); + gv_fullname4(n, gv, "", FALSE); o2 = newSVOP(OP_CONST, 0, n); prev->op_sibling = o2; o2->op_sibling = sibling;