From 4c74a7df3242aa95d62dcfbcc231b8a55cc03c59 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Mon, 5 Jul 2010 20:40:33 +0100 Subject: [PATCH] protect CvSTASH weakref with backrefs 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 | 4 ++-- embed.h | 12 ++++++++---- global.sym | 1 + gv.c | 4 ++++ hv.c | 2 +- op.c | 4 ++++ pad.c | 2 ++ proto.h | 14 +++++++------- sv.c | 27 +++++++++++++++++++++++++-- t/op/stash.t | 15 ++++++++++++++- 10 files changed, 68 insertions(+), 17 deletions(-) diff --git a/embed.fnc b/embed.fnc index a1e8ecd..295b6b2 100644 --- 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 --- a/embed.h +++ b/embed.h @@ -1558,17 +1558,19 @@ #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 @@ -4004,7 +4006,7 @@ #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 @@ -4012,13 +4014,15 @@ #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 diff --git a/global.sym b/global.sym index db01b92..cfdb93d 100644 --- a/global.sym +++ b/global.sym @@ -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 --- 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 --- 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 --- 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. */ diff --git a/pad.c b/pad.c index e8ba139..92f4041 100644 --- 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 --- 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 --- 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)); diff --git a/t/op/stash.t b/t/op/stash.t index 8eb5051..676c26c 100644 --- a/t/op/stash.t +++ b/t/op/stash.t @@ -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"); + } } -- 1.8.3.1