lib/Class/MOP/Mixin/HasAttributes.pm

   1 package Class::MOP::Mixin::HasAttributes;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION   = '1.11';
   7 $VERSION = eval $VERSION;
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 use Carp         'confess';
  11 use Scalar::Util 'blessed';
  12
  13 use base 'Class::MOP::Mixin';
  14
  15 sub add_attribute {
  16     my $self = shift;
  17
  18     my $attribute
  19         = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_);
  20
  21     ( $attribute->isa('Class::MOP::Mixin::AttributeCore') )
  22         || confess
  23         "Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)";
  24
  25     $self->_attach_attribute($attribute);
  26
  27     my $attr_name = $attribute->name;
  28
  29     $self->remove_attribute($attr_name)
  30         if $self->has_attribute($attr_name);
  31
  32     my $order = ( scalar keys %{ $self->_attribute_map } );
  33     $attribute->_set_insertion_order($order);
  34
  35     $self->_attribute_map->{$attr_name} = $attribute;
  36
  37     # This method is called to allow for installing accessors. Ideally, we'd
  38     # use method overriding, but then the subclass would be responsible for
  39     # making the attribute, which would end up with lots of code
  40     # duplication. Even more ideally, we'd use augment/inner, but this is
  41     # Class::MOP!
  42     $self->_post_add_attribute($attribute)
  43         if $self->can('_post_add_attribute');
  44
  45     return $attribute;
  46 }
  47
  48 sub has_attribute {
  49     my ( $self, $attribute_name ) = @_;
  50
  51     ( defined $attribute_name )
  52         || confess "You must define an attribute name";
  53
  54     exists $self->_attribute_map->{$attribute_name};
  55 }
  56
  57 sub get_attribute {
  58     my ( $self, $attribute_name ) = @_;
  59
  60     ( defined $attribute_name )
  61         || confess "You must define an attribute name";
  62
  63     return $self->_attribute_map->{$attribute_name};
  64 }
  65
  66 sub remove_attribute {
  67     my ( $self, $attribute_name ) = @_;
  68
  69     ( defined $attribute_name )
  70         || confess "You must define an attribute name";
  71
  72     my $removed_attribute = $self->_attribute_map->{$attribute_name};
  73     return unless defined $removed_attribute;
  74
  75     delete $self->_attribute_map->{$attribute_name};
  76
  77     return $removed_attribute;
  78 }
  79
  80 sub get_attribute_list {
  81     my $self = shift;
  82     keys %{ $self->_attribute_map };
  83 }
  84
  85 sub _restore_metaattributes_from {
  86     my $self = shift;
  87     my ($old_meta) = @_;
  88
  89     for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
  90                        map { $old_meta->get_attribute($_) }
  91                            $old_meta->get_attribute_list) {
  92         $attr->_make_compatible_with($self->attribute_metaclass);
  93         $self->add_attribute($attr);
  94     }
  95 }
  96
  97 1;
  98
  99 __END__
 100
 101 =pod
 102
 103 =head1 NAME
 104
 105 Class::MOP::Mixin::HasMethods - Methods for metaclasses which have attributes
 106
 107 =head1 DESCRIPTION
 108
 109 This class implements methods for metaclasses which have attributes
 110 (L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for
 111 API details.
 112
 113 =head1 AUTHORS
 114
 115 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 116
 117 =head1 COPYRIGHT AND LICENSE
 118
 119 Copyright 2006-2010 by Infinity Interactive, Inc.
 120
 121 L<http://www.iinteractive.com>
 122
 123 This library is free software; you can redistribute it and/or modify
 124 it under the same terms as Perl itself.
 125
 126 =cut