Commit | Line | Data |
38bf2a25 |
1 | package Class::MOP::Mixin::HasAttributes; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
38bf2a25 |
6 | use Carp 'confess'; |
7 | use Scalar::Util 'blessed'; |
8 | |
9 | use base 'Class::MOP::Mixin'; |
10 | |
11 | sub add_attribute { |
12 | my $self = shift; |
13 | |
14 | my $attribute |
15 | = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_); |
16 | |
17 | ( $attribute->isa('Class::MOP::Mixin::AttributeCore') ) |
18 | || confess |
19 | "Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)"; |
20 | |
21 | $self->_attach_attribute($attribute); |
22 | |
23 | my $attr_name = $attribute->name; |
24 | |
25 | $self->remove_attribute($attr_name) |
26 | if $self->has_attribute($attr_name); |
27 | |
28 | my $order = ( scalar keys %{ $self->_attribute_map } ); |
29 | $attribute->_set_insertion_order($order); |
30 | |
31 | $self->_attribute_map->{$attr_name} = $attribute; |
32 | |
33 | # This method is called to allow for installing accessors. Ideally, we'd |
34 | # use method overriding, but then the subclass would be responsible for |
35 | # making the attribute, which would end up with lots of code |
36 | # duplication. Even more ideally, we'd use augment/inner, but this is |
37 | # Class::MOP! |
38 | $self->_post_add_attribute($attribute) |
39 | if $self->can('_post_add_attribute'); |
40 | |
41 | return $attribute; |
42 | } |
43 | |
44 | sub has_attribute { |
45 | my ( $self, $attribute_name ) = @_; |
46 | |
47 | ( defined $attribute_name ) |
48 | || confess "You must define an attribute name"; |
49 | |
50 | exists $self->_attribute_map->{$attribute_name}; |
51 | } |
52 | |
53 | sub get_attribute { |
54 | my ( $self, $attribute_name ) = @_; |
55 | |
56 | ( defined $attribute_name ) |
57 | || confess "You must define an attribute name"; |
58 | |
59 | return $self->_attribute_map->{$attribute_name}; |
60 | } |
61 | |
62 | sub remove_attribute { |
63 | my ( $self, $attribute_name ) = @_; |
64 | |
65 | ( defined $attribute_name ) |
66 | || confess "You must define an attribute name"; |
67 | |
68 | my $removed_attribute = $self->_attribute_map->{$attribute_name}; |
69 | return unless defined $removed_attribute; |
70 | |
71 | delete $self->_attribute_map->{$attribute_name}; |
72 | |
73 | return $removed_attribute; |
74 | } |
75 | |
76 | sub get_attribute_list { |
77 | my $self = shift; |
78 | keys %{ $self->_attribute_map }; |
79 | } |
80 | |
81 | sub _restore_metaattributes_from { |
82 | my $self = shift; |
83 | my ($old_meta) = @_; |
84 | |
85 | for my $attr (sort { $a->insertion_order <=> $b->insertion_order } |
86 | map { $old_meta->get_attribute($_) } |
87 | $old_meta->get_attribute_list) { |
88 | $attr->_make_compatible_with($self->attribute_metaclass); |
89 | $self->add_attribute($attr); |
90 | } |
91 | } |
92 | |
93 | 1; |
94 | |
95 | # ABSTRACT: Methods for metaclasses which have attributes |
96 | |
97 | __END__ |
98 | |
99 | =pod |
100 | |
101 | =head1 DESCRIPTION |
102 | |
103 | This class implements methods for metaclasses which have attributes |
104 | (L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for |
105 | API details. |
106 | |
107 | =cut |