From: Brandon Black <blblack@gmail.com>
Date: Wed, 27 Jun 2007 10:07:54 +0000 (-0500)
Subject: Re: [perl #43357] *DESTROY = sub {} at runtime
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5be5c7a687aa37f2ea9dec7988eb57cad1f1ec24;p=p5sagit%2Fp5-mst-13.2.git

Re: [perl #43357] *DESTROY = sub {} at runtime
From: "Brandon Black" <blblack@gmail.com>
Message-ID: <84621a60706270807r7af65546x8d959b131ffa28e6@mail.gmail.com>

p4raw-id: //depot/perl@31489
---

diff --git a/embed.fnc b/embed.fnc
index fbd6ec7..4acd2fd 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -455,6 +455,7 @@ p	|int	|magic_setenv	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setfm	|NN SV* sv|NN MAGIC* mg
 dp	|int	|magic_sethint	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setisa	|NN SV* sv|NN MAGIC* mg
+p	|int	|magic_freeisa	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setglob	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setmglob	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setnkeys	|NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index bfa2cd1..198439e 100644
--- a/embed.h
+++ b/embed.h
@@ -441,6 +441,7 @@
 #define magic_setfm		Perl_magic_setfm
 #define magic_sethint		Perl_magic_sethint
 #define magic_setisa		Perl_magic_setisa
+#define magic_freeisa		Perl_magic_freeisa
 #define magic_setglob		Perl_magic_setglob
 #define magic_setmglob		Perl_magic_setmglob
 #define magic_setnkeys		Perl_magic_setnkeys
@@ -2731,6 +2732,7 @@
 #define magic_setfm(a,b)	Perl_magic_setfm(aTHX_ a,b)
 #define magic_sethint(a,b)	Perl_magic_sethint(aTHX_ a,b)
 #define magic_setisa(a,b)	Perl_magic_setisa(aTHX_ a,b)
+#define magic_freeisa(a,b)	Perl_magic_freeisa(aTHX_ a,b)
 #define magic_setglob(a,b)	Perl_magic_setglob(aTHX_ a,b)
 #define magic_setmglob(a,b)	Perl_magic_setmglob(aTHX_ a,b)
 #define magic_setnkeys(a,b)	Perl_magic_setnkeys(aTHX_ a,b)
diff --git a/hv.c b/hv.c
index cf0f3f4..adbfbdf 100644
--- a/hv.c
+++ b/hv.c
@@ -1518,12 +1518,19 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
 {
     dVAR;
     SV *val;
+    I32 isa_changing = 0;
 
     if (!entry)
 	return;
     val = HeVAL(entry);
-    if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
-        mro_method_changed_in(hv);	/* deletion of method from stash */
+
+    if(HvNAME_get(hv) && val && isGV(val)) {
+        if(GvCVu((GV*)val))
+            mro_method_changed_in(hv);	/* deletion of method from stash */
+        else if(GvAV((GV*)val) && strEQ(GvNAME((GV*)val), "ISA"))
+            isa_changing = 1;
+    }
+
     SvREFCNT_dec(val);
     if (HeKLEN(entry) == HEf_SVKEY) {
 	SvREFCNT_dec(HeKEY_sv(entry));
@@ -1534,6 +1541,8 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
     else
 	Safefree(HeKEY_hek(entry));
     del_HE(entry);
+
+    if(isa_changing) mro_isa_changed_in(hv);	/* deletion of @ISA from stash */
 }
 
 void
@@ -1844,8 +1853,21 @@ Perl_hv_undef(pTHX_ HV *hv)
     DEBUG_A(Perl_hv_assert(aTHX_ hv));
     xhv = (XPVHV*)SvANY(hv);
 
-    if ((name = HvNAME_get(hv)) && !PL_dirty)
+    /* If it's a stash, undef the @ISA and call
+       mro_isa_changed_in before proceeding with
+       the rest of the destruction */
+    if ((name = HvNAME_get(hv)) && !PL_dirty) {
+        GV** gvp;
+        GV* gv;
+        AV* isa;
+
+        gvp = (GV**)hv_fetchs(hv, "ISA", FALSE);
+        gv = gvp ? *gvp : NULL;
+        isa = (gv && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
+    
+        if(isa) av_undef(isa);
         mro_isa_changed_in(hv);
+    }
 
     hfreeentries(hv);
     if (name) {
diff --git a/mg.c b/mg.c
index 77100b9..c68543c 100644
--- a/mg.c
+++ b/mg.c
@@ -1541,6 +1541,26 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+int Perl_magic_freeisa(pTHX_ SV *sv, MAGIC *mg)
+{
+    dVAR;
+    GV** gvp;
+    GV* gv;
+    AV* isa;
+
+    PERL_UNUSED_ARG(sv);
+
+    if(PL_dirty) return 0;
+
+    gvp = (GV**)hv_fetchs(GvSTASH((GV*)mg->mg_obj), "ISA", FALSE);
+    gv = gvp ? *gvp : NULL;
+    isa = (gv && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
+
+    if(isa) av_undef(isa);
+
+    return 0;
+}
+
 int
 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
 {
diff --git a/mro.c b/mro.c
index d2ba841..01461b1 100644
--- a/mro.c
+++ b/mro.c
@@ -448,8 +448,10 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
     bool is_universal;
     struct mro_meta * meta;
 
-    const char * const stashname = HvNAME_get(stash);
-    const STRLEN stashname_len = HvNAMELEN_get(stash);
+    const char * const stashname = stash ? HvNAME_get(stash) : NULL;
+    const STRLEN stashname_len = stash ? HvNAMELEN_get(stash) : 0;
+
+    if(!stash) return;
 
     if(!stashname)
         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
diff --git a/perl.h b/perl.h
index b989f3e..5b8c574 100644
--- a/perl.h
+++ b/perl.h
@@ -4768,7 +4768,7 @@ MGVTBL_SET(
     MEMBER_TO_FPTR(Perl_magic_setisa),
     0,
     MEMBER_TO_FPTR(Perl_magic_setisa),
-    0,
+    MEMBER_TO_FPTR(Perl_magic_freeisa),
     0,
     0,
     0
diff --git a/proto.h b/proto.h
index aa65950..5ef97ad 100644
--- a/proto.h
+++ b/proto.h
@@ -1217,6 +1217,10 @@ PERL_CALLCONV int	Perl_magic_setisa(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
 
+PERL_CALLCONV int	Perl_magic_freeisa(pTHX_ SV* sv, MAGIC* mg)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+
 PERL_CALLCONV int	Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
diff --git a/sv.c b/sv.c
index f503f14..7f030e3 100644
--- a/sv.c
+++ b/sv.c
@@ -4397,6 +4397,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
     */
     if (!obj || obj == sv ||
 	how == PERL_MAGIC_arylen ||
+	how == PERL_MAGIC_isaelem ||
 	how == PERL_MAGIC_qr ||
 	how == PERL_MAGIC_symtab ||
 	(SvTYPE(obj) == SVt_PVGV &&
diff --git a/t/mro/basic.t b/t/mro/basic.t
index 332782e..be7e3dd 100644
--- a/t/mro/basic.t
+++ b/t/mro/basic.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-require q(./test.pl); plan(tests => 21);
+require q(./test.pl); plan(tests => 27);
 
 {
     package MRO_A;
@@ -127,6 +127,8 @@ is(eval { MRO_N->testfunc() }, 123);
 }
 
 # clearing @ISA in different ways
+#  some are destructive to the package, hence the new
+#  package name each time
 {
     no warnings 'uninitialized';
     {
@@ -141,6 +143,48 @@ is(eval { MRO_N->testfunc() }, 123);
     $ISACLEAR::ISA[1] = undef;
     ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX main ZZ/]));
 
+    # undef the array itself
     undef @ISACLEAR::ISA;
     ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/]));
 }
+
+{
+    {
+        package ISACLEAR2;
+        our @ISA = qw/XX YY ZZ/;
+    }
+
+    # baseline
+    ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2 XX YY ZZ/]));
+
+    # delete @ISA
+    delete $ISACLEAR2::{ISA};
+    ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/]));
+}
+
+# another destructive test, undef the ISA glob
+{
+    {
+        package ISACLEAR3;
+        our @ISA = qw/XX YY ZZ/;
+    }
+    # baseline
+    ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3 XX YY ZZ/]));
+
+    undef *ISACLEAR3::ISA;
+    ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3/]));
+}
+
+# This is how Class::Inner does it
+{
+    {
+        package ISACLEAR4;
+        our @ISA = qw/XX YY ZZ/;
+    }
+    # baseline
+    ok(eq_array(mro::get_linear_isa('ISACLEAR4'),[qw/ISACLEAR4 XX YY ZZ/]));
+
+    delete $ISACLEAR4::{ISA};
+    delete $::{ISACLEAR4::};
+    ok(eq_array(mro::get_linear_isa('ISACLEAR4'),[qw/ISACLEAR4/]));
+}