add CvSTASH_set() macro and make CvSTASH() rvalue only

Now that CvSTASH requires backreference bookkeeping, stop people from
directly assigning to it (by using CvSTASH() as an lvalue), and instead
force them to use CvSTASH_set().

diff --git a/cv.h b/cv.h
index e6f5cba..6fdf5cb 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -36,7 +36,8 @@ Returns the stash of the CV.
 #  define Nullcv Null(CV*)
 #endif
 
-#define CvSTASH(sv)    ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_stash
+#define CvSTASH(sv)    (0+((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_stash)
+#define CvSTASH_set(cv,st) Perl_cvstash_set(aTHX_ cv, st)
 #define CvSTART(sv)    ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_start_u.xcv_start
 #define CvROOT(sv)     ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_root
 #define CvXSUB(sv)     ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_xsub

diff --git a/embed.fnc b/embed.fnc
index e08b76a..700e5da 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -438,6 +438,7 @@ Ap  |void   |gv_fullname4   |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool
 : Used in scope.c
 pMox   |GP *   |newGP          |NN GV *const gv
 pX     |void   |cvgv_set       |NN CV* cv|NULLOK GV* gv
+pX     |void   |cvstash_set    |NN CV* cv|NULLOK HV* stash
 Ap     |void   |gv_init        |NN GV* gv|NULLOK HV* stash|NN const char* name|STRLEN len|int multi
 Ap     |void   |gv_name_set    |NN GV* gv|NN const char *name|U32 len|U32 flags
 XMpd   |void   |gv_try_downgrade|NN GV* gv

diff --git a/embed.h b/embed.h
index 10eba36..c17baef 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -960,6 +960,7 @@
 #define cv_ckproto_len(a,b,c,d)        Perl_cv_ckproto_len(aTHX_ a,b,c,d)
 #define cv_clone(a)            Perl_cv_clone(aTHX_ a)
 #define cvgv_set(a,b)          Perl_cvgv_set(aTHX_ a,b)
+#define cvstash_set(a,b)       Perl_cvstash_set(aTHX_ a,b)
 #define deb_stack_all()                Perl_deb_stack_all(aTHX)
 #define delete_eval_scope()    Perl_delete_eval_scope(aTHX)
 #define die_unwind(a)          Perl_die_unwind(aTHX_ a)

diff --git a/global.sym b/global.sym
index d8eae72..692991d 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -72,6 +72,7 @@ Perl_cv_get_call_checker
 Perl_cv_set_call_checker
 Perl_cv_undef
 Perl_cvgv_set
+Perl_cvstash_set
 Perl_cx_dump
 Perl_cxinc
 Perl_deb

diff --git a/gv.c b/gv.c
index 6d55245..ab43177 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -235,6 +235,21 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
     }
 }
 
+/* Assign CvSTASH(cv) = st, handling weak references. */
+
+void
+Perl_cvstash_set(pTHX_ CV *cv, HV *st)
+{
+    HV *oldst = CvSTASH(cv);
+    PERL_ARGS_ASSERT_CVSTASH_SET;
+    if (oldst == st)
+       return;
+    if (oldst)
+       sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
+    SvANY(cv)->xcv_stash = st;
+    if (st)
+       Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
+}
 
 void
 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
@@ -320,9 +335,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
         mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
        CvGV_set(cv, gv);
        CvFILE_set_from_cop(cv, PL_curcop);
-       CvSTASH(cv) = PL_curstash;
-       if (PL_curstash)
-           Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
+       CvSTASH_set(cv, PL_curstash);
        if (proto) {
            sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
                            SV_HAS_TRAILING_NUL);
@@ -795,11 +808,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
          * and split that value on the last '::',
          * pass along the same data via some unused fields in the CV
          */
-       if (CvSTASH(cv))
-           sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
-        CvSTASH(cv) = stash;
-       if (stash)
-           Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(cv));
+       CvSTASH_set(cv, stash);
         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
         SvCUR_set(cv, len);
         return gv;

diff --git a/op.c b/op.c
index 21f8e97..cfa9d6b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6279,8 +6279,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
            if (PERLDB_INTER)/* Advice debugger on the new sub. */
              ++PL_sub_generation;
-           if (CvSTASH(cv))
-               sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
        }
        else {
            /* Might have had built-in attributes applied -- propagate them. */
@@ -6308,9 +6306,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     if (!CvGV(cv)) {
        CvGV_set(cv, gv);
        CvFILE_set_from_cop(cv, PL_curcop);
-       CvSTASH(cv) = PL_curstash;
-       if (PL_curstash)
-           Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
+       CvSTASH_set(cv, PL_curstash);
     }
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */

diff --git a/pad.c b/pad.c
index e945113..d395e71 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1573,9 +1573,7 @@ Perl_cv_clone(pTHX_ CV *proto)
     CvFILE(cv)         = CvFILE(proto);
 #endif
     CvGV_set(cv,CvGV(proto));
-    CvSTASH(cv)                = CvSTASH(proto);
-    if (CvSTASH(cv))
-       Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
+    CvSTASH_set(cv, CvSTASH(proto));
     OP_REFCNT_LOCK;
     CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     OP_REFCNT_UNLOCK;

diff --git a/proto.h b/proto.h
index c7f40cb..739ae41 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -602,6 +602,11 @@ PERL_CALLCONV void Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 #define PERL_ARGS_ASSERT_CVGV_SET      \
        assert(cv)
 
+PERL_CALLCONV void     Perl_cvstash_set(pTHX_ CV* cv, HV* stash)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CVSTASH_SET   \
+       assert(cv)
+
 PERL_CALLCONV void     Perl_cx_dump(pTHX_ PERL_CONTEXT* cx)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_CX_DUMP       \

diff --git a/sv.c b/sv.c
index 88d022d..13fc40e 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5558,7 +5558,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
                        /* You lookin' at me?  */
                        assert(CvSTASH(referrer));
                        assert(CvSTASH(referrer) == (const HV *)sv);
-                       CvSTASH(referrer) = 0;
+                       SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
                    }
                    else {
                        assert(SvTYPE(sv) == SVt_PVGV);
@@ -11800,7 +11800,8 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                /*FALLTHROUGH*/
            case SVt_PVFM:
                /* NOTE: not refcounted */
-               CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
+               SvANY(MUTABLE_CV(dstr))->xcv_stash =
+                   hv_dup(CvSTASH(dstr), param);
                if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
                    Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
                OP_REFCNT_LOCK;