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