1 package MooseX::ClassAttribute::Role::Meta::Class;
6 use MooseX::AttributeHelpers;
7 use MooseX::ClassAttribute::Role::Meta::Attribute;
8 use Scalar::Util qw( blessed );
13 has class_attribute_map =>
14 ( metaclass => 'Collection::Hash',
16 isa => 'HashRef[Moose::Meta::Attribute]',
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',
23 default => sub { {} },
24 reader => 'get_class_attribute_map',
27 has _class_attribute_values =>
28 ( metaclass => 'Collection::Hash',
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',
37 default => sub { $_[0]->_class_attribute_values_hashref() },
41 sub add_class_attribute
46 blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
48 : $self->_process_class_attribute(@_);
50 my $name = $attr->name();
52 $self->remove_class_attribute($name)
53 if $self->has_class_attribute($name);
55 $attr->attach_to_class($self);
57 $self->_add_class_attribute( $name => $attr );
59 my $e = do { local $@; eval { $attr->install_accessors() }; $@ };
63 $self->remove_attribute($name);
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
79 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
81 if ($name =~ /^\+(.*)/)
83 return $self->_process_inherited_class_attribute( $1, @args );
87 return $self->_process_new_class_attribute( $name, @args );
91 sub _process_new_class_attribute
99 push @{ $p{traits} },'MooseX::ClassAttribute::Role::Meta::Attribute'
103 $p{traits} = [ 'MooseX::ClassAttribute::Role::Meta::Attribute' ];
106 return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
109 sub _process_inherited_class_attribute
115 my $inherited_attr = $self->find_class_attribute_by_name($name);
117 (defined $inherited_attr)
118 || confess "Could not find an attribute by the name of '$name' to inherit from";
120 return $inherited_attr->clone_and_inherit_options(%p);
123 sub remove_class_attribute
128 (defined $name && $name)
129 || confess 'You must provide an attribute name';
131 my $removed_attr = $self->get_class_attribute($name);
132 return unless $removed_attr;
134 $self->_remove_class_attribute($name);
136 $removed_attr->remove_accessors();
137 $removed_attr->detach_from_class();
139 return $removed_attr;
142 sub get_all_class_attributes
147 map { my $meta = Class::MOP::Class->initialize($_);
148 $meta->can('get_class_attribute_map')
149 ? %{ $meta->get_class_attribute_map() }
152 reverse $self->linearized_isa;
154 return values %attrs;
157 sub compute_all_applicable_class_attributes
159 warn 'The compute_all_applicable_class_attributes method has been deprecated.'
160 . " Use get_all_class_attributes instead.\n";
162 shift->compute_all_applicable_class_attributes(@_);
165 sub find_class_attribute_by_name
170 foreach my $class ( $self->linearized_isa() )
172 my $meta = Class::MOP::Class->initialize($class);
174 return $meta->get_class_attribute($name)
175 if $meta->can('has_class_attribute') && $meta->has_class_attribute($name);
181 sub _class_attribute_values_hashref
186 return \%{ $self->_class_attribute_var_name() };
189 sub _class_attribute_var_name
193 return $self->name() . q'::__ClassAttributeValues';
196 sub inline_class_slot_access
201 return '$' . $self->_class_attribute_var_name . '{"' . quotemeta($name) . '"}';
204 sub inline_get_class_slot_value
209 return $self->inline_class_slot_access($name);
212 sub inline_set_class_slot_value
216 my $val_name = shift;
218 return $self->inline_class_slot_access($name) . ' = ' . $val_name;
221 sub inline_is_class_slot_initialized
226 return 'exists ' . $self->inline_class_slot_access($name);
229 sub inline_deinitialize_class_slot
234 return 'delete ' . $self->inline_class_slot_access($name);
237 sub inline_weaken_class_slot_value
242 return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')';
255 MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes
259 for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
266 This role adds awareness of class attributes to a metaclass object. It
267 provides a set of introspection methods that largely parallel the
268 existing attribute methods, except they operate on class attributes.
272 Every method provided by this role has an analogous method in
273 C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
275 =head2 $meta->has_class_attribute($name)
277 =head2 $meta->get_class_attribute($name)
279 =head2 $meta->get_class_attribute_list()
281 =head2 $meta->get_class_attribute_map()
283 These methods operate on the current metaclass only.
285 =head2 $meta->add_class_attribute(...)
287 This accepts the same options as the L<Moose::Meta::Attribute>
288 C<add_attribute()> method. However, if an attribute is specified as
289 "required" an error will be thrown.
291 =head2 $meta->remove_class_attribute($name)
293 If the named class attribute exists, it is removed from the class,
294 along with its accessor methods.
296 =head2 $meta->get_all_class_attributes()
298 This method returns a list of attribute objects for the class and all
301 =head2 $meta->find_class_attribute_by_name($name)
303 This method looks at the class and all its parent classes for the
304 named class attribute.
306 =head2 $meta->get_class_attribute_value($name)
308 =head2 $meta->set_class_attribute_value($name, $value)
310 =head2 $meta->set_class_attribute_value($name)
312 =head2 $meta->clear_class_attribute_value($name)
314 These methods operate on the storage for class attribute values, which
315 is attached to the metaclass object.
317 There's really no good reason for you to call these methods unless
318 you're doing some deep hacking. They are named as public methods
319 solely because they are used by other meta roles and classes in this
322 =head2 inline_class_slot_access($name)
324 =head2 inline_get_class_slot_value($name)
326 =head2 inline_set_class_slot_value($name, $val_name)
328 =head2 inline_is_class_slot_initialized($name)
330 =head2 inline_deinitialize_class_slot($name)
332 =head2 inline_weaken_class_slot_value($name)
334 These methods return code snippets for inlining.
336 There's really no good reason for you to call these methods unless
337 you're doing some deep hacking. They are named as public methods
338 solely because they are used by other meta roles and classes in this
343 Dave Rolsky, C<< <autarch@urth.org> >>
347 See L<MooseX::ClassAttribute> for details.
349 =head1 COPYRIGHT & LICENSE
351 Copyright 2007-2008 Dave Rolsky, All Rights Reserved.
353 This program is free software; you can redistribute it and/or modify
354 it under the same terms as Perl itself.