Commit | Line | Data |
bb70fe3a |
1 | package MooseX::ClassAttribute::Role::Meta::Class; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use MooseX::AttributeHelpers; |
df4f57e0 |
7 | use MooseX::ClassAttribute::Role::Meta::Attribute; |
bb70fe3a |
8 | use Scalar::Util qw( blessed ); |
9 | |
10 | use Moose::Role; |
11 | |
12 | |
13 | has class_attribute_map => |
14 | ( metaclass => 'Collection::Hash', |
15 | is => 'ro', |
a1ec1ff1 |
16 | isa => 'HashRef[Moose::Meta::Attribute]', |
bb70fe3a |
17 | provides => { set => '_add_class_attribute', |
18 | exists => 'has_class_attribute', |
19 | get => 'get_class_attribute', |
20 | delete => '_remove_class_attribute', |
21 | keys => 'get_class_attribute_list', |
22 | }, |
23 | default => sub { {} }, |
24 | reader => 'get_class_attribute_map', |
25 | ); |
26 | |
27 | has _class_attribute_values => |
28 | ( metaclass => 'Collection::Hash', |
29 | is => 'ro', |
30 | isa => 'HashRef', |
31 | provides => { get => 'get_class_attribute_value', |
32 | set => 'set_class_attribute_value', |
33 | exists => 'has_class_attribute_value', |
34 | delete => 'clear_class_attribute_value', |
35 | }, |
36 | lazy => 1, |
37 | default => sub { $_[0]->_class_attribute_values_hashref() }, |
38 | ); |
39 | |
40 | |
41 | sub add_class_attribute |
42 | { |
43 | my $self = shift; |
44 | |
45 | my $attr = |
46 | blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') |
47 | ? $_[0] |
48 | : $self->_process_class_attribute(@_); |
49 | |
50 | my $name = $attr->name(); |
51 | |
52 | $self->remove_class_attribute($name) |
53 | if $self->has_class_attribute($name); |
54 | |
55 | $attr->attach_to_class($self); |
56 | |
57 | $self->_add_class_attribute( $name => $attr ); |
58 | |
59 | my $e = do { local $@; eval { $attr->install_accessors() }; $@ }; |
60 | |
61 | if ( $e ) |
62 | { |
63 | $self->remove_attribute($name); |
64 | die $e; |
65 | } |
66 | |
67 | return $attr; |
68 | } |
69 | |
70 | # It'd be nice if I didn't have to replicate this for class |
71 | # attributes, since it's basically just a copy of |
72 | # Moose::Meta::Class->_process_attribute |
73 | sub _process_class_attribute |
74 | { |
75 | my $self = shift; |
76 | my $name = shift; |
77 | my @args = @_; |
78 | |
79 | @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH'; |
80 | |
81 | if ($name =~ /^\+(.*)/) |
82 | { |
83 | return $self->_process_inherited_class_attribute( $1, @args ); |
84 | } |
85 | else |
86 | { |
87 | return $self->_process_new_class_attribute( $name, @args ); |
88 | } |
89 | } |
90 | |
91 | sub _process_new_class_attribute |
92 | { |
93 | my $self = shift; |
94 | my $name = shift; |
95 | my %p = @_; |
96 | |
a1ec1ff1 |
97 | if ( $p{traits} ) |
bb70fe3a |
98 | { |
a1ec1ff1 |
99 | push @{ $p{traits} },'MooseX::ClassAttribute::Role::Meta::Attribute' |
bb70fe3a |
100 | } |
101 | else |
102 | { |
a1ec1ff1 |
103 | $p{traits} = [ 'MooseX::ClassAttribute::Role::Meta::Attribute' ]; |
bb70fe3a |
104 | } |
105 | |
106 | return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p ); |
107 | } |
108 | |
109 | sub _process_inherited_class_attribute |
110 | { |
111 | my $self = shift; |
112 | my $name = shift; |
113 | my %p = @_; |
114 | |
115 | my $inherited_attr = $self->find_class_attribute_by_name($name); |
116 | |
117 | (defined $inherited_attr) |
118 | || confess "Could not find an attribute by the name of '$name' to inherit from"; |
119 | |
120 | return $inherited_attr->clone_and_inherit_options(%p); |
121 | } |
122 | |
123 | sub remove_class_attribute |
124 | { |
125 | my $self = shift; |
126 | my $name = shift; |
127 | |
128 | (defined $name && $name) |
129 | || confess 'You must provide an attribute name'; |
130 | |
131 | my $removed_attr = $self->get_class_attribute($name); |
132 | return unless $removed_attr; |
133 | |
134 | $self->_remove_class_attribute($name); |
135 | |
136 | $removed_attr->remove_accessors(); |
137 | $removed_attr->detach_from_class(); |
138 | |
139 | return $removed_attr; |
140 | } |
141 | |
142 | sub get_all_class_attributes |
143 | { |
144 | shift->compute_all_applicable_class_attributes(@_); |
145 | } |
146 | |
147 | sub compute_all_applicable_class_attributes |
148 | { |
149 | my $self = shift; |
150 | |
151 | my %attrs = |
7a4a3b1e |
152 | map { my $meta = Class::MOP::Class->initialize($_); |
153 | $meta->can('get_class_attribute_map') |
154 | ? %{ $meta->get_class_attribute_map() } |
155 | : () |
156 | } |
bb70fe3a |
157 | reverse $self->linearized_isa; |
158 | |
159 | return values %attrs; |
160 | } |
161 | |
162 | sub find_class_attribute_by_name |
163 | { |
164 | my $self = shift; |
165 | my $name = shift; |
166 | |
167 | foreach my $class ( $self->linearized_isa() ) |
168 | { |
169 | my $meta = Class::MOP::Class->initialize($class); |
170 | |
171 | return $meta->get_class_attribute($name) |
7a4a3b1e |
172 | if $meta->can('has_class_attribute') && $meta->has_class_attribute($name); |
bb70fe3a |
173 | } |
174 | |
175 | return; |
176 | } |
177 | |
178 | sub _class_attribute_values_hashref |
179 | { |
180 | my $self = shift; |
181 | |
182 | no strict 'refs'; |
183 | return \%{ $self->_class_attribute_var_name() }; |
184 | } |
185 | |
186 | sub _class_attribute_var_name |
187 | { |
188 | my $self = shift; |
189 | |
190 | return $self->name() . q'::__ClassAttributeValues'; |
191 | } |
192 | |
193 | sub inline_class_slot_access |
194 | { |
195 | my $self = shift; |
196 | my $name = shift; |
197 | |
7aab7f6c |
198 | return '$' . $self->_class_attribute_var_name . '{"' . quotemeta($name) . '"}'; |
bb70fe3a |
199 | } |
200 | |
201 | sub inline_get_class_slot_value |
202 | { |
203 | my $self = shift; |
204 | my $name = shift; |
205 | |
206 | return $self->inline_class_slot_access($name); |
207 | } |
208 | |
209 | sub inline_set_class_slot_value |
210 | { |
211 | my $self = shift; |
212 | my $name = shift; |
213 | my $val_name = shift; |
214 | |
215 | return $self->inline_class_slot_access($name) . ' = ' . $val_name; |
216 | } |
217 | |
218 | sub inline_is_class_slot_initialized |
219 | { |
220 | my $self = shift; |
221 | my $name = shift; |
222 | |
223 | return 'exists ' . $self->inline_class_slot_access($name); |
224 | } |
225 | |
226 | sub inline_deinitialize_class_slot |
227 | { |
228 | my $self = shift; |
229 | my $name = shift; |
230 | |
231 | return 'delete ' . $self->inline_class_slot_access($name); |
232 | } |
233 | |
234 | sub inline_weaken_class_slot_value |
235 | { |
236 | my $self = shift; |
237 | my $name = shift; |
238 | |
239 | return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')'; |
240 | } |
241 | |
242 | no Moose::Role; |
243 | |
244 | 1; |
7a4a3b1e |
245 | |
246 | __END__ |
247 | |
248 | =pod |
249 | |
250 | =head1 NAME |
251 | |
252 | MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes |
253 | |
254 | =head1 SYNOPSIS |
255 | |
256 | for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() ) |
257 | { |
258 | print $attr->name(); |
259 | } |
260 | |
261 | =head1 DESCRIPTION |
262 | |
263 | This role adds awareness of class attributes to a metaclass object. It |
264 | provides a set of introspection methods that largely parallel the |
265 | existing attribute methods, except they operate on class attributes. |
266 | |
267 | =head1 METHODS |
268 | |
269 | Every method provided by this role has an analogous method in |
270 | C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes. |
271 | |
272 | =head2 $meta->has_class_attribute($name) |
273 | |
274 | =head2 $meta->get_class_attribute($name) |
275 | |
276 | =head2 $meta->get_class_attribute_list() |
277 | |
278 | =head2 $meta->get_class_attribute_map() |
279 | |
280 | These methods operate on the current metaclass only. |
281 | |
282 | =head2 $meta->add_class_attribute(...) |
283 | |
284 | This accepts the same options as the L<Moose::Meta::Attribute> |
285 | C<add_attribute()> method. However, if an attribute is specified as |
286 | "required" an error will be thrown. |
287 | |
288 | =head2 $meta->remove_class_attribute($name) |
289 | |
290 | If the named class attribute exists, it is removed from the class, |
291 | along with its accessor methods. |
292 | |
293 | =head2 $meta->get_all_class_attributes() |
294 | |
295 | =head2 $meta->compute_all_applicable_class_attributes() |
296 | |
297 | These methods return a list of attribute objects for the class and all |
298 | its parent classes. |
299 | |
300 | =head2 $meta->find_class_attribute_by_name($name) |
301 | |
302 | This method looks at the class and all its parent classes for the |
303 | named class attribute. |
304 | |
305 | =head2 $meta->get_class_attribute_value($name) |
306 | |
307 | =head2 $meta->set_class_attribute_value($name, $value) |
308 | |
309 | =head2 $meta->set_class_attribute_value($name) |
310 | |
311 | =head2 $meta->clear_class_attribute_value($name) |
312 | |
313 | These methods operate on the storage for class attribute values, which |
314 | is attached to the metaclass object. |
315 | |
316 | There's really no good reason for you to call these methods unless |
317 | you're doing some deep hacking. They are named as public methods |
318 | solely because they are used by other meta roles and classes in this |
319 | distribution. |
320 | |
321 | =head2 inline_class_slot_access($name) |
322 | |
323 | =head2 inline_get_class_slot_value($name) |
324 | |
325 | =head2 inline_set_class_slot_value($name, $val_name) |
326 | |
327 | =head2 inline_is_class_slot_initialized($name) |
328 | |
329 | =head2 inline_deinitialize_class_slot($name) |
330 | |
331 | =head2 inline_weaken_class_slot_value($name) |
332 | |
333 | These methods return code snippets for inlining. |
334 | |
335 | There's really no good reason for you to call these methods unless |
336 | you're doing some deep hacking. They are named as public methods |
337 | solely because they are used by other meta roles and classes in this |
338 | distribution. |
339 | |
340 | =head1 AUTHOR |
341 | |
342 | Dave Rolsky, C<< <autarch@urth.org> >> |
343 | |
344 | =head1 BUGS |
345 | |
346 | See L<MooseX::ClassAttribute> for details. |
347 | |
348 | =head1 COPYRIGHT & LICENSE |
349 | |
350 | Copyright 2007-2008 Dave Rolsky, All Rights Reserved. |
351 | |
352 | This program is free software; you can redistribute it and/or modify |
353 | it under the same terms as Perl itself. |
354 | |
355 | =cut |