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