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 MooseX::ClassAttribute::Role::Meta::Attribute;
   8 use Scalar::Util qw( blessed );
   9
  10 use Moose::Role;
  11
  12
  13 has class_attribute_map =>
  14     ( metaclass => 'Collection::Hash',
  15       is        => 'ro',
  16       isa       => 'HashRef[Moose::Meta::Attribute]',
  17       provides  => { set    => '_add_class_attribute',
  18                      exists => 'has_class_attribute',
  19                      get    => 'get_class_attribute',
  20                      delete => '_remove_class_attribute',
  21                      keys   => 'get_class_attribute_list',
  22                    },
  23       default   => sub { {} },
  24       reader    => 'get_class_attribute_map',
  25     );
  26
  27 has _class_attribute_values =>
  28     ( metaclass => 'Collection::Hash',
  29       is        => 'ro',
  30       isa       => 'HashRef',
  31       provides  => { get    => 'get_class_attribute_value',
  32                      set    => 'set_class_attribute_value',
  33                      exists => 'has_class_attribute_value',
  34                      delete => 'clear_class_attribute_value',
  35                    },
  36       lazy      => 1,
  37       default   => sub { $_[0]->_class_attribute_values_hashref() },
  38     );
  39
  40
  41 sub add_class_attribute
  42 {
  43     my $self = shift;
  44
  45     my $attr =
  46         blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
  47         ? $_[0]
  48         : $self->_process_class_attribute(@_);
  49
  50     my $name = $attr->name();
  51
  52     $self->remove_class_attribute($name)
  53         if $self->has_class_attribute($name);
  54
  55     $attr->attach_to_class($self);
  56
  57     $self->_add_class_attribute( $name => $attr );
  58
  59     my $e = do { local $@; eval { $attr->install_accessors() }; $@ };
  60
  61     if ( $e )
  62     {
  63         $self->remove_attribute($name);
  64         die $e;
  65     }
  66
  67     return $attr;
  68 }
  69
  70 # It'd be nice if I didn't have to replicate this for class
  71 # attributes, since it's basically just a copy of
  72 # Moose::Meta::Class->_process_attribute
  73 sub _process_class_attribute
  74 {
  75     my $self = shift;
  76     my $name = shift;
  77     my @args = @_;
  78
  79     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
  80
  81     if ($name =~ /^\+(.*)/)
  82     {
  83         return $self->_process_inherited_class_attribute( $1, @args );
  84     }
  85     else
  86     {
  87         return $self->_process_new_class_attribute( $name, @args );
  88     }
  89 }
  90
  91 sub _process_new_class_attribute
  92 {
  93     my $self = shift;
  94     my $name = shift;
  95     my %p    = @_;
  96
  97     if ( $p{traits} )
  98     {
  99         push @{ $p{traits} },'MooseX::ClassAttribute::Role::Meta::Attribute'
 100     }
 101     else
 102     {
 103         $p{traits} = [ 'MooseX::ClassAttribute::Role::Meta::Attribute' ];
 104     }
 105
 106     return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
 107 }
 108
 109 sub _process_inherited_class_attribute
 110 {
 111     my $self = shift;
 112     my $name = shift;
 113     my %p    = @_;
 114
 115     my $inherited_attr = $self->find_class_attribute_by_name($name);
 116
 117     (defined $inherited_attr)
 118         || confess "Could not find an attribute by the name of '$name' to inherit from";
 119
 120     return $inherited_attr->clone_and_inherit_options(%p);
 121 }
 122
 123 sub remove_class_attribute
 124 {
 125     my $self = shift;
 126     my $name = shift;
 127
 128     (defined $name && $name)
 129         || confess 'You must provide an attribute name';
 130
 131     my $removed_attr = $self->get_class_attribute($name);
 132     return unless $removed_attr;
 133
 134     $self->_remove_class_attribute($name);
 135
 136     $removed_attr->remove_accessors();
 137     $removed_attr->detach_from_class();
 138
 139     return $removed_attr;
 140 }
 141
 142 sub get_all_class_attributes
 143 {
 144     shift->compute_all_applicable_class_attributes(@_);
 145 }
 146
 147 sub compute_all_applicable_class_attributes
 148 {
 149     my $self = shift;
 150
 151     my %attrs =
 152         map { my $meta = Class::MOP::Class->initialize($_);
 153               $meta->can('get_class_attribute_map')
 154               ? %{ $meta->get_class_attribute_map() }
 155               : ()
 156             }
 157         reverse $self->linearized_isa;
 158
 159     return values %attrs;
 160 }
 161
 162 sub find_class_attribute_by_name
 163 {
 164     my $self = shift;
 165     my $name = shift;
 166
 167     foreach my $class ( $self->linearized_isa() )
 168     {
 169         my $meta = Class::MOP::Class->initialize($class);
 170
 171         return $meta->get_class_attribute($name)
 172             if $meta->can('has_class_attribute') && $meta->has_class_attribute($name);
 173     }
 174
 175     return;
 176 }
 177
 178 sub _class_attribute_values_hashref
 179 {
 180     my $self = shift;
 181
 182     no strict 'refs';
 183     return \%{ $self->_class_attribute_var_name() };
 184 }
 185
 186 sub _class_attribute_var_name
 187 {
 188     my $self = shift;
 189
 190     return $self->name() . q'::__ClassAttributeValues';
 191 }
 192
 193 sub inline_class_slot_access
 194 {
 195     my $self = shift;
 196     my $name = shift;
 197
 198     return '$' . $self->_class_attribute_var_name . '{' . $name . '}';
 199 }
 200
 201 sub inline_get_class_slot_value
 202 {
 203     my $self = shift;
 204     my $name = shift;
 205
 206     return $self->inline_class_slot_access($name);
 207 }
 208
 209 sub inline_set_class_slot_value
 210 {
 211     my $self     = shift;
 212     my $name     = shift;
 213     my $val_name = shift;
 214
 215     return $self->inline_class_slot_access($name) . ' = ' . $val_name;
 216 }
 217
 218 sub inline_is_class_slot_initialized
 219 {
 220     my $self     = shift;
 221     my $name     = shift;
 222
 223     return 'exists ' . $self->inline_class_slot_access($name);
 224 }
 225
 226 sub inline_deinitialize_class_slot
 227 {
 228     my $self     = shift;
 229     my $name     = shift;
 230
 231     return 'delete ' . $self->inline_class_slot_access($name);
 232 }
 233
 234 sub inline_weaken_class_slot_value
 235 {
 236     my $self     = shift;
 237     my $name     = shift;
 238
 239     return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')';
 240 }
 241
 242 no Moose::Role;
 243
 244 1;
 245
 246 __END__
 247
 248 =pod
 249
 250 =head1 NAME
 251
 252 MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes
 253
 254 =head1 SYNOPSIS
 255
 256   for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
 257   {
 258       print $attr->name();
 259   }
 260
 261 =head1 DESCRIPTION
 262
 263 This role adds awareness of class attributes to a metaclass object. It
 264 provides a set of introspection methods that largely parallel the
 265 existing attribute methods, except they operate on class attributes.
 266
 267 =head1 METHODS
 268
 269 Every method provided by this role has an analogous method in
 270 C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
 271
 272 =head2 $meta->has_class_attribute($name)
 273
 274 =head2 $meta->get_class_attribute($name)
 275
 276 =head2 $meta->get_class_attribute_list()
 277
 278 =head2 $meta->get_class_attribute_map()
 279
 280 These methods operate on the current metaclass only.
 281
 282 =head2 $meta->add_class_attribute(...)
 283
 284 This accepts the same options as the L<Moose::Meta::Attribute>
 285 C<add_attribute()> method. However, if an attribute is specified as
 286 "required" an error will be thrown.
 287
 288 =head2 $meta->remove_class_attribute($name)
 289
 290 If the named class attribute exists, it is removed from the class,
 291 along with its accessor methods.
 292
 293 =head2 $meta->get_all_class_attributes()
 294
 295 =head2 $meta->compute_all_applicable_class_attributes()
 296
 297 These methods return a list of attribute objects for the class and all
 298 its parent classes.
 299
 300 =head2 $meta->find_class_attribute_by_name($name)
 301
 302 This method looks at the class and all its parent classes for the
 303 named class attribute.
 304
 305 =head2 $meta->get_class_attribute_value($name)
 306
 307 =head2 $meta->set_class_attribute_value($name, $value)
 308
 309 =head2 $meta->set_class_attribute_value($name)
 310
 311 =head2 $meta->clear_class_attribute_value($name)
 312
 313 These methods operate on the storage for class attribute values, which
 314 is attached to the metaclass object.
 315
 316 There's really no good reason for you to call these methods unless
 317 you're doing some deep hacking. They are named as public methods
 318 solely because they are used by other meta roles and classes in this
 319 distribution.
 320
 321 =head2 inline_class_slot_access($name)
 322
 323 =head2 inline_get_class_slot_value($name)
 324
 325 =head2 inline_set_class_slot_value($name, $val_name)
 326
 327 =head2 inline_is_class_slot_initialized($name)
 328
 329 =head2 inline_deinitialize_class_slot($name)
 330
 331 =head2 inline_weaken_class_slot_value($name)
 332
 333 These methods return code snippets for inlining.
 334
 335 There's really no good reason for you to call these methods unless
 336 you're doing some deep hacking. They are named as public methods
 337 solely because they are used by other meta roles and classes in this
 338 distribution.
 339
 340 =head1 AUTHOR
 341
 342 Dave Rolsky, C<< <autarch@urth.org> >>
 343
 344 =head1 BUGS
 345
 346 See L<MooseX::ClassAttribute> for details.
 347
 348 =head1 COPYRIGHT & LICENSE
 349
 350 Copyright 2007-2008 Dave Rolsky, All Rights Reserved.
 351
 352 This program is free software; you can redistribute it and/or modify
 353 it under the same terms as Perl itself.
 354
 355 =cut