From: Dave Rolsky <autarch@urth.org>
Date: Mon, 6 Jul 2009 18:51:24 +0000 (-0500)
Subject: apply patch from Goro Fuji for anon class mem leak
X-Git-Tag: 0.90~30
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=efc98200d49cae9fb74285a58d12e3b988da0a97;hp=58f2ff6389737c2b492dd6874250ba2e45abca57;p=gitmo%2FClass-MOP.git

apply patch from Goro Fuji for anon class mem leak
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 29b00e6..e3c38ff 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -53,7 +53,7 @@ XSLoader::load( __PACKAGE__, $XS_VERSION );
     sub store_metaclass_by_name     { $METAS{$_[0]} = $_[1] }
     sub weaken_metaclass            { weaken($METAS{$_[0]}) }
     sub does_metaclass_exist        { exists $METAS{$_[0]} && defined $METAS{$_[0]} }
-    sub remove_metaclass_by_name    { $METAS{$_[0]} = undef }
+    sub remove_metaclass_by_name    { delete $METAS{$_[0]}; return }
 
     # This handles instances as well as class names
     sub class_of {
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index ddf890e..8810338 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -250,21 +250,23 @@ sub _check_metaclass_compatibility {
         return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
 
         no warnings 'uninitialized';
-        return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
+        my $name = $self->name;
+        return unless $name =~ /^$ANON_CLASS_PREFIX/;
         # Moose does a weird thing where it replaces the metaclass for
         # class when fixing metaclass incompatibility. In that case,
         # we don't want to clean out the namespace now. We can detect
         # that because Moose will explicitly update the singleton
         # cache in Class::MOP.
-        my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
+        my $current_meta = Class::MOP::get_metaclass_by_name($name);
         return if $current_meta ne $self;
 
-        my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
+        my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/);
         no strict 'refs';
-        foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
-            delete ${$ANON_CLASS_PREFIX . $serial_id}{$key};
-        }
-        delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'};
+        @{$name . '::ISA'} = ();
+        %{$name . '::'}    = ();
+        delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
+
+        Class::MOP::remove_metaclass_by_name($name);
     }
 
 }
diff --git a/mop.c b/mop.c
index 126568d..0fc1be1 100644
--- a/mop.c
+++ b/mop.c
@@ -149,7 +149,7 @@ mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb
                            but that's the API */
                         key = HePV(he, keylen);
                         package = HvNAME(stash);
-                        fq = newSVpvf("%s::%s", package, key);
+                        fq = sv_2mortal(newSVpvf("%s::%s", package, key));
                         sv = (SV *)get_cv(SvPV_nolen(fq), 0);
                         break;
                     }
diff --git a/xs/Class.xs b/xs/Class.xs
index bad7864..e187b4d 100644
--- a/xs/Class.xs
+++ b/xs/Class.xs
@@ -12,7 +12,7 @@ mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stas
     dSP;
 
     symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
-
+    sv_2mortal((SV*)symbols);
     (void)hv_iterinit(symbols);
     while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
         CV *cv = (CV *)SvRV(coderef);
diff --git a/xs/MOP.xs b/xs/MOP.xs
index cf07b55..5dfc0cd 100644
--- a/xs/MOP.xs
+++ b/xs/MOP.xs
@@ -47,8 +47,8 @@ get_code_info(coderef)
     PPCODE:
         if (mop_get_code_info(coderef, &pkg, &name)) {
             EXTEND(SP, 2);
-            PUSHs(newSVpv(pkg, 0));
-            PUSHs(newSVpv(name, 0));
+            mPUSHs(newSVpv(pkg, 0));
+            mPUSHs(newSVpv(name, 0));
         }
 
 # This is some pretty grotty logic. It _should_ be parallel to the