lib/Class/MOP/HasAttributes.pm

   1 package Class::MOP::HasAttributes;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp         'confess';
   7 use Scalar::Util 'blessed';
   8 use Try::Tiny;
   9
  10 use base 'Class::MOP::Object';
  11
  12 sub _attribute_map      { $_[0]->{'attributes'} }
  13 sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
  14
  15 sub add_attribute {
  16     my $self = shift;
  17
  18     # either we have an attribute object already
  19     # or we need to create one from the args provided
  20     my $attribute
  21         = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_);
  22
  23     # make sure it is derived from the correct type though
  24     ( $attribute->isa('Class::MOP::Attribute') )
  25         || confess
  26         "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
  27
  28     # first we attach our new attribute
  29     # because it might need certain information
  30     # about the class which it is attached to
  31     $attribute->attach_to_class($self);
  32
  33     my $attr_name = $attribute->name;
  34
  35     # then we remove attributes of a conflicting
  36     # name here so that we can properly detach
  37     # the old attr object, and remove any
  38     # accessors it would have generated
  39     if ( $self->has_attribute($attr_name) ) {
  40         $self->remove_attribute($attr_name);
  41     }
  42     else {
  43         $self->invalidate_meta_instances()
  44             if $self->can('invalidate_meta_instances');
  45     }
  46
  47     # get our count of previously inserted attributes and
  48     # increment by one so this attribute knows its order
  49     my $order = ( scalar keys %{ $self->_attribute_map } );
  50     $attribute->_set_insertion_order($order);
  51
  52     # then onto installing the new accessors
  53     $self->_attribute_map->{$attr_name} = $attribute;
  54
  55     # invalidate package flag here
  56     try {
  57         local $SIG{__DIE__};
  58         $attribute->install_accessors();
  59     }
  60     catch {
  61         $self->remove_attribute($attr_name);
  62         die $_;
  63     };
  64
  65     return $attribute;
  66 }
  67
  68 sub has_attribute {
  69     my ( $self, $attribute_name ) = @_;
  70
  71     ( defined $attribute_name )
  72         || confess "You must define an attribute name";
  73
  74     exists $self->_attribute_map->{$attribute_name};
  75 }
  76
  77 sub get_attribute {
  78     my ( $self, $attribute_name ) = @_;
  79
  80     ( defined $attribute_name )
  81         || confess "You must define an attribute name";
  82
  83     return $self->_attribute_map->{$attribute_name};
  84 }
  85
  86 sub remove_attribute {
  87     my ( $self, $attribute_name ) = @_;
  88
  89     ( defined $attribute_name )
  90         || confess "You must define an attribute name";
  91
  92     my $removed_attribute = $self->_attribute_map->{$attribute_name};
  93     return unless defined $removed_attribute;
  94
  95     delete $self->_attribute_map->{$attribute_name};
  96     $self->invalidate_meta_instances()
  97         if $self->can('invalidate_meta_instances');
  98     $removed_attribute->remove_accessors();
  99     $removed_attribute->detach_from_class();
 100
 101     return $removed_attribute;
 102 }
 103
 104 sub get_attribute_list {
 105     my $self = shift;
 106     keys %{ $self->_attribute_map };
 107 }
 108
 109 sub find_attribute_by_name {
 110     my ( $self, $attr_name ) = @_;
 111
 112     foreach my $class ( $self->linearized_isa ) {
 113         # fetch the meta-class ...
 114         my $meta = $self->initialize($class);
 115         return $meta->get_attribute($attr_name)
 116             if $meta->has_attribute($attr_name);
 117     }
 118
 119     return;
 120 }
 121
 122 1;