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 | |
e7264861 |
38 | sub calculate_all_roles { |
39 | my $self = shift; |
40 | my %seen; |
41 | return grep { !$seen{ $_->name }++ } |
42 | ($self, map { $_->calculate_all_roles } @{ $self->get_roles }); |
43 | } |
44 | |
6cfa1e5e |
45 | sub get_required_method_list{ |
46 | return @{ $_[0]->{required_methods} }; |
47 | } |
afc73948 |
48 | |
59089ec3 |
49 | sub add_required_methods { |
ea249879 |
50 | my($self, @methods) = @_; |
71e7b544 |
51 | my %required = map{ $_ => 1 } @{$self->{required_methods}}; |
52 | push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods; |
53 | return; |
59089ec3 |
54 | } |
55 | |
6cfa1e5e |
56 | sub requires_method { |
57 | my($self, $name) = @_; |
58 | return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0; |
59 | } |
60 | |
274b6cce |
61 | sub add_attribute { |
62 | my $self = shift; |
63 | my $name = shift; |
6cfa1e5e |
64 | |
65 | $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ }; |
c9313657 |
66 | return; |
da0c885d |
67 | } |
68 | |
3a63a2e7 |
69 | sub _check_required_methods{ |
71e7b544 |
70 | my($role, $applicant, $args) = @_; |
3a63a2e7 |
71 | |
71e7b544 |
72 | if($args->{_to} eq 'role'){ |
73 | $applicant->add_required_methods($role->get_required_method_list); |
74 | } |
75 | else{ # to class or instance |
2d2e77f9 |
76 | my $applicant_class_name = $applicant->name; |
77 | |
7a50b450 |
78 | my @missing; |
3a63a2e7 |
79 | foreach my $method_name(@{$role->{required_methods}}){ |
2d2e77f9 |
80 | next if exists $args->{aliased_methods}{$method_name}; |
81 | next if exists $role->{methods}{$method_name}; |
82 | next if $applicant_class_name->can($method_name); |
83 | |
84 | push @missing, $method_name; |
3a63a2e7 |
85 | } |
7a50b450 |
86 | if(@missing){ |
2d2e77f9 |
87 | $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'", |
88 | $role->name, |
89 | (@missing == 1 ? '' : 's'), # method or methods |
90 | english_list(map{ sprintf q{'%s'}, $_ } @missing), |
91 | $applicant_class_name); |
7a50b450 |
92 | } |
93 | } |
2e92bb89 |
94 | |
3a63a2e7 |
95 | return; |
2e92bb89 |
96 | } |
97 | |
3a63a2e7 |
98 | sub _apply_methods{ |
71e7b544 |
99 | my($role, $applicant, $args) = @_; |
da0c885d |
100 | |
7a50b450 |
101 | my $alias = $args->{-alias}; |
102 | my $excludes = $args->{-excludes}; |
e0b163e1 |
103 | |
3a63a2e7 |
104 | foreach my $method_name($role->get_method_list){ |
105 | next if $method_name eq 'meta'; |
106 | |
71e7b544 |
107 | my $code = $role->get_method_body($method_name); |
6cfa1e5e |
108 | |
2d2e77f9 |
109 | if(!exists $excludes->{$method_name}){ |
71e7b544 |
110 | if(!$applicant->has_method($method_name)){ |
2d2e77f9 |
111 | # The third argument $role is used in Role::Composite |
71e7b544 |
112 | $applicant->add_method($method_name => $code, $role); |
6cfa1e5e |
113 | } |
2e92bb89 |
114 | } |
2e92bb89 |
115 | |
2d2e77f9 |
116 | if(exists $alias->{$method_name}){ |
3a63a2e7 |
117 | my $dstname = $alias->{$method_name}; |
6cfa1e5e |
118 | |
71e7b544 |
119 | my $dstcode = $applicant->get_method_body($dstname); |
7a50b450 |
120 | |
121 | if(defined($dstcode) && $dstcode != $code){ |
71e7b544 |
122 | $role->throw_error("Cannot create a method alias if a local method of the same name exists"); |
21498b08 |
123 | } |
3a63a2e7 |
124 | else{ |
71e7b544 |
125 | $applicant->add_method($dstname => $code, $role); |
2e92bb89 |
126 | } |
59089ec3 |
127 | } |
128 | } |
129 | |
3a63a2e7 |
130 | return; |
131 | } |
132 | |
133 | sub _apply_attributes{ |
71e7b544 |
134 | my($role, $applicant, $args) = @_; |
3a63a2e7 |
135 | |
71e7b544 |
136 | for my $attr_name ($role->get_attribute_list) { |
137 | next if $applicant->has_attribute($attr_name); |
3a63a2e7 |
138 | |
71e7b544 |
139 | $applicant->add_attribute($attr_name => $role->get_attribute($attr_name)); |
da0c885d |
140 | } |
3a63a2e7 |
141 | return; |
142 | } |
143 | |
144 | sub _apply_modifiers{ |
71e7b544 |
145 | my($role, $applicant, $args) = @_; |
3a63a2e7 |
146 | |
2d2e77f9 |
147 | if(my $modifiers = $role->{override_method_modifiers}){ |
148 | foreach my $method_name (keys %{$modifiers}){ |
149 | $applicant->add_override_method_modifier($method_name => $modifiers->{$method_name}); |
150 | } |
151 | } |
152 | |
153 | for my $modifier_type (qw/before around after/) { |
71e7b544 |
154 | my $modifiers = $role->{"${modifier_type}_method_modifiers"} |
155 | or next; |
156 | |
3a63a2e7 |
157 | my $add_modifier = "add_${modifier_type}_method_modifier"; |
d99db7b6 |
158 | |
71e7b544 |
159 | foreach my $method_name (keys %{$modifiers}){ |
2d2e77f9 |
160 | foreach my $code(@{ $modifiers->{$method_name} }){ |
161 | next if $applicant->{"_applied_$modifier_type"}{$method_name, $code}++; # skip applied modifiers |
71e7b544 |
162 | $applicant->$add_modifier($method_name => $code); |
d99db7b6 |
163 | } |
164 | } |
165 | } |
3a63a2e7 |
166 | return; |
da0c885d |
167 | } |
0fc8adbc |
168 | |
3a63a2e7 |
169 | sub _append_roles{ |
71e7b544 |
170 | my($role, $applicant, $args) = @_; |
21498b08 |
171 | |
71e7b544 |
172 | my $roles = ($args->{_to} eq 'role') ? $applicant->get_roles : $applicant->roles; |
3a63a2e7 |
173 | |
174 | foreach my $r($role, @{$role->get_roles}){ |
71e7b544 |
175 | if(!$applicant->does_role($r->name)){ |
3a63a2e7 |
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 { |
7a50b450 |
184 | my $self = shift; |
185 | my $applicant = shift; |
7a50b450 |
186 | |
71e7b544 |
187 | my %args = (@_ == 1) ? %{ $_[0] } : @_; |
60b5c3be |
188 | |
f774b7de |
189 | my $instance; |
190 | |
71e7b544 |
191 | if($applicant->isa('Mouse::Meta::Class')){ # Application::ToClass |
192 | $args{_to} = 'class'; |
193 | } |
194 | elsif($applicant->isa('Mouse::Meta::Role')){ # Application::ToRole |
195 | $args{_to} = 'role'; |
196 | } |
197 | else{ # Appplication::ToInstance |
198 | $args{_to} = 'instance'; |
f774b7de |
199 | $instance = $applicant; |
60b5c3be |
200 | |
f774b7de |
201 | $applicant = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')->create_anon_class( |
202 | superclasses => [ref $instance], |
71e7b544 |
203 | cache => 1, |
204 | ); |
71e7b544 |
205 | } |
60b5c3be |
206 | |
71e7b544 |
207 | if($args{alias} && !exists $args{-alias}){ |
208 | $args{-alias} = $args{alias}; |
209 | } |
210 | if($args{excludes} && !exists $args{-excludes}){ |
211 | $args{-excludes} = $args{excludes}; |
212 | } |
60b5c3be |
213 | |
2d2e77f9 |
214 | $args{aliased_methods} = {}; |
71e7b544 |
215 | if(my $alias = $args{-alias}){ |
2d2e77f9 |
216 | @{$args{aliased_methods}}{ values %{$alias} } = (); |
60b5c3be |
217 | } |
71e7b544 |
218 | |
219 | if(my $excludes = $args{-excludes}){ |
220 | $args{-excludes} = {}; # replace with a hash ref |
221 | if(ref $excludes){ |
222 | %{$args{-excludes}} = (map{ $_ => undef } @{$excludes}); |
60b5c3be |
223 | } |
224 | else{ |
71e7b544 |
225 | $args{-excludes}{$excludes} = undef; |
60b5c3be |
226 | } |
227 | } |
228 | |
71e7b544 |
229 | $self->_check_required_methods($applicant, \%args); |
230 | $self->_apply_attributes($applicant, \%args); |
231 | $self->_apply_methods($applicant, \%args); |
232 | $self->_apply_modifiers($applicant, \%args); |
233 | $self->_append_roles($applicant, \%args); |
f774b7de |
234 | |
235 | |
236 | if(defined $instance){ # Application::ToInstance |
237 | # rebless instance |
238 | bless $instance, $applicant->name; |
239 | $applicant->_initialize_object($instance, $instance); |
240 | } |
241 | |
71e7b544 |
242 | return; |
243 | } |
244 | |
21498b08 |
245 | |
71e7b544 |
246 | sub combine { |
247 | my($role_class, @role_specs) = @_; |
21498b08 |
248 | |
71e7b544 |
249 | require 'Mouse/Meta/Role/Composite.pm'; # we don't want to create its namespace |
7a50b450 |
250 | |
71e7b544 |
251 | my $composite = Mouse::Meta::Role::Composite->create_anon_role(); |
252 | |
253 | foreach my $role_spec (@role_specs) { |
254 | my($role_name, $args) = @{$role_spec}; |
255 | $role_name->meta->apply($composite, %{$args}); |
21498b08 |
256 | } |
71e7b544 |
257 | return $composite; |
21498b08 |
258 | } |
259 | |
6cfa1e5e |
260 | for my $modifier_type (qw/before after around/) { |
3a63a2e7 |
261 | |
262 | my $modifier = "${modifier_type}_method_modifiers"; |
c9313657 |
263 | |
3a63a2e7 |
264 | my $add_method_modifier = sub { |
fc0e0bbd |
265 | my ($self, $method_name, $method) = @_; |
266 | |
3a63a2e7 |
267 | push @{ $self->{$modifier}->{$method_name} ||= [] }, $method; |
268 | return; |
fc0e0bbd |
269 | }; |
c9313657 |
270 | |
3a63a2e7 |
271 | my $get_method_modifiers = sub { |
272 | my ($self, $method_name) = @_; |
273 | return @{ $self->{$modifier}->{$method_name} ||= [] } |
c2f128e7 |
274 | }; |
c2f128e7 |
275 | |
3a63a2e7 |
276 | no strict 'refs'; |
277 | *{ 'add_' . $modifier_type . '_method_modifier' } = $add_method_modifier; |
278 | *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers; |
c9313657 |
279 | |
280 | # has_${modifier_type}_method_modifiers is moved into t::lib::Test::Mouse |
3a63a2e7 |
281 | } |
47f36c05 |
282 | |
6cfa1e5e |
283 | sub add_override_method_modifier{ |
284 | my($self, $method_name, $method) = @_; |
285 | |
60b5c3be |
286 | if($self->has_method($method_name)){ |
287 | # This error happens in the override keyword or during role composition, |
288 | # so I added a message, "A local method of ...", only for compatibility (gfx) |
8e64d0fa |
289 | $self->throw_error("Cannot add an override of method '$method_name' " |
60b5c3be |
290 | . "because there is a local version of '$method_name'" |
291 | . "(A local method of the same name as been found)"); |
292 | } |
6cfa1e5e |
293 | |
294 | $self->{override_method_modifiers}->{$method_name} = $method; |
295 | } |
296 | |
8e64d0fa |
297 | sub get_override_method_modifier { |
298 | my ($self, $method_name) = @_; |
299 | return $self->{override_method_modifiers}->{$method_name}; |
6cfa1e5e |
300 | } |
301 | |
67199842 |
302 | sub does_role { |
303 | my ($self, $role_name) = @_; |
304 | |
305 | (defined $role_name) |
fce211ae |
306 | || $self->throw_error("You must supply a role name to look for"); |
67199842 |
307 | |
308 | # if we are it,.. then return true |
309 | return 1 if $role_name eq $self->name; |
3a63a2e7 |
310 | # otherwise.. check our children |
311 | for my $role (@{ $self->get_roles }) { |
67199842 |
312 | return 1 if $role->does_role($role_name); |
313 | } |
314 | return 0; |
315 | } |
316 | |
a2227e71 |
317 | 1; |
1820fffe |
318 | __END__ |
319 | |
320 | =head1 NAME |
321 | |
322 | Mouse::Meta::Role - The Mouse Role metaclass |
323 | |
a25ca8d6 |
324 | =head1 VERSION |
325 | |
034587d8 |
326 | This document describes Mouse version 0.40 |
a25ca8d6 |
327 | |
1820fffe |
328 | =head1 SEE ALSO |
329 | |
330 | L<Moose::Meta::Role> |
331 | |
332 | =cut |