1 package MooseX::ClassAttribute::Role::Meta::Class;
6 use MooseX::AttributeHelpers;
7 use Scalar::Util qw( blessed );
12 has class_attribute_map =>
13 ( metaclass => 'Collection::Hash',
15 isa => 'HashRef[MooseX::ClassAttribute::Meta::Attribute]',
16 provides => { set => '_add_class_attribute',
17 exists => 'has_class_attribute',
18 get => 'get_class_attribute',
19 delete => '_remove_class_attribute',
20 keys => 'get_class_attribute_list',
22 default => sub { {} },
23 reader => 'get_class_attribute_map',
26 has _class_attribute_values =>
27 ( metaclass => 'Collection::Hash',
30 provides => { get => 'get_class_attribute_value',
31 set => 'set_class_attribute_value',
32 exists => 'has_class_attribute_value',
33 delete => 'clear_class_attribute_value',
36 default => sub { $_[0]->_class_attribute_values_hashref() },
40 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 );
58 my $e = do { local $@; eval { $attr->install_accessors() }; $@ };
62 $self->remove_attribute($name);
69 # It'd be nice if I didn't have to replicate this for class
70 # attributes, since it's basically just a copy of
71 # Moose::Meta::Class->_process_attribute
72 sub _process_class_attribute
78 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
80 if ($name =~ /^\+(.*)/)
82 return $self->_process_inherited_class_attribute( $1, @args );
86 return $self->_process_new_class_attribute( $name, @args );
90 sub _process_new_class_attribute
99 Moose::Meta::Class->create_anon_class
100 ( superclasses => [ 'MooseX::ClassAttribute::Meta::Attribute', $p{metaclass} ],
106 $p{metaclass} = 'MooseX::ClassAttribute::Meta::Attribute';
109 return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
112 sub _process_inherited_class_attribute
118 my $inherited_attr = $self->find_class_attribute_by_name($name);
120 (defined $inherited_attr)
121 || confess "Could not find an attribute by the name of '$name' to inherit from";
123 return $inherited_attr->clone_and_inherit_options(%p);
126 sub remove_class_attribute
131 (defined $name && $name)
132 || confess 'You must provide an attribute name';
134 my $removed_attr = $self->get_class_attribute($name);
135 return unless $removed_attr;
137 $self->_remove_class_attribute($name);
139 $removed_attr->remove_accessors();
140 $removed_attr->detach_from_class();
142 return $removed_attr;
145 sub get_all_class_attributes
147 shift->compute_all_applicable_class_attributes(@_);
150 sub compute_all_applicable_class_attributes
155 map { %{ Class::MOP::Class->initialize($_)->get_class_attribute_map } }
156 reverse $self->linearized_isa;
158 return values %attrs;
161 sub find_class_attribute_by_name
166 foreach my $class ( $self->linearized_isa() )
168 my $meta = Class::MOP::Class->initialize($class);
170 return $meta->get_class_attribute($name)
171 if $meta->has_class_attribute($name);
177 sub _class_attribute_values_hashref
182 return \%{ $self->_class_attribute_var_name() };
185 sub _class_attribute_var_name
189 return $self->name() . q'::__ClassAttributeValues';
192 sub inline_class_slot_access
197 return '$' . $self->_class_attribute_var_name . '{' . $name . '}';
200 sub inline_get_class_slot_value
205 return $self->inline_class_slot_access($name);
208 sub inline_set_class_slot_value
212 my $val_name = shift;
214 return $self->inline_class_slot_access($name) . ' = ' . $val_name;
217 sub inline_is_class_slot_initialized
222 return 'exists ' . $self->inline_class_slot_access($name);
225 sub inline_deinitialize_class_slot
230 return 'delete ' . $self->inline_class_slot_access($name);
233 sub inline_weaken_class_slot_value
238 return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')';