From: Dave Rolsky 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;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