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 | |
197 | =head1 METHODS |
198 | |
199 | =over 4 |
200 | |
201 | =item B<meta> |
202 | |
203 | =item B<new> |
204 | |
78cd1d3b |
205 | =item B<apply> |
206 | |
e185c027 |
207 | =back |
208 | |
209 | =over 4 |
210 | |
211 | =item B<name> |
212 | |
213 | =item B<version> |
214 | |
215 | =item B<role_meta> |
216 | |
217 | =back |
218 | |
219 | =over 4 |
220 | |
221 | =item B<get_method> |
222 | |
223 | =item B<has_method> |
224 | |
225 | =item B<get_method_list> |
226 | |
227 | =back |
228 | |
229 | =over 4 |
230 | |
231 | =item B<add_attribute> |
232 | |
233 | =item B<has_attribute> |
234 | |
235 | =item B<get_attribute> |
236 | |
237 | =item B<get_attribute_list> |
238 | |
239 | =item B<get_attribute_map> |
240 | |
241 | =item B<remove_attribute> |
242 | |
243 | =back |
244 | |
245 | =over 4 |
246 | |
247 | =item B<add_method_modifier> |
248 | |
249 | =item B<get_method_modifier> |
250 | |
251 | =item B<has_method_modifier> |
252 | |
253 | =item B<get_method_modifier_list> |
254 | |
255 | =item B<get_method_modifier_map> |
256 | |
257 | =item B<remove_method_modifier> |
258 | |
259 | =back |
260 | |
261 | =head1 BUGS |
262 | |
263 | All complex software has bugs lurking in it, and this module is no |
264 | exception. If you find a bug please either email me, or add the bug |
265 | to cpan-RT. |
266 | |
267 | =head1 AUTHOR |
268 | |
269 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
270 | |
271 | =head1 COPYRIGHT AND LICENSE |
272 | |
273 | Copyright 2006 by Infinity Interactive, Inc. |
274 | |
275 | L<http://www.iinteractive.com> |
276 | |
277 | This library is free software; you can redistribute it and/or modify |
278 | it under the same terms as Perl itself. |
279 | |
280 | =cut |