lib/MooseX/ClassAttribute/Trait/Class.pm

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