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 | { |
bb70fe3a |
144 | my $self = shift; |
145 | |
146 | my %attrs = |
941ae03a |
147 | map { my $meta = Class::MOP::class_of($_); |
148 | $meta && $meta->can('get_class_attribute_map') |
7a4a3b1e |
149 | ? %{ $meta->get_class_attribute_map() } |
150 | : () |
151 | } |
bb70fe3a |
152 | reverse $self->linearized_isa; |
153 | |
154 | return values %attrs; |
155 | } |
156 | |
b64c8efa |
157 | sub compute_all_applicable_class_attributes |
158 | { |
159 | warn 'The compute_all_applicable_class_attributes method has been deprecated.' |
160 | . " Use get_all_class_attributes instead.\n"; |
161 | |
162 | shift->compute_all_applicable_class_attributes(@_); |
163 | } |
164 | |
bb70fe3a |
165 | sub find_class_attribute_by_name |
166 | { |
167 | my $self = shift; |
168 | my $name = shift; |
169 | |
170 | foreach my $class ( $self->linearized_isa() ) |
171 | { |
941ae03a |
172 | my $meta = Class::MOP::class_of($class) |
173 | or next; |
bb70fe3a |
174 | |
175 | return $meta->get_class_attribute($name) |
7a4a3b1e |
176 | if $meta->can('has_class_attribute') && $meta->has_class_attribute($name); |
bb70fe3a |
177 | } |
178 | |
179 | return; |
180 | } |
181 | |
182 | sub _class_attribute_values_hashref |
183 | { |
184 | my $self = shift; |
185 | |
186 | no strict 'refs'; |
187 | return \%{ $self->_class_attribute_var_name() }; |
188 | } |
189 | |
190 | sub _class_attribute_var_name |
191 | { |
192 | my $self = shift; |
193 | |
194 | return $self->name() . q'::__ClassAttributeValues'; |
195 | } |
196 | |
197 | sub inline_class_slot_access |
198 | { |
199 | my $self = shift; |
200 | my $name = shift; |
201 | |
7aab7f6c |
202 | return '$' . $self->_class_attribute_var_name . '{"' . quotemeta($name) . '"}'; |
bb70fe3a |
203 | } |
204 | |
205 | sub inline_get_class_slot_value |
206 | { |
207 | my $self = shift; |
208 | my $name = shift; |
209 | |
210 | return $self->inline_class_slot_access($name); |
211 | } |
212 | |
213 | sub inline_set_class_slot_value |
214 | { |
215 | my $self = shift; |
216 | my $name = shift; |
217 | my $val_name = shift; |
218 | |
219 | return $self->inline_class_slot_access($name) . ' = ' . $val_name; |
220 | } |
221 | |
222 | sub inline_is_class_slot_initialized |
223 | { |
224 | my $self = shift; |
225 | my $name = shift; |
226 | |
227 | return 'exists ' . $self->inline_class_slot_access($name); |
228 | } |
229 | |
230 | sub inline_deinitialize_class_slot |
231 | { |
232 | my $self = shift; |
233 | my $name = shift; |
234 | |
235 | return 'delete ' . $self->inline_class_slot_access($name); |
236 | } |
237 | |
238 | sub inline_weaken_class_slot_value |
239 | { |
240 | my $self = shift; |
241 | my $name = shift; |
242 | |
243 | return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')'; |
244 | } |
245 | |
246 | no Moose::Role; |
247 | |
248 | 1; |
7a4a3b1e |
249 | |
250 | __END__ |
251 | |
252 | =pod |
253 | |
254 | =head1 NAME |
255 | |
256 | MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes |
257 | |
258 | =head1 SYNOPSIS |
259 | |
260 | for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() ) |
261 | { |
262 | print $attr->name(); |
263 | } |
264 | |
265 | =head1 DESCRIPTION |
266 | |
267 | This role adds awareness of class attributes to a metaclass object. It |
268 | provides a set of introspection methods that largely parallel the |
269 | existing attribute methods, except they operate on class attributes. |
270 | |
271 | =head1 METHODS |
272 | |
273 | Every method provided by this role has an analogous method in |
274 | C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes. |
275 | |
276 | =head2 $meta->has_class_attribute($name) |
277 | |
278 | =head2 $meta->get_class_attribute($name) |
279 | |
280 | =head2 $meta->get_class_attribute_list() |
281 | |
282 | =head2 $meta->get_class_attribute_map() |
283 | |
284 | These methods operate on the current metaclass only. |
285 | |
286 | =head2 $meta->add_class_attribute(...) |
287 | |
288 | This accepts the same options as the L<Moose::Meta::Attribute> |
289 | C<add_attribute()> method. However, if an attribute is specified as |
290 | "required" an error will be thrown. |
291 | |
292 | =head2 $meta->remove_class_attribute($name) |
293 | |
294 | If the named class attribute exists, it is removed from the class, |
295 | along with its accessor methods. |
296 | |
297 | =head2 $meta->get_all_class_attributes() |
298 | |
b64c8efa |
299 | This method returns a list of attribute objects for the class and all |
7a4a3b1e |
300 | its parent classes. |
301 | |
302 | =head2 $meta->find_class_attribute_by_name($name) |
303 | |
304 | This method looks at the class and all its parent classes for the |
305 | named class attribute. |
306 | |
307 | =head2 $meta->get_class_attribute_value($name) |
308 | |
309 | =head2 $meta->set_class_attribute_value($name, $value) |
310 | |
311 | =head2 $meta->set_class_attribute_value($name) |
312 | |
313 | =head2 $meta->clear_class_attribute_value($name) |
314 | |
315 | These methods operate on the storage for class attribute values, which |
316 | is attached to the metaclass object. |
317 | |
318 | There's really no good reason for you to call these methods unless |
319 | you're doing some deep hacking. They are named as public methods |
320 | solely because they are used by other meta roles and classes in this |
321 | distribution. |
322 | |
323 | =head2 inline_class_slot_access($name) |
324 | |
325 | =head2 inline_get_class_slot_value($name) |
326 | |
327 | =head2 inline_set_class_slot_value($name, $val_name) |
328 | |
329 | =head2 inline_is_class_slot_initialized($name) |
330 | |
331 | =head2 inline_deinitialize_class_slot($name) |
332 | |
333 | =head2 inline_weaken_class_slot_value($name) |
334 | |
335 | These methods return code snippets for inlining. |
336 | |
337 | There's really no good reason for you to call these methods unless |
338 | you're doing some deep hacking. They are named as public methods |
339 | solely because they are used by other meta roles and classes in this |
340 | distribution. |
341 | |
342 | =head1 AUTHOR |
343 | |
344 | Dave Rolsky, C<< <autarch@urth.org> >> |
345 | |
346 | =head1 BUGS |
347 | |
348 | See L<MooseX::ClassAttribute> for details. |
349 | |
350 | =head1 COPYRIGHT & LICENSE |
351 | |
352 | Copyright 2007-2008 Dave Rolsky, All Rights Reserved. |
353 | |
354 | This program is free software; you can redistribute it and/or modify |
355 | it under the same terms as Perl itself. |
356 | |
357 | =cut |