In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/4fec321675757b1adbfc9b8317737404d211664f?hp=3f1788e11f2685299067ac0f8d3e4fd141a5b5cd>
- Log ----------------------------------------------------------------- commit 4fec321675757b1adbfc9b8317737404d211664f Author: Rafael Garcia-Suarez <[email protected]> Date: Sun Jun 21 13:44:08 2009 +0200 Regenerate headers and fix compilation with threads after last commit M embed.h M hv.c M proto.h commit f1c32fec87699aee2eeb638f44135f21217d2127 Author: Ben Morrow <[email protected]> Date: Sun Jan 4 20:04:39 2009 +0000 When a glob is deleted, mark its sub as ANON. M embed.fnc M hv.c commit d018fae575c7e183deffddccedc84f1f5d7ddacb Author: Ben Morrow <[email protected]> Date: Mon Jan 5 17:31:54 2009 +0000 Tests for deleting stash entries. M t/op/stash.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 2 + hv.c | 43 +++++++++++++++++++++++++++- proto.h | 5 +++ t/op/stash.t | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 5 files changed, 131 insertions(+), 6 deletions(-) diff --git a/embed.fnc b/embed.fnc index 439203c..08f7725 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1354,6 +1354,7 @@ paRxo |void* |get_arena |const size_t svtype|const U32 misc #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) s |void |hsplit |NN HV *hv s |void |hfreeentries |NN HV *hv +s |I32 |anonymise_cv |NULLOK const char *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 diff --git a/embed.h b/embed.h index 9af17f6..1b2c9de 100644 --- a/embed.h +++ b/embed.h @@ -1179,6 +1179,7 @@ #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 @@ -3515,6 +3516,7 @@ #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 diff --git a/hv.c b/hv.c index ebb10fb..8d1c6a9 100644 --- a/hv.c +++ b/hv.c @@ -1468,8 +1468,8 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) if (!entry) return; val = HeVAL(entry); - if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv)) - mro_method_changed_in(hv); /* deletion of method from stash */ + if (HvNAME(hv) && anonymise_cv(HvNAME(hv), val) && GvCVu(val)) + mro_method_changed_in(hv); SvREFCNT_dec(val); if (HeKLEN(entry) == HEf_SVKEY) { SvREFCNT_dec(HeKEY_sv(entry)); @@ -1482,6 +1482,29 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) del_HE(entry); } +static I32 +S_anonymise_cv(pTHX_ const char *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) { + SV *gvname; + GV *anongv; + + gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__", stash ? stash : "__ANON__"); + anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV); + SvREFCNT_dec(gvname); + CvGV(cv) = anongv; + CvANON_on(cv); + return 1; + } + } + return 0; +} + void Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) { @@ -1646,6 +1669,22 @@ 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/proto.h b/proto.h index 285e05f..ffa7c39 100644 --- a/proto.h +++ b/proto.h @@ -4254,6 +4254,11 @@ STATIC void S_hfreeentries(pTHX_ HV *hv) #define PERL_ARGS_ASSERT_HFREEENTRIES \ assert(hv) +STATIC I32 S_anonymise_cv(pTHX_ const char *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__; diff --git a/t/op/stash.t b/t/op/stash.t index 4d8bc7c..e2f8901 100644 --- a/t/op/stash.t +++ b/t/op/stash.t @@ -7,7 +7,7 @@ BEGIN { BEGIN { require "./test.pl"; } -plan( tests => 13 ); +plan( tests => 30 ); # Used to segfault (bug #15479) fresh_perl_is( @@ -58,6 +58,84 @@ ok( !eval q{ defined %schoenmaker:: }, 'works in eval("")' ); # now tests with strictures -use strict; -ok( !defined %pig::, q(referencing a non-existent stash doesn't produce stricture errors) ); -ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) ); +{ + use strict; + ok( !defined %pig::, q(referencing a non-existent stash doesn't produce stricture errors) ); + ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) ); +} + +SKIP: { + eval { require B; 1 } or skip "no B", 12; + + *b = \&B::svref_2object; + my $CVf_ANON = B::CVf_ANON(); + + my $sub = do { + package one; + \&{"one"}; + }; + delete $one::{one}; + my $gv = b($sub)->GV; + + isa_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV"); + is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); + is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); + is( eval { $gv->STASH->NAME }, "one", "...but leaves stash intact"); + + $sub = do { + package two; + \&{"two"}; + }; + %two:: = (); + $gv = b($sub)->GV; + + isa_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV"); + is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); + is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); + is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash"); + + $sub = do { + package three; + \&{"three"}; + }; + undef %three::; + $gv = b($sub)->GV; + + isa_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV"); + is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); + 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"; + + $sub = do { + package four; + sub { 1 }; + }; + %four:: = (); + $gv = b($sub)->GV; + + isa_ok( $gv, "B::GV", "cleared stash leaves anon CV with valid GV"); + is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash"); + + $sub = do { + package five; + sub { 1 }; + }; + undef %five::; + $gv = b($sub)->GV; + + isa_ok( $gv, "B::GV", "undefed stash leaves anon CV with valid GV"); + is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash"); + } + + # [perl #58530] + fresh_perl_is( + 'sub foo { 1 }; use overload q/""/ => \&foo;' . + 'delete $main::{foo}; bless []', + "", + {}, + "no segfault with overload/deleted stash entry [#58530]", + ); +} -- Perl5 Master Repository
