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