Commit | Line | Data |
a2227e71 |
1 | package Mouse::Meta::Role; |
2 | use strict; |
3 | use warnings; |
59089ec3 |
4 | use Carp 'confess'; |
74be9f76 |
5 | |
3a63a2e7 |
6 | use base qw(Mouse::Meta::Module); |
a2227e71 |
7 | |
acf0f643 |
8 | do { |
9 | my %METACLASS_CACHE; |
10 | |
11 | # because Mouse doesn't introspect existing classes, we're forced to |
12 | # only pay attention to other Mouse classes |
13 | sub _metaclass_cache { |
14 | my $class = shift; |
15 | my $name = shift; |
16 | return $METACLASS_CACHE{$name}; |
17 | } |
18 | |
19 | sub initialize { |
3a63a2e7 |
20 | my($class, $package_name, @args) = @_; |
21 | |
22 | ($package_name && !ref($package_name))\r |
23 | || confess("You must pass a package name and it cannot be blessed");\r |
24 | |
25 | return $METACLASS_CACHE{$package_name} |
26 | ||= $class->_new(package => $package_name, @args); |
acf0f643 |
27 | } |
28 | }; |
29 | |
3a63a2e7 |
30 | sub _new { |
acf0f643 |
31 | my $class = shift; |
32 | my %args = @_; |
33 | |
3a63a2e7 |
34 | $args{methods} ||= {}; |
59089ec3 |
35 | $args{attributes} ||= {}; |
36 | $args{required_methods} ||= []; |
47f36c05 |
37 | $args{roles} ||= []; |
274b6cce |
38 | |
acf0f643 |
39 | bless \%args, $class; |
40 | } |
a2227e71 |
41 | |
afc73948 |
42 | sub get_roles { $_[0]->{roles} } |
43 | |
44 | |
59089ec3 |
45 | sub add_required_methods { |
46 | my $self = shift; |
47 | my @methods = @_; |
48 | push @{$self->{required_methods}}, @methods; |
49 | } |
50 | |
274b6cce |
51 | sub add_attribute { |
52 | my $self = shift; |
53 | my $name = shift; |
69ac1dcf |
54 | my $spec = shift; |
9c85e9dc |
55 | $self->{attributes}->{$name} = $spec; |
da0c885d |
56 | } |
57 | |
274b6cce |
58 | sub has_attribute { exists $_[0]->{attributes}->{$_[1]} } |
59 | sub get_attribute_list { keys %{ $_[0]->{attributes} } } |
69ac1dcf |
60 | sub get_attribute { $_[0]->{attributes}->{$_[1]} } |
274b6cce |
61 | |
3a63a2e7 |
62 | sub _check_required_methods{ |
63 | my($role, $class, $args, @other_roles) = @_; |
64 | |
65 | if($class->isa('Mouse::Meta::Class')){ |
66 | my $class_name = $class->name; |
67 | foreach my $method_name(@{$role->{required_methods}}){ |
68 | unless($class_name->can($method_name)){ |
69 | my $role_name = $role->name; |
70 | my $has_method = 0; |
71 | |
72 | foreach my $another_role_spec(@other_roles){ |
73 | my $another_role_name = $another_role_spec->[0]; |
74 | if($role_name ne $another_role_name && $another_role_name->can($method_name)){ |
75 | $has_method = 1; |
76 | last; |
77 | } |
78 | } |
79 | |
80 | confess "'$role_name' requires the method '$method_name' to be implemented by '$class_name'" |
81 | unless $has_method; |
82 | } |
83 | } |
84 | } |
2e92bb89 |
85 | |
3a63a2e7 |
86 | return; |
2e92bb89 |
87 | } |
88 | |
3a63a2e7 |
89 | sub _apply_methods{ |
90 | my($role, $class, $args) = @_; |
da0c885d |
91 | |
3a63a2e7 |
92 | my $role_name = $role->name; |
93 | my $class_name = $class->name; |
94 | my $alias = $args->{alias}; |
e0b163e1 |
95 | |
3a63a2e7 |
96 | foreach my $method_name($role->get_method_list){ |
97 | next if $method_name eq 'meta'; |
98 | |
99 | my $code = $role_name->can($method_name); |
100 | if(do{ no strict 'refs'; defined &{$class_name . '::' . $method_name} }){ |
101 | # XXX what's Moose's behavior? |
102 | } |
103 | else{ |
104 | $class->add_method($method_name => $code); |
2e92bb89 |
105 | } |
2e92bb89 |
106 | |
3a63a2e7 |
107 | if($alias && $alias->{$method_name}){ |
108 | my $dstname = $alias->{$method_name}; |
109 | if(do{ no strict 'refs'; defined &{$class_name . '::' . $dstname} }){ |
110 | # XXX wat's Moose's behavior? |
21498b08 |
111 | } |
3a63a2e7 |
112 | else{ |
113 | $class->add_method($dstname => $code); |
2e92bb89 |
114 | } |
59089ec3 |
115 | } |
116 | } |
117 | |
3a63a2e7 |
118 | return; |
119 | } |
120 | |
121 | sub _apply_attributes{ |
122 | my($role, $class, $args) = @_; |
123 | |
b1b81553 |
124 | if ($class->isa('Mouse::Meta::Class')) { |
125 | # apply role to class |
3a63a2e7 |
126 | for my $attr_name ($role->get_attribute_list) { |
127 | next if $class->has_attribute($attr_name); |
128 | |
129 | my $spec = $role->get_attribute($attr_name); |
05b9dc92 |
130 | |
3a63a2e7 |
131 | my $attr_metaclass = 'Mouse::Meta::Attribute'; |
05b9dc92 |
132 | if ( my $metaclass_name = $spec->{metaclass} ) { |
3a63a2e7 |
133 | $attr_metaclass = Mouse::Util::resolve_metaclass_alias( |
05b9dc92 |
134 | 'Attribute', |
135 | $metaclass_name |
136 | ); |
05b9dc92 |
137 | } |
138 | |
3a63a2e7 |
139 | $attr_metaclass->create($class, $attr_name => %$spec); |
b1b81553 |
140 | } |
141 | } else { |
142 | # apply role to role |
3a63a2e7 |
143 | for my $attr_name ($role->get_attribute_list) { |
144 | next if $class->has_attribute($attr_name); |
145 | |
146 | my $spec = $role->get_attribute($attr_name); |
147 | $class->add_attribute($attr_name => $spec); |
b1b81553 |
148 | } |
da0c885d |
149 | } |
d99db7b6 |
150 | |
3a63a2e7 |
151 | return; |
152 | } |
153 | |
154 | sub _apply_modifiers{ |
155 | my($role, $class, $args) = @_; |
156 | |
67199842 |
157 | for my $modifier_type (qw/before after around override/) { |
3a63a2e7 |
158 | my $add_modifier = "add_${modifier_type}_method_modifier"; |
159 | my $modifiers = $role->{"${modifier_type}_method_modifiers"}; |
d99db7b6 |
160 | |
3a63a2e7 |
161 | while(my($method_name, $modifier_codes) = each %{$modifiers}){ |
162 | foreach my $code(@{$modifier_codes}){ |
163 | $class->$add_modifier($method_name => $code); |
d99db7b6 |
164 | } |
165 | } |
166 | } |
3a63a2e7 |
167 | return; |
da0c885d |
168 | } |
0fc8adbc |
169 | |
3a63a2e7 |
170 | sub _append_roles{ |
171 | my($role, $class, $args) = @_; |
21498b08 |
172 | |
3a63a2e7 |
173 | my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles; |
174 | |
175 | foreach my $r($role, @{$role->get_roles}){ |
176 | if(!$class->does_role($r->name)){ |
177 | push @{$roles}, $r; |
21498b08 |
178 | } |
179 | } |
3a63a2e7 |
180 | return; |
181 | } |
21498b08 |
182 | |
3a63a2e7 |
183 | # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole |
184 | sub apply { |
185 | my($self, $class, %args) = @_; |
186 | |
187 | if ($class->isa('Mouse::Object')) { |
188 | Carp::croak('Mouse does not support Application::ToInstance yet'); |
21498b08 |
189 | } |
190 | |
3a63a2e7 |
191 | $self->_check_required_methods($class, \%args); |
192 | $self->_apply_methods($class, \%args); |
193 | $self->_apply_attributes($class, \%args); |
194 | $self->_apply_modifiers($class, \%args); |
195 | $self->_append_roles($class, \%args); |
196 | return; |
197 | } |
21498b08 |
198 | |
3a63a2e7 |
199 | sub combine_apply { |
200 | my(undef, $class, @roles) = @_; |
05b9dc92 |
201 | |
3a63a2e7 |
202 | foreach my $role_spec (@roles) { |
203 | my($role_name, $args) = @{$role_spec}; |
21498b08 |
204 | |
3a63a2e7 |
205 | my $role = $role_name->meta; |
21498b08 |
206 | |
3a63a2e7 |
207 | $role->_check_required_methods($class, $args, @roles); |
208 | $role->_apply_methods($class, $args); |
209 | $role->_apply_attributes($class, $args); |
210 | $role->_apply_modifiers($class, $args); |
211 | $role->_append_roles($class, $args); |
21498b08 |
212 | } |
3a63a2e7 |
213 | return; |
21498b08 |
214 | } |
215 | |
67199842 |
216 | for my $modifier_type (qw/before after around override/) { |
3a63a2e7 |
217 | |
218 | my $modifier = "${modifier_type}_method_modifiers"; |
219 | my $add_method_modifier = sub { |
fc0e0bbd |
220 | my ($self, $method_name, $method) = @_; |
221 | |
3a63a2e7 |
222 | push @{ $self->{$modifier}->{$method_name} ||= [] }, $method; |
223 | return; |
fc0e0bbd |
224 | }; |
3370794f |
225 | my $has_method_modifiers = sub{ |
226 | my($self, $method_name) = @_; |
227 | my $m = $self->{$modifier}->{$method_name}; |
228 | return $m && @{$m} != 0; |
229 | }; |
3a63a2e7 |
230 | my $get_method_modifiers = sub { |
231 | my ($self, $method_name) = @_; |
232 | return @{ $self->{$modifier}->{$method_name} ||= [] } |
c2f128e7 |
233 | }; |
c2f128e7 |
234 | |
3a63a2e7 |
235 | no strict 'refs'; |
236 | *{ 'add_' . $modifier_type . '_method_modifier' } = $add_method_modifier; |
3370794f |
237 | *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers; |
3a63a2e7 |
238 | *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers; |
239 | } |
47f36c05 |
240 | |
67199842 |
241 | # This is currently not passing all the Moose tests. |
242 | sub does_role { |
243 | my ($self, $role_name) = @_; |
244 | |
245 | (defined $role_name) |
246 | || confess "You must supply a role name to look for"; |
247 | |
248 | # if we are it,.. then return true |
249 | return 1 if $role_name eq $self->name; |
3a63a2e7 |
250 | # otherwise.. check our children |
251 | for my $role (@{ $self->get_roles }) { |
67199842 |
252 | return 1 if $role->does_role($role_name); |
253 | } |
254 | return 0; |
255 | } |
256 | |
257 | |
a2227e71 |
258 | 1; |
259 | |