make github the primary repository
[gitmo/Moose.git] / lib / Class / MOP / Mixin / HasMethods.pm
CommitLineData
38bf2a25 1package Class::MOP::Mixin::HasMethods;
2
3use strict;
4use warnings;
5
6use Class::MOP::Method::Meta;
2683d371 7use Class::MOP::Method::Overload;
38bf2a25 8
38bf2a25 9use Scalar::Util 'blessed';
10use Carp 'confess';
11use Sub::Name 'subname';
12
2683d371 13use overload ();
14
38bf2a25 15use base 'Class::MOP::Mixin';
16
17sub _meta_method_class { 'Class::MOP::Method::Meta' }
18
19sub _add_meta_method {
20 my $self = shift;
21 my ($name) = @_;
22 my $existing_method = $self->can('find_method_by_name')
23 ? $self->find_method_by_name($name)
24 : $self->get_method($name);
25 return if $existing_method
26 && $existing_method->isa($self->_meta_method_class);
27 $self->add_method(
28 $name => $self->_meta_method_class->wrap(
29 name => $name,
30 package_name => $self->name,
31 associated_metaclass => $self,
32 )
33 );
34}
35
36sub wrap_method_body {
37 my ( $self, %args ) = @_;
38
39 ( 'CODE' eq ref $args{body} )
40 || confess "Your code block must be a CODE reference";
41
42 $self->method_metaclass->wrap(
43 package_name => $self->name,
44 %args,
45 );
46}
47
48sub add_method {
49 my ( $self, $method_name, $method ) = @_;
50 ( defined $method_name && length $method_name )
51 || confess "You must define a method name";
52
53 my $package_name = $self->name;
54
55 my $body;
56 if ( blessed($method) ) {
57 $body = $method->body;
58 if ( $method->package_name ne $package_name ) {
59 $method = $method->clone(
60 package_name => $package_name,
61 name => $method_name,
62 );
63 }
64
65 $method->attach_to_class($self);
66 }
67 else {
68 # If a raw code reference is supplied, its method object is not created.
69 # The method object won't be created until required.
70 $body = $method;
71 }
72
73 $self->_method_map->{$method_name} = $method;
74
75 my ($current_package, $current_name) = Class::MOP::get_code_info($body);
76
77 subname($package_name . '::' . $method_name, $body)
78 unless defined $current_name && $current_name !~ /^__ANON__/;
79
80 $self->add_package_symbol("&$method_name", $body);
81
82 # we added the method to the method map too, so it's still valid
83 $self->update_package_cache_flag;
84}
85
86sub _code_is_mine {
87 my ( $self, $code ) = @_;
88
89 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
90
91 return ( $code_package && $code_package eq $self->name )
92 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
93}
94
95sub has_method {
96 my ( $self, $method_name ) = @_;
97
98 ( defined $method_name && length $method_name )
99 || confess "You must define a method name";
100
101 my $method = $self->_get_maybe_raw_method($method_name)
102 or return;
103
104 return defined($self->_method_map->{$method_name} = $method);
105}
106
107sub get_method {
108 my ( $self, $method_name ) = @_;
109
110 ( defined $method_name && length $method_name )
111 || confess "You must define a method name";
112
113 my $method = $self->_get_maybe_raw_method($method_name)
114 or return;
115
116 return $method if blessed $method;
117
118 return $self->_method_map->{$method_name} = $self->wrap_method_body(
119 body => $method,
120 name => $method_name,
121 associated_metaclass => $self,
122 );
123}
124
125sub _get_maybe_raw_method {
126 my ( $self, $method_name ) = @_;
127
128 my $map_entry = $self->_method_map->{$method_name};
129 return $map_entry if defined $map_entry;
130
131 my $code = $self->get_package_symbol("&$method_name");
132
133 return unless $code && $self->_code_is_mine($code);
134
135 return $code;
136}
137
138sub remove_method {
139 my ( $self, $method_name ) = @_;
140
141 ( defined $method_name && length $method_name )
142 || confess "You must define a method name";
143
144 my $removed_method = delete $self->_method_map->{$method_name};
145
146 $self->remove_package_symbol("&$method_name");
147
148 $removed_method->detach_from_class
149 if blessed($removed_method);
150
151 # still valid, since we just removed the method from the map
152 $self->update_package_cache_flag;
153
154 return $removed_method;
155}
156
157sub get_method_list {
158 my $self = shift;
159
160 return keys %{ $self->_full_method_map };
161}
162
163sub _get_local_methods {
164 my $self = shift;
165
166 return values %{ $self->_full_method_map };
167}
168
169sub _restore_metamethods_from {
170 my $self = shift;
171 my ($old_meta) = @_;
172
173 for my $method ($old_meta->_get_local_methods) {
174 $method->_make_compatible_with($self->method_metaclass);
175 $self->add_method($method->name => $method);
176 }
177}
178
179sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
180sub update_package_cache_flag {
181 my $self = shift;
182 # NOTE:
183 # we can manually update the cache number
184 # since we are actually adding the method
185 # to our cache as well. This avoids us
186 # having to regenerate the method_map.
187 # - SL
188 $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
189}
190
191sub _full_method_map {
192 my $self = shift;
193
194 my $pkg_gen = Class::MOP::check_package_cache_flag($self->name);
195
196 if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) {
197 # forcibly reify all method map entries
198 $self->get_method($_)
199 for $self->list_all_package_symbols('CODE');
200 $self->{_package_cache_flag_full} = $pkg_gen;
201 }
202
203 return $self->_method_map;
204}
205
2683d371 206# overloading
207
644d6eaa 208my $overload_operators;
209sub overload_operators {
210 $overload_operators ||= [map { split /\s+/ } values %overload::ops];
4a0bc88f 211 return @$overload_operators;
2683d371 212}
213
c18e272e 214sub is_overloaded {
215 my $self = shift;
216 return overload::Overloaded($self->name);
217}
218
2683d371 219# XXX this could probably stand to be cached, but i figure it should be
220# uncommon enough to not particularly matter
221sub _overload_map {
222 my $self = shift;
223
c18e272e 224 return {} unless $self->is_overloaded;
2683d371 225
226 my %map;
4a0bc88f 227 for my $op ($self->overload_operators) {
456105f5 228 my $body = $self->_get_overloaded_operator_body($op);
2683d371 229 next unless defined $body;
230 $map{$op} = $body;
231 }
232
233 return \%map;
234}
235
236sub get_overload_list {
237 my $self = shift;
252ced44 238 return keys %{ $self->_overload_map };
2683d371 239}
240
87a1f36e 241sub get_all_overloaded_operators {
2683d371 242 my $self = shift;
87a1f36e 243 my $map = $self->_overload_map;
252ced44 244 return map { $self->_wrap_overload($_, $map->{$_}) } keys %$map;
2683d371 245}
246
644d6eaa 247sub has_overloaded_operator {
2683d371 248 my $self = shift;
249 my ($op) = @_;
456105f5 250 return defined $self->_get_overloaded_operator_body($op);
2683d371 251}
252
644d6eaa 253sub get_overloaded_operator {
2683d371 254 my $self = shift;
255 my ($op) = @_;
456105f5 256 my $body = $self->_get_overloaded_operator_body($op);
2683d371 257 return unless defined $body;
258 return $self->_wrap_overload($op, $body);
259}
260
4a0bc88f 261sub add_overloaded_operator {
2683d371 262 my $self = shift;
263 my ($op, $body) = @_;
f477bafa 264 $self->name->overload::OVERLOAD($op => $body);
2683d371 265}
266
702be3d8 267sub remove_overloaded_operator {
268 my $self = shift;
269 my ($op) = @_;
270 # ugh, overload.pm provides no api for this
271 $self->get_or_add_package_symbol('%OVERLOAD')->{dummy}++;
272 $self->remove_package_symbol('&(' . $op);
273}
274
456105f5 275sub _get_overloaded_operator_body {
276 my $self = shift;
277 my ($op) = @_;
278 return overload::Method($self->name, $op);
279}
280
2683d371 281sub _wrap_overload {
282 my $self = shift;
283 my ($op, $body) = @_;
284 return Class::MOP::Method::Overload->wrap(
644d6eaa 285 operator => $op,
2683d371 286 package_name => $self->name,
287 associated_metaclass => $self,
288 body => $body,
289 );
290}
291
38bf2a25 2921;
293
294# ABSTRACT: Methods for metaclasses which have methods
295
296__END__
297
298=pod
299
300=head1 DESCRIPTION
301
302This class implements methods for metaclasses which have methods
303(L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
304for API details.
305
306=cut