This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
protect CvSTASH weakref with backrefs
authorDavid Mitchell <davem@iabyn.com>
Mon, 5 Jul 2010 19:40:33 +0000 (20:40 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 14 Jul 2010 22:06:17 +0000 (23:06 +0100)
Each CV usually has a pointer, CvSTASH, back to the stash that it was
complied in. This pointer isn't reference counted, to avoid loops. Which
can leave it dangling if the stash is deleted.

There is already protection for the similar GvSTASH field in GVs: the
stash has an array of backrefs, xhv_backreferences, pointing to the GVs
whose GvSTASHes point to it, and which is used to zero all the GvSTASH
fields should the stash be deleted.

All this patch does is also add the CVs with CvSTASH to that stash's
backref list too.

embed.fnc
embed.h
global.sym
gv.c
hv.c
op.c
pad.c
proto.h
sv.c
t/op/stash.t

index a1e8ecd..295b6b2 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1852,7 +1852,7 @@ s |SV*    |pm_description |NN const PMOP *pm
 s      |SV*    |save_scalar_at |NN SV **sptr|const U32 flags
 #endif
 
-#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 : Used in gv.c
 po     |void   |sv_add_backref |NN SV *const tsv|NN SV *const sv
 #endif
@@ -1862,12 +1862,12 @@ po      |void   |sv_add_backref |NN SV *const tsv|NN SV *const sv
 poM    |int    |sv_kill_backrefs       |NN SV *const sv|NN AV *const av
 #endif
 
+pX     |void   |sv_del_backref |NN SV *const tsv|NN SV *const sv
 #if defined(PERL_IN_SV_C)
 nsR    |char * |uiv_2buf       |NN char *const buf|const IV iv|UV uv|const int is_uv|NN char **const peob
 s      |void   |sv_unglob      |NN SV *const sv
 s      |void   |not_a_number   |NN SV *const sv
 s      |I32    |visit          |NN SVFUNC_t f|const U32 flags|const U32 mask
-s      |void   |sv_del_backref |NN SV *const tsv|NN SV *const sv
 sR     |SV *   |varname        |NULLOK const GV *const gv|const char gvtype \
                                |PADOFFSET targ|NULLOK const SV *const keyname \
                                |I32 aindex|int subscript_type
diff --git a/embed.h b/embed.h
index f62a803..a425f46 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define save_scalar_at         S_save_scalar_at
 #endif
 #endif
-#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 #endif
 #if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C)
 #endif
+#ifdef PERL_CORE
+#define sv_del_backref         Perl_sv_del_backref
+#endif
 #if defined(PERL_IN_SV_C)
 #ifdef PERL_CORE
 #define uiv_2buf               S_uiv_2buf
 #define sv_unglob              S_sv_unglob
 #define not_a_number           S_not_a_number
 #define visit                  S_visit
-#define sv_del_backref         S_sv_del_backref
 #define varname                        S_varname
 #endif
 #  ifdef DEBUGGING
 #define save_scalar_at(a,b)    S_save_scalar_at(aTHX_ a,b)
 #endif
 #endif
-#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 #ifdef PERL_CORE
 #endif
 #endif
 #ifdef PERL_CORE
 #endif
 #endif
+#ifdef PERL_CORE
+#define sv_del_backref(a,b)    Perl_sv_del_backref(aTHX_ a,b)
+#endif
 #if defined(PERL_IN_SV_C)
 #ifdef PERL_CORE
 #define uiv_2buf               S_uiv_2buf
 #define sv_unglob(a)           S_sv_unglob(aTHX_ a)
 #define not_a_number(a)                S_not_a_number(aTHX_ a)
 #define visit(a,b,c)           S_visit(aTHX_ a,b,c)
-#define sv_del_backref(a,b)    S_sv_del_backref(aTHX_ a,b)
 #define varname(a,b,c,d,e,f)   S_varname(aTHX_ a,b,c,d,e,f)
 #endif
 #  ifdef DEBUGGING
index db01b92..cfdb93d 100644 (file)
@@ -752,6 +752,7 @@ Perl_sv_nounlocking
 Perl_nothreadhook
 Perl_Slab_Alloc
 Perl_Slab_Free
+Perl_sv_del_backref
 Perl_sv_setsv_flags
 Perl_sv_catpvn_flags
 Perl_sv_catsv_flags
diff --git a/gv.c b/gv.c
index 7f32ec6..fce31b7 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -269,6 +269,8 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
        CvGV(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));
        if (proto) {
            sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
                            SV_HAS_TRAILING_NUL);
@@ -742,6 +744,8 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
          * pass along the same data via some unused fields in the CV
          */
         CvSTASH(cv) = stash;
+       if (stash)
+           Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(cv));
         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
         SvCUR_set(cv, len);
         return gv;
diff --git a/hv.c b/hv.c
index f94d6d4..b47b83a 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1709,7 +1709,7 @@ S_hfreeentries(pTHX_ HV *hv)
            HE *entry;
             struct mro_meta *meta;
            struct xpvhv_aux * const iter = HvAUX(hv);
-           SV *const av = iter->xhv_backreferences;
+           AV *const av = iter->xhv_backreferences;
 
            if (av) {
                Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
diff --git a/op.c b/op.c
index d832c99..bd7b84b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5844,6 +5844,8 @@ 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. */
@@ -5872,6 +5874,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        CvGV(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));
     }
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
diff --git a/pad.c b/pad.c
index e8ba139..92f4041 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1573,6 +1573,8 @@ Perl_cv_clone(pTHX_ CV *proto)
 #endif
     CvGV(cv)           = CvGV(proto);
     CvSTASH(cv)                = CvSTASH(proto);
+    if (CvSTASH(cv))
+       Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
     OP_REFCNT_LOCK;
     CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     OP_REFCNT_UNLOCK;
diff --git a/proto.h b/proto.h
index 688a2f0..727d3d5 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5735,7 +5735,7 @@ STATIC SV*        S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
 
 #endif
 
-#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 PERL_CALLCONV void     Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
@@ -5753,6 +5753,12 @@ PERL_CALLCONV int        Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
 
 #endif
 
+PERL_CALLCONV void     Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DEL_BACKREF        \
+       assert(tsv); assert(sv)
+
 #if defined(PERL_IN_SV_C)
 STATIC char *  S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
                        __attribute__warn_unused_result__
@@ -5776,12 +5782,6 @@ STATIC I32       S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 #define PERL_ARGS_ASSERT_VISIT \
        assert(f)
 
-STATIC void    S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
-                       __attribute__nonnull__(pTHX_1)
-                       __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_SV_DEL_BACKREF        \
-       assert(tsv); assert(sv)
-
 STATIC SV *    S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type)
                        __attribute__warn_unused_result__;
 
diff --git a/sv.c b/sv.c
index 504bc15..c841dc9 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5363,8 +5363,8 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
  * with the SV we point to.
  */
 
-STATIC void
-S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
+void
+Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
 {
     dVAR;
     AV *av = NULL;
@@ -5429,6 +5429,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
                SV *const referrer = *svp;
                if (SvWEAKREF(referrer)) {
                    /* XXX Should we check that it hasn't changed? */
+                   assert(SvROK(referrer));
                    SvRV_set(referrer, 0);
                    SvOK_off(referrer);
                    SvWEAKREF_off(referrer);
@@ -5439,6 +5440,11 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
                    assert(GvSTASH(referrer));
                    assert(GvSTASH(referrer) == (const HV *)sv);
                    GvSTASH(referrer) = 0;
+               } else if (SvTYPE(referrer) == SVt_PVCV) {
+                   /* You lookin' at me?  */
+                   assert(CvSTASH(referrer));
+                   assert(CvSTASH(referrer) == (const HV *)sv);
+                   CvSTASH(referrer) = 0;
                } else {
                    Perl_croak(aTHX_
                               "panic: magic_killbackrefs (flags=%"UVxf")",
@@ -5763,6 +5769,10 @@ Perl_sv_clear(pTHX_ register SV *const sv)
     case SVt_PVCV:
     case SVt_PVFM:
        cv_undef(MUTABLE_CV(sv));
+       /* If we're in a stash, we don't own a reference to it. However it does
+          have a back reference to us, which needs to be cleared.  */
+       if ((stash = CvSTASH(sv)))
+           sv_del_backref(MUTABLE_SV(stash), sv);
        goto freescalar;
     case SVt_PVHV:
        if (PL_last_swash_hv == (const HV *)sv) {
@@ -11342,9 +11352,22 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                if (!(param->flags & CLONEf_COPY_STACKS)) {
                    CvDEPTH(dstr) = 0;
                }
+               /*FALLTHROUGH*/
            case SVt_PVFM:
                /* NOTE: not refcounted */
                CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
+               if(param->flags & CLONEf_JOIN_IN && CvSTASH(dstr)) {
+                   const HEK * const hvname
+                    = HvNAME_HEK(CvSTASH(dstr));
+                   if( hvname
+                    && CvSTASH(dstr) == gv_stashpvn(
+                        HEK_KEY(hvname), HEK_LEN(hvname), 0
+                       )
+                     )
+                       Perl_sv_add_backref(
+                        aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr
+                       );
+               }
                OP_REFCNT_LOCK;
                if (!CvISXSUB(dstr))
                    CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
index 8eb5051..676c26c 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan( tests => 31 );
+plan( tests => 32 );
 
 # Used to segfault (bug #15479)
 fresh_perl_like(
@@ -168,4 +168,17 @@ SKIP: {
         {},
         "no segfault with overload/deleted stash entry [#58530]",
     );
+
+    # CvSTASH should be null on a nmed sub if the stash has been deleted
+    {
+       package FOO;
+       sub foo {}
+       my $rfoo = \&foo;
+       package main;
+       delete $::{'FOO::'};
+       my $cv = B::svref_2object($rfoo);
+       # XXX is there a better way of testing for NULL ?
+       my $stash = $cv->STASH;
+       like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
+    }
 }