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::ClassAttribute::Role::Meta::Attribute;
   7 use Scalar::Util qw( blessed );
   8
   9 use namespace::autoclean;
  10 use Moose::Role;
  11
  12 with 'MooseX::ClassAttribute::Role::Meta::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 sub add_class_attribute {
  30     my $self = shift;
  31
  32     my $attr
  33         = blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
  34         ? $_[0]
  35         : $self->_process_class_attribute(@_);
  36
  37     my $name = $attr->name();
  38
  39     $self->remove_class_attribute($name)
  40         if $self->has_class_attribute($name);
  41
  42     $attr->attach_to_class($self);
  43
  44     $self->_add_class_attribute( $name => $attr );
  45
  46     my $e = do {
  47         local $@;
  48         eval { $attr->install_accessors() };
  49         $@;
  50     };
  51
  52     if ($e) {
  53         $self->remove_attribute($name);
  54         die $e;
  55     }
  56
  57     return $attr;
  58 }
  59
  60 # It'd be nice if I didn't have to replicate this for class
  61 # attributes, since it's basically just a copy of
  62 # Moose::Meta::Class->_process_attribute
  63 sub _process_class_attribute {
  64     my $self = shift;
  65     my $name = shift;
  66     my @args = @_;
  67
  68     @args = %{ $args[0] } if scalar @args == 1 && ref( $args[0] ) eq 'HASH';
  69
  70     if ( $name =~ /^\+(.*)/ ) {
  71         return $self->_process_inherited_class_attribute( $1, @args );
  72     }
  73     else {
  74         return $self->_process_new_class_attribute( $name, @args );
  75     }
  76 }
  77
  78 sub _process_new_class_attribute {
  79     my $self = shift;
  80     my $name = shift;
  81     my %p    = @_;
  82
  83     if ( $p{traits} ) {
  84         push @{ $p{traits} }, 'MooseX::ClassAttribute::Role::Meta::Attribute';
  85     }
  86     else {
  87         $p{traits} = ['MooseX::ClassAttribute::Role::Meta::Attribute'];
  88     }
  89
  90     return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
  91 }
  92
  93 sub _process_inherited_class_attribute {
  94     my $self = shift;
  95     my $name = shift;
  96     my %p    = @_;
  97
  98     my $inherited_attr = $self->find_class_attribute_by_name($name);
  99
 100     ( defined $inherited_attr )
 101         || confess
 102         "Could not find an attribute by the name of '$name' to inherit from";
 103
 104     return $inherited_attr->clone_and_inherit_options(%p);
 105 }
 106
 107 sub remove_class_attribute {
 108     my $self = shift;
 109     my $name = shift;
 110
 111     ( defined $name && $name )
 112         || confess 'You must provide an attribute name';
 113
 114     my $removed_attr = $self->get_class_attribute($name);
 115     return unless $removed_attr;
 116
 117     $self->_remove_class_attribute($name);
 118
 119     $removed_attr->remove_accessors();
 120     $removed_attr->detach_from_class();
 121
 122     return $removed_attr;
 123 }
 124
 125 sub get_all_class_attributes {
 126     my $self = shift;
 127
 128     my %attrs
 129         = map {
 130         my $meta = Class::MOP::class_of($_);
 131         $meta && $meta->can('get_class_attribute_map')
 132             ? %{ $meta->get_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 __END__
 228
 229 =pod
 230
 231 =head1 NAME
 232
 233 MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes
 234
 235 =head1 SYNOPSIS
 236
 237   for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
 238   {
 239       print $attr->name();
 240   }
 241
 242 =head1 DESCRIPTION
 243
 244 This role adds awareness of class attributes to a metaclass object. It
 245 provides a set of introspection methods that largely parallel the
 246 existing attribute methods, except they operate on class attributes.
 247
 248 =head1 METHODS
 249
 250 Every method provided by this role has an analogous method in
 251 C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
 252
 253 =head2 $meta->has_class_attribute($name)
 254
 255 =head2 $meta->get_class_attribute($name)
 256
 257 =head2 $meta->get_class_attribute_list()
 258
 259 =head2 $meta->get_class_attribute_map()
 260
 261 These methods operate on the current metaclass only.
 262
 263 =head2 $meta->add_class_attribute(...)
 264
 265 This accepts the same options as the L<Moose::Meta::Attribute>
 266 C<add_attribute()> method. However, if an attribute is specified as
 267 "required" an error will be thrown.
 268
 269 =head2 $meta->remove_class_attribute($name)
 270
 271 If the named class attribute exists, it is removed from the class,
 272 along with its accessor methods.
 273
 274 =head2 $meta->get_all_class_attributes()
 275
 276 This method returns a list of attribute objects for the class and all
 277 its parent classes.
 278
 279 =head2 $meta->find_class_attribute_by_name($name)
 280
 281 This method looks at the class and all its parent classes for the
 282 named class attribute.
 283
 284 =head2 $meta->get_class_attribute_value($name)
 285
 286 =head2 $meta->set_class_attribute_value($name, $value)
 287
 288 =head2 $meta->set_class_attribute_value($name)
 289
 290 =head2 $meta->clear_class_attribute_value($name)
 291
 292 These methods operate on the storage for class attribute values, which
 293 is attached to the metaclass object.
 294
 295 There's really no good reason for you to call these methods unless
 296 you're doing some deep hacking. They are named as public methods
 297 solely because they are used by other meta roles and classes in this
 298 distribution.
 299
 300 =head2 inline_class_slot_access($name)
 301
 302 =head2 inline_get_class_slot_value($name)
 303
 304 =head2 inline_set_class_slot_value($name, $val_name)
 305
 306 =head2 inline_is_class_slot_initialized($name)
 307
 308 =head2 inline_deinitialize_class_slot($name)
 309
 310 =head2 inline_weaken_class_slot_value($name)
 311
 312 These methods return code snippets for inlining.
 313
 314 There's really no good reason for you to call these methods unless
 315 you're doing some deep hacking. They are named as public methods
 316 solely because they are used by other meta roles and classes in this
 317 distribution.
 318
 319 =head1 AUTHOR
 320
 321 Dave Rolsky, C<< <autarch@urth.org> >>
 322
 323 =head1 BUGS
 324
 325 See L<MooseX::ClassAttribute> for details.
 326
 327 =head1 COPYRIGHT & LICENSE
 328
 329 Copyright 2007-2008 Dave Rolsky, All Rights Reserved.
 330
 331 This program is free software; you can redistribute it and/or modify
 332 it under the same terms as Perl itself.
 333
 334 =cut