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     my $self = shift;
 145
 146     my %attrs =
 147         map { my $meta = Class::MOP::class_of($_);
 148               $meta && $meta->can('get_class_attribute_map')
 149               ? %{ $meta->get_class_attribute_map() }
 150               : ()
 151             }
 152         reverse $self->linearized_isa;
 153
 154     return values %attrs;
 155 }
 156
 157 sub compute_all_applicable_class_attributes
 158 {
 159     warn 'The compute_all_applicable_class_attributes method has been deprecated.'
 160         . " Use get_all_class_attributes instead.\n";
 161
 162     shift->compute_all_applicable_class_attributes(@_);
 163 }
 164
 165 sub find_class_attribute_by_name
 166 {
 167     my $self = shift;
 168     my $name = shift;
 169
 170     foreach my $class ( $self->linearized_isa() )
 171     {
 172         my $meta = Class::MOP::class_of($class)
 173             or next;
 174
 175         return $meta->get_class_attribute($name)
 176             if $meta->can('has_class_attribute') && $meta->has_class_attribute($name);
 177     }
 178
 179     return;
 180 }
 181
 182 sub _class_attribute_values_hashref
 183 {
 184     my $self = shift;
 185
 186     no strict 'refs';
 187     return \%{ $self->_class_attribute_var_name() };
 188 }
 189
 190 sub _class_attribute_var_name
 191 {
 192     my $self = shift;
 193
 194     return $self->name() . q'::__ClassAttributeValues';
 195 }
 196
 197 sub inline_class_slot_access
 198 {
 199     my $self = shift;
 200     my $name = shift;
 201
 202     return '$' . $self->_class_attribute_var_name . '{"' . quotemeta($name) . '"}';
 203 }
 204
 205 sub inline_get_class_slot_value
 206 {
 207     my $self = shift;
 208     my $name = shift;
 209
 210     return $self->inline_class_slot_access($name);
 211 }
 212
 213 sub inline_set_class_slot_value
 214 {
 215     my $self     = shift;
 216     my $name     = shift;
 217     my $val_name = shift;
 218
 219     return $self->inline_class_slot_access($name) . ' = ' . $val_name;
 220 }
 221
 222 sub inline_is_class_slot_initialized
 223 {
 224     my $self     = shift;
 225     my $name     = shift;
 226
 227     return 'exists ' . $self->inline_class_slot_access($name);
 228 }
 229
 230 sub inline_deinitialize_class_slot
 231 {
 232     my $self     = shift;
 233     my $name     = shift;
 234
 235     return 'delete ' . $self->inline_class_slot_access($name);
 236 }
 237
 238 sub inline_weaken_class_slot_value
 239 {
 240     my $self     = shift;
 241     my $name     = shift;
 242
 243     return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')';
 244 }
 245
 246 no Moose::Role;
 247
 248 1;
 249
 250 __END__
 251
 252 =pod
 253
 254 =head1 NAME
 255
 256 MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes
 257
 258 =head1 SYNOPSIS
 259
 260   for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
 261   {
 262       print $attr->name();
 263   }
 264
 265 =head1 DESCRIPTION
 266
 267 This role adds awareness of class attributes to a metaclass object. It
 268 provides a set of introspection methods that largely parallel the
 269 existing attribute methods, except they operate on class attributes.
 270
 271 =head1 METHODS
 272
 273 Every method provided by this role has an analogous method in
 274 C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
 275
 276 =head2 $meta->has_class_attribute($name)
 277
 278 =head2 $meta->get_class_attribute($name)
 279
 280 =head2 $meta->get_class_attribute_list()
 281
 282 =head2 $meta->get_class_attribute_map()
 283
 284 These methods operate on the current metaclass only.
 285
 286 =head2 $meta->add_class_attribute(...)
 287
 288 This accepts the same options as the L<Moose::Meta::Attribute>
 289 C<add_attribute()> method. However, if an attribute is specified as
 290 "required" an error will be thrown.
 291
 292 =head2 $meta->remove_class_attribute($name)
 293
 294 If the named class attribute exists, it is removed from the class,
 295 along with its accessor methods.
 296
 297 =head2 $meta->get_all_class_attributes()
 298
 299 This method returns a list of attribute objects for the class and all
 300 its parent classes.
 301
 302 =head2 $meta->find_class_attribute_by_name($name)
 303
 304 This method looks at the class and all its parent classes for the
 305 named class attribute.
 306
 307 =head2 $meta->get_class_attribute_value($name)
 308
 309 =head2 $meta->set_class_attribute_value($name, $value)
 310
 311 =head2 $meta->set_class_attribute_value($name)
 312
 313 =head2 $meta->clear_class_attribute_value($name)
 314
 315 These methods operate on the storage for class attribute values, which
 316 is attached to the metaclass object.
 317
 318 There's really no good reason for you to call these methods unless
 319 you're doing some deep hacking. They are named as public methods
 320 solely because they are used by other meta roles and classes in this
 321 distribution.
 322
 323 =head2 inline_class_slot_access($name)
 324
 325 =head2 inline_get_class_slot_value($name)
 326
 327 =head2 inline_set_class_slot_value($name, $val_name)
 328
 329 =head2 inline_is_class_slot_initialized($name)
 330
 331 =head2 inline_deinitialize_class_slot($name)
 332
 333 =head2 inline_weaken_class_slot_value($name)
 334
 335 These methods return code snippets for inlining.
 336
 337 There's really no good reason for you to call these methods unless
 338 you're doing some deep hacking. They are named as public methods
 339 solely because they are used by other meta roles and classes in this
 340 distribution.
 341
 342 =head1 AUTHOR
 343
 344 Dave Rolsky, C<< <autarch@urth.org> >>
 345
 346 =head1 BUGS
 347
 348 See L<MooseX::ClassAttribute> for details.
 349
 350 =head1 COPYRIGHT & LICENSE
 351
 352 Copyright 2007-2008 Dave Rolsky, All Rights Reserved.
 353
 354 This program is free software; you can redistribute it and/or modify
 355 it under the same terms as Perl itself.
 356
 357 =cut