In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/803f274831f937654d48f8cf0468521cbf8f5dff?hp=fd2c61bcfdb4c097be4d3934b00729bb46787824>
- Log -----------------------------------------------------------------
commit 803f274831f937654d48f8cf0468521cbf8f5dff
Author: David Mitchell <da...@iabyn.com>
Date: Mon Jul 12 20:53:04 2010 +0100
protect CvGV weakref with backref
Each CV usually has a pointer, CvGV(cv), back to the GV that corresponds
to the CV's name (or to *foo::__ANON__ for anon CVs). This pointer wasn't
reference counted, to avoid loops. This could leave it dangling if the GV
is deleted.
We fix this by:
For named subs, adding backref magic to the GV, so that when the GV is
freed, it can trigger processing the CV's CvGV field. This processing
consists of: if it looks like the freeing of the GV is about to trigger
freeing of the CV too, set it to NULL; otherwise make it point to
*foo::__ANON__ (and set CvAONON(cv)).
For anon subs, make CvGV a strong reference, i.e. increment the refcnt of
*foo::__ANON__. This doesn't cause a loop, since in this case the
__ANON__ glob doesn't point to the CV. This also avoids dangling pointers
if someone does an explicit 'delete $foo::{__ANON__}'.
Note that there was already some partial protection for CvGV with
commit f1c32fec87699aee2eeb638f44135f21217d2127. This worked by
anonymising any corresponding CV when freeing a stash or stash entry.
This had two drawbacks. First it didn't fix CVs that were anonmous or that
weren't currently pointed to by the GV (e.g. after local *foo), and
second, it caused *all* CVs to get anonymised during cleanup, even the
ones that would have been deleted shortly afterwards anyway. This commit
effectively removes that former commit, while reusing a bit of the
actual anonymising code.
M cv.h
M embed.fnc
M embed.h
M global.sym
M gv.c
M hv.c
M op.c
M pad.c
M pp.c
M proto.h
M sv.c
M t/op/caller.t
M t/op/stash.t
commit 96bafef935f82644670a19c8ca57886c240cd969
Author: David Mitchell <da...@iabyn.com>
Date: Mon Jul 5 22:25:12 2010 +0100
in CLONEf_JOIN_IN, cache found stashes
When joining a thread, we skip cloning a stash if a stash of the same
name already exists in the parent thread. Add it to PL_ptr_table too, so
we don't have to repeat the expensive name comparison each time
M sv.c
commit ab95db60dabd8d8c36f2a83a140b52898d8d4f68
Author: David Mitchell <da...@iabyn.com>
Date: Mon Jul 5 22:07:30 2010 +0100
add all stash backrefs individually when joining
When joining a thread, a 'mini' interpreter clone is performed to
clone the returned SVs and dependents back into the parent interpreter.
To make things simple in this case, don't clone the xhv_backreferences
array of any stashes, but individually add in any cloned GVs and CVs
whose [CG]vSTASH points that way. This is faster (avoids an expensive test
per CV/GV) and better (doesn't clone unnecessary SVs in the backref array)
M sv.c
commit 64345bb5cdba725a5e2af06c99aa36d8a1b8b873
Author: David Mitchell <da...@iabyn.com>
Date: Mon Jul 5 21:11:21 2010 +0100
make it an error to look for magic hv backref
Now that we only store a stash's backref AV in xhv_backreferences,
make it a panic if we don't find it there, rather than falling back to
look for backref magic.
M sv.c
commit 4c74a7df3242aa95d62dcfbcc231b8a55cc03c59
Author: David Mitchell <da...@iabyn.com>
Date: Mon Jul 5 20:40:33 2010 +0100
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.
M embed.fnc
M embed.h
M global.sym
M gv.c
M hv.c
M op.c
M pad.c
M proto.h
M sv.c
M t/op/stash.t
commit e3d2b9e76ba8553f994404cc1438760e83dd8b76
Author: David Mitchell <da...@iabyn.com>
Date: Sun Jul 4 21:44:35 2010 +0100
tidy some code in gv_init()
Use an intermediate variable cv to avoid lots of GvCV(gv)'s
M gv.c
commit 044d8c24fa9214cf0fe9c6fc8a44e03f3f5374d7
Author: David Mitchell <da...@iabyn.com>
Date: Sun Jul 4 20:51:35 2010 +0100
process xhv_backreferences early in S_hfreeentries
When deleting a stash, make the algorithm
GvSTASH($_) = NULL for (@xhv_backreferences);
delete xhv_backreferences;
free each stash entry;
Previously the algorithm was
hide xhv_backreferences as ordinary backref magic;
free each stash entry:
this may trigger a sv_del_backref() for each GV being freed
delete @xhv_backreferences
The new method is:
* more efficient: one scan through @xhv_backreferences rather than lots of
calls to sv_del_backref(), removing elements one by one;
* makes the code simpler; the 'hide xhv_backreferences as backref magic'
hack no longer needs to be done
* removes a bug whereby GVs that had a refcnt > 1 (the usual case) were
left with a GvSTASH pointing to the freed stash; it's now NULL instead. I
couldn't think of a test for this.
There are two drawbacks:
* If the GV gets freed at the same time as the stash, the freeing code
sees the GV with a GVSTASH of NULL rather than still pointing to the
stash.
* As far as I can see, the only difference this currently makes is that
mro_method_changed_in() is no longer called by sv_clear(), but since we're
blowing away the whole stash anyway, method resolution doesn't really
bother us any more.
At some point in the future I might set GvSTASH to %__ANON__ rather than
NULL.
M embed.fnc
M embed.h
M hv.c
M proto.h
M sv.c
-----------------------------------------------------------------------
Summary of changes:
cv.h | 5 +-
embed.fnc | 11 +--
embed.h | 26 ++++----
global.sym | 2 +
gv.c | 67 ++++++++++++++++++--
hv.c | 94 +++--------------------------
op.c | 21 ++++---
pad.c | 4 +-
pp.c | 2 +-
proto.h | 37 ++++++------
sv.c | 189 +++++++++++++++++++++++++++++++++++++++------------------
t/op/caller.t | 8 +-
t/op/stash.t | 131 ++++++++++++++++++++++++---------------
13 files changed, 342 insertions(+), 255 deletions(-)
diff --git a/cv.h b/cv.h
index 64eb02a..fe96aa3 100644
--- a/cv.h
+++ b/cv.h
@@ -70,7 +70,10 @@ Returns the stash of the CV.
#define CVf_WEAKOUTSIDE 0x0010 /* CvOUTSIDE isn't ref counted */
#define CVf_CLONE 0x0020 /* anon CV uses external lexicals */
#define CVf_CLONED 0x0040 /* a clone of one of those */
-#define CVf_ANON 0x0080 /* CvGV() can't be trusted */
+#define CVf_ANON 0x0080 /* implies: CV is not pointed to by a GV,
+ CvGV is refcounted, and
+ points to an __ANON__ GV;
+ at compile time only, also implies sub {} */
#define CVf_UNIQUE 0x0100 /* sub is only called once (eg PL_main_cv,
* require, eval). */
#define CVf_NODEBUG 0x0200 /* no DB::sub indirection for this CV
diff --git a/embed.fnc b/embed.fnc
index 85beec1..8493dd7 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -439,6 +439,7 @@ Apmb |void |gv_fullname3 |NN SV* sv|NN const GV*
gv|NULLOK const char* prefix
Ap |void |gv_fullname4 |NN SV* sv|NN const GV* gv|NULLOK const char*
prefix|bool keepmain
: Used in scope.c
pMox |GP * |newGP |NN GV *const gv
+pX |void |cvgv_set |NN CV* cv|NULLOK GV* gv
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
@@ -1498,7 +1499,6 @@ paRxoM |void* |get_arena |const size_t arenasize
|const svtype bodytype
#if defined(PERL_IN_HV_C)
s |void |hsplit |NN HV *hv
s |void |hfreeentries |NN HV *hv
-s |I32 |anonymise_cv |NULLOK HEK *stash|NN SV *val
sa |HE* |new_he
sanR |HEK* |save_hek_flags |NN const char *str|I32 len|U32 hash|int flags
sn |void |hv_magic_check |NN HV *hv|NN bool *needs_copy|NN bool
*needs_store
@@ -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
@@ -1910,6 +1910,7 @@ s |void |glob_assign_glob|NN SV *const dstr|NN SV
*const sstr \
|const int dtype
s |void |glob_assign_ref|NN SV *const dstr|NN SV *const sstr
sRn |PTR_TBL_ENT_t *|ptr_table_find|NN PTR_TBL_t *const tbl|NULLOK const
void *const sv
+s |void |anonymise_cv_maybe |NN GV *gv|NN CV *cv
#endif
#if defined(PERL_IN_TOKE_C)
@@ -2134,10 +2135,6 @@ Apo |void |hv_eiter_set |NN HV *hv|NULLOK HE
*eiter
Ap |void |hv_name_set |NN HV *hv|NULLOK const char *name|U32 len|U32
flags
: Used in dump.c and hv.c
poM |AV** |hv_backreferences_p |NN HV *hv
-#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)
-: Only used in sv.c
-poM |void |hv_kill_backrefs |NN HV *hv
-#endif
Apd |void |hv_clear_placeholders |NN HV *hv
ApoR |I32* |hv_placeholders_p |NN HV *hv
ApoR |I32 |hv_placeholders_get |NN const HV *hv
diff --git a/embed.h b/embed.h
index d7a62dd..8fb3cbe 100644
--- a/embed.h
+++ b/embed.h
@@ -292,6 +292,9 @@
#define gv_fetchpv Perl_gv_fetchpv
#define gv_fullname Perl_gv_fullname
#define gv_fullname4 Perl_gv_fullname4
+#ifdef PERL_CORE
+#define cvgv_set Perl_cvgv_set
+#endif
#define gv_init Perl_gv_init
#define gv_name_set Perl_gv_name_set
#ifdef PERL_CORE
@@ -1243,7 +1246,6 @@
#ifdef PERL_CORE
#define hsplit S_hsplit
#define hfreeentries S_hfreeentries
-#define anonymise_cv S_anonymise_cv
#define new_he S_new_he
#define save_hek_flags S_save_hek_flags
#define hv_magic_check S_hv_magic_check
@@ -1558,17 +1560,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
@@ -1612,6 +1616,7 @@
#define glob_assign_glob S_glob_assign_glob
#define glob_assign_ref S_glob_assign_ref
#define ptr_table_find S_ptr_table_find
+#define anonymise_cv_maybe S_anonymise_cv_maybe
#endif
#endif
#if defined(PERL_IN_TOKE_C)
@@ -1817,8 +1822,6 @@
#endif
#define hv_scalar Perl_hv_scalar
#define hv_name_set Perl_hv_name_set
-#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)
-#endif
#define hv_clear_placeholders Perl_hv_clear_placeholders
#ifdef PERL_CORE
#define magic_scalarpack Perl_magic_scalarpack
@@ -2729,6 +2732,7 @@
#define gv_fullname(a,b) Perl_gv_fullname(aTHX_ a,b)
#define gv_fullname4(a,b,c,d) Perl_gv_fullname4(aTHX_ a,b,c,d)
#ifdef PERL_CORE
+#define cvgv_set(a,b) Perl_cvgv_set(aTHX_ a,b)
#endif
#define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e)
#define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d)
@@ -3682,7 +3686,6 @@
#ifdef PERL_CORE
#define hsplit(a) S_hsplit(aTHX_ a)
#define hfreeentries(a) S_hfreeentries(aTHX_ a)
-#define anonymise_cv(a,b) S_anonymise_cv(aTHX_ a,b)
#define new_he() S_new_he(aTHX)
#define save_hek_flags S_save_hek_flags
#define hv_magic_check S_hv_magic_check
@@ -4006,7 +4009,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
@@ -4014,13 +4017,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
@@ -4064,6 +4069,7 @@
#define glob_assign_glob(a,b,c) S_glob_assign_glob(aTHX_ a,b,c)
#define glob_assign_ref(a,b) S_glob_assign_ref(aTHX_ a,b)
#define ptr_table_find S_ptr_table_find
+#define anonymise_cv_maybe(a,b) S_anonymise_cv_maybe(aTHX_ a,b)
#endif
#endif
#if defined(PERL_IN_TOKE_C)
@@ -4269,10 +4275,6 @@
#define hv_name_set(a,b,c,d) Perl_hv_name_set(aTHX_ a,b,c,d)
#ifdef PERL_CORE
#endif
-#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)
-#ifdef PERL_CORE
-#endif
-#endif
#define hv_clear_placeholders(a) Perl_hv_clear_placeholders(aTHX_ a)
#ifdef PERL_CORE
#define magic_scalarpack(a,b) Perl_magic_scalarpack(aTHX_ a,b)
diff --git a/global.sym b/global.sym
index db01b92..aa61a69 100644
--- a/global.sym
+++ b/global.sym
@@ -153,6 +153,7 @@ Perl_gv_fetchpv
Perl_gv_fullname
Perl_gv_fullname3
Perl_gv_fullname4
+Perl_cvgv_set
Perl_gv_init
Perl_gv_name_set
Perl_gv_try_downgrade
@@ -752,6 +753,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 2d4cebc..4764863 100644
--- a/gv.c
+++ b/gv.c
@@ -193,6 +193,43 @@ Perl_newGP(pTHX_ GV *const gv)
return gp;
}
+/* Assign CvGV(cv) = gv, handling weak references.
+ * See also S_anonymise_cv_maybe */
+
+void
+Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
+{
+ GV * const oldgv = CvGV(cv);
+ PERL_ARGS_ASSERT_CVGV_SET;
+
+ if (oldgv == gv)
+ return;
+
+ if (oldgv) {
+ if (CvANON(cv))
+ SvREFCNT_dec(oldgv);
+ else {
+ assert(strNE(GvNAME(oldgv),"__ANON__"));
+ sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
+ }
+ }
+
+ CvGV(cv) = gv;
+
+ if (!gv)
+ return;
+
+ if (CvANON(cv)) {
+ assert(strnEQ(GvNAME(gv),"__ANON__", 8));
+ SvREFCNT_inc_simple_void_NN(gv);
+ }
+ else {
+ assert(strNE(GvNAME(gv),"__ANON__"));
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
+ }
+}
+
+
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
@@ -248,10 +285,11 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name,
STRLEN len, int multi)
if (multi || doproto) /* doproto means it _was_ mentioned */
GvMULTI_on(gv);
if (doproto) { /* Replicate part of newSUB here. */
+ CV *cv;
ENTER;
if (has_constant) {
/* newCONSTSUB takes ownership of the reference from us. */
- GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+ cv = newCONSTSUB(stash, name, has_constant);
/* If this reference was a copy of another, then the subroutine
must have been "imported", by a Perl space assignment to a GV
from a reference to CV. */
@@ -259,16 +297,19 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name,
STRLEN len, int multi)
GvIMPORTED_CV_on(gv);
} else {
(void) start_subparse(0,0); /* Create empty CV in compcv. */
- GvCV(gv) = PL_compcv;
+ cv = PL_compcv;
}
+ GvCV(gv) = cv;
LEAVE;
mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub
ASDF::baz($); *ASDF::baz = \&Foo::bar */
- CvGV(GvCV(gv)) = gv;
- CvFILE_set_from_cop(GvCV(gv), PL_curcop);
- CvSTASH(GvCV(gv)) = PL_curstash;
+ 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));
if (proto) {
- sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen,
+ sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
SV_HAS_TRAILING_NUL);
}
}
@@ -740,6 +781,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;
@@ -2491,12 +2534,22 @@ Perl_gv_try_downgrade(pTHX_ GV *gv)
SV **gvp;
PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
- !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) &&
+ !SvOBJECT(gv) && !SvREADONLY(gv) &&
isGV_with_GP(gv) && GvGP(gv) &&
!GvINTRO(gv) && GvREFCNT(gv) == 1 &&
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
return;
+ if (SvMAGICAL(gv)) {
+ MAGIC *mg;
+ /* only backref magic is allowed */
+ if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
+ return;
+ for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
+ if (mg->mg_type != PERL_MAGIC_backref)
+ return;
+ }
+ }
cv = GvCV(gv);
if (!cv) {
HEK *gvnhek = GvNAME_HEK(gv);
diff --git a/hv.c b/hv.c
index 880a46d..1ec7ffc 100644
--- a/hv.c
+++ b/hv.c
@@ -1458,8 +1458,8 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
if (!entry)
return;
val = HeVAL(entry);
- if (HvNAME(hv) && anonymise_cv(HvNAME_HEK(hv), val) && GvCVu(val))
- mro_method_changed_in(hv);
+ if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv))
+ mro_method_changed_in(hv); /* deletion of method from stash */
SvREFCNT_dec(val);
if (HeKLEN(entry) == HEf_SVKEY) {
SvREFCNT_dec(HeKEY_sv(entry));
@@ -1472,33 +1472,6 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
del_HE(entry);
}
-static I32
-S_anonymise_cv(pTHX_ HEK *stash, SV *val)
-{
- CV *cv;
-
- PERL_ARGS_ASSERT_ANONYMISE_CV;
-
- if (val && isGV(val) && isGV_with_GP(val) && (cv = GvCV(val))) {
- if ((SV *)CvGV(cv) == val) {
- GV *anongv;
-
- if (stash) {
- SV *gvname = newSVhek(stash);
- sv_catpvs(gvname, "::__ANON__");
- anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
- SvREFCNT_dec(gvname);
- } else {
- anongv = gv_fetchpvs("__ANON__::__ANON__", GV_ADDMULTI,
- SVt_PVCV);
- }
- CvGV(cv) = anongv;
- CvANON_on(cv);
- return 1;
- }
- }
- return 0;
-}
void
Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
@@ -1662,22 +1635,6 @@ S_hfreeentries(pTHX_ HV *hv)
if (!orig_array)
return;
- if (HvNAME(hv) && orig_array != NULL) {
- /* symbol table: make all the contained subs ANON */
- STRLEN i;
- XPVHV *xhv = (XPVHV*)SvANY(hv);
-
- for (i = 0; i <= xhv->xhv_max; i++) {
- HE *entry = (HvARRAY(hv))[i];
- for (; entry; entry = HeNEXT(entry)) {
- SV *val = HeVAL(entry);
- /* we need to put the subs in the __ANON__ symtable, as
- * this one is being cleared. */
- anonymise_cv(NULL, val);
- }
- }
- }
-
if (SvOOK(hv)) {
/* If the hash is actually a symbol table with a name, look after the
name. */
@@ -1708,28 +1665,13 @@ S_hfreeentries(pTHX_ HV *hv)
if (SvOOK(hv)) {
HE *entry;
struct mro_meta *meta;
- struct xpvhv_aux *iter = HvAUX(hv);
- /* If there are weak references to this HV, we need to avoid
- freeing them up here. In particular we need to keep the AV
- visible as what we're deleting might well have weak references
- back to this HV, so the for loop below may well trigger
- the removal of backreferences from this array. */
-
- if (iter->xhv_backreferences) {
- /* So donate them to regular backref magic to keep them safe.
- The sv_magic will increase the reference count of the AV,
- so we need to drop it first. */
- SvREFCNT_dec(iter->xhv_backreferences);
- if (AvFILLp(iter->xhv_backreferences) == -1) {
- /* Turns out that the array is empty. Just free it. */
- SvREFCNT_dec(iter->xhv_backreferences);
+ struct xpvhv_aux * const iter = HvAUX(hv);
+ AV *const av = iter->xhv_backreferences;
- } else {
- sv_magic(MUTABLE_SV(hv),
- MUTABLE_SV(iter->xhv_backreferences),
- PERL_MAGIC_backref, NULL, 0);
- }
- iter->xhv_backreferences = NULL;
+ if (av) {
+ Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
+ SvREFCNT_dec(av);
+ iter->xhv_backreferences = 0;
}
entry = iter->xhv_eiter; /* HvEITER(hv) */
@@ -1765,7 +1707,7 @@ S_hfreeentries(pTHX_ HV *hv)
}
/* make everyone else think the array is empty, so that the destructors
- * called for freed entries can't recusively mess with us */
+ * called for freed entries can't recursively mess with us */
HvARRAY(hv) = NULL;
((XPVHV*) SvANY(hv))->xhv_keys = 0;
@@ -2068,24 +2010,6 @@ Perl_hv_backreferences_p(pTHX_ HV *hv) {
return &(iter->xhv_backreferences);
}
-void
-Perl_hv_kill_backrefs(pTHX_ HV *hv) {
- AV *av;
-
- PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
-
- if (!SvOOK(hv))
- return;
-
- av = HvAUX(hv)->xhv_backreferences;
-
- if (av) {
- HvAUX(hv)->xhv_backreferences = 0;
- Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
- SvREFCNT_dec(av);
- }
-}
-
/*
hv_iternext is implemented as a macro in hv.h
diff --git a/op.c b/op.c
index d832c99..e5f9604 100644
--- a/op.c
+++ b/op.c
@@ -5459,7 +5459,7 @@ Perl_cv_undef(pTHX_ CV *cv)
LEAVE;
}
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
- CvGV(cv) = NULL;
+ cvgv_set(cv, NULL);
pad_undef(cv);
@@ -5476,8 +5476,9 @@ Perl_cv_undef(pTHX_ CV *cv)
if (CvISXSUB(cv) && CvXSUB(cv)) {
CvXSUB(cv) = NULL;
}
- /* delete all flags except WEAKOUTSIDE */
- CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
+ /* delete all flags except WEAKOUTSIDE and ANON, which indicate the
+ * ref status of CvOUTSIDE and CvGV */
+ CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_ANON);
}
void
@@ -5844,6 +5845,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. */
@@ -5869,9 +5872,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
}
}
if (!CvGV(cv)) {
- CvGV(cv) = gv;
+ 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));
}
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
@@ -6229,7 +6234,9 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr,
const char *filename)
mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
- CvGV(cv) = gv;
+ if (!name)
+ CvANON_on(cv);
+ cvgv_set(cv, gv);
(void)gv_fetchfile(filename);
CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
an external constant string */
@@ -6238,8 +6245,6 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr,
const char *filename)
if (name)
process_special_blocks(name, gv, cv);
- else
- CvANON_on(cv);
return cv;
}
@@ -6280,7 +6285,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
}
cv = PL_compcv;
GvFORM(gv) = cv;
- CvGV(cv) = gv;
+ cvgv_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
diff --git a/pad.c b/pad.c
index e8ba139..fa9f55a 100644
--- a/pad.c
+++ b/pad.c
@@ -1571,8 +1571,10 @@ Perl_cv_clone(pTHX_ CV *proto)
#else
CvFILE(cv) = CvFILE(proto);
#endif
- CvGV(cv) = CvGV(proto);
+ cvgv_set(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/pp.c b/pp.c
index 64facc2..a78c1cc 100644
--- a/pp.c
+++ b/pp.c
@@ -838,7 +838,7 @@ PP(pp_undef)
/* let user-undef'd sub keep its identity */
GV* const gv = CvGV((const CV *)sv);
cv_undef(MUTABLE_CV(sv));
- CvGV((const CV *)sv) = gv;
+ cvgv_set(MUTABLE_CV(sv), gv);
}
break;
case SVt_PVGV:
diff --git a/proto.h b/proto.h
index 1824377..6a5110e 100644
--- a/proto.h
+++ b/proto.h
@@ -959,6 +959,11 @@ PERL_CALLCONV GP * Perl_newGP(pTHX_ GV *const gv)
#define PERL_ARGS_ASSERT_NEWGP \
assert(gv)
+PERL_CALLCONV void Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CVGV_SET \
+ assert(cv)
+
PERL_CALLCONV void Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name,
STRLEN len, int multi)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_3);
@@ -4489,11 +4494,6 @@ STATIC void S_hfreeentries(pTHX_ HV *hv)
#define PERL_ARGS_ASSERT_HFREEENTRIES \
assert(hv)
-STATIC I32 S_anonymise_cv(pTHX_ HEK *stash, SV *val)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_ANONYMISE_CV \
- assert(val)
-
STATIC HE* S_new_he(pTHX)
__attribute__malloc__
__attribute__warn_unused_result__;
@@ -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__;
@@ -5901,6 +5901,12 @@ STATIC PTR_TBL_ENT_t * S_ptr_table_find(PTR_TBL_t
*const tbl, const void *const
#define PERL_ARGS_ASSERT_PTR_TABLE_FIND \
assert(tbl)
+STATIC void S_anonymise_cv_maybe(pTHX_ GV *gv, CV *cv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE \
+ assert(gv); assert(cv)
+
#endif
#if defined(PERL_IN_TOKE_C)
@@ -6459,13 +6465,6 @@ PERL_CALLCONV AV** Perl_hv_backreferences_p(pTHX_
HV *hv)
#define PERL_ARGS_ASSERT_HV_BACKREFERENCES_P \
assert(hv)
-#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)
-PERL_CALLCONV void Perl_hv_kill_backrefs(pTHX_ HV *hv)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_HV_KILL_BACKREFS \
- assert(hv)
-
-#endif
PERL_CALLCONV void Perl_hv_clear_placeholders(pTHX_ HV *hv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS \
diff --git a/sv.c b/sv.c
index 7ba5ab7..a069b09 100644
--- a/sv.c
+++ b/sv.c
@@ -5310,19 +5310,17 @@ Perl_sv_rvweaken(pTHX_ SV *const sv)
/* A discussion about the backreferences array and its refcount:
*
* The AV holding the backreferences is pointed to either as the mg_obj of
- * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
- * structure, from the xhv_backreferences field. (A HV without hv_aux will
- * have the standard magic instead.) The array is created with a refcount
- * of 2. This means that if during global destruction the array gets
- * picked on first to have its refcount decremented by the random zapper,
- * it won't actually be freed, meaning it's still theere for when its
- * parent gets freed.
+ * PERL_MAGIC_backref, or in the specific case of a HV, from the
+ * xhv_backreferences field of the HvAUX structure. The array is created
+ * with a refcount of 2. This means that if during global destruction the
+ * array gets picked on before its parent to have its refcount decremented
+ * by the random zapper, it won't actually be freed, meaning it's still
+ * there for when its parent gets freed.
* When the parent SV is freed, in the case of magic, the magic is freed,
* Perl_magic_killbackrefs is called which decrements one refcount, then
* mg_obj is freed which kills the second count.
- * In the vase of a HV being freed, one ref is removed by
- * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
- * calls.
+ * In the vase of a HV being freed, one ref is removed by S_hfreeentries,
+ * the other by Perl_sv_kill_backrefs, which it calls.
*/
void
@@ -5338,23 +5336,9 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
av = *avp;
if (!av) {
- /* There is no AV in the offical place - try a fixup. */
- MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
-
- if (mg) {
- /* Aha. They've got it stowed in magic. Bring it back. */
- av = MUTABLE_AV(mg->mg_obj);
- /* Stop mg_free decreasing the refernce count. */
- mg->mg_obj = NULL;
- /* Stop mg_free even calling the destructor, given that
- there's no AV to free up. */
- mg->mg_virtual = 0;
- sv_unmagic(tsv, PERL_MAGIC_backref);
- } else {
- av = newAV();
- AvREAL_off(av);
- SvREFCNT_inc_simple_void(av); /* see discussion above */
- }
+ av = newAV();
+ AvREAL_off(av);
+ SvREFCNT_inc_simple_void(av); /* see discussion above */
*avp = av;
}
} else {
@@ -5379,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;
@@ -5389,14 +5373,16 @@ S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
- if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
- av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
- /* We mustn't attempt to "fix up" the hash here by moving the
- backreference array back to the hv_aux structure, as that is stored
- in the main HvARRAY(), and hfreentries assumes that no-one
- reallocates HvARRAY() while it is running. */
+ if (SvTYPE(tsv) == SVt_PVHV) {
+ if (SvOOK(tsv)) {
+ /* SvOOK: We must avoid creating the hv_aux structure if its
+ * not already there, as that is stored in the main HvARRAY(),
+ * and hfreentries assumes that no-one reallocates HvARRAY()
+ * while it is running. */
+ av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
+ }
}
- if (!av) {
+ else {
const MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
if (mg)
@@ -5434,27 +5420,45 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
SV **svp = AvARRAY(av);
PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
- PERL_UNUSED_ARG(sv);
- assert(!svp || !SvIS_FREED(av));
if (svp) {
SV *const *const last = svp + AvFILLp(av);
+ assert(!SvIS_FREED(av));
while (svp <= last) {
if (*svp) {
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);
SvSETMAGIC(referrer);
} else if (SvTYPE(referrer) == SVt_PVGV ||
SvTYPE(referrer) == SVt_PVLV) {
+ assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
/* You lookin' at me? */
assert(GvSTASH(referrer));
assert(GvSTASH(referrer) == (const HV *)sv);
GvSTASH(referrer) = 0;
+ } else if (SvTYPE(referrer) == SVt_PVCV ||
+ SvTYPE(referrer) == SVt_PVFM) {
+ if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
+ /* You lookin' at me? */
+ assert(CvSTASH(referrer));
+ assert(CvSTASH(referrer) == (const HV *)sv);
+ CvSTASH(referrer) = 0;
+ }
+ else {
+ assert(SvTYPE(sv) == SVt_PVGV);
+ /* You lookin' at me? */
+ assert(CvGV(referrer));
+ assert(CvGV(referrer) == (const GV *)sv);
+ anonymise_cv_maybe(MUTABLE_GV(sv),
+ MUTABLE_CV(referrer));
+ }
+
} else {
Perl_croak(aTHX_
"panic: magic_killbackrefs (flags=%"UVxf")",
@@ -5465,6 +5469,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
}
svp++;
}
+ AvFILLp(av) = -1;
}
SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
return 0;
@@ -5648,6 +5653,44 @@ Perl_sv_replace(pTHX_ register SV *const sv, register SV
*const nsv)
del_SV(nsv);
}
+/* We're about to free a GV which has a CV that refers back to us.
+ * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
+ * field) */
+
+STATIC void
+S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
+{
+ char *stash;
+ SV *gvname;
+ GV *anongv;
+
+ PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
+
+ /* be assertive! */
+ assert(SvREFCNT(gv) == 0);
+ assert(isGV(gv) && isGV_with_GP(gv));
+ assert(GvGP(gv));
+ assert(!CvANON(cv));
+ assert(CvGV(cv) == gv);
+
+ /* will the CV shortly be freed by gp_free() ? */
+ if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
+ CvGV(cv) = NULL;
+ return;
+ }
+
+ /* if not, anonymise: */
+ stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
+ gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
+ stash ? stash : "__ANON__");
+ anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
+ SvREFCNT_dec(gvname);
+
+ CvANON_on(cv);
+ CvGV(cv) = MUTABLE_GV(SvREFCNT_inc(anongv));
+}
+
+
/*
=for apidoc sv_clear
@@ -5778,12 +5821,15 @@ 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) {
PL_last_swash_hv = NULL;
}
- Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
hv_undef(MUTABLE_HV(sv));
break;
case SVt_PVAV:
@@ -10756,6 +10802,13 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
+
+ if ((param->flags & CLONEf_JOIN_IN)
+ && mg->mg_type == PERL_MAGIC_backref)
+ /* when joining, we let the individual SVs add themselves to
+ * backref as needed. */
+ continue;
+
Newx(nmg, 1, MAGIC);
*mgprev_p = nmg;
mgprev_p = &(nmg->mg_moremagic);
@@ -10995,10 +11048,16 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const
sstr, CLONE_PARAMS *const pa
PERL_ARGS_ASSERT_RVPV_DUP;
if (SvROK(sstr)) {
- SvRV_set(dstr, SvWEAKREF(sstr)
- ? sv_dup(SvRV_const(sstr), param)
- : sv_dup_inc(SvRV_const(sstr), param));
-
+ if (SvWEAKREF(sstr)) {
+ SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
+ if (param->flags & CLONEf_JOIN_IN) {
+ /* if joining, we add any back references individually rather
+ * than copying the whole backref array */
+ Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
+ }
+ }
+ else
+ SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
}
else if (SvPVX_const(sstr)) {
/* Has something there */
@@ -11075,9 +11134,12 @@ S_sv_dup_common(pTHX_ const SV *const sstr,
CLONE_PARAMS *const param)
something that is bad **/
if (SvTYPE(sstr) == SVt_PVHV) {
const HEK * const hvname = HvNAME_HEK(sstr);
- if (hvname)
+ if (hvname) {
/** don't clone stashes if they already exist **/
- return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
0));
+ dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
0));
+ ptr_table_store(PL_ptr_table, sstr, dstr);
+ return dstr;
+ }
}
}
@@ -11226,18 +11288,8 @@ S_sv_dup_common(pTHX_ const SV *const sstr,
CLONE_PARAMS *const param)
/* Danger Will Robinson - GvGP(dstr) isn't initialised
at the point of this comment. */
GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
- if(param->flags & CLONEf_JOIN_IN) {
- const HEK * const hvname
- = HvNAME_HEK(GvSTASH(dstr));
- if( hvname
- && GvSTASH(dstr) == gv_stashpvn(
- HEK_KEY(hvname), HEK_LEN(hvname), 0
- )
- )
- Perl_sv_add_backref(
- aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
- );
- }
+ if (param->flags & CLONEf_JOIN_IN)
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)),
dstr);
GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
} else
@@ -11337,7 +11389,16 @@ S_sv_dup_common(pTHX_ const SV *const sstr,
CLONE_PARAMS *const param)
cBOOL(HvSHAREKEYS(sstr)), param) : 0;
/* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
- saux->xhv_backreferences
+ (param->flags & CLONEf_JOIN_IN)
+ /* when joining, we let the individual GVs and
+ * CVs add themselves to backref as
+ * needed. This avoids pulling in stuff
+ * that isn't required, and simplifies the
+ * case where stashes aren't cloned back
+ * if they already exist in the parent
+ * thread */
+ ? NULL
+ : saux->xhv_backreferences
? MUTABLE_AV(SvREFCNT_inc(
sv_dup_inc((const SV
*)saux->xhv_backreferences, param)))
: 0;
@@ -11358,9 +11419,12 @@ 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))
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
OP_REFCNT_LOCK;
if (!CvISXSUB(dstr))
CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
@@ -11371,8 +11435,13 @@ S_sv_dup_common(pTHX_ const SV *const sstr,
CLONE_PARAMS *const param)
}
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
- CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
- NULL : gv_dup(CvGV(dstr), param) ;
+ CvGV(dstr) =
+ CvANON(dstr)
+ ? gv_dup_inc(CvGV(sstr), param)
+ : (param->flags & CLONEf_JOIN_IN)
+ ? NULL
+ : gv_dup(CvGV(sstr), param);
+
CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
CvOUTSIDE(dstr) =
CvWEAKOUTSIDE(sstr)
diff --git a/t/op/caller.t b/t/op/caller.t
index 67992f1..27a55a8 100644
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -31,8 +31,8 @@ ok( $c[4], "hasargs true with anon sub" );
sub foo { @c = caller(0) }
my $fooref = delete $::{foo};
$fooref -> ();
-is( $c[3], "(unknown)", "unknown subroutine name" );
-ok( $c[4], "hasargs true with unknown sub" );
+is( $c[3], "main::__ANON__", "deleted subroutine name" );
+ok( $c[4], "hasargs true with deleted sub" );
print "# Tests with caller(1)\n";
@@ -60,8 +60,8 @@ ok( $c[4], "hasargs true with anon sub" );
sub foo2 { f() }
my $fooref2 = delete $::{foo2};
$fooref2 -> ();
-is( $c[3], "(unknown)", "unknown subroutine name" );
-ok( $c[4], "hasargs true with unknown sub" );
+is( $c[3], "main::__ANON__", "deleted subroutine name" );
+ok( $c[4], "hasargs true with deleted sub" );
# See if caller() returns the correct warning mask
diff --git a/t/op/stash.t b/t/op/stash.t
index 8eb5051..81ca233 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 => 37 );
# Used to segfault (bug #15479)
fresh_perl_like(
@@ -110,56 +110,34 @@ SKIP: {
is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");
- TODO: {
- local $TODO = "anon CVs not accounted for yet";
-
- my @results = split "\n", runperl(
- switches => [ "-MB", "-l" ],
- prog => q{
- my $sub = do {
- package four;
- sub { 1 };
- };
- %four:: = ();
-
- my $gv = B::svref_2object($sub)->GV;
- print $gv->isa(q/B::GV/) ? q/ok/ : q/not ok/;
-
- my $st = eval { $gv->STASH->NAME };
- print $st eq q/__ANON__/ ? q/ok/ : q/not ok/;
-
- my $sub = do {
- package five;
- sub { 1 };
- };
- undef %five::;
-
- $gv = B::svref_2object($sub)->GV;
- print $gv->isa(q/B::GV/) ? q/ok/ : q/not ok/;
-
- $st = eval { $gv->STASH->NAME };
- print $st eq q/__ANON__/ ? q/ok/ : q/not ok/;
-
- print q/done/;
- },
- ($^O eq 'VMS') ? (stderr => 1) : ()
- );
-
- ok( @results == 5 && $results[4] eq "done",
- "anon CVs in undefed stash don't segfault" )
- or todo_skip $TODO, 4;
-
- ok( $results[0] eq "ok",
- "cleared stash leaves anon CV with valid GV");
- ok( $results[1] eq "ok",
- "...and an __ANON__ stash");
-
- ok( $results[2] eq "ok",
- "undefed stash leaves anon CV with valid GV");
- ok( $results[3] eq "ok",
- "...and an __ANON__ stash");
+ my $sub = do {
+ package four;
+ sub { 1 };
+ };
+ %four:: = ();
+
+ my $gv = B::svref_2object($sub)->GV;
+ ok($gv->isa(q/B::GV/), "cleared stash leaves anon CV with valid GV");
+
+ my $st = eval { $gv->STASH->NAME };
+ { local $TODO = 'STASHES not anonymized';
+ is($st, q/__ANON__/, "...and an __ANON__ stash");
}
-
+
+ my $sub = do {
+ package five;
+ sub { 1 };
+ };
+ undef %five::;
+
+ $gv = B::svref_2object($sub)->GV;
+ ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV");
+
+ $st = eval { $gv->STASH->NAME };
+ { local $TODO = 'STASHES not anonymized';
+ is($st, q/__ANON__/, "...and an __ANON__ stash");
+ }
+
# [perl #58530]
fresh_perl_is(
'sub foo { 1 }; use overload q/""/ => \&foo;' .
@@ -168,4 +146,57 @@ SKIP: {
{},
"no segfault with overload/deleted stash entry [#58530]",
);
+
+ # CvSTASH should be null on a named sub if the stash has been deleted
+ {
+ package FOO;
+ sub foo {}
+ my $rfoo = \&foo;
+ package main;
+ delete $::{'FOO::'};
+ my $cv = B::svref_2object($rfoo);
+ # (is there a better way of testing for NULL ?)
+ my $stash = $cv->STASH;
+ like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
+ }
+
+ # on glob reassignment, orphaned CV should have anon CvGV
+
+ {
+ my $r;
+ eval q[
+ package FOO2;
+ sub f{};
+ $r = \&f;
+ *f = sub {};
+ ];
+ delete $FOO2::{f};
+ my $cv = B::svref_2object($r);
+ my $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "orphaned CV has valid GV");
+ is($gv->NAME, '__ANON__', "orphaned CV has anon GV");
+ }
+
+ # deleting __ANON__ glob shouldn't break things
+
+ {
+ package FOO3;
+ sub named {};
+ my $anon = sub {};
+ my $named = eval q[\&named];
+ package main;
+ delete $FOO3::{named}; # make named anonymous
+
+ delete $FOO3::{__ANON__}; # whoops!
+ my ($cv,$gv);
+ $cv = B::svref_2object($named);
+ $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "ex-named CV has valid GV");
+ is($gv->NAME, '__ANON__', "ex-named CV has anon GV");
+
+ $cv = B::svref_2object($anon);
+ $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "anon CV has valid GV");
+ is($gv->NAME, '__ANON__', "anon CV has anon GV");
+ }
}
--
Perl5 Master Repository
