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[MooseX::ClassAttribute::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{metaclass} )
  97     {
  98         $p{metaclass} =
  99             Moose::Meta::Class->create_anon_class
 100                 ( superclasses => [ 'MooseX::ClassAttribute::Meta::Attribute', $p{metaclass} ],
 101                   cache        => 1,
 102                 )->name();
 103     }
 104     else
 105     {
 106         $p{metaclass} = 'MooseX::ClassAttribute::Meta::Attribute';
 107     }
 108
 109     return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
 110 }
 111
 112 sub _process_inherited_class_attribute
 113 {
 114     my $self = shift;
 115     my $name = shift;
 116     my %p    = @_;
 117
 118     my $inherited_attr = $self->find_class_attribute_by_name($name);
 119
 120     (defined $inherited_attr)
 121         || confess "Could not find an attribute by the name of '$name' to inherit from";
 122
 123     return $inherited_attr->clone_and_inherit_options(%p);
 124 }
 125
 126 sub remove_class_attribute
 127 {
 128     my $self = shift;
 129     my $name = shift;
 130
 131     (defined $name && $name)
 132         || confess 'You must provide an attribute name';
 133
 134     my $removed_attr = $self->get_class_attribute($name);
 135     return unless $removed_attr;
 136
 137     $self->_remove_class_attribute($name);
 138
 139     $removed_attr->remove_accessors();
 140     $removed_attr->detach_from_class();
 141
 142     return $removed_attr;
 143 }
 144
 145 sub get_all_class_attributes
 146 {
 147     shift->compute_all_applicable_class_attributes(@_);
 148 }
 149
 150 sub compute_all_applicable_class_attributes
 151 {
 152     my $self = shift;
 153
 154     my %attrs =
 155         map { %{ Class::MOP::Class->initialize($_)->get_class_attribute_map } }
 156         reverse $self->linearized_isa;
 157
 158     return values %attrs;
 159 }
 160
 161 sub find_class_attribute_by_name
 162 {
 163     my $self = shift;
 164     my $name = shift;
 165
 166     foreach my $class ( $self->linearized_isa() )
 167     {
 168         my $meta = Class::MOP::Class->initialize($class);
 169
 170         return $meta->get_class_attribute($name)
 171             if $meta->has_class_attribute($name);
 172     }
 173
 174     return;
 175 }
 176
 177 sub _class_attribute_values_hashref
 178 {
 179     my $self = shift;
 180
 181     no strict 'refs';
 182     return \%{ $self->_class_attribute_var_name() };
 183 }
 184
 185 sub _class_attribute_var_name
 186 {
 187     my $self = shift;
 188
 189     return $self->name() . q'::__ClassAttributeValues';
 190 }
 191
 192 sub inline_class_slot_access
 193 {
 194     my $self = shift;
 195     my $name = shift;
 196
 197     return '$' . $self->_class_attribute_var_name . '{' . $name . '}';
 198 }
 199
 200 sub inline_get_class_slot_value
 201 {
 202     my $self = shift;
 203     my $name = shift;
 204
 205     return $self->inline_class_slot_access($name);
 206 }
 207
 208 sub inline_set_class_slot_value
 209 {
 210     my $self     = shift;
 211     my $name     = shift;
 212     my $val_name = shift;
 213
 214     return $self->inline_class_slot_access($name) . ' = ' . $val_name;
 215 }
 216
 217 sub inline_is_class_slot_initialized
 218 {
 219     my $self     = shift;
 220     my $name     = shift;
 221
 222     return 'exists ' . $self->inline_class_slot_access($name);
 223 }
 224
 225 sub inline_deinitialize_class_slot
 226 {
 227     my $self     = shift;
 228     my $name     = shift;
 229
 230     return 'delete ' . $self->inline_class_slot_access($name);
 231 }
 232
 233 sub inline_weaken_class_slot_value
 234 {
 235     my $self     = shift;
 236     my $name     = shift;
 237
 238     return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')';
 239 }
 240
 241 no Moose::Role;
 242
 243 1;