X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FMixin%2FHasMethods.pm;h=141bfa71143053dc4e34edb1877d5fd623f40a09;hb=53362bcb1b32d87630190fbf50679dc37bb51adf;hp=cd11a8fb3e5cf966be712a684a38bff065b3f4d9;hpb=ef8d6eaee0d3a8a57f7e42c5cf3eab266fe25476;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Mixin/HasMethods.pm b/lib/Class/MOP/Mixin/HasMethods.pm index cd11a8f..141bfa7 100644 --- a/lib/Class/MOP/Mixin/HasMethods.pm +++ b/lib/Class/MOP/Mixin/HasMethods.pm @@ -3,7 +3,9 @@ package Class::MOP::Mixin::HasMethods; use strict; use warnings; -our $VERSION = '1.04'; +use Class::MOP::Method::Meta; + +our $VERSION = '1.11'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -13,14 +15,24 @@ use Sub::Name 'subname'; use base 'Class::MOP::Mixin'; -sub method_metaclass { $_[0]->{'method_metaclass'} } -sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } +sub _meta_method_class { 'Class::MOP::Method::Meta' } -# This doesn't always get initialized in a constructor because there is a -# weird object construction path for subclasses of Class::MOP::Class. At one -# point, this always got initialized by calling into the XS code first, but -# that is no longer guaranteed to happen. -sub _method_map { $_[0]->{'methods'} ||= {} } +sub _add_meta_method { + my $self = shift; + my ($name) = @_; + my $existing_method = $self->can('find_method_by_name') + ? $self->find_method_by_name($name) + : $self->get_method($name); + return if $existing_method + && $existing_method->isa($self->_meta_method_class); + $self->add_method( + $name => $self->_meta_method_class->wrap( + name => $name, + package_name => $self->name, + associated_metaclass => $self, + ) + ); +} sub wrap_method_body { my ( $self, %args ) = @_; @@ -68,10 +80,11 @@ sub add_method { subname( $full_method_name => $body ); } - $self->add_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name }, - $body, - ); + $self->add_package_symbol("&$method_name", $body); + + # if we added the actual method object to the method map, we're still valid + $self->update_package_cache_flag + if blessed($method); } sub _code_is_mine { @@ -89,7 +102,10 @@ sub has_method { ( defined $method_name && length $method_name ) || confess "You must define a method name"; - return defined( $self->get_method($method_name) ); + my $method = $self->_get_maybe_raw_method($method_name) + or return; + + return defined($self->_method_map->{$method_name} = $method); } sub get_method { @@ -98,34 +114,31 @@ sub get_method { ( defined $method_name && length $method_name ) || confess "You must define a method name"; - 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', - } + my $method = $self->_get_maybe_raw_method($method_name) + or return; + + return $method if blessed $method; + + return $self->_method_map->{$method_name} = $self->wrap_method_body( + body => $method, + name => $method_name, + associated_metaclass => $self, ); +} + +sub _get_maybe_raw_method { + my ( $self, $method_name ) = @_; - # This seems to happen in some weird cases where methods modifiers are - # added via roles or some other such bizareness. Honestly, I don't totally - # understand this, but returning the entry works, and keeps various MX - # modules from blowing up. - DR - return $map_entry - if blessed $map_entry && ( !$code || $map_entry->body == $code ); + my $map_entry = $self->_method_map->{$method_name}; + return $map_entry if defined $map_entry; + + my $code = $self->get_package_symbol("&$method_name"); unless ($map_entry) { return unless $code && $self->_code_is_mine($code); } - $code ||= $map_entry; - - return $method_map->{$method_name} = $self->wrap_method_body( - body => $code, - name => $method_name, - associated_metaclass => $self, - ); + return $code; } sub remove_method { @@ -133,10 +146,9 @@ sub remove_method { ( defined $method_name && length $method_name ) || confess "You must define a method name"; - my $removed_method = delete $self->_full_method_map->{$method_name}; + my $removed_method = delete $self->_method_map->{$method_name}; - $self->remove_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name } ); + $self->remove_package_symbol("&$method_name"); $removed_method->detach_from_class if $removed_method && blessed $removed_method; @@ -149,7 +161,54 @@ sub remove_method { sub get_method_list { my $self = shift; - return grep { $self->has_method($_) } keys %{ $self->namespace }; + + return keys %{ $self->_full_method_map }; +} + +# This should probably be what get_method_list actually does, instead of just +# returning names. This was created as a much faster alternative to +# $meta->get_method($_) for $meta->get_method_list +sub _get_local_methods { + my $self = shift; + + return values %{ $self->_full_method_map }; +} + +sub _restore_metamethods_from { + my $self = shift; + my ($old_meta) = @_; + + for my $method ($old_meta->_get_local_methods) { + $method->_make_compatible_with($self->method_metaclass); + $self->add_method($method->name => $method); + } +} + +sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef } +sub update_package_cache_flag { + my $self = shift; + # NOTE: + # we can manually update the cache number + # since we are actually adding the method + # to our cache as well. This avoids us + # having to regenerate the method_map. + # - SL + $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); +} + +sub _full_method_map { + my $self = shift; + + my $pkg_gen = Class::MOP::check_package_cache_flag($self->name); + + if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) { + # forcibly reify all method map entries + $self->get_method($_) + for $self->list_all_package_symbols('CODE'); + $self->{_package_cache_flag_full} = $pkg_gen; + } + + return $self->_method_map; } 1;