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::Object';
  10
  11 sub _attribute_map      { $_[0]->{'attributes'} }
  12 sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
  13
  14 sub add_attribute {
  15     my $self = shift;
  16
  17     my $attribute
  18         = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_);
  19
  20     ( $attribute->isa('Class::MOP::Attribute') )
  21         || confess
  22         "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
  23
  24     $self->_attach_attribute($attribute);
  25
  26     my $attr_name = $attribute->name;
  27
  28     $self->remove_attribute($attr_name)
  29         if $self->has_attribute($attr_name);
  30
  31     my $order = ( scalar keys %{ $self->_attribute_map } );
  32     $attribute->_set_insertion_order($order);
  33
  34     $self->_attribute_map->{$attr_name} = $attribute;
  35
  36     # This method is called to allow for installing accessors. Ideally, we'd
  37     # use method overriding, but then the subclass would be responsible for
  38     # making the attribute, which would end up with lots of code
  39     # duplication. Even more ideally, we'd use augment/inner, but this is
  40     # Class::MOP!
  41     $self->_post_add_attribute($attribute)
  42         if $self->can('_post_add_attribute');
  43
  44     return $attribute;
  45 }
  46
  47 sub has_attribute {
  48     my ( $self, $attribute_name ) = @_;
  49
  50     ( defined $attribute_name )
  51         || confess "You must define an attribute name";
  52
  53     exists $self->_attribute_map->{$attribute_name};
  54 }
  55
  56 sub get_attribute {
  57     my ( $self, $attribute_name ) = @_;
  58
  59     ( defined $attribute_name )
  60         || confess "You must define an attribute name";
  61
  62     return $self->_attribute_map->{$attribute_name};
  63 }
  64
  65 sub remove_attribute {
  66     my ( $self, $attribute_name ) = @_;
  67
  68     ( defined $attribute_name )
  69         || confess "You must define an attribute name";
  70
  71     my $removed_attribute = $self->_attribute_map->{$attribute_name};
  72     return unless defined $removed_attribute;
  73
  74     delete $self->_attribute_map->{$attribute_name};
  75
  76     return $removed_attribute;
  77 }
  78
  79 sub get_attribute_list {
  80     my $self = shift;
  81     keys %{ $self->_attribute_map };
  82 }
  83
  84 1;