Commit | Line | Data |
a2227e71 |
1 | package Mouse::Meta::Role; |
bc69ee88 |
2 | use Mouse::Util qw(:meta not_supported english_list); # enables strict and warnings |
74be9f76 |
3 | |
6d28c5cf |
4 | use Mouse::Meta::Module; |
f3bb863f |
5 | our @ISA = qw(Mouse::Meta::Module); |
a2227e71 |
6 | |
6cfa1e5e |
7 | sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method() |
8 | |
8e64d0fa |
9 | sub _construct_meta { |
acf0f643 |
10 | my $class = shift; |
7a50b450 |
11 | |
acf0f643 |
12 | my %args = @_; |
13 | |
3a63a2e7 |
14 | $args{methods} ||= {}; |
59089ec3 |
15 | $args{attributes} ||= {}; |
16 | $args{required_methods} ||= []; |
47f36c05 |
17 | $args{roles} ||= []; |
274b6cce |
18 | |
9009aca1 |
19 | my $self = bless \%args, ref($class) || $class; |
20 | if($class ne __PACKAGE__){ |
21 | $self->meta->_initialize_object($self, \%args); |
22 | } |
7a50b450 |
23 | |
9009aca1 |
24 | return $self; |
7a50b450 |
25 | } |
26 | |
27 | sub create_anon_role{ |
28 | my $self = shift; |
29 | return $self->create(undef, @_); |
30 | } |
31 | |
32 | sub is_anon_role{ |
33 | return exists $_[0]->{anon_serial_id}; |
acf0f643 |
34 | } |
a2227e71 |
35 | |
afc73948 |
36 | sub get_roles { $_[0]->{roles} } |
37 | |
6cfa1e5e |
38 | sub get_required_method_list{ |
39 | return @{ $_[0]->{required_methods} }; |
40 | } |
afc73948 |
41 | |
59089ec3 |
42 | sub add_required_methods { |
ea249879 |
43 | my($self, @methods) = @_; |
59089ec3 |
44 | push @{$self->{required_methods}}, @methods; |
45 | } |
46 | |
6cfa1e5e |
47 | sub requires_method { |
48 | my($self, $name) = @_; |
49 | return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0; |
50 | } |
51 | |
274b6cce |
52 | sub add_attribute { |
53 | my $self = shift; |
54 | my $name = shift; |
6cfa1e5e |
55 | |
56 | $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ }; |
da0c885d |
57 | } |
58 | |
7a50b450 |
59 | sub _canonicalize_apply_args{ |
60 | my($self, $applicant, %args) = @_; |
61 | |
fb6960c6 |
62 | if($applicant->isa('Mouse::Meta::Class')){ # Application::ToClass |
7a50b450 |
63 | $args{_to} = 'class'; |
64 | } |
fb6960c6 |
65 | elsif($applicant->isa('Mouse::Meta::Role')){ # Application::ToRole |
7a50b450 |
66 | $args{_to} = 'role'; |
67 | } |
fb6960c6 |
68 | else{ # Appplication::ToInstance |
69 | $args{_to} = 'class'; |
70 | |
71 | my $metaclass = $applicant->meta->create_anon_class( |
72 | superclasses => [ref $applicant], |
73 | cache => 1, |
74 | ); |
75 | bless $applicant, $metaclass->name; # rebless |
7a50b450 |
76 | |
fb6960c6 |
77 | $applicant = $metaclass; |
7a50b450 |
78 | } |
79 | |
80 | if($args{alias} && !exists $args{-alias}){ |
81 | $args{-alias} = $args{alias}; |
82 | } |
83 | if($args{excludes} && !exists $args{-excludes}){ |
84 | $args{-excludes} = $args{excludes}; |
85 | } |
86 | |
87 | if(my $excludes = $args{-excludes}){ |
88 | $args{-excludes} = {}; # replace with a hash ref |
89 | if(ref $excludes){ |
90 | %{$args{-excludes}} = (map{ $_ => undef } @{$excludes}); |
91 | } |
92 | else{ |
93 | $args{-excludes}{$excludes} = undef; |
94 | } |
95 | } |
96 | |
fb6960c6 |
97 | return( $applicant, \%args ); |
7a50b450 |
98 | } |
99 | |
3a63a2e7 |
100 | sub _check_required_methods{ |
101 | my($role, $class, $args, @other_roles) = @_; |
102 | |
7a50b450 |
103 | if($args->{_to} eq 'class'){ |
3a63a2e7 |
104 | my $class_name = $class->name; |
7a50b450 |
105 | my $role_name = $role->name; |
106 | my @missing; |
3a63a2e7 |
107 | foreach my $method_name(@{$role->{required_methods}}){ |
7a50b450 |
108 | if(!$class_name->can($method_name)){ |
3a63a2e7 |
109 | my $has_method = 0; |
110 | |
111 | foreach my $another_role_spec(@other_roles){ |
112 | my $another_role_name = $another_role_spec->[0]; |
113 | if($role_name ne $another_role_name && $another_role_name->can($method_name)){ |
114 | $has_method = 1; |
115 | last; |
116 | } |
117 | } |
7a50b450 |
118 | |
119 | push @missing, $method_name if !$has_method; |
3a63a2e7 |
120 | } |
121 | } |
7a50b450 |
122 | if(@missing){ |
123 | $class->throw_error("'$role_name' requires the " |
124 | . (@missing == 1 ? 'method' : 'methods') |
125 | . " " |
126 | . english_list(map{ sprintf q{'%s'}, $_ } @missing) |
127 | . " to be implemented by '$class_name'"); |
128 | } |
129 | } |
fb6960c6 |
130 | else { |
7a50b450 |
131 | # apply role($role) to role($class) |
132 | foreach my $method_name($role->get_required_method_list){ |
133 | next if $class->has_method($method_name); # already has it |
134 | $class->add_required_methods($method_name); |
135 | } |
3a63a2e7 |
136 | } |
2e92bb89 |
137 | |
3a63a2e7 |
138 | return; |
2e92bb89 |
139 | } |
140 | |
3a63a2e7 |
141 | sub _apply_methods{ |
142 | my($role, $class, $args) = @_; |
da0c885d |
143 | |
3a63a2e7 |
144 | my $role_name = $role->name; |
145 | my $class_name = $class->name; |
6cfa1e5e |
146 | |
7a50b450 |
147 | my $alias = $args->{-alias}; |
148 | my $excludes = $args->{-excludes}; |
e0b163e1 |
149 | |
3a63a2e7 |
150 | foreach my $method_name($role->get_method_list){ |
151 | next if $method_name eq 'meta'; |
152 | |
153 | my $code = $role_name->can($method_name); |
6cfa1e5e |
154 | |
7a50b450 |
155 | if(!exists $excludes->{$method_name}){ |
6cfa1e5e |
156 | if(!$class->has_method($method_name)){ |
157 | $class->add_method($method_name => $code); |
158 | } |
2e92bb89 |
159 | } |
2e92bb89 |
160 | |
3a63a2e7 |
161 | if($alias && $alias->{$method_name}){ |
162 | my $dstname = $alias->{$method_name}; |
6cfa1e5e |
163 | |
7a50b450 |
164 | my $dstcode = do{ no strict 'refs'; *{$class_name . '::' . $dstname}{CODE} }; |
165 | |
166 | if(defined($dstcode) && $dstcode != $code){ |
6cfa1e5e |
167 | $class->throw_error("Cannot create a method alias if a local method of the same name exists"); |
21498b08 |
168 | } |
3a63a2e7 |
169 | else{ |
170 | $class->add_method($dstname => $code); |
2e92bb89 |
171 | } |
59089ec3 |
172 | } |
173 | } |
174 | |
3a63a2e7 |
175 | return; |
176 | } |
177 | |
178 | sub _apply_attributes{ |
179 | my($role, $class, $args) = @_; |
180 | |
7a50b450 |
181 | if ($args->{_to} eq 'class') { |
b1b81553 |
182 | # apply role to class |
3a63a2e7 |
183 | for my $attr_name ($role->get_attribute_list) { |
184 | next if $class->has_attribute($attr_name); |
185 | |
186 | my $spec = $role->get_attribute($attr_name); |
05b9dc92 |
187 | |
1b9e472d |
188 | $class->add_attribute($attr_name => %{$spec}); |
b1b81553 |
189 | } |
7a50b450 |
190 | } |
fb6960c6 |
191 | else { |
b1b81553 |
192 | # apply role to role |
3a63a2e7 |
193 | for my $attr_name ($role->get_attribute_list) { |
194 | next if $class->has_attribute($attr_name); |
195 | |
196 | my $spec = $role->get_attribute($attr_name); |
197 | $class->add_attribute($attr_name => $spec); |
b1b81553 |
198 | } |
da0c885d |
199 | } |
d99db7b6 |
200 | |
3a63a2e7 |
201 | return; |
202 | } |
203 | |
204 | sub _apply_modifiers{ |
205 | my($role, $class, $args) = @_; |
206 | |
7a50b450 |
207 | for my $modifier_type (qw/override before around after/) { |
3a63a2e7 |
208 | my $add_modifier = "add_${modifier_type}_method_modifier"; |
209 | my $modifiers = $role->{"${modifier_type}_method_modifiers"}; |
d99db7b6 |
210 | |
3a63a2e7 |
211 | while(my($method_name, $modifier_codes) = each %{$modifiers}){ |
6cfa1e5e |
212 | foreach my $code(ref($modifier_codes) eq 'ARRAY' ? @{$modifier_codes} : $modifier_codes){ |
3a63a2e7 |
213 | $class->$add_modifier($method_name => $code); |
d99db7b6 |
214 | } |
215 | } |
216 | } |
3a63a2e7 |
217 | return; |
da0c885d |
218 | } |
0fc8adbc |
219 | |
3a63a2e7 |
220 | sub _append_roles{ |
221 | my($role, $class, $args) = @_; |
21498b08 |
222 | |
7a50b450 |
223 | my $roles = ($args->{_to} eq 'class') ? $class->roles : $class->get_roles; |
3a63a2e7 |
224 | |
225 | foreach my $r($role, @{$role->get_roles}){ |
226 | if(!$class->does_role($r->name)){ |
227 | push @{$roles}, $r; |
21498b08 |
228 | } |
229 | } |
3a63a2e7 |
230 | return; |
231 | } |
21498b08 |
232 | |
3a63a2e7 |
233 | # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole |
234 | sub apply { |
7a50b450 |
235 | my $self = shift; |
236 | my $applicant = shift; |
fb6960c6 |
237 | my $args; |
3a63a2e7 |
238 | |
fb6960c6 |
239 | ($applicant, $args) = $self->_canonicalize_apply_args($applicant, @_); |
21498b08 |
240 | |
7a50b450 |
241 | $self->_check_required_methods($applicant, $args); |
242 | $self->_apply_methods($applicant, $args); |
243 | $self->_apply_attributes($applicant, $args); |
244 | $self->_apply_modifiers($applicant, $args); |
245 | $self->_append_roles($applicant, $args); |
3a63a2e7 |
246 | return; |
247 | } |
21498b08 |
248 | |
3a63a2e7 |
249 | sub combine_apply { |
fb6960c6 |
250 | my($role_class, $applicant, @roles) = @_; |
05b9dc92 |
251 | |
fb6960c6 |
252 | ($applicant) = $role_class->_canonicalize_apply_args($applicant); |
7a50b450 |
253 | |
60b5c3be |
254 | # check conflicting |
255 | my %method_provided; |
256 | my @method_conflicts; |
257 | my %attr_provided; |
258 | my %override_provided; |
259 | |
260 | foreach my $role_spec (@roles) { |
261 | my $role = $role_spec->[0]->meta; |
262 | my $role_name = $role->name; |
263 | |
264 | # methods |
265 | foreach my $method_name($role->get_method_list){ |
fb6960c6 |
266 | next if $applicant->has_method($method_name); # manually resolved |
60b5c3be |
267 | |
268 | my $code = do{ no strict 'refs'; \&{ $role_name . '::' . $method_name } }; |
269 | |
270 | my $c = $method_provided{$method_name}; |
271 | |
272 | if($c && $c->[0] != $code){ |
273 | push @{$c}, $role; |
274 | push @method_conflicts, $c; |
275 | } |
276 | else{ |
277 | $method_provided{$method_name} = [$code, $method_name, $role]; |
278 | } |
279 | } |
280 | |
281 | # attributes |
282 | foreach my $attr_name($role->get_attribute_list){ |
283 | my $attr = $role->get_attribute($attr_name); |
284 | my $c = $attr_provided{$attr_name}; |
285 | if($c && $c != $attr){ |
fb6960c6 |
286 | $role_class->throw_error("We have encountered an attribute conflict with '$attr_name' " |
60b5c3be |
287 | . "during composition. This is fatal error and cannot be disambiguated.") |
288 | } |
289 | else{ |
290 | $attr_provided{$attr_name} = $attr; |
291 | } |
292 | } |
293 | |
294 | # override modifiers |
295 | foreach my $method_name($role->get_method_modifier_list('override')){ |
296 | my $override = $role->get_override_method_modifier($method_name); |
297 | my $c = $override_provided{$method_name}; |
298 | if($c && $c != $override){ |
fb6960c6 |
299 | $role_class->throw_error( "We have encountered an 'override' method conflict with '$method_name' during " |
8e64d0fa |
300 | . "composition (Two 'override' methods of the same name encountered). " |
60b5c3be |
301 | . "This is fatal error.") |
302 | } |
303 | else{ |
304 | $override_provided{$method_name} = $override; |
305 | } |
306 | } |
307 | } |
308 | if(@method_conflicts){ |
309 | my $error; |
310 | |
311 | if(@method_conflicts == 1){ |
312 | my($code, $method_name, @roles) = @{$method_conflicts[0]}; |
fb6960c6 |
313 | $role_class->throw_error( |
60b5c3be |
314 | sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'}, |
fb6960c6 |
315 | english_list(map{ sprintf q{'%s'}, $_->name } @roles), $method_name, $applicant->name |
60b5c3be |
316 | ); |
317 | } |
318 | else{ |
319 | @method_conflicts = sort { $a->[0] cmp $b->[0] } @method_conflicts; # to avoid hash-ordering bugs |
320 | my $methods = english_list(map{ sprintf q{'%s'}, $_->[1] } @method_conflicts); |
321 | my $roles = english_list( |
322 | map{ sprintf q{'%s'}, $_->name } |
323 | map{ my($code, $method_name, @roles) = @{$_}; @roles } @method_conflicts |
324 | ); |
325 | |
fb6960c6 |
326 | $role_class->throw_error( |
60b5c3be |
327 | sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'}, |
fb6960c6 |
328 | $roles, $methods, $applicant->name |
60b5c3be |
329 | ); |
330 | } |
331 | } |
332 | |
3a63a2e7 |
333 | foreach my $role_spec (@roles) { |
334 | my($role_name, $args) = @{$role_spec}; |
21498b08 |
335 | |
3a63a2e7 |
336 | my $role = $role_name->meta; |
21498b08 |
337 | |
fb6960c6 |
338 | ($applicant, $args) = $role->_canonicalize_apply_args($applicant, %{$args}); |
7a50b450 |
339 | |
fb6960c6 |
340 | $role->_check_required_methods($applicant, $args, @roles); |
341 | $role->_apply_methods($applicant, $args); |
342 | $role->_apply_attributes($applicant, $args); |
343 | $role->_apply_modifiers($applicant, $args); |
344 | $role->_append_roles($applicant, $args); |
21498b08 |
345 | } |
3a63a2e7 |
346 | return; |
21498b08 |
347 | } |
348 | |
6cfa1e5e |
349 | for my $modifier_type (qw/before after around/) { |
3a63a2e7 |
350 | |
351 | my $modifier = "${modifier_type}_method_modifiers"; |
352 | my $add_method_modifier = sub { |
fc0e0bbd |
353 | my ($self, $method_name, $method) = @_; |
354 | |
3a63a2e7 |
355 | push @{ $self->{$modifier}->{$method_name} ||= [] }, $method; |
356 | return; |
fc0e0bbd |
357 | }; |
3370794f |
358 | my $has_method_modifiers = sub{ |
359 | my($self, $method_name) = @_; |
360 | my $m = $self->{$modifier}->{$method_name}; |
361 | return $m && @{$m} != 0; |
362 | }; |
3a63a2e7 |
363 | my $get_method_modifiers = sub { |
364 | my ($self, $method_name) = @_; |
365 | return @{ $self->{$modifier}->{$method_name} ||= [] } |
c2f128e7 |
366 | }; |
c2f128e7 |
367 | |
3a63a2e7 |
368 | no strict 'refs'; |
369 | *{ 'add_' . $modifier_type . '_method_modifier' } = $add_method_modifier; |
3370794f |
370 | *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers; |
3a63a2e7 |
371 | *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers; |
372 | } |
47f36c05 |
373 | |
6cfa1e5e |
374 | sub add_override_method_modifier{ |
375 | my($self, $method_name, $method) = @_; |
376 | |
60b5c3be |
377 | if($self->has_method($method_name)){ |
378 | # This error happens in the override keyword or during role composition, |
379 | # so I added a message, "A local method of ...", only for compatibility (gfx) |
8e64d0fa |
380 | $self->throw_error("Cannot add an override of method '$method_name' " |
60b5c3be |
381 | . "because there is a local version of '$method_name'" |
382 | . "(A local method of the same name as been found)"); |
383 | } |
6cfa1e5e |
384 | |
385 | $self->{override_method_modifiers}->{$method_name} = $method; |
386 | } |
387 | |
8e64d0fa |
388 | sub has_override_method_modifier { |
389 | my ($self, $method_name) = @_; |
390 | return exists $self->{override_method_modifiers}->{$method_name}; |
391 | } |
392 | |
393 | sub get_override_method_modifier { |
394 | my ($self, $method_name) = @_; |
395 | return $self->{override_method_modifiers}->{$method_name}; |
6cfa1e5e |
396 | } |
397 | |
398 | sub get_method_modifier_list { |
399 | my($self, $modifier_type) = @_; |
400 | |
401 | return keys %{ $self->{$modifier_type . '_method_modifiers'} }; |
402 | } |
403 | |
67199842 |
404 | # This is currently not passing all the Moose tests. |
405 | sub does_role { |
406 | my ($self, $role_name) = @_; |
407 | |
408 | (defined $role_name) |
fce211ae |
409 | || $self->throw_error("You must supply a role name to look for"); |
67199842 |
410 | |
411 | # if we are it,.. then return true |
412 | return 1 if $role_name eq $self->name; |
3a63a2e7 |
413 | # otherwise.. check our children |
414 | for my $role (@{ $self->get_roles }) { |
67199842 |
415 | return 1 if $role->does_role($role_name); |
416 | } |
417 | return 0; |
418 | } |
419 | |
420 | |
a2227e71 |
421 | 1; |
422 | |
1820fffe |
423 | __END__ |
424 | |
425 | =head1 NAME |
426 | |
427 | Mouse::Meta::Role - The Mouse Role metaclass |
428 | |
429 | =head1 SEE ALSO |
430 | |
431 | L<Moose::Meta::Role> |
432 | |
433 | =cut |