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