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