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';
14 use Sub::Name 'subname';
16 use base 'Class::MOP::Mixin';
18 sub method_metaclass { $_[0]->{'method_metaclass'} }
19 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
20 sub _meta_method_class { 'Class::MOP::Method::Meta' }
22 sub _add_meta_method {
24 my $existing_method = $self->can('find_method_by_name')
25 ? $self->find_method_by_name('meta')
26 : $self->get_method('meta');
27 return if $existing_method
28 && $existing_method->isa($self->_meta_method_class);
30 'meta' => $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 if ( !defined $current_name || $current_name =~ /^__ANON__/ ) {
86 my $full_method_name = ( $package_name . '::' . $method_name );
87 subname( $full_method_name => $body );
90 $self->add_package_symbol(
91 { sigil => '&', type => 'CODE', name => $method_name },
97 my ( $self, $code ) = @_;
99 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
101 return $code_package && $code_package eq $self->name
102 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
106 my ( $self, $method_name ) = @_;
108 ( defined $method_name && length $method_name )
109 || confess "You must define a method name";
111 return defined( $self->_get_maybe_raw_method($method_name) );
115 my ( $self, $method_name ) = @_;
117 ( defined $method_name && length $method_name )
118 || confess "You must define a method name";
120 my $method = $self->_get_maybe_raw_method($method_name)
123 return $method if blessed $method;
125 return $self->_method_map->{$method_name} = $self->wrap_method_body(
127 name => $method_name,
128 associated_metaclass => $self,
132 sub _get_maybe_raw_method {
133 my ( $self, $method_name ) = @_;
135 my $method_map = $self->_method_map;
136 my $map_entry = $method_map->{$method_name};
137 my $code = $self->get_package_symbol(
139 name => $method_name,
145 # The !$code case seems to happen in some weird cases where methods
146 # modifiers are added via roles or some other such bizareness. Honestly, I
147 # don't totally understand this, but returning the entry works, and keeps
148 # various MX modules from blowing up. - DR
150 if blessed $map_entry && ( !$code || $map_entry->body == $code );
152 unless ($map_entry) {
153 return unless $code && $self->_code_is_mine($code);
160 my ( $self, $method_name ) = @_;
161 ( defined $method_name && length $method_name )
162 || confess "You must define a method name";
164 my $removed_method = delete $self->_full_method_map->{$method_name};
166 $self->remove_package_symbol(
167 { sigil => '&', type => 'CODE', name => $method_name } );
169 $removed_method->detach_from_class
170 if $removed_method && blessed $removed_method;
172 # still valid, since we just removed the method from the map
173 $self->update_package_cache_flag;
175 return $removed_method;
178 sub get_method_list {
181 my $namespace = $self->namespace;
183 # Constants may show up as some sort of non-GLOB reference in the
184 # namespace hash ref, depending on the Perl version.
186 defined $namespace->{$_}
187 && ( ref( \$namespace->{$_} ) ne 'GLOB'
188 || *{ $namespace->{$_} }{CODE} )
189 && $self->has_method($_)
194 # This should probably be what get_method_list actually does, instead of just
195 # returning names. This was created as a much faster alternative to
196 # $meta->get_method($_) for $meta->get_method_list
197 sub _get_local_methods {
200 my $namespace = $self->namespace;
202 return map { $self->get_method($_) }
204 defined $namespace->{$_}
205 && ( ref $namespace->{$_}
206 || *{ $namespace->{$_} }{CODE} )
211 sub _restore_metamethods_from {
215 for my $method ($old_meta->_get_local_methods) {
216 # XXX: this is pretty gross. the issue here is that
217 # CMOP::Method::Wrapped objects are subclasses of CMOP::Method, but
218 # when we get to moose, they'll need to be compatible with
219 # Moose::Meta::Method, which isn't possible. the right solution here is
220 # to make ::Wrapped into a role that gets applied to whatever the
221 # method_metaclass happens to be and get rid of
222 # wrapped_method_metaclass entirely, but that's not going to happen
223 # until we ditch cmop and get roles into the bootstrapping, so.
224 # i'm not maintaining the previous behavior of turning them into
225 # instances of the new method_metaclass because that's equally broken,
226 # and at least this way any issues will at least be detectable and
227 # potentially fixable. -doy
228 if (!$method->isa($self->wrapped_method_metaclass)
229 # and the same issue occurs with CMOP::Method::Meta objects/:
230 && !$method->isa($self->_meta_method_class)) {
231 $method->_make_compatible_with($self->method_metaclass);
233 $self->add_method($method->name => $method);
245 Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
249 This class implements methods for metaclasses which have methods
250 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
255 Dave Rolsky E<lt>autarch@urth.orgE<gt>
257 =head1 COPYRIGHT AND LICENSE
259 Copyright 2006-2010 by Infinity Interactive, Inc.
261 L<http://www.iinteractive.com>
263 This library is free software; you can redistribute it and/or modify
264 it under the same terms as Perl itself.