Bug #47480 for Class-MOP: create_anon_class() leaks SVs

Hi, I found that create_anon_class() leaks SVs, tested in "anonclass.t". This memory leaks consists of several bugs. First, get_code_info() (in MOP.xs) does not mortalize its return values. Second, mop_update_method_map() (in Class.xs) does not mortalize a working SV, HV* symbols, which mop_get_all_package_symbols() returns. Third, "$hash{$key} = undef" does not remove hash entries and weaken($hash{key}) does not, neither. That is, Class::MOP::remove_metaclass_by_name() should use "delete $METAS{$_[0]}", not "$METAS{$_[0]} = undef" and Class::MOP::Class::DESTROY() should call remove_metaclass_by_name() at the end of the subroutine. Finally, Class::MOP::Class::DESTROY() does not remove all the data, especially @ISA. I don't know why @ISA is not released, but it does happen. See "fix-leaks.patch" for details. Regards, -- Goro Fuji (gfx) GFUJI at CPAN.org

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 7884594..2e78f51 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 f4c8a4e..6b01137 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -251,21 +251,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..bfd3e36 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 709953e..daae08e 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

#!perl -w use strict; use Class::MOP; use Test::More tests => 2; use Test::LeakTrace; #XXX: 5.10.0 has a bug on weaken($hash_ref), which leaks an AV. my $expected = ($] == 5.010_000 ? 1 : 0); leaks_cmp_ok{ Class::MOP::Class->create_anon_class(); } '<=', $expected, 'create_anon_class()'; leaks_cmp_ok{ Class::MOP::Class->create_anon_class(superclasses => [qw(Exporter)]); } '<=', $expected, 'create_anon_class(superclass => [...])';