X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FMetaRole.pm;h=b68294f83462b441e491ffbd9c321a185f12293b;hb=eea9eb4d0a9d6d7453cfb6fca6bb6aae618254c4;hp=b333a6282e4981450b5fc379cd9edaaea83ce713;hpb=21097b40485a26add33c0275a9cc7351d689e342;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/MetaRole.pm b/lib/Moose/Util/MetaRole.pm index b333a62..b68294f 100644 --- a/lib/Moose/Util/MetaRole.pm +++ b/lib/Moose/Util/MetaRole.pm @@ -2,86 +2,109 @@ package Moose::Util::MetaRole; use strict; use warnings; +use Scalar::Util 'blessed'; -our $VERSION = '0.79'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - +use Carp qw( croak ); use List::MoreUtils qw( all ); +use List::Util qw( first ); +use Moose::Deprecated; +use Scalar::Util qw( blessed ); + +sub apply_metaroles { + my %args = @_; + + my $for = _metathing_for( $args{for} ); -my @Classes = qw( constructor_class destructor_class error_class ); + 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 apply_metaclass_roles { - my %options = @_; +sub _metathing_for { + my $passed = shift; - my $for = $options{for_class}; + my $found + = blessed $passed + ? $passed + : Class::MOP::class_of($passed); - my %old_classes = map { $_ => Class::MOP::class_of($for)->$_ } - grep { Class::MOP::class_of($for)->can($_) } - @Classes; + return $found + if defined $found + && blessed $found + && ( $found->isa('Moose::Meta::Role') + || $found->isa('Moose::Meta::Class') ); - my $meta = _make_new_metaclass( $for, \%options ); + local $Carp::CarpLevel = $Carp::CarpLevel + 1; - for my $c ( grep { $meta->can($_) } @Classes ) { - if ( $options{ $c . '_roles' } ) { - my $class = _make_new_class( - $meta->$c(), - $options{ $c . '_roles' } - ); + my $error_start + = 'When using Moose::Util::MetaRole, you must pass a Moose class name,' + . ' role name, metaclass object, or metarole object.'; - $meta->$c($class); - } - else { - $meta->$c( $old_classes{$c} ); - } + if ( defined $found && blessed $found ) { + croak $error_start + . " You passed $passed, and we resolved this to a " + . ( blessed $found ) + . ' object.'; } - return $meta; + if ( defined $passed && !defined $found ) { + croak $error_start + . " You passed $passed, and this did not resolve to a metaclass or metarole." + . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?'; + } + + if ( !defined $passed ) { + croak $error_start + . " You passed an undef." + . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?'; + } } 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 - ); + 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 - ); + = 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} ); + } - return $new_metaclass->reinitialize( $for, %classes ); + my $new_meta = $new_metaclass->reinitialize( $for, %classes ); + + return $new_meta; } sub apply_base_class_roles { - my %options = @_; - - my $for = $options{for_class}; + my %args = @_; - my $meta = Class::MOP::class_of($for); + my $meta = _metathing_for( $args{for} || $args{for_class} ); + croak 'You can only apply base class roles to a Moose class, not a role.' + if $meta->isa('Moose::Meta::Role'); my $new_base = _make_new_class( - $for, - $options{roles}, + $meta->name, + $args{roles}, [ $meta->superclasses() ], ); @@ -99,7 +122,8 @@ sub _make_new_class { my $meta = Class::MOP::Class->initialize($existing_class); return $existing_class - if $meta->can('does_role') && all { $meta->does_role($_) } @{$roles}; + if $meta->can('does_role') && all { $meta->does_role($_) } + grep { !ref $_ } @{$roles}; return Moose::Meta::Class->create_anon_class( superclasses => $superclasses, @@ -110,11 +134,9 @@ sub _make_new_class { 1; -__END__ +# ABSTRACT: Apply roles to any metaclass, as well as the object base class -=head1 NAME - -Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class +__END__ =head1 SYNOPSIS @@ -132,22 +154,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 @@ -163,67 +187,96 @@ extensions can apply roles in any order. =head1 USAGE -B. The process of applying roles -to the metaclass reinitializes the metaclass object, which wipes out -any existing attributes already defined. However, as long as you do -this when your module is imported, the caller should not have any -attributes defined yet. - -The easiest way to ensure that this happens is to use -L and provide an C method that will be +The easiest way to use this module is through L, which can +generate the appropriate C method for you, and make sure it is called when imported. =head1 FUNCTIONS 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. -This specifies the class for which to alter the meta classes. +It accepts the following keys: -=item * metaclass_roles => \@roles +=over 8 -=item * attribute_metaclass_roles => \@roles +=item class -=item * method_metaclass_roles => \@roles +=item attribute -=item * wrapped_method_metaclass_roles => \@roles +=item method -=item * instance_metaclass_roles => \@roles +=item wrapped_method -=item * constructor_class_roles => \@roles +=item instance -=item * destructor_class_roles => \@roles +=item constructor -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 destructor + +=item error =back -=head2 apply_base_class_roles( for_class => $class, roles => \@roles ) +=item * role_metaroles => \%roles -This function will apply the specified roles to the object's base class. +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 -=head1 AUTHOR +=item attribute -Dave Rolsky Eautarch@urth.orgE +=item method -=head1 COPYRIGHT AND LICENSE +=item required_method -Copyright 2009 by Infinity Interactive, Inc. +=item conflicting_method + +=item application_to_class + +=item application_to_role + +=item application_to_instance + +=item application_role_summation + +=back + +=back + +=head2 apply_base_class_roles( for => $class, roles => \@roles ) + +This function will apply the specified roles to the object's base class. -L +=head1 BUGS -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +See L for details on reporting bugs. =cut