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