X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FClassAttribute%2FRole%2FMeta%2FClass.pm;h=8ec293b4e75d3bacd1b8718eee51ecf757a73ddd;hb=ad109c62903c1bf4d05c93b57c059a1392e1d8b5;hp=e486b00c4c0f212b5011997e8b57708c9eb4251d;hpb=bb70fe3ad64b3a6061784a338ead11df88eb9367;p=gitmo%2FMooseX-ClassAttribute.git diff --git a/lib/MooseX/ClassAttribute/Role/Meta/Class.pm b/lib/MooseX/ClassAttribute/Role/Meta/Class.pm index e486b00..8ec293b 100644 --- a/lib/MooseX/ClassAttribute/Role/Meta/Class.pm +++ b/lib/MooseX/ClassAttribute/Role/Meta/Class.pm @@ -3,210 +3,196 @@ package MooseX::ClassAttribute::Role::Meta::Class; use strict; use warnings; -use MooseX::AttributeHelpers; +use MooseX::ClassAttribute::Role::Meta::Attribute; use Scalar::Util qw( blessed ); +use namespace::autoclean; use Moose::Role; - -has class_attribute_map => - ( metaclass => 'Collection::Hash', - is => 'ro', - isa => 'HashRef[MooseX::ClassAttribute::Meta::Attribute]', - provides => { set => '_add_class_attribute', - exists => 'has_class_attribute', - get => 'get_class_attribute', - delete => '_remove_class_attribute', - keys => 'get_class_attribute_list', - }, - default => sub { {} }, - reader => 'get_class_attribute_map', - ); - -has _class_attribute_values => - ( metaclass => 'Collection::Hash', - is => 'ro', - isa => 'HashRef', - provides => { get => 'get_class_attribute_value', - set => 'set_class_attribute_value', - exists => 'has_class_attribute_value', - delete => 'clear_class_attribute_value', - }, - lazy => 1, - default => sub { $_[0]->_class_attribute_values_hashref() }, - ); - - -sub add_class_attribute -{ +with 'MooseX::ClassAttribute::Role::Meta::Mixin::HasClassAttributes'; + +has _class_attribute_values => ( + traits => ['Hash'], + is => 'ro', + isa => 'HashRef', + handles => { + 'get_class_attribute_value' => 'get', + 'set_class_attribute_value' => 'set', + 'has_class_attribute_value' => 'exists', + 'clear_class_attribute_value' => 'delete', + }, + lazy => 1, + default => sub { $_[0]->_class_attribute_values_hashref() }, + init_arg => undef, +); + +around add_class_attribute => sub { + my $orig = shift; my $self = shift; - - my $attr = + my $attr = ( blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') ? $_[0] - : $self->_process_class_attribute(@_); + : $self->_process_class_attribute(@_) + ); - my $name = $attr->name(); + $self->$orig($attr); - $self->remove_class_attribute($name) - if $self->has_class_attribute($name); + return $attr; +}; - $attr->attach_to_class($self); +sub _post_add_class_attribute { + my $self = shift; + my $attr = shift; - $self->_add_class_attribute( $name => $attr ); + my $name = $attr->name(); - my $e = do { local $@; eval { $attr->install_accessors() }; $@ }; + my $e = do { + local $@; + eval { $attr->install_accessors() }; + $@; + }; - if ( $e ) - { + if ($e) { $self->remove_attribute($name); die $e; } +} - return $attr; +sub _attach_class_attribute { + my ($self, $attribute) = @_; + $attribute->attach_to_class($self); } # It'd be nice if I didn't have to replicate this for class # attributes, since it's basically just a copy of # Moose::Meta::Class->_process_attribute -sub _process_class_attribute -{ +sub _process_class_attribute { my $self = shift; my $name = shift; my @args = @_; - @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH'; + @args = %{ $args[0] } if scalar @args == 1 && ref( $args[0] ) eq 'HASH'; - if ($name =~ /^\+(.*)/) - { + if ( $name =~ /^\+(.*)/ ) { return $self->_process_inherited_class_attribute( $1, @args ); } - else - { + else { return $self->_process_new_class_attribute( $name, @args ); } } -sub _process_new_class_attribute -{ +sub _process_new_class_attribute { my $self = shift; my $name = shift; my %p = @_; - if ( $p{metaclass} ) - { - $p{metaclass} = - Moose::Meta::Class->create_anon_class - ( superclasses => [ 'MooseX::ClassAttribute::Meta::Attribute', $p{metaclass} ], - cache => 1, - )->name(); + if ( $p{traits} ) { + push @{ $p{traits} }, 'MooseX::ClassAttribute::Role::Meta::Attribute'; } - else - { - $p{metaclass} = 'MooseX::ClassAttribute::Meta::Attribute'; + else { + $p{traits} = ['MooseX::ClassAttribute::Role::Meta::Attribute']; } return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p ); } -sub _process_inherited_class_attribute -{ +sub _process_inherited_class_attribute { my $self = shift; my $name = shift; my %p = @_; my $inherited_attr = $self->find_class_attribute_by_name($name); - (defined $inherited_attr) - || confess "Could not find an attribute by the name of '$name' to inherit from"; + ( defined $inherited_attr ) + || confess + "Could not find an attribute by the name of '$name' to inherit from"; return $inherited_attr->clone_and_inherit_options(%p); } -sub remove_class_attribute -{ +around remove_class_attribute => sub { + my $orig = shift; my $self = shift; - my $name = shift; - - (defined $name && $name) - || confess 'You must provide an attribute name'; - my $removed_attr = $self->get_class_attribute($name); - return unless $removed_attr; - - $self->_remove_class_attribute($name); + my $removed_attr = $self->$orig(@_) + or return; $removed_attr->remove_accessors(); $removed_attr->detach_from_class(); return $removed_attr; -} - -sub get_all_class_attributes -{ - shift->compute_all_applicable_class_attributes(@_); -} +}; -sub compute_all_applicable_class_attributes -{ +sub get_all_class_attributes { my $self = shift; - my %attrs = - map { %{ Class::MOP::Class->initialize($_)->get_class_attribute_map } } + my %attrs + = map { + my $meta = Class::MOP::class_of($_); + $meta && $meta->can('get_class_attribute_map') + ? %{ $meta->get_class_attribute_map() } + : () + } reverse $self->linearized_isa; return values %attrs; } -sub find_class_attribute_by_name -{ +sub compute_all_applicable_class_attributes { + warn + 'The compute_all_applicable_class_attributes method has been deprecated.' + . " Use get_all_class_attributes instead.\n"; + + shift->compute_all_applicable_class_attributes(@_); +} + +sub find_class_attribute_by_name { my $self = shift; my $name = shift; - foreach my $class ( $self->linearized_isa() ) - { - my $meta = Class::MOP::Class->initialize($class); + foreach my $class ( $self->linearized_isa() ) { + my $meta = Class::MOP::class_of($class) + or next; return $meta->get_class_attribute($name) - if $meta->has_class_attribute($name); + if $meta->can('has_class_attribute') + && $meta->has_class_attribute($name); } return; } -sub _class_attribute_values_hashref -{ +sub _class_attribute_values_hashref { my $self = shift; no strict 'refs'; return \%{ $self->_class_attribute_var_name() }; } -sub _class_attribute_var_name -{ +sub _class_attribute_var_name { my $self = shift; return $self->name() . q'::__ClassAttributeValues'; } -sub inline_class_slot_access -{ +sub inline_class_slot_access { my $self = shift; my $name = shift; - return '$' . $self->_class_attribute_var_name . '{' . $name . '}'; + return + '$' + . $self->_class_attribute_var_name . '{"' + . quotemeta($name) . '"}'; } -sub inline_get_class_slot_value -{ +sub inline_get_class_slot_value { my $self = shift; my $name = shift; return $self->inline_class_slot_access($name); } -sub inline_set_class_slot_value -{ +sub inline_set_class_slot_value { my $self = shift; my $name = shift; my $val_name = shift; @@ -214,30 +200,136 @@ sub inline_set_class_slot_value return $self->inline_class_slot_access($name) . ' = ' . $val_name; } -sub inline_is_class_slot_initialized -{ - my $self = shift; - my $name = shift; +sub inline_is_class_slot_initialized { + my $self = shift; + my $name = shift; return 'exists ' . $self->inline_class_slot_access($name); } -sub inline_deinitialize_class_slot -{ - my $self = shift; - my $name = shift; +sub inline_deinitialize_class_slot { + my $self = shift; + my $name = shift; return 'delete ' . $self->inline_class_slot_access($name); } -sub inline_weaken_class_slot_value -{ - my $self = shift; - my $name = shift; +sub inline_weaken_class_slot_value { + my $self = shift; + my $name = shift; - return 'Scalar::Util::weaken( ' . $self->inline_class_slot_access($name) . ')'; + return + 'Scalar::Util::weaken( ' + . $self->inline_class_slot_access($name) . ')'; } -no Moose::Role; - 1; + +__END__ + +=pod + +=head1 NAME + +MooseX::ClassAttribute::Role::Meta::Class - A metaclass role for classes with class attributes + +=head1 SYNOPSIS + + for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() ) + { + print $attr->name(); + } + +=head1 DESCRIPTION + +This role adds awareness of class attributes to a metaclass object. It +provides a set of introspection methods that largely parallel the +existing attribute methods, except they operate on class attributes. + +=head1 METHODS + +Every method provided by this role has an analogous method in +C or C for regular attributes. + +=head2 $meta->has_class_attribute($name) + +=head2 $meta->get_class_attribute($name) + +=head2 $meta->get_class_attribute_list() + +=head2 $meta->get_class_attribute_map() + +These methods operate on the current metaclass only. + +=head2 $meta->add_class_attribute(...) + +This accepts the same options as the L +C method. However, if an attribute is specified as +"required" an error will be thrown. + +=head2 $meta->remove_class_attribute($name) + +If the named class attribute exists, it is removed from the class, +along with its accessor methods. + +=head2 $meta->get_all_class_attributes() + +This method returns a list of attribute objects for the class and all +its parent classes. + +=head2 $meta->find_class_attribute_by_name($name) + +This method looks at the class and all its parent classes for the +named class attribute. + +=head2 $meta->get_class_attribute_value($name) + +=head2 $meta->set_class_attribute_value($name, $value) + +=head2 $meta->set_class_attribute_value($name) + +=head2 $meta->clear_class_attribute_value($name) + +These methods operate on the storage for class attribute values, which +is attached to the metaclass object. + +There's really no good reason for you to call these methods unless +you're doing some deep hacking. They are named as public methods +solely because they are used by other meta roles and classes in this +distribution. + +=head2 inline_class_slot_access($name) + +=head2 inline_get_class_slot_value($name) + +=head2 inline_set_class_slot_value($name, $val_name) + +=head2 inline_is_class_slot_initialized($name) + +=head2 inline_deinitialize_class_slot($name) + +=head2 inline_weaken_class_slot_value($name) + +These methods return code snippets for inlining. + +There's really no good reason for you to call these methods unless +you're doing some deep hacking. They are named as public methods +solely because they are used by other meta roles and classes in this +distribution. + +=head1 AUTHOR + +Dave Rolsky, C<< >> + +=head1 BUGS + +See L for details. + +=head1 COPYRIGHT & LICENSE + +Copyright 2007-2008 Dave Rolsky, All Rights Reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut