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     }
  45
  46     # get our count of previously inserted attributes and
  47     # increment by one so this attribute knows its order
  48     my $order = ( scalar keys %{ $self->_attribute_map } );
  49     $attribute->_set_insertion_order($order);
  50
  51     # then onto installing the new accessors
  52     $self->_attribute_map->{$attr_name} = $attribute;
  53
  54     # invalidate package flag here
  55     try {
  56         local $SIG{__DIE__};
  57         $attribute->install_accessors();
  58     }
  59     catch {
  60         $self->remove_attribute($attr_name);
  61         die $_;
  62     };
  63
  64     return $attribute;
  65 }
  66
  67 sub has_attribute {
  68     my ( $self, $attribute_name ) = @_;
  69
  70     ( defined $attribute_name )
  71         || confess "You must define an attribute name";
  72
  73     exists $self->_attribute_map->{$attribute_name};
  74 }
  75
  76 sub get_attribute {
  77     my ( $self, $attribute_name ) = @_;
  78
  79     ( defined $attribute_name )
  80         || confess "You must define an attribute name";
  81
  82     return $self->_attribute_map->{$attribute_name};
  83 }
  84
  85 sub remove_attribute {
  86     my ( $self, $attribute_name ) = @_;
  87
  88     ( defined $attribute_name )
  89         || confess "You must define an attribute name";
  90
  91     my $removed_attribute = $self->_attribute_map->{$attribute_name};
  92     return unless defined $removed_attribute;
  93
  94     delete $self->_attribute_map->{$attribute_name};
  95     $self->invalidate_meta_instances();
  96     $removed_attribute->remove_accessors();
  97     $removed_attribute->detach_from_class();
  98
  99     return $removed_attribute;
 100 }
 101
 102 sub get_attribute_list {
 103     my $self = shift;
 104     keys %{ $self->_attribute_map };
 105 }
 106
 107 sub get_all_attributes {
 108     my $self = shift;
 109     my %attrs = map { %{ $self->initialize($_)->_attribute_map } }
 110         reverse $self->linearized_isa;
 111     return values %attrs;
 112 }
 113
 114 sub find_attribute_by_name {
 115     my ( $self, $attr_name ) = @_;
 116
 117     foreach my $class ( $self->linearized_isa ) {
 118         # fetch the meta-class ...
 119         my $meta = $self->initialize($class);
 120         return $meta->get_attribute($attr_name)
 121             if $meta->has_attribute($attr_name);
 122     }
 123
 124     return;
 125 }
 126
 127 1;