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