lib/MooseX/ClassAttribute/Role/Meta/Class.pm

   1 package MooseX::ClassAttribute::Role::Meta::Class;
   2
   3 use strict;
   4 use warnings;
   5
   6 use MooseX::AttributeHelpers;
   7 use Scalar::Util qw( blessed );
   8
   9 use Moose::Role;
  10
  11
  12 has class_attribute_map =>
  13     ( metaclass => 'Collection::Hash',
  14       is        => 'ro',
  15       isa       => 'HashRef[Moose::Meta::Attribute]',
  16       provides  => { set    => '_add_class_attribute',
  17                      exists => 'has_class_attribute',
  18                      get    => 'get_class_attribute',
  19                      delete => '_remove_class_attribute',
  20                      keys   => 'get_class_attribute_list',
  21                    },
  22       default   => sub { {} },
  23       reader    => 'get_class_attribute_map',
  24     );
  25
  26 has _class_attribute_values =>
  27     ( metaclass => 'Collection::Hash',
  28       is        => 'ro',
  29       isa       => 'HashRef',
  30       provides  => { get    => 'get_class_attribute_value',
  31                      set    => 'set_class_attribute_value',
  32                      exists => 'has_class_attribute_value',
  33                      delete => 'clear_class_attribute_value',
  34                    },
  35       lazy      => 1,
  36       default   => sub { $_[0]->_class_attribute_values_hashref() },
  37     );
  38
  39
  40 sub add_class_attribute
  41 {
  42     my $self = shift;
  43
  44     my $attr =
  45         blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
  46         ? $_[0]
  47         : $self->_process_class_attribute(@_);
  48
  49     my $name = $attr->name();
  50
  51     $self->remove_class_attribute($name)
  52         if $self->has_class_attribute($name);
  53
  54     $attr->attach_to_class($self);
  55
  56     $self->_add_class_attribute( $name => $attr );
  57
  58     my $e = do { local $@; eval { $attr->install_accessors() }; $@ };
  59
  60     if ( $e )
  61     {
  62         $self->remove_attribute($name);
  63         die $e;
  64     }
  65
  66     return $attr;
  67 }
  68
  69 # It'd be nice if I didn't have to replicate this for class
  70 # attributes, since it's basically just a copy of
  71 # Moose::Meta::Class->_process_attribute
  72 sub _process_class_attribute
  73 {
  74     my $self = shift;
  75     my $name = shift;
  76     my @args = @_;
  77
  78     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
  79
  80     if ($name =~ /^\+(.*)/)
  81     {
  82         return $self->_process_inherited_class_attribute( $1, @args );
  83     }
  84     else
  85     {
  86         return $self->_process_new_class_attribute( $name, @args );
  87     }
  88 }
  89
  90 sub _process_new_class_attribute
  91 {
  92     my $self = shift;
  93     my $name = shift;
  94     my %p    = @_;
  95
  96     if ( $p{traits} )
  97     {
  98         push @{ $p{traits} },'MooseX::ClassAttribute::Role::Meta::Attribute'
  99     }
 100     else
 101     {
 102         $p{traits} = [ 'MooseX::ClassAttribute::Role::Meta::Attribute' ];
 103     }
 104
 105     return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
 106 }
 107
 108 sub _process_inherited_class_attribute
 109 {
 110     my $self = shift;
 111     my $name = shift;
 112     my %p    = @_;
 113
 114     my $inherited_attr = $self->find_class_attribute_by_name($name);
 115
 116     (defined $inherited_attr)
 117         || confess "Could not find an attribute by the name of '$name' to inherit from";
 118
 119     return $inherited_attr->clone_and_inherit_options(%p);
 120 }
 121
 122 sub remove_class_attribute
 123 {
 124     my $self = shift;
 125     my $name = shift;
 126
 127     (defined $name && $name)
 128         || confess 'You must provide an attribute name';
 129
 130     my $removed_attr = $self->get_class_attribute($name);
 131     return unless $removed_attr;
 132
 133     $self->_remove_class_attribute($name);
 134
 135     $removed_attr->remove_accessors();
 136     $removed_attr->detach_from_class();
 137
 138     return $removed_attr;
 139 }
 140
 141 sub get_all_class_attributes
 142 {
 143     shift->compute_all_applicable_class_attributes(@_);
 144 }
 145
 146 sub compute_all_applicable_class_attributes
 147 {
 148     my $self = shift;
 149
 150     my %attrs =
 151         map { %{ Class::MOP::Class->initialize($_)->get_class_attribute_map } }
 152         reverse $self->linearized_isa;
 153
 154     return values %attrs;
 155 }
 156
 157 sub find_class_attribute_by_name
 158 {
 159     my $self = shift;
 160     my $name = shift;
 161
 162     foreach my $class ( $self->linearized_isa() )
 163     {
 164         my $meta = Class::MOP::Class->initialize($class);
 165
 166         return $meta->get_class_attribute($name)
 167             if $meta->has_class_attribute($name);
 168     }
 169
 170     return;
 171 }
 172
 173 sub _class_attribute_values_hashref
 174 {
 175     my $self = shift;
 176
 177     no strict 'refs';
 178     return \%{ $self->_class_attribute_var_name() };
 179 }
 180
 181 sub _class_attribute_var_name
 182 {
 183     my $self = shift;
 184
 185     return $self->name() . q'::__ClassAttributeValues';
 186 }
 187
 188 sub inline_class_slot_access
 189 {
 190     my $self = shift;
 191     my $name = shift;
 192
 193     return '$' . $self->_class_attribute_var_name . '{' . $name . '}';
 194 }
 195
 196 sub inline_get_class_slot_value
 197 {
 198     my $self = shift;
 199     my $name = shift;
 200
 201     return $self->inline_class_slot_access($name);
 202 }
 203
 204 sub inline_set_class_slot_value
 205 {
 206     my $self     = shift;
 207     my $name     = shift;
 208     my $val_name = shift;
 209
 210     return $self->inline_class_slot_access($name) . ' = ' . $val_name;
 211 }
 212
 213 sub inline_is_class_slot_initialized
 214 {
 215     my $self     = shift;
 216     my $name     = shift;
 217
 218     return 'exists ' . $self->inline_class_slot_access($name);
 219 }
 220
 221 sub inline_deinitialize_class_slot
 222 {
 223     my $self     = shift;
 224     my $name     = shift;
 225
 226     return 'delete ' . $self->inline_class_slot_access($name);
 227 }
 228
 229 sub inline_weaken_class_slot_value
 230 {
 231     my $self     = shift;
 232     my $name     = shift;
 233
 234     return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')';
 235 }
 236
 237 no Moose::Role;
 238
 239 1;