lib/MooseX/ClassAttribute/Trait/Class.pm

   1 package MooseX::ClassAttribute::Trait::Class;
   2
   3 use strict;
   4 use warnings;
   5
   6 use MooseX::ClassAttribute::Trait::Attribute;
   7 use Scalar::Util qw( blessed );
   8
   9 use namespace::autoclean;
  10 use Moose::Role;
  11
  12 with 'MooseX::ClassAttribute::Trait::Mixin::HasClassAttributes';
  13
  14 has _class_attribute_values => (
  15     traits  => ['Hash'],
  16     is      => 'ro',
  17     isa     => 'HashRef',
  18     handles => {
  19         'get_class_attribute_value'   => 'get',
  20         'set_class_attribute_value'   => 'set',
  21         'has_class_attribute_value'   => 'exists',
  22         'clear_class_attribute_value' => 'delete',
  23     },
  24     lazy     => 1,
  25     default  => sub { $_[0]->_class_attribute_values_hashref() },
  26     init_arg => undef,
  27 );
  28
  29 around add_class_attribute => sub {
  30     my $orig = shift;
  31     my $self = shift;
  32     my $attr = (
  33         blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
  34         ? $_[0]
  35         : $self->_process_class_attribute(@_)
  36     );
  37
  38     $self->$orig($attr);
  39
  40     return $attr;
  41 };
  42
  43 sub _post_add_class_attribute {
  44     my $self = shift;
  45     my $attr = shift;
  46
  47     my $name = $attr->name();
  48
  49     my $e = do {
  50         local $@;
  51         eval { $attr->install_accessors() };
  52         $@;
  53     };
  54
  55     if ($e) {
  56         $self->remove_attribute($name);
  57         die $e;
  58     }
  59 }
  60
  61 sub _attach_class_attribute {
  62     my ( $self, $attribute ) = @_;
  63     $attribute->attach_to_class($self);
  64 }
  65
  66 # It'd be nice if I didn't have to replicate this for class
  67 # attributes, since it's basically just a copy of
  68 # Moose::Meta::Class->_process_attribute
  69 sub _process_class_attribute {
  70     my $self = shift;
  71     my $name = shift;
  72     my @args = @_;
  73
  74     @args = %{ $args[0] } if scalar @args == 1 && ref( $args[0] ) eq 'HASH';
  75
  76     if ( $name =~ /^\+(.*)/ ) {
  77         return $self->_process_inherited_class_attribute( $1, @args );
  78     }
  79     else {
  80         return $self->_process_new_class_attribute( $name, @args );
  81     }
  82 }
  83
  84 sub _process_new_class_attribute {
  85     my $self = shift;
  86     my $name = shift;
  87     my %p    = @_;
  88
  89     if ( $p{traits} ) {
  90         push @{ $p{traits} }, 'MooseX::ClassAttribute::Trait::Attribute';
  91     }
  92     else {
  93         $p{traits} = ['MooseX::ClassAttribute::Trait::Attribute'];
  94     }
  95
  96     return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
  97 }
  98
  99 sub _process_inherited_class_attribute {
 100     my $self = shift;
 101     my $name = shift;
 102     my %p    = @_;
 103
 104     my $inherited_attr = $self->find_class_attribute_by_name($name);
 105
 106     ( defined $inherited_attr )
 107         || confess
 108         "Could not find an attribute by the name of '$name' to inherit from";
 109
 110     return $inherited_attr->clone_and_inherit_options(%p);
 111 }
 112
 113 around remove_class_attribute => sub {
 114     my $orig = shift;
 115     my $self = shift;
 116
 117     my $removed_attr = $self->$orig(@_)
 118         or return;
 119
 120     $removed_attr->remove_accessors();
 121     $removed_attr->detach_from_class();
 122
 123     return $removed_attr;
 124 };
 125
 126 sub get_all_class_attributes {
 127     my $self = shift;
 128
 129     my %attrs = map {
 130         my $meta = Class::MOP::class_of($_);
 131         $meta && $meta->can('_class_attribute_map')
 132             ? %{ $meta->_class_attribute_map() }
 133             : ()
 134         }
 135         reverse $self->linearized_isa;
 136
 137     return values %attrs;
 138 }
 139
 140 sub compute_all_applicable_class_attributes {
 141     warn
 142         'The compute_all_applicable_class_attributes method has been deprecated.'
 143         . " Use get_all_class_attributes instead.\n";
 144
 145     shift->compute_all_applicable_class_attributes(@_);
 146 }
 147
 148 sub find_class_attribute_by_name {
 149     my $self = shift;
 150     my $name = shift;
 151
 152     foreach my $class ( $self->linearized_isa() ) {
 153         my $meta = Class::MOP::class_of($class)
 154             or next;
 155
 156         return $meta->get_class_attribute($name)
 157             if $meta->can('has_class_attribute')
 158             && $meta->has_class_attribute($name);
 159     }
 160
 161     return;
 162 }
 163
 164 sub _class_attribute_values_hashref {
 165     my $self = shift;
 166
 167     no strict 'refs';
 168     return \%{ $self->_class_attribute_var_name() };
 169 }
 170
 171 sub _class_attribute_var_name {
 172     my $self = shift;
 173
 174     return $self->name() . q'::__ClassAttributeValues';
 175 }
 176
 177 sub _inline_class_slot_access {
 178     my $self = shift;
 179     my $name = shift;
 180
 181     return
 182           '$'
 183         . $self->_class_attribute_var_name . '{"'
 184         . quotemeta($name) . '"}';
 185 }
 186
 187 sub _inline_get_class_slot_value {
 188     my $self = shift;
 189     my $name = shift;
 190
 191     return $self->_inline_class_slot_access($name);
 192 }
 193
 194 sub _inline_set_class_slot_value {
 195     my $self     = shift;
 196     my $name     = shift;
 197     my $val_name = shift;
 198
 199     return $self->_inline_class_slot_access($name) . ' = ' . $val_name;
 200 }
 201
 202 sub _inline_is_class_slot_initialized {
 203     my $self = shift;
 204     my $name = shift;
 205
 206     return 'exists ' . $self->_inline_class_slot_access($name);
 207 }
 208
 209 sub _inline_deinitialize_class_slot {
 210     my $self = shift;
 211     my $name = shift;
 212
 213     return 'delete ' . $self->_inline_class_slot_access($name);
 214 }
 215
 216 sub _inline_weaken_class_slot_value {
 217     my $self = shift;
 218     my $name = shift;
 219
 220     return
 221         'Scalar::Util::weaken( '
 222         . $self->_inline_class_slot_access($name) . ')';
 223 }
 224
 225 1;
 226
 227 # ABSTRACT: A trait for classes with class attributes
 228
 229 __END__
 230
 231 =pod
 232
 233 =head1 SYNOPSIS
 234
 235   for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
 236   {
 237       print $attr->name();
 238   }
 239
 240 =head1 DESCRIPTION
 241
 242 This role adds awareness of class attributes to a metaclass object. It
 243 provides a set of introspection methods that largely parallel the
 244 existing attribute methods, except they operate on class attributes.
 245
 246 =head1 METHODS
 247
 248 Every method provided by this role has an analogous method in
 249 C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
 250
 251 =head2 $meta->has_class_attribute($name)
 252
 253 =head2 $meta->get_class_attribute($name)
 254
 255 =head2 $meta->get_class_attribute_list()
 256
 257 These methods operate on the current metaclass only.
 258
 259 =head2 $meta->add_class_attribute(...)
 260
 261 This accepts the same options as the L<Moose::Meta::Attribute>
 262 C<add_attribute()> method. However, if an attribute is specified as
 263 "required" an error will be thrown.
 264
 265 =head2 $meta->remove_class_attribute($name)
 266
 267 If the named class attribute exists, it is removed from the class,
 268 along with its accessor methods.
 269
 270 =head2 $meta->get_all_class_attributes()
 271
 272 This method returns a list of attribute objects for the class and all
 273 its parent classes.
 274
 275 =head2 $meta->find_class_attribute_by_name($name)
 276
 277 This method looks at the class and all its parent classes for the
 278 named class attribute.
 279
 280 =head2 $meta->get_class_attribute_value($name)
 281
 282 =head2 $meta->set_class_attribute_value($name, $value)
 283
 284 =head2 $meta->set_class_attribute_value($name)
 285
 286 =head2 $meta->clear_class_attribute_value($name)
 287
 288 These methods operate on the storage for class attribute values, which
 289 is attached to the metaclass object.
 290
 291 There's really no good reason for you to call these methods unless
 292 you're doing some deep hacking. They are named as public methods
 293 solely because they are used by other meta roles and classes in this
 294 distribution.
 295
 296 =head1 BUGS
 297
 298 See L<MooseX::ClassAttribute> for details.
 299
 300 =cut