lib/MooseX/ClassAttribute/Role/Meta/Mixin/HasClassAttributes.pm

   1 package MooseX::ClassAttribute::Role::Meta::Mixin::HasClassAttributes;
   2
   3 use strict;
   4 use warnings;
   5
   6 use namespace::autoclean;
   7 use Moose::Role;
   8
   9 has _class_attribute_map => (
  10     traits  => ['Hash'],
  11     is      => 'ro',
  12     isa     => 'HashRef[Class::MOP::Mixin::AttributeCore]',
  13     handles => {
  14         '_add_class_attribute'     => 'set',
  15         'has_class_attribute'      => 'exists',
  16         'get_class_attribute'      => 'get',
  17         '_remove_class_attribute'  => 'delete',
  18         'get_class_attribute_list' => 'keys',
  19     },
  20     default  => sub { {} },
  21     init_arg => undef,
  22 );
  23
  24 # deprecated
  25 sub get_class_attribute_map {
  26     return $_[0]->_class_attribute_map();
  27 }
  28
  29 sub add_class_attribute {
  30     my $self      = shift;
  31     my $attribute = shift;
  32
  33     ( $attribute->isa('Class::MOP::Mixin::AttributeCore') )
  34         || confess
  35         "Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)";
  36
  37     $self->_attach_class_attribute($attribute);
  38
  39     my $attr_name = $attribute->name;
  40
  41     $self->remove_class_attribute($attr_name)
  42         if $self->has_class_attribute($attr_name);
  43
  44     my $order = ( scalar keys %{ $self->_attribute_map } );
  45     $attribute->_set_insertion_order($order);
  46
  47     $self->_add_class_attribute( $attr_name => $attribute );
  48
  49     # This method is called to allow for installing accessors. Ideally, we'd
  50     # use method overriding, but then the subclass would be responsible for
  51     # making the attribute, which would end up with lots of code
  52     # duplication. Even more ideally, we'd use augment/inner, but this is
  53     # Class::MOP!
  54     $self->_post_add_class_attribute($attribute)
  55         if $self->can('_post_add_class_attribute');
  56
  57     return $attribute;
  58 }
  59
  60 sub remove_class_attribute {
  61     my $self = shift;
  62     my $name = shift;
  63
  64     ( defined $name && $name )
  65         || confess 'You must provide an attribute name';
  66
  67     my $removed_attr = $self->get_class_attribute($name);
  68     return unless $removed_attr;
  69
  70     $self->_remove_class_attribute($name);
  71
  72     return $removed_attr;
  73 }
  74
  75 1;