X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FMixin%2FHasMethods.pm;h=d3ceaa89b818aa702a5efa08e9d4f5c7256bee63;hb=fd05ff5f1f8bfebdfc0845412739a6997cbc02b0;hp=4baa3208cddfe2bf3cf29dfa4c6225d75c513fc4;hpb=814ad9dc96c1c038147d316b6bb19226e09d8ec3;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Mixin/HasMethods.pm b/lib/Class/MOP/Mixin/HasMethods.pm index 4baa320..d3ceaa8 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 = '0.99'; +use Class::MOP::Method::Meta; + +our $VERSION = '1.11'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -15,12 +17,24 @@ 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 ) = @_; @@ -39,12 +53,14 @@ sub add_method { ( defined $method_name && length $method_name ) || confess "You must define a method name"; + my $package_name = $self->name; + my $body; if ( blessed($method) ) { $body = $method->body; - if ( $method->package_name ne $self->name ) { + if ( $method->package_name ne $package_name ) { $method = $method->clone( - package_name => $self->name, + package_name => $package_name, name => $method_name, ) if $method->can('clone'); } @@ -62,7 +78,7 @@ sub add_method { my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); if ( !defined $current_name || $current_name =~ /^__ANON__/ ) { - my $full_method_name = ( $self->name . '::' . $method_name ); + my $full_method_name = ( $package_name . '::' . $method_name ); subname( $full_method_name => $body ); } @@ -87,7 +103,7 @@ sub has_method { ( defined $method_name && length $method_name ) || confess "You must define a method name"; - return defined( $self->get_method($method_name) ); + return defined( $self->_get_maybe_raw_method($method_name) ); } sub get_method { @@ -96,6 +112,21 @@ sub get_method { ( defined $method_name && length $method_name ) || confess "You must define a method name"; + 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 ) = @_; + my $method_map = $self->_method_map; my $map_entry = $method_map->{$method_name}; my $code = $self->get_package_symbol( @@ -106,25 +137,18 @@ sub get_method { } ); - # 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; - - return $map_entry if blessed $map_entry && $map_entry->body == $code; + # The !$code case 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 ); 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 { @@ -132,7 +156,7 @@ 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 } ); @@ -148,7 +172,57 @@ sub remove_method { sub get_method_list { my $self = shift; - return grep { $self->has_method($_) } keys %{ $self->namespace }; + + my $namespace = $self->namespace; + + # Constants may show up as some sort of non-GLOB reference in the + # namespace hash ref, depending on the Perl version. + return grep { + defined $namespace->{$_} + && ( ref( \$namespace->{$_} ) ne 'GLOB' + || *{ $namespace->{$_} }{CODE} ) + && $self->has_method($_) + } + keys %{$namespace}; +} + +# 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; + + my $namespace = $self->namespace; + + return map { $self->get_method($_) } + grep { + defined $namespace->{$_} + && ( ref $namespace->{$_} + || *{ $namespace->{$_} }{CODE} ) + } + keys %{$namespace}; +} + +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); } 1;