lib/MooseX/ClassAttribute/Trait/Class.pm

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