X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=caf1d8433d4e95c50a356cca53c147a75c4156c6;hb=5c144d81801caa5e8317f6a38b40eb08257c47ea;hp=1afdbc00dd00bb93973d1b593ab80b4ab76a2555;hpb=c69006e4a4556d3b1d6e1a57c49a95b1d16efeb0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 1afdbc0..caf1d84 100644 --- a/op.c +++ b/op.c @@ -407,18 +407,21 @@ clear_pmop: { HV *pmstash = PmopSTASH(cPMOPo); if (pmstash && SvREFCNT(pmstash)) { - PMOP *pmop = HvPMROOT(pmstash); - PMOP *lastpmop = NULL; - while (pmop) { - if (cPMOPo == pmop) { - if (lastpmop) - lastpmop->op_pmnext = pmop->op_pmnext; - else - HvPMROOT(pmstash) = pmop->op_pmnext; - break; + MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); + if (mg) { + PMOP *pmop = (PMOP*) mg->mg_obj; + PMOP *lastpmop = NULL; + while (pmop) { + if (cPMOPo == pmop) { + if (lastpmop) + lastpmop->op_pmnext = pmop->op_pmnext; + else + mg->mg_obj = (SV*) pmop->op_pmnext; + break; + } + lastpmop = pmop; + pmop = pmop->op_pmnext; } - lastpmop = pmop; - pmop = pmop->op_pmnext; } } PmopSTASH_free(cPMOPo); @@ -782,9 +785,9 @@ Perl_scalarvoid(pTHX_ OP *o) built upon these three nroff macros being used in void context. The pink camel has the details in the script wrapman near page 319. */ - if (strnEQ(SvPVX(sv), "di", 2) || - strnEQ(SvPVX(sv), "ds", 2) || - strnEQ(SvPVX(sv), "ig", 2)) + if (strnEQ(SvPVX_const(sv), "di", 2) || + strnEQ(SvPVX_const(sv), "ds", 2) || + strnEQ(SvPVX_const(sv), "ig", 2)) useless = 0; } } @@ -1376,12 +1379,12 @@ S_scalar_mod_type(pTHX_ const OP *o, I32 type) } STATIC bool -S_is_handle_constructor(pTHX_ const OP *o, I32 argnum) +S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) { switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: - if (argnum == 2) + if (numargs == 2) return TRUE; /* FALL THROUGH */ case OP_SYSOPEN: @@ -1390,7 +1393,7 @@ S_is_handle_constructor(pTHX_ const OP *o, I32 argnum) case OP_SOCKET: case OP_OPEN_DIR: case OP_ACCEPT: - if (argnum == 1) + if (numargs == 1) return TRUE; /* FALL THROUGH */ default: @@ -1531,18 +1534,14 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) /* fake up C */ ENTER; /* need to protect against side-effects of 'use' */ SAVEINT(PL_expect); - if (stash) - stashsv = newSVpv(HvNAME(stash), 0); - else - stashsv = &PL_sv_no; + stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" if (for_my) { - SV **svp; /* Don't force the C if we don't need it. */ - svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, + SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, sizeof(ATTRSMODULE_PM)-1, 0); if (svp && *svp != &PL_sv_undef) ; /* already in %INC */ @@ -1585,10 +1584,8 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); /* Build up the real arg-list. */ - if (stash) - stashsv = newSVpv(HvNAME(stash), 0); - else - stashsv = &PL_sv_no; + stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; + arg = newOP(OP_PADSV, 0); arg->op_targ = target->op_targ; arg = prepend_elem(OP_LIST, @@ -1600,11 +1597,11 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) /* Fake up a method call to import */ meth = newSVpvn("import", 6); - (void)SvUPGRADE(meth, SVt_PVIV); + SvUPGRADE(meth, SVt_PVIV); (void)SvIOK_on(meth); { U32 hash; - PERL_HASH(hash, SvPVX(meth), SvCUR(meth)); + PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth)); SvUV_set(meth, hash); } imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, @@ -2366,9 +2363,8 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) return fold_constants((OP *)binop); } -static int uvcompare(const void *a, const void *b) __attribute__((nonnull,pure)); -static int -uvcompare(const void *a, const void *b) +static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__; +static int uvcompare(const void *a, const void *b) { if (*((const UV *)a) < (*(const UV *)b)) return -1; @@ -2388,8 +2384,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SV *rstr = ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; - U8 *t = (U8*)SvPV(tstr, tlen); - U8 *r = (U8*)SvPV(rstr, rlen); + const U8 *t = (U8*)SvPV_const(tstr, tlen); + const U8 *r = (U8*)SvPV_const(rstr, rlen); register I32 i; register I32 j; I32 del; @@ -2412,8 +2408,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SV* listsv = newSVpvn("# comment\n",10); SV* transv = 0; - U8* tend = t + tlen; - U8* rend = r + rlen; + const U8* tend = t + tlen; + const U8* rend = r + rlen; STRLEN ulen; UV tfirst = 1; UV tlast = 0; @@ -2434,12 +2430,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (!from_utf) { STRLEN len = tlen; - tsave = t = bytes_to_utf8(t, &len); + t = tsave = bytes_to_utf8(t, &len); tend = t + len; } if (!to_utf && rlen) { STRLEN len = rlen; - rsave = r = bytes_to_utf8(r, &len); + r = rsave = bytes_to_utf8(r, &len); rend = r + len; } @@ -2725,8 +2721,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) /* link into pm list */ if (type != OP_TRANS && PL_curstash) { - pmop->op_pmnext = HvPMROOT(PL_curstash); - HvPMROOT(PL_curstash) = pmop; + MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); + + if (!mg) { + mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); + } + pmop->op_pmnext = (PMOP*)mg->mg_obj; + mg->mg_obj = (SV*)pmop; PmopSTASH_set(pmop,PL_curstash); } @@ -2791,15 +2792,31 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) if (expr->op_type == OP_CONST) { STRLEN plen; SV *pat = ((SVOP*)expr)->op_sv; - char *p = SvPV(pat, plen); + const char *p = SvPV_const(pat, plen); if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { + U32 was_readonly = SvREADONLY(pat); + + if (was_readonly) { + if (SvFAKE(pat)) { + sv_force_normal_flags(pat, 0); + assert(!SvREADONLY(pat)); + was_readonly = 0; + } else { + SvREADONLY_off(pat); + } + } + sv_setpvn(pat, "\\s+", 3); - p = SvPV(pat, plen); + + SvFLAGS(pat) |= was_readonly; + + p = SvPV_const(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } if (DO_UTF8(pat)) pm->op_pmdynflags |= PMdf_UTF8; - PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm)); + /* FIXME - can we make this function take const char * args? */ + PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); if (strEQ("\\s+", PM_GETRE(pm)->precomp)) pm->op_pmflags |= PMf_WHITE; op_free(expr); @@ -2995,7 +3012,7 @@ Perl_package(pTHX_ OP *o) save_hptr(&PL_curstash); save_item(PL_curstname); - name = SvPV(cSVOPo->op_sv, len); + name = SvPV_const(cSVOPo->op_sv, len); PL_curstash = gv_stashpvn(name, len, TRUE); sv_setpvn(PL_curstname, name, len); op_free(o); @@ -3039,7 +3056,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) (void)SvIOK_on(meth); { U32 hash; - PERL_HASH(hash, SvPVX(meth), SvCUR(meth)); + PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth)); SvUV_set(meth, hash); } veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, @@ -3063,11 +3080,11 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) /* Fake up a method call to import/unimport */ meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8); - (void)SvUPGRADE(meth, SVt_PVIV); + SvUPGRADE(meth, SVt_PVIV); (void)SvIOK_on(meth); { U32 hash; - PERL_HASH(hash, SvPVX(meth), SvCUR(meth)); + PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth)); SvUV_set(meth, hash); } imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, @@ -3219,7 +3236,7 @@ Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) } STATIC I32 -S_list_assignment(pTHX_ register const OP *o) +S_is_list_assignment(pTHX_ register const OP *o) { if (!o) return TRUE; @@ -3228,8 +3245,8 @@ S_list_assignment(pTHX_ register const OP *o) o = cUNOPo->op_first; if (o->op_type == OP_COND_EXPR) { - const I32 t = list_assignment(cLOGOPo->op_first->op_sibling); - const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); + const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); + const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); if (t && f) return TRUE; @@ -3274,7 +3291,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } - if (list_assignment(left)) { + if (is_list_assignment(left)) { OP *curop; PL_modcount = 0; @@ -4008,7 +4025,7 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) o = newOP(type, OPf_SPECIAL); else { o = newPVOP(type, 0, savepv(label->op_type == OP_CONST - ? SvPVx(((SVOP*)label)->op_sv, n_a) + ? SvPVx_const(((SVOP*)label)->op_sv, n_a) : "")); } op_free(label); @@ -4056,6 +4073,7 @@ Perl_cv_undef(pTHX_ CV *cv) op_free(CvROOT(cv)); CvROOT(cv) = Nullop; + CvSTART(cv) = Nullop; LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ @@ -4083,7 +4101,7 @@ Perl_cv_undef(pTHX_ CV *cv) void Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) { - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { + if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4233,16 +4251,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) STRLEN n_a; const char *aname; GV *gv; - char *ps; + const char *ps; STRLEN ps_len; register CV *cv=0; SV *const_sv; - const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; + const char * const name = o ? SvPVx_const(cSVOPo->op_sv, n_a) : Nullch; if (proto) { assert(proto->op_type == OP_CONST); - ps = SvPVx(((SVOP*)proto)->op_sv, ps_len); + ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); } else ps = Nullch; @@ -4252,7 +4270,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - aname = SvPVX(sv); + aname = SvPVX_const(sv); } else aname = Nullch; @@ -4502,9 +4520,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); gv_efullname3(tmpstr, gv, Nullch); - hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); - if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) + if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr)) && (pcv = GvCV(db_postponed))) { dSP; @@ -4646,8 +4664,9 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ + /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */ if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv)) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) { + && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) { const line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); @@ -4900,11 +4919,7 @@ Perl_oopsCV(pTHX_ OP *o) Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__); /* STUB */ (void)o; -#ifndef HASATTRIBUTE - /* No __attribute__, so the compiler doesn't know that croak never returns - */ - return 0; -#endif + NORETURN_FUNCTION_END; } OP * @@ -4957,8 +4972,8 @@ Perl_ck_bitop(pTHX_ OP *o) || o->op_type == OP_BIT_AND || o->op_type == OP_BIT_XOR)) { - const OP * left = cBINOPo->op_first; - const OP * right = left->op_sibling; + const OP * const left = cBINOPo->op_first; + const OP * const right = left->op_sibling; if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && @@ -5159,17 +5174,6 @@ Perl_ck_exists(pTHX_ OP *o) return o; } -#if 0 -OP * -Perl_ck_gvconst(pTHX_ register OP *o) -{ - o = fold_constants(o); - if (o->op_type == OP_CONST) - o->op_type = OP_GV; - return o; -} -#endif - OP * Perl_ck_rvconst(pTHX_ register OP *o) { @@ -5180,12 +5184,12 @@ Perl_ck_rvconst(pTHX_ register OP *o) if (kid->op_type == OP_CONST) { int iscv; GV *gv; - SV *kidsv = kid->op_sv; + SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ if (SvROK(kidsv) && SvREADONLY(kidsv)) { SV *rsv = SvRV(kidsv); - int svtype = SvTYPE(rsv); + const int svtype = SvTYPE(rsv); const char *badtype = Nullch; switch (o->op_type) { @@ -5512,7 +5516,7 @@ Perl_ck_fun(pTHX_ OP *o) SV *namesv; targ = pad_alloc(OP_RV2GV, SVs_PADTMP); namesv = PAD_SVl(targ); - (void)SvUPGRADE(namesv, SVt_PV); + SvUPGRADE(namesv, SVt_PV); if (*name != '$') sv_setpvn(namesv, "$", 1); sv_catpvn(namesv, name, len); @@ -5838,10 +5842,10 @@ Perl_ck_method(pTHX_ OP *o) OP *kid = cUNOPo->op_first; if (kid->op_type == OP_CONST) { SV* sv = kSVOP->op_sv; - if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { + if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) { OP *cmop; if (!SvREADONLY(sv) || !SvFAKE(sv)) { - sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0); + sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0); } else { kSVOP->op_sv = Nullsv; @@ -5893,7 +5897,7 @@ Perl_ck_open(pTHX_ OP *o) OP *first = cLISTOPx(o)->op_first; /* The pushmark. */ OP *last = cLISTOPx(o)->op_last; /* The bareword. */ OP *oa; - char *mode; + const char *mode; if ((last->op_type == OP_CONST) && /* The bareword. */ (last->op_private & OPpCONST_BARE) && @@ -5901,7 +5905,7 @@ Perl_ck_open(pTHX_ OP *o) (oa = first->op_sibling) && /* The fh. */ (oa = oa->op_sibling) && /* The mode. */ SvPOK(((SVOP*)oa)->op_sv) && - (mode = SvPVX(((SVOP*)oa)->op_sv)) && + (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && mode[0] == '>' && mode[1] == '&' && /* A dup open. */ (last == oa->op_sibling)) /* The bareword. */ last->op_private &= ~OPpCONST_STRICT; @@ -5930,21 +5934,29 @@ Perl_ck_require(pTHX_ OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { + SV *sv = kid->op_sv; + U32 was_readonly = SvREADONLY(sv); char *s; - for (s = SvPVX(kid->op_sv); *s; s++) { + + if (was_readonly) { + if (SvFAKE(sv)) { + sv_force_normal_flags(sv, 0); + assert(!SvREADONLY(sv)); + was_readonly = 0; + } else { + SvREADONLY_off(sv); + } + } + + for (s = SvPVX(sv); *s; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; Move(s+2, s+1, strlen(s+2)+1, char); - SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1); + SvCUR_set(sv, SvCUR(sv) - 1); } } - if (SvREADONLY(kid->op_sv)) { - SvREADONLY_off(kid->op_sv); - sv_catpvn(kid->op_sv, ".pm", 3); - SvREADONLY_on(kid->op_sv); - } - else - sv_catpvn(kid->op_sv, ".pm", 3); + sv_catpvn(sv, ".pm", 3); + SvFLAGS(sv) |= was_readonly; } } @@ -6676,7 +6688,7 @@ Perl_peep(pTHX_ register OP *o) } else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { GV *gv = cGVOPo_gv; - if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) { + if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ SV *sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); @@ -6802,7 +6814,7 @@ Perl_peep(pTHX_ register OP *o) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", - key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname))); + key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); } break; @@ -6859,7 +6871,7 @@ Perl_peep(pTHX_ register OP *o) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", - key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname))); + key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); } } break; @@ -7131,7 +7143,7 @@ const_sv_xsub(pTHX_ CV* cv) if (items != 0) { #if 0 Perl_croak(aTHX_ "usage: %s::%s()", - HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); + HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } EXTEND(sp, 1); @@ -7146,5 +7158,5 @@ const_sv_xsub(pTHX_ CV* cv) * indent-tabs-mode: t * End: * - * vim: shiftwidth=4: -*/ + * ex: set ts=8 sts=4 sw=4 noet: + */