lib/Class/MOP/Mixin/HasAttributes.pm

   1 package Class::MOP::Mixin::HasAttributes;
   2
   3 use strict;
   4 use warnings;
   5
   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