X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FMetaRole.pm;h=ca312c2d5a9f320b33c56d8ea401a4eda0492b67;hb=ae7820b1b884344a7ee90d94b484ca46459eb7b1;hp=9169727ae5de2c4683893bf668375f6710826d07;hpb=95056a1ecd68b4e3b63c08dfda4d3d10a8ba0e0f;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/MetaRole.pm b/lib/Moose/Util/MetaRole.pm index 9169727..ca312c2 100644 --- a/lib/Moose/Util/MetaRole.pm +++ b/lib/Moose/Util/MetaRole.pm @@ -2,92 +2,131 @@ package Moose::Util::MetaRole; use strict; use warnings; +use Scalar::Util 'blessed'; -our $VERSION = '0.89_01'; +our $VERSION = '1.06'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use List::MoreUtils qw( all ); - -my @Classes = qw( constructor_class destructor_class error_class ); +use List::Util qw( first ); sub apply_metaclass_roles { - my %options = @_; + goto &apply_metaroles; +} + +sub apply_metaroles { + my %args = @_; + + _fixup_old_style_args(\%args); + Carp::cluck('applying') if $::D; + my $for + = blessed $args{for} + ? $args{for} + : Class::MOP::class_of( $args{for} ); + + if ( $for->isa('Moose::Meta::Role') ) { + return _make_new_metaclass( $for, $args{role_metaroles}, 'role' ); + } + else { + return _make_new_metaclass( $for, $args{class_metaroles}, 'class' ); + } +} + +sub _fixup_old_style_args { + my $args = shift; + + return if $args->{class_metaroles} || $args->{roles_metaroles}; + + $args->{for} = delete $args->{for_class} + if exists $args->{for_class}; + + my @old_keys = qw( + attribute_metaclass_roles + method_metaclass_roles + wrapped_method_metaclass_roles + instance_metaclass_roles + constructor_class_roles + destructor_class_roles + error_class_roles - my $for = $options{for_class}; + application_to_class_class_roles + application_to_role_class_roles + application_to_instance_class_roles + application_role_summation_class_roles + ); + + my $for + = blessed $args->{for} + ? $args->{for} + : Class::MOP::class_of( $args->{for} ); + + my $top_key; + if ( $for->isa('Moose::Meta::Class') ) { + $top_key = 'class_metaroles'; - my %old_classes = map { $_ => Class::MOP::class_of($for)->$_ } - grep { Class::MOP::class_of($for)->can($_) } - @Classes; + $args->{class_metaroles}{class} = delete $args->{metaclass_roles} + if exists $args->{metaclass_roles}; + } + else { + $top_key = 'role_metaroles'; - my $meta = _make_new_metaclass( $for, \%options ); + $args->{role_metaroles}{role} = delete $args->{metaclass_roles} + if exists $args->{metaclass_roles}; + } - for my $c ( grep { $meta->can($_) } @Classes ) { - if ( $options{ $c . '_roles' } ) { - my $class = _make_new_class( - $meta->$c(), - $options{ $c . '_roles' } - ); + for my $old_key (@old_keys) { + my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/; - $meta->$c($class); - } - else { - $meta->$c( $old_classes{$c} ); - } + $args->{$top_key}{$new_key} = delete $args->{$old_key} + if exists $args->{$old_key}; } - return $meta; + return; } sub _make_new_metaclass { my $for = shift; - my $options = shift; - - return Class::MOP::class_of($for) - unless grep { exists $options->{ $_ . '_roles' } } - qw( - metaclass - attribute_metaclass - method_metaclass - wrapped_method_metaclass - instance_metaclass - application_to_class_class - application_to_role_class - application_to_instance_class - ); + my $roles = shift; + my $primary = shift; + + return $for unless keys %{$roles}; - my $old_meta = Class::MOP::class_of($for); my $new_metaclass - = _make_new_class( ref $old_meta, $options->{metaclass_roles} ); - - # This could get called for a Moose::Meta::Role as well as a Moose::Meta::Class - my %classes = map { - $_ => _make_new_class( $old_meta->$_(), $options->{ $_ . '_roles' } ) - } - grep { $old_meta->can($_) } - qw( - attribute_metaclass - method_metaclass - wrapped_method_metaclass - instance_metaclass - application_to_class_class - application_to_role_class - application_to_instance_class - ); + = exists $roles->{$primary} + ? _make_new_class( ref $for, $roles->{$primary} ) + : blessed $for; + + my %classes; + + for my $key ( grep { $_ ne $primary } keys %{$roles} ) { + my $attr = first {$_} + map { $for->meta->find_attribute_by_name($_) } ( + $key . '_metaclass', + $key . '_class' + ); + + my $reader = $attr->get_read_method; + + $classes{ $attr->init_arg } + = _make_new_class( $for->$reader(), $roles->{$key} ); + } + + my $new_meta = $new_metaclass->reinitialize( $for, %classes ); - return $new_metaclass->reinitialize( $for, %classes ); + return $new_meta; } sub apply_base_class_roles { - my %options = @_; + my %args = @_; - my $for = $options{for_class}; + my $for = $args{for} || $args{for_class}; my $meta = Class::MOP::class_of($for); my $new_base = _make_new_class( $for, - $options{roles}, + $args{roles}, [ $meta->superclasses() ], ); @@ -139,22 +178,24 @@ Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base sub init_meta { shift; - my %options = @_; + my %args = @_; - Moose->init_meta(%options); + Moose->init_meta(%args); - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => $options{for_class}, - metaclass_roles => ['MyApp::Role::Meta::Class'], - constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'], + Moose::Util::MetaRole::apply_metaroles( + for => $args{for_class}, + class_metaroles => { + class => => ['MyApp::Role::Meta::Class'], + constructor => ['MyApp::Role::Meta::Method::Constructor'], + }, ); Moose::Util::MetaRole::apply_base_class_roles( - for_class => $options{for_class}, - roles => ['MyApp::Role::Object'], + for => $args{for_class}, + roles => ['MyApp::Role::Object'], ); - return $options{for_class}->meta(); + return $args{for_class}->meta(); } =head1 DESCRIPTION @@ -185,47 +226,90 @@ method for you, and make sure it is called when imported. This module provides two functions. -=head2 apply_metaclass_roles( ... ) +=head2 apply_metaroles( ... ) + +This function will apply roles to one or more metaclasses for the specified +class. It will return a new metaclass object for the class or role passed in +the "for" parameter. -This function will apply roles to one or more metaclasses for the -specified class. It accepts the following parameters: +It accepts the following parameters: =over 4 -=item * for_class => $name +=item * for => $name + +This specifies the class or for which to alter the meta classes. This can be a +package name, or an appropriate meta-object (a L or +L). + +=item * class_metaroles => \%roles + +This is a hash reference specifying which metaroles will be applied to the +class metaclass and its contained metaclasses and helper classes. + +Each key should in turn point to an array reference of role names. + +It accepts the following keys: + +=over 8 + +=item class + +=item attribute + +=item method -This specifies the class for which to alter the meta classes. +=item wrapped_method -=item * metaclass_roles => \@roles +=item instance -=item * attribute_metaclass_roles => \@roles +=item constructor -=item * method_metaclass_roles => \@roles +=item destructor -=item * wrapped_method_metaclass_roles => \@roles +=item error -=item * instance_metaclass_roles => \@roles +=back + +=item * role_metaroles => \%roles + +This is a hash reference specifying which metaroles will be applied to the +role metaclass and its contained metaclasses and helper classes. + +It accepts the following keys: + +=over 8 + +=item role -=item * constructor_class_roles => \@roles +=item attribute -=item * destructor_class_roles => \@roles +=item method -=item * application_to_class_class_roles => \@roles +=item required_method -=item * application_to_role_class_roles => \@roles +=item conflicting_method -=item * application_to_instance_class_roles => \@roles +=item application_to_class -These parameter all specify one or more roles to be applied to the -specified metaclass. You can pass any or all of these parameters at -once. +=item application_to_role + +=item application_to_instance + +=item application_role_summation + +=back =back -=head2 apply_base_class_roles( for_class => $class, roles => \@roles ) +=head2 apply_base_class_roles( for => $class, roles => \@roles ) This function will apply the specified roles to the object's base class. +=head1 BUGS + +See L for details on reporting bugs. + =head1 AUTHOR Dave Rolsky Eautarch@urth.orgE