lib/Class/MOP/Mixin/HasAttributes.pm

   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