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