From: Dave Rolsky Date: Tue, 25 Aug 2009 17:58:07 +0000 (-0500) Subject: Fix RT 48985 X-Git-Tag: 0.93~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5327fc78ef56d2ad4988098f5a3c806edad24bd9;p=gitmo%2FClass-MOP.git Fix RT 48985 When add_method is called, it now always adds _something_ to the method map, but it may be a raw coderef. In get_method, we check for this and inflate it into a proper method meta-object as needed. This means that the method map contains a mix of objects and code refs, and so is no longer fit for public consumption. --- diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 2cb803c..aae44a2 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -650,7 +650,15 @@ sub find_method_by_name { sub get_all_methods { my $self = shift; - my %methods = map { %{ $self->initialize($_)->get_method_map } } reverse $self->linearized_isa; + + my %methods; + for my $class ( reverse $self->linearized_isa ) { + my $meta = $self->initialize($class); + + $methods{$_} = $meta->get_method($_) + for $meta->get_method_list; + } + return values %methods; } @@ -863,12 +871,9 @@ sub is_pristine { return if $self->get_attribute_list; # or any non-declared methods - if ( my @methods = values %{ $self->get_method_map } ) { - my $metaclass = $self->method_metaclass; - foreach my $method ( @methods ) { - return if $method->isa("Class::MOP::Method::Generated"); - # FIXME do we need to enforce this too? return unless $method->isa($metaclass); - } + for my $method ( map { $self->get_method($_) } $self->get_method_list ) { + return if $method->isa("Class::MOP::Method::Generated"); + # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass ); } return 1; diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 9333f51..370f158 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -322,7 +322,6 @@ sub add_method { } $method->attach_to_class($self); - $self->_method_map->{$method_name} = $method; } else { # If a raw code reference is supplied, its method object is not created. @@ -330,6 +329,7 @@ sub add_method { $body = $method; } + $self->_method_map->{$method_name} = $method; my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); @@ -362,34 +362,36 @@ sub has_method { } sub get_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) + my ( $self, $method_name ) = @_; + ( defined $method_name && $method_name ) || confess "You must define a method name"; - my $method_map = $self->_method_map; - my $method_object = $method_map->{$method_name}; - my $code = $self->get_package_symbol({ - name => $method_name, - sigil => '&', - type => 'CODE', - }); - - unless ( $method_object && $method_object->body == ( $code || 0 ) ) { - if ( $code && $self->_code_is_mine($code) ) { - $method_object = $method_map->{$method_name} - = $self->wrap_method_body( - body => $code, - name => $method_name, - associated_metaclass => $self, - ); - } - else { - delete $method_map->{$method_name}; - return undef; + my $method_map = $self->_method_map; + my $map_entry = $method_map->{$method_name}; + my $code = $self->get_package_symbol( + { + name => $method_name, + sigil => '&', + type => 'CODE', } + ); + + return $map_entry if blessed $map_entry && $map_entry->body == $code; + + # we should never have a blessed map entry but no $code in the package + die 'WTF' if blessed $map_entry && ! $code; + + unless ($map_entry) { + return unless $code && $self->_code_is_mine($code); } - return $method_object; + $code ||= $map_entry; + + return $method_map->{$method_name} = $self->wrap_method_body( + body => $code, + name => $method_name, + associated_metaclass => $self, + ); } sub remove_method { @@ -403,7 +405,7 @@ sub remove_method { { sigil => '&', type => 'CODE', name => $method_name } ); - $removed_method->detach_from_class if $removed_method; + $removed_method->detach_from_class if $removed_method && blessed $removed_method; $self->update_package_cache_flag; # still valid, since we just removed the method from the map diff --git a/t/003_methods.t b/t/003_methods.t index a6ba53a..1eaa655 100644 --- a/t/003_methods.t +++ b/t/003_methods.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 67; +use Test::More tests => 70; use Test::Exception; use Scalar::Util qw/reftype/; @@ -320,7 +320,9 @@ is( $new_method->original_method, $method, } ); - $meta->add_method( 'new', sub { return bless {}, shift } ); + sub new { + return bless {}, shift; + } } { @@ -331,6 +333,22 @@ is( $new_method->original_method, $method, is( $o->{custom_store}, $str, - 'Custom glob-assignment-created accessor is still method modifier is added' + 'Custom glob-assignment-created accessor still has method modifier' ); } + +{ + # Since the sub reference below is not a closure, Perl caches it and uses + # the same reference each time through the loop. See RT #48985 for the + # bug. + foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) { + my $meta = Class::MOP::Class->create($ns); + + my $sub = sub { }; + + $meta->add_method( 'foo', $sub ); + + my $method = $meta->get_method('foo'); + ok( $method, 'Got the foo method back' ); + } +} diff --git a/t/314_class_is_pristine.t b/t/314_class_is_pristine.t new file mode 100644 index 0000000..08e4b64 --- /dev/null +++ b/t/314_class_is_pristine.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Class::MOP; + +use Test::More tests => 3; + +{ + package Foo; + + sub foo { } + sub bar { } +} + +my $meta = Class::MOP::Class->initialize('Foo'); +ok( $meta->is_pristine, 'Foo is still pristine' ); + +$meta->add_method( baz => sub { } ); +ok( $meta->is_pristine, 'Foo is still pristine after add_method' ); + +$meta->add_attribute( name => 'attr', reader => 'get_attr' ); +ok( ! $meta->is_pristine, 'Foo is not pristine after add_attribute' ); diff --git a/xs/Package.xs b/xs/Package.xs index 362c407..675e894 100644 --- a/xs/Package.xs +++ b/xs/Package.xs @@ -34,7 +34,15 @@ mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stas method_slot = *hv_fetch(map, method_name, method_name_len, TRUE); if ( SvOK(method_slot) ) { - SV *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */ + SV *body; + + if ( sv_isobject(method_slot) ) { + body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */ + } + else { + body = method_slot; + } + if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) { continue; }