1 package MooseX::ClassAttribute::Role::Meta::Class;
6 use MooseX::AttributeHelpers;
7 use MooseX::ClassAttribute::Role::Meta::Attribute;
8 use Scalar::Util qw( blessed );
12 has class_attribute_map => (
13 metaclass => 'Collection::Hash',
15 isa => 'HashRef[Moose::Meta::Attribute]',
17 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',
23 default => sub { {} },
24 reader => 'get_class_attribute_map',
27 has _class_attribute_values => (
28 metaclass => 'Collection::Hash',
32 get => 'get_class_attribute_value',
33 set => 'set_class_attribute_value',
34 exists => 'has_class_attribute_value',
35 delete => 'clear_class_attribute_value',
38 default => sub { $_[0]->_class_attribute_values_hashref() },
41 sub add_class_attribute {
45 = blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
47 : $self->_process_class_attribute(@_);
49 my $name = $attr->name();
51 $self->remove_class_attribute($name)
52 if $self->has_class_attribute($name);
54 $attr->attach_to_class($self);
56 $self->_add_class_attribute( $name => $attr );
60 eval { $attr->install_accessors() };
65 $self->remove_attribute($name);
72 # It'd be nice if I didn't have to replicate this for class
73 # attributes, since it's basically just a copy of
74 # Moose::Meta::Class->_process_attribute
75 sub _process_class_attribute {
80 @args = %{ $args[0] } if scalar @args == 1 && ref( $args[0] ) eq 'HASH';
82 if ( $name =~ /^\+(.*)/ ) {
83 return $self->_process_inherited_class_attribute( $1, @args );
86 return $self->_process_new_class_attribute( $name, @args );
90 sub _process_new_class_attribute {
96 push @{ $p{traits} }, 'MooseX::ClassAttribute::Role::Meta::Attribute';
99 $p{traits} = ['MooseX::ClassAttribute::Role::Meta::Attribute'];
102 return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
105 sub _process_inherited_class_attribute {
110 my $inherited_attr = $self->find_class_attribute_by_name($name);
112 ( defined $inherited_attr )
114 "Could not find an attribute by the name of '$name' to inherit from";
116 return $inherited_attr->clone_and_inherit_options(%p);
119 sub remove_class_attribute {
123 ( defined $name && $name )
124 || confess 'You must provide an attribute name';
126 my $removed_attr = $self->get_class_attribute($name);
127 return unless $removed_attr;
129 $self->_remove_class_attribute($name);
131 $removed_attr->remove_accessors();
132 $removed_attr->detach_from_class();
134 return $removed_attr;
137 sub get_all_class_attributes {
142 my $meta = Class::MOP::class_of($_);
143 $meta && $meta->can('get_class_attribute_map')
144 ? %{ $meta->get_class_attribute_map() }
147 reverse $self->linearized_isa;
149 return values %attrs;
152 sub compute_all_applicable_class_attributes {
154 'The compute_all_applicable_class_attributes method has been deprecated.'
155 . " Use get_all_class_attributes instead.\n";
157 shift->compute_all_applicable_class_attributes(@_);
160 sub find_class_attribute_by_name {
164 foreach my $class ( $self->linearized_isa() ) {
165 my $meta = Class::MOP::class_of($class)
168 return $meta->get_class_attribute($name)
169 if $meta->can('has_class_attribute')
170 && $meta->has_class_attribute($name);
176 sub _class_attribute_values_hashref {
180 return \%{ $self->_class_attribute_var_name() };
183 sub _class_attribute_var_name {
186 return $self->name() . q'::__ClassAttributeValues';
189 sub inline_class_slot_access {
195 . $self->_class_attribute_var_name . '{"'
196 . quotemeta($name) . '"}';
199 sub inline_get_class_slot_value {
203 return $self->inline_class_slot_access($name);
206 sub inline_set_class_slot_value {
209 my $val_name = shift;
211 return $self->inline_class_slot_access($name) . ' = ' . $val_name;
214 sub inline_is_class_slot_initialized {
218 return 'exists ' . $self->inline_class_slot_access($name);
221 sub inline_deinitialize_class_slot {
225 return 'delete ' . $self->inline_class_slot_access($name);
228 sub inline_weaken_class_slot_value {
233 'Scalar::Util::weaken( '
234 . $self->inline_class_slot_access($name) . ')';
247 MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes
251 for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
258 This role adds awareness of class attributes to a metaclass object. It
259 provides a set of introspection methods that largely parallel the
260 existing attribute methods, except they operate on class attributes.
264 Every method provided by this role has an analogous method in
265 C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
267 =head2 $meta->has_class_attribute($name)
269 =head2 $meta->get_class_attribute($name)
271 =head2 $meta->get_class_attribute_list()
273 =head2 $meta->get_class_attribute_map()
275 These methods operate on the current metaclass only.
277 =head2 $meta->add_class_attribute(...)
279 This accepts the same options as the L<Moose::Meta::Attribute>
280 C<add_attribute()> method. However, if an attribute is specified as
281 "required" an error will be thrown.
283 =head2 $meta->remove_class_attribute($name)
285 If the named class attribute exists, it is removed from the class,
286 along with its accessor methods.
288 =head2 $meta->get_all_class_attributes()
290 This method returns a list of attribute objects for the class and all
293 =head2 $meta->find_class_attribute_by_name($name)
295 This method looks at the class and all its parent classes for the
296 named class attribute.
298 =head2 $meta->get_class_attribute_value($name)
300 =head2 $meta->set_class_attribute_value($name, $value)
302 =head2 $meta->set_class_attribute_value($name)
304 =head2 $meta->clear_class_attribute_value($name)
306 These methods operate on the storage for class attribute values, which
307 is attached to the metaclass object.
309 There's really no good reason for you to call these methods unless
310 you're doing some deep hacking. They are named as public methods
311 solely because they are used by other meta roles and classes in this
314 =head2 inline_class_slot_access($name)
316 =head2 inline_get_class_slot_value($name)
318 =head2 inline_set_class_slot_value($name, $val_name)
320 =head2 inline_is_class_slot_initialized($name)
322 =head2 inline_deinitialize_class_slot($name)
324 =head2 inline_weaken_class_slot_value($name)
326 These methods return code snippets for inlining.
328 There's really no good reason for you to call these methods unless
329 you're doing some deep hacking. They are named as public methods
330 solely because they are used by other meta roles and classes in this
335 Dave Rolsky, C<< <autarch@urth.org> >>
339 See L<MooseX::ClassAttribute> for details.
341 =head1 COPYRIGHT & LICENSE
343 Copyright 2007-2008 Dave Rolsky, All Rights Reserved.
345 This program is free software; you can redistribute it and/or modify
346 it under the same terms as Perl itself.