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