make github the primary repository
[gitmo/Moose.git] / lib / Class / MOP / Mixin / HasMethods.pm
1 package Class::MOP::Mixin::HasMethods;
2
3 use strict;
4 use warnings;
5
6 use Class::MOP::Method::Meta;
7 use Class::MOP::Method::Overload;
8
9 use Scalar::Util 'blessed';
10 use Carp         'confess';
11 use Sub::Name    'subname';
12
13 use overload ();
14
15 use base 'Class::MOP::Mixin';
16
17 sub _meta_method_class { 'Class::MOP::Method::Meta' }
18
19 sub _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
36 sub 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
48 sub 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
86 sub _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
95 sub 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
107 sub 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
125 sub _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
138 sub 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
157 sub get_method_list {
158     my $self = shift;
159
160     return keys %{ $self->_full_method_map };
161 }
162
163 sub _get_local_methods {
164     my $self = shift;
165
166     return values %{ $self->_full_method_map };
167 }
168
169 sub _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
179 sub reset_package_cache_flag  { (shift)->{'_package_cache_flag'} = undef }
180 sub 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
191 sub _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
206 # overloading
207
208 my $overload_operators;
209 sub overload_operators {
210     $overload_operators ||= [map { split /\s+/ } values %overload::ops];
211     return @$overload_operators;
212 }
213
214 sub is_overloaded {
215     my $self = shift;
216     return overload::Overloaded($self->name);
217 }
218
219 # XXX this could probably stand to be cached, but i figure it should be
220 # uncommon enough to not particularly matter
221 sub _overload_map {
222     my $self = shift;
223
224     return {} unless $self->is_overloaded;
225
226     my %map;
227     for my $op ($self->overload_operators) {
228         my $body = $self->_get_overloaded_operator_body($op);
229         next unless defined $body;
230         $map{$op} = $body;
231     }
232
233     return \%map;
234 }
235
236 sub get_overload_list {
237     my $self = shift;
238     return keys %{ $self->_overload_map };
239 }
240
241 sub get_all_overloaded_operators {
242     my $self = shift;
243     my $map = $self->_overload_map;
244     return map { $self->_wrap_overload($_, $map->{$_}) } keys %$map;
245 }
246
247 sub has_overloaded_operator {
248     my $self = shift;
249     my ($op) = @_;
250     return defined $self->_get_overloaded_operator_body($op);
251 }
252
253 sub get_overloaded_operator {
254     my $self = shift;
255     my ($op) = @_;
256     my $body = $self->_get_overloaded_operator_body($op);
257     return unless defined $body;
258     return $self->_wrap_overload($op, $body);
259 }
260
261 sub add_overloaded_operator {
262     my $self = shift;
263     my ($op, $body) = @_;
264     $self->name->overload::OVERLOAD($op => $body);
265 }
266
267 sub 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
275 sub _get_overloaded_operator_body {
276     my $self = shift;
277     my ($op) = @_;
278     return overload::Method($self->name, $op);
279 }
280
281 sub _wrap_overload {
282     my $self = shift;
283     my ($op, $body) = @_;
284     return Class::MOP::Method::Overload->wrap(
285         operator             => $op,
286         package_name         => $self->name,
287         associated_metaclass => $self,
288         body                 => $body,
289     );
290 }
291
292 1;
293
294 # ABSTRACT: Methods for metaclasses which have methods
295
296 __END__
297
298 =pod
299
300 =head1 DESCRIPTION
301
302 This class implements methods for metaclasses which have methods
303 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
304 for API details.
305
306 =cut