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[Moose::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
98 push @{ $p{traits} },'MooseX::ClassAttribute::Role::Meta::Attribute'
102 $p{traits} = [ 'MooseX::ClassAttribute::Role::Meta::Attribute' ];
105 return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
108 sub _process_inherited_class_attribute
114 my $inherited_attr = $self->find_class_attribute_by_name($name);
116 (defined $inherited_attr)
117 || confess "Could not find an attribute by the name of '$name' to inherit from";
119 return $inherited_attr->clone_and_inherit_options(%p);
122 sub remove_class_attribute
127 (defined $name && $name)
128 || confess 'You must provide an attribute name';
130 my $removed_attr = $self->get_class_attribute($name);
131 return unless $removed_attr;
133 $self->_remove_class_attribute($name);
135 $removed_attr->remove_accessors();
136 $removed_attr->detach_from_class();
138 return $removed_attr;
141 sub get_all_class_attributes
143 shift->compute_all_applicable_class_attributes(@_);
146 sub compute_all_applicable_class_attributes
151 map { %{ Class::MOP::Class->initialize($_)->get_class_attribute_map } }
152 reverse $self->linearized_isa;
154 return values %attrs;
157 sub find_class_attribute_by_name
162 foreach my $class ( $self->linearized_isa() )
164 my $meta = Class::MOP::Class->initialize($class);
166 return $meta->get_class_attribute($name)
167 if $meta->has_class_attribute($name);
173 sub _class_attribute_values_hashref
178 return \%{ $self->_class_attribute_var_name() };
181 sub _class_attribute_var_name
185 return $self->name() . q'::__ClassAttributeValues';
188 sub inline_class_slot_access
193 return '$' . $self->_class_attribute_var_name . '{' . $name . '}';
196 sub inline_get_class_slot_value
201 return $self->inline_class_slot_access($name);
204 sub inline_set_class_slot_value
208 my $val_name = shift;
210 return $self->inline_class_slot_access($name) . ' = ' . $val_name;
213 sub inline_is_class_slot_initialized
218 return 'exists ' . $self->inline_class_slot_access($name);
221 sub inline_deinitialize_class_slot
226 return 'delete ' . $self->inline_class_slot_access($name);
229 sub inline_weaken_class_slot_value
234 return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')';