Commit | Line | Data |
e185c027 |
1 | |
2 | package Moose::Meta::Role; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | use metaclass; |
7 | |
8 | use Carp 'confess'; |
9 | |
10 | our $VERSION = '0.01'; |
11 | |
12 | __PACKAGE__->meta->add_attribute('role_meta' => ( |
13 | reader => 'role_meta' |
14 | )); |
15 | |
16 | __PACKAGE__->meta->add_attribute('attribute_map' => ( |
17 | reader => 'get_attribute_map', |
18 | default => sub { {} } |
19 | )); |
20 | |
21 | __PACKAGE__->meta->add_attribute('method_modifier_map' => ( |
22 | reader => 'get_method_modifier_map', |
23 | default => sub { |
24 | return { |
25 | before => {}, |
26 | after => {}, |
27 | around => {}, |
78cd1d3b |
28 | override => {} |
e185c027 |
29 | }; |
30 | } |
31 | )); |
32 | |
33 | sub new { |
34 | my $class = shift; |
35 | my %options = @_; |
a7d0cd00 |
36 | $options{role_meta} = Class::MOP::Class->initialize( |
37 | $options{role_name}, |
38 | ':method_metaclass' => 'Moose::Meta::Role::Method' |
39 | ); |
e185c027 |
40 | my $self = $class->meta->new_object(%options); |
41 | return $self; |
42 | } |
43 | |
78cd1d3b |
44 | sub apply { |
45 | my ($self, $other) = @_; |
46 | |
47 | foreach my $attribute_name ($self->get_attribute_list) { |
48 | # skip it if it has one already |
49 | next if $other->has_attribute($attribute_name); |
50 | # add it, although it could be overriden |
51 | $other->add_attribute( |
52 | $attribute_name, |
53 | %{$self->get_attribute($attribute_name)} |
54 | ); |
55 | } |
56 | |
57 | foreach my $method_name ($self->get_method_list) { |
58 | # skip it if it has one already |
59 | next if $other->has_method($method_name); |
60 | # add it, although it could be overriden |
a7d0cd00 |
61 | $other->alias_method( |
78cd1d3b |
62 | $method_name, |
63 | $self->get_method($method_name) |
64 | ); |
65 | } |
66 | |
67 | foreach my $method_name ($self->get_method_modifier_list('override')) { |
68 | # skip it if it has one already |
69 | next if $other->has_method($method_name); |
70 | # add it, although it could be overriden |
71 | $other->add_override_method_modifier( |
72 | $method_name, |
73 | $self->get_method_modifier('override' => $method_name), |
74 | $self->name |
75 | ); |
76 | } |
77 | |
78 | foreach my $method_name ($self->get_method_modifier_list('before')) { |
79 | $other->add_before_method_modifier( |
80 | $method_name, |
81 | $self->get_method_modifier('before' => $method_name) |
82 | ); |
83 | } |
84 | |
85 | foreach my $method_name ($self->get_method_modifier_list('after')) { |
86 | $other->add_after_method_modifier( |
87 | $method_name, |
88 | $self->get_method_modifier('after' => $method_name) |
89 | ); |
90 | } |
91 | |
92 | foreach my $method_name ($self->get_method_modifier_list('around')) { |
93 | $other->add_around_method_modifier( |
94 | $method_name, |
95 | $self->get_method_modifier('around' => $method_name) |
96 | ); |
97 | } |
98 | |
99 | } |
100 | |
e185c027 |
101 | # NOTE: |
102 | # we delegate to some role_meta methods for convience here |
103 | # the Moose::Meta::Role is meant to be a read-only interface |
104 | # to the underlying role package, if you want to manipulate |
105 | # that, just use ->role_meta |
106 | |
107 | sub name { (shift)->role_meta->name } |
108 | sub version { (shift)->role_meta->version } |
109 | |
110 | sub get_method { (shift)->role_meta->get_method(@_) } |
111 | sub has_method { (shift)->role_meta->has_method(@_) } |
112 | sub get_method_list { |
113 | my ($self) = @_; |
114 | # meta is not applicable in this context, |
115 | # if you want to see it use the ->role_meta |
116 | grep { !/^meta$/ } $self->role_meta->get_method_list; |
117 | } |
118 | |
119 | # ... however the items in statis (attributes & method modifiers) |
120 | # can be removed and added to through this API |
121 | |
122 | # attributes |
123 | |
124 | sub add_attribute { |
125 | my ($self, $name, %attr_desc) = @_; |
126 | $self->get_attribute_map->{$name} = \%attr_desc; |
127 | } |
128 | |
129 | sub has_attribute { |
130 | my ($self, $name) = @_; |
131 | exists $self->get_attribute_map->{$name} ? 1 : 0; |
132 | } |
133 | |
134 | sub get_attribute { |
135 | my ($self, $name) = @_; |
136 | $self->get_attribute_map->{$name} |
137 | } |
138 | |
139 | sub remove_attribute { |
140 | my ($self, $name) = @_; |
141 | delete $self->get_attribute_map->{$name} |
142 | } |
143 | |
144 | sub get_attribute_list { |
145 | my ($self) = @_; |
146 | keys %{$self->get_attribute_map}; |
147 | } |
148 | |
149 | # method modifiers |
150 | |
151 | sub add_method_modifier { |
152 | my ($self, $modifier_type, $method_name, $method) = @_; |
153 | $self->get_method_modifier_map->{$modifier_type}->{$method_name} = $method; |
154 | } |
155 | |
156 | sub has_method_modifier { |
157 | my ($self, $modifier_type, $method_name) = @_; |
158 | exists $self->get_method_modifier_map->{$modifier_type}->{$method_name} ? 1 : 0 |
159 | } |
160 | |
161 | sub get_method_modifier { |
162 | my ($self, $modifier_type, $method_name) = @_; |
163 | $self->get_method_modifier_map->{$modifier_type}->{$method_name}; |
164 | } |
165 | |
166 | sub remove_method_modifier { |
167 | my ($self, $modifier_type, $method_name) = @_; |
168 | delete $self->get_method_modifier_map->{$modifier_type}->{$method_name}; |
169 | } |
170 | |
171 | sub get_method_modifier_list { |
172 | my ($self, $modifier_type) = @_; |
173 | keys %{$self->get_method_modifier_map->{$modifier_type}}; |
174 | } |
175 | |
a7d0cd00 |
176 | package Moose::Meta::Role::Method; |
177 | |
178 | use strict; |
179 | use warnings; |
180 | |
181 | our $VERSION = '0.01'; |
182 | |
183 | use base 'Class::MOP::Method'; |
e185c027 |
184 | |
185 | 1; |
186 | |
187 | __END__ |
188 | |
189 | =pod |
190 | |
191 | =head1 NAME |
192 | |
193 | Moose::Meta::Role - The Moose Role metaclass |
194 | |
195 | =head1 DESCRIPTION |
196 | |
79592a54 |
197 | Moose's Roles are being actively developed, please see L<Moose::Role> |
198 | for more information. |
199 | |
e185c027 |
200 | =head1 METHODS |
201 | |
202 | =over 4 |
203 | |
204 | =item B<meta> |
205 | |
206 | =item B<new> |
207 | |
78cd1d3b |
208 | =item B<apply> |
209 | |
e185c027 |
210 | =back |
211 | |
212 | =over 4 |
213 | |
214 | =item B<name> |
215 | |
216 | =item B<version> |
217 | |
218 | =item B<role_meta> |
219 | |
220 | =back |
221 | |
222 | =over 4 |
223 | |
224 | =item B<get_method> |
225 | |
226 | =item B<has_method> |
227 | |
228 | =item B<get_method_list> |
229 | |
230 | =back |
231 | |
232 | =over 4 |
233 | |
234 | =item B<add_attribute> |
235 | |
236 | =item B<has_attribute> |
237 | |
238 | =item B<get_attribute> |
239 | |
240 | =item B<get_attribute_list> |
241 | |
242 | =item B<get_attribute_map> |
243 | |
244 | =item B<remove_attribute> |
245 | |
246 | =back |
247 | |
248 | =over 4 |
249 | |
250 | =item B<add_method_modifier> |
251 | |
252 | =item B<get_method_modifier> |
253 | |
254 | =item B<has_method_modifier> |
255 | |
256 | =item B<get_method_modifier_list> |
257 | |
258 | =item B<get_method_modifier_map> |
259 | |
260 | =item B<remove_method_modifier> |
261 | |
262 | =back |
263 | |
264 | =head1 BUGS |
265 | |
266 | All complex software has bugs lurking in it, and this module is no |
267 | exception. If you find a bug please either email me, or add the bug |
268 | to cpan-RT. |
269 | |
270 | =head1 AUTHOR |
271 | |
272 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
273 | |
274 | =head1 COPYRIGHT AND LICENSE |
275 | |
276 | Copyright 2006 by Infinity Interactive, Inc. |
277 | |
278 | L<http://www.iinteractive.com> |
279 | |
280 | This library is free software; you can redistribute it and/or modify |
281 | it under the same terms as Perl itself. |
282 | |
283 | =cut |