1 package Class::MOP::Mixin::HasMethods;
6 use Class::MOP::Method::Meta;
9 $VERSION = eval $VERSION;
10 our $AUTHORITY = 'cpan:STEVAN';
12 use Scalar::Util 'blessed';
15 use base 'Class::MOP::Mixin';
17 sub method_metaclass { $_[0]->{'method_metaclass'} }
18 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
19 sub _meta_method_class { 'Class::MOP::Method::Meta' }
21 sub _add_meta_method {
24 my $existing_method = $self->can('find_method_by_name')
25 ? $self->find_method_by_name($name)
26 : $self->get_method($name);
27 return if $existing_method
28 && $existing_method->isa($self->_meta_method_class);
30 $name => $self->_meta_method_class->wrap(
32 package_name => $self->name,
33 associated_metaclass => $self,
38 # This doesn't always get initialized in a constructor because there is a
39 # weird object construction path for subclasses of Class::MOP::Class. At one
40 # point, this always got initialized by calling into the XS code first, but
41 # that is no longer guaranteed to happen.
42 sub _method_map { $_[0]->{'methods'} ||= {} }
44 sub wrap_method_body {
45 my ( $self, %args ) = @_;
47 ( 'CODE' eq ref $args{body} )
48 || confess "Your code block must be a CODE reference";
50 $self->method_metaclass->wrap(
51 package_name => $self->name,
57 my ( $self, $method_name, $method ) = @_;
58 ( defined $method_name && length $method_name )
59 || confess "You must define a method name";
61 my $package_name = $self->name;
64 if ( blessed($method) ) {
65 $body = $method->body;
66 if ( $method->package_name ne $package_name ) {
67 $method = $method->clone(
68 package_name => $package_name,
70 ) if $method->can('clone');
73 $method->attach_to_class($self);
76 # If a raw code reference is supplied, its method object is not created.
77 # The method object won't be created until required.
81 $self->_method_map->{$method_name} = $method;
83 my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
85 $self->add_package_symbol(
86 { sigil => '&', type => 'CODE', name => $method_name },
88 (!defined($current_name) || $current_name =~ /^__ANON__/)
89 ? (subname => $method_name)
95 my ( $self, $code ) = @_;
97 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
99 return $code_package && $code_package eq $self->name
100 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
104 my ( $self, $method_name ) = @_;
106 ( defined $method_name && length $method_name )
107 || confess "You must define a method name";
109 return defined( $self->_get_maybe_raw_method($method_name) );
113 my ( $self, $method_name ) = @_;
115 ( defined $method_name && length $method_name )
116 || confess "You must define a method name";
118 my $method = $self->_get_maybe_raw_method($method_name)
121 return $method if blessed $method;
123 return $self->_method_map->{$method_name} = $self->wrap_method_body(
125 name => $method_name,
126 associated_metaclass => $self,
130 sub _get_maybe_raw_method {
131 my ( $self, $method_name ) = @_;
133 my $method_map = $self->_method_map;
134 my $map_entry = $method_map->{$method_name};
135 my $code = $self->get_package_symbol(
137 name => $method_name,
143 # The !$code case seems to happen in some weird cases where methods
144 # modifiers are added via roles or some other such bizareness. Honestly, I
145 # don't totally understand this, but returning the entry works, and keeps
146 # various MX modules from blowing up. - DR
148 if blessed $map_entry && ( !$code || $map_entry->body == $code );
150 unless ($map_entry) {
151 return unless $code && $self->_code_is_mine($code);
158 my ( $self, $method_name ) = @_;
159 ( defined $method_name && length $method_name )
160 || confess "You must define a method name";
162 my $removed_method = delete $self->_full_method_map->{$method_name};
164 $self->remove_package_symbol(
165 { sigil => '&', type => 'CODE', name => $method_name } );
167 $removed_method->detach_from_class
168 if $removed_method && blessed $removed_method;
170 # still valid, since we just removed the method from the map
171 $self->update_package_cache_flag;
173 return $removed_method;
176 sub get_method_list {
179 my $namespace = $self->namespace;
181 # Constants may show up as some sort of non-GLOB reference in the
182 # namespace hash ref, depending on the Perl version.
184 defined $namespace->{$_}
185 && ( ref( \$namespace->{$_} ) ne 'GLOB'
186 || *{ $namespace->{$_} }{CODE} )
187 && $self->has_method($_)
192 # This should probably be what get_method_list actually does, instead of just
193 # returning names. This was created as a much faster alternative to
194 # $meta->get_method($_) for $meta->get_method_list
195 sub _get_local_methods {
198 my $namespace = $self->namespace;
200 return map { $self->get_method($_) }
202 defined $namespace->{$_}
203 && ( ref $namespace->{$_}
204 || *{ $namespace->{$_} }{CODE} )
209 sub _restore_metamethods_from {
213 for my $method ($old_meta->_get_local_methods) {
214 $method->_make_compatible_with($self->method_metaclass);
215 $self->add_method($method->name => $method);
227 Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
231 This class implements methods for metaclasses which have methods
232 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
237 Dave Rolsky E<lt>autarch@urth.orgE<gt>
239 =head1 COPYRIGHT AND LICENSE
241 Copyright 2006-2010 by Infinity Interactive, Inc.
243 L<http://www.iinteractive.com>
245 This library is free software; you can redistribute it and/or modify
246 it under the same terms as Perl itself.