This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add CvSTASH_set() macro and make CvSTASH() rvalue only
authorZefram <zefram@fysh.org>
Mon, 25 Oct 2010 22:34:23 +0000 (23:34 +0100)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 26 Oct 2010 00:45:14 +0000 (17:45 -0700)
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().

cv.h
embed.fnc
embed.h
global.sym
gv.c
op.c
pad.c
proto.h
sv.c

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
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
 #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)
index d8eae72..692991d 100644 (file)
@@ -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;