From 803f274831f937654d48f8cf0468521cbf8f5dff Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Mon, 12 Jul 2010 20:53:04 +0100 Subject: [PATCH] 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. --- cv.h | 5 ++- embed.fnc | 3 +- embed.h | 8 +++- global.sym | 1 + gv.c | 51 +++++++++++++++++++++++- hv.c | 47 +--------------------- op.c | 17 ++++---- pad.c | 2 +- pp.c | 2 +- proto.h | 16 +++++--- sv.c | 92 +++++++++++++++++++++++++++++++++++++------ t/op/caller.t | 8 ++-- t/op/stash.t | 122 +++++++++++++++++++++++++++++++++------------------------- 13 files changed, 240 insertions(+), 134 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 295b6b2..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 @@ -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) diff --git a/embed.h b/embed.h index a425f46..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 @@ -1614,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) @@ -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 @@ -4066,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) diff --git a/global.sym b/global.sym index cfdb93d..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 diff --git a/gv.c b/gv.c index fce31b7..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) { @@ -266,7 +303,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) LEAVE; mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */ - CvGV(cv) = gv; + cvgv_set(cv, gv); CvFILE_set_from_cop(cv, PL_curcop); CvSTASH(cv) = PL_curstash; if (PL_curstash) @@ -2497,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 b47b83a..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. */ diff --git a/op.c b/op.c index bd7b84b..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 @@ -5871,7 +5872,7 @@ 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) @@ -6233,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 */ @@ -6242,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; } @@ -6284,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 92f4041..fa9f55a 100644 --- a/pad.c +++ b/pad.c @@ -1571,7 +1571,7 @@ 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)); 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 727d3d5..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__; @@ -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) diff --git a/sv.c b/sv.c index 13a1390..a069b09 100644 --- a/sv.c +++ b/sv.c @@ -5420,7 +5420,6 @@ 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); if (svp) { SV *const *const last = svp + AvFILLp(av); @@ -5438,15 +5437,28 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) 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) { - /* You lookin' at me? */ - assert(CvSTASH(referrer)); - assert(CvSTASH(referrer) == (const HV *)sv); - CvSTASH(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")", @@ -5641,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 @@ -10752,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); @@ -10991,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 */ @@ -11372,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 676c26c..81ca233 100644 --- a/t/op/stash.t +++ b/t/op/stash.t @@ -7,7 +7,7 @@ BEGIN { BEGIN { require "./test.pl"; } -plan( tests => 32 ); +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;' . @@ -169,7 +147,7 @@ SKIP: { "no segfault with overload/deleted stash entry [#58530]", ); - # CvSTASH should be null on a nmed sub if the stash has been deleted + # CvSTASH should be null on a named sub if the stash has been deleted { package FOO; sub foo {} @@ -177,8 +155,48 @@ SKIP: { package main; delete $::{'FOO::'}; my $cv = B::svref_2object($rfoo); - # XXX is there a better way of testing for NULL ? + # (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"); + } } -- 2.7.4