diff options
Diffstat (limited to 'lib/Moose/Meta/Role/Application')
| -rw-r--r-- | lib/Moose/Meta/Role/Application/RoleSummation.pm | 440 | ||||
| -rw-r--r-- | lib/Moose/Meta/Role/Application/ToClass.pm | 314 | ||||
| -rw-r--r-- | lib/Moose/Meta/Role/Application/ToInstance.pm | 141 | ||||
| -rw-r--r-- | lib/Moose/Meta/Role/Application/ToRole.pm | 283 |
4 files changed, 1178 insertions, 0 deletions
diff --git a/lib/Moose/Meta/Role/Application/RoleSummation.pm b/lib/Moose/Meta/Role/Application/RoleSummation.pm new file mode 100644 index 0000000..1276b66 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/RoleSummation.pm @@ -0,0 +1,440 @@ +package Moose::Meta::Role::Application::RoleSummation; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use List::Util 1.33 qw( all ); +use Scalar::Util 'blessed'; + +use Moose::Meta::Role::Composite; + +use parent 'Moose::Meta::Role::Application'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('role_params' => ( + reader => 'role_params', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub get_exclusions_for_role { + my ($self, $role) = @_; + $role = $role->name if blessed $role; + my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ? + '-excludes' : 'excludes'; + if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) { + if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') { + return $self->role_params->{$role}->{$excludes_key}; + } + return [ $self->role_params->{$role}->{$excludes_key} ]; + } + return []; +} + +sub get_method_aliases_for_role { + my ($self, $role) = @_; + $role = $role->name if blessed $role; + my $alias_key = exists $self->role_params->{$role}->{'-alias'} ? + '-alias' : 'alias'; + if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) { + return $self->role_params->{$role}->{$alias_key}; + } + return {}; +} + +sub is_method_excluded { + my ($self, $role, $method_name) = @_; + foreach ($self->get_exclusions_for_role($role->name)) { + return 1 if $_ eq $method_name; + } + return 0; +} + +sub is_method_aliased { + my ($self, $role, $method_name) = @_; + exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0 +} + +sub is_aliased_method { + my ($self, $role, $method_name) = @_; + my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)}; + exists $aliased_names{$method_name} ? 1 : 0; +} + +sub check_role_exclusions { + my ($self, $c) = @_; + + my %excluded_roles; + for my $role (@{ $c->get_roles }) { + my $name = $role->name; + + for my $excluded ($role->get_excluded_roles_list) { + push @{ $excluded_roles{$excluded} }, $name; + } + } + + foreach my $role (@{$c->get_roles}) { + foreach my $excluded (keys %excluded_roles) { + next unless $role->does_role($excluded); + + my @excluding = @{ $excluded_roles{$excluded} }; + + throw_exception( RoleExclusionConflict => roles => \@excluding, + role_name => $excluded + ); + } + } + + $c->add_excluded_roles(keys %excluded_roles); +} + +sub check_required_methods { + my ($self, $c) = @_; + + my %all_required_methods = + map { $_->name => $_ } + map { $_->get_required_method_list } + @{$c->get_roles}; + + foreach my $role (@{$c->get_roles}) { + foreach my $required (keys %all_required_methods) { + + delete $all_required_methods{$required} + if $role->has_method($required) + || $self->is_aliased_method($role, $required); + } + } + + $c->add_required_methods(values %all_required_methods); +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $c) = @_; + + my @all_attributes; + + for my $role ( @{ $c->get_roles } ) { + push @all_attributes, + map { $role->get_attribute($_) } $role->get_attribute_list; + } + + my %seen; + foreach my $attr (@all_attributes) { + my $name = $attr->name; + + if ( exists $seen{$name} ) { + next if $seen{$name}->is_same_as($attr); + + my $role1 = $seen{$name}->associated_role->name; + my $role2 = $attr->associated_role->name; + + throw_exception( AttributeConflictInSummation => attribute_name => $name, + role_name => $role1, + second_role_name => $role2, + ); + } + + $seen{$name} = $attr; + } + + foreach my $attr (@all_attributes) { + $c->add_attribute( $attr->clone ); + } +} + +sub apply_methods { + my ($self, $c) = @_; + + my @all_methods = map { + my $role = $_; + my $aliases = $self->get_method_aliases_for_role($role); + my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) }; + ( + (map { + exists $excludes{$_} ? () : + +{ + role => $role, + name => $_, + method => $role->get_method($_), + } + } map { $_->name } + grep { !$_->isa('Class::MOP::Method::Meta') } + $role->_get_local_methods), + (map { + +{ + role => $role, + name => $aliases->{$_}, + method => $role->get_method($_), + } + } keys %$aliases) + ); + } @{$c->get_roles}; + + my (%seen, %conflicts, %method_map); + foreach my $method (@all_methods) { + next if $conflicts{$method->{name}}; + my $seen = $seen{$method->{name}}; + + if ($seen) { + if ($seen->{method}->body != $method->{method}->body) { + $c->add_conflicting_method( + name => $method->{name}, + roles => [$method->{role}->name, $seen->{role}->name], + ); + + delete $method_map{$method->{name}}; + $conflicts{$method->{name}} = 1; + next; + } + } + + $seen{$method->{name}} = $method; + $method_map{$method->{name}} = $method->{method}; + } + + $c->add_method($_ => $method_map{$_}) for keys %method_map; +} + +sub apply_override_method_modifiers { + my ($self, $c) = @_; + + my @all_overrides = map { + my $role = $_; + map { + +{ + name => $_, + method => $role->get_override_method_modifier($_), + } + } $role->get_method_modifier_list('override'); + } @{$c->get_roles}; + + my %seen; + foreach my $override (@all_overrides) { + my @role_names = map { $_->name } @{$c->get_roles}; + if ( $c->has_method($override->{name}) ){ + throw_exception( OverrideConflictInSummation => role_names => \@role_names, + role_application => $self, + method_name => $override->{name} + ); + } + if (exists $seen{$override->{name}}) { + if ( $seen{$override->{name}} != $override->{method} ) { + throw_exception( OverrideConflictInSummation => role_names => \@role_names, + role_application => $self, + method_name => $override->{name}, + two_overrides_found => 1 + ); + } + } + $seen{$override->{name}} = $override->{method}; + } + + $c->add_override_method_modifier( + $_->{name}, $_->{method} + ) for @all_overrides; + +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $c) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $role (@{$c->get_roles}) { + foreach my $method_name ($role->get_method_modifier_list($modifier_type)) { + $c->$add( + $method_name, + $_ + ) foreach $role->$get($method_name); + } + } +} + +sub apply_overloading { + my ( $self, $c ) = @_; + + my @overloaded_roles = grep { $_->is_overloaded } @{ $c->get_roles }; + return unless @overloaded_roles; + + my %fallback; + for my $role (@overloaded_roles) { + $fallback{ $role->name } = $role->get_overload_fallback_value; + } + + for my $role_name ( keys %fallback ) { + for my $other_role_name ( grep { $_ ne $role_name } keys %fallback ) { + my @fb_values = @fallback{ $role_name, $other_role_name }; + if ( all {defined} @fb_values ) { + next if $fallback{$role_name} eq $fallback{$other_role_name}; + throw_exception( + 'OverloadConflictInSummation', + role_names => [ $role_name, $other_role_name ], + role_application => $self, + overloaded_op => 'fallback', + ); + } + + next if all { !defined } @fb_values; + throw_exception( + 'OverloadConflictInSummation', + role_names => [ $role_name, $other_role_name ], + role_application => $self, + overloaded_op => 'fallback', + ); + } + } + + if ( keys %fallback ) { + $c->set_overload_fallback_value( ( values %fallback )[0] ); + } + + my %overload_map; + for my $role (@overloaded_roles) { + for my $overload ( $role->get_all_overloaded_operators ) { + $overload_map{ $overload->operator }{ $role->name } = $overload; + } + } + + for my $op_name ( keys %overload_map ) { + my @roles = keys %{ $overload_map{$op_name} }; + my $overload = $overload_map{$op_name}{ $roles[0] }; + + if ( @roles > 1 && !all { $overload->_is_equal_to($_) } + values %{ $overload_map{$op_name} } ) { + + throw_exception( + 'OverloadConflictInSummation', + role_names => [ @roles[ 0, 1 ] ], + role_application => $self, + overloaded_op => $op_name, + ); + } + + $c->add_overloaded_operator( + $op_name => $overload_map{$op_name}{ $roles[0] } ); + } +} + +1; + +# ABSTRACT: Combine two or more roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::RoleSummation - Combine two or more roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +Summation composes two traits, forming the union of non-conflicting +bindings and 'disabling' the conflicting bindings + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<role_params> + +=item B<get_exclusions_for_role> + +=item B<get_method_aliases_for_role> + +=item B<is_aliased_method> + +=item B<is_method_aliased> + +=item B<is_method_excluded> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_overloading> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm new file mode 100644 index 0000000..03eeedd --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToClass.pm @@ -0,0 +1,314 @@ +package Moose::Meta::Role::Application::ToClass; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use List::Util 'first'; +use Moose::Util 'throw_exception'; +use Scalar::Util 'weaken'; + +use parent 'Moose::Meta::Role::Application'; + +__PACKAGE__->meta->add_attribute('role' => ( + reader => 'role', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('class' => ( + accessor => 'class', + Class::MOP::_definition_context(), +)); + +sub apply { + my ($self, $role, $class) = @_; + + # We need weak_ref in CMOP :( + weaken($self->{role} = $role); + weaken($self->{class} = $class); + + $self->SUPER::apply($role, $class); + + $class->add_role($role); + $class->add_role_application($self); +} + +sub check_role_exclusions { + my ($self, $role, $class) = @_; + if ($class->excludes_role($role->name)) { + throw_exception( ConflictDetectedInCheckRoleExclusionsInToClass => class_name => $class->name, + role_name => $role->name, + ); + } + foreach my $excluded_role_name ($role->get_excluded_roles_list) { + if ($class->does_role($excluded_role_name)) { + throw_exception( ClassDoesTheExcludedRole => role_name => $role->name, + excluded_role_name => $excluded_role_name, + class_name => $class->name, + ); + } + } +} + +sub check_required_methods { + my ($self, $role, $class) = @_; + + my @missing; + my @is_attr; + + # NOTE: + # we might need to move this down below the + # the attributes so that we can require any + # attribute accessors. However I am thinking + # that maybe those are somehow exempt from + # the require methods stuff. + foreach my $required_method ($role->get_required_method_list) { + my $required_method_name = $required_method->name; + + if (!$class->find_method_by_name($required_method_name)) { + + next if $self->is_aliased_method($required_method_name); + + push @missing, $required_method; + } + } + + return unless @missing; + + my $error = ''; + + @missing = sort { $a->name cmp $b->name } @missing; + my @conflicts = grep { $_->isa('Moose::Meta::Role::Method::Conflicting') } @missing; + + if (@conflicts) { + my $conflict = $conflicts[0]; + my $roles = $conflict->roles_as_english_list; + + my @same_role_conflicts = grep { $_->roles_as_english_list eq $roles } @conflicts; + + throw_exception( MethodNameConflictInRoles => conflict => \@same_role_conflicts, + class_name => $class->name + ); + } + elsif (@missing) { + if (my $meth = first { $class->name->can($_) } @missing) { + throw_exception( RequiredMethodsImportedByClass => class_name => $class->name, + role_name => $role->name, + missing_methods => \@missing, + imported_method => $meth + ); + } + else { + throw_exception( RequiredMethodsNotImplementedByClass => class_name => $class->name, + role_name => $role->name, + missing_methods => \@missing, + ); + } + } +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $role, $class) = @_; + + foreach my $attribute_name ($role->get_attribute_list) { + # it if it has one already + if ($class->has_attribute($attribute_name) && + # make sure we haven't seen this one already too + $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) { + next; + } + else { + $class->add_attribute( + $role->get_attribute($attribute_name)->attribute_for_class + ); + } + } +} + +sub apply_methods { + my ( $self, $role, $class ) = @_; + + foreach my $method ( $role->_get_local_methods ) { + my $method_name = $method->name; + + next if $method->isa('Class::MOP::Method::Meta'); + + unless ( $self->is_method_excluded($method_name) ) { + + my $class_method = $class->get_method($method_name); + + next if $class_method && $class_method->body != $method->body; + + $class->add_method( + $method_name, + $method, + ); + } + + next unless $self->is_method_aliased($method_name); + + my $aliased_method_name = $self->get_method_aliases->{$method_name}; + + my $class_method = $class->get_method($aliased_method_name); + + if ( $class_method && $class_method->body != $method->body ) { + throw_exception( CannotCreateMethodAliasLocalMethodIsPresentInClass => aliased_method_name => $aliased_method_name, + method => $method, + role_name => $role->name, + class_name => $class->name, + ); + } + + $class->add_method( + $aliased_method_name, + $method, + ); + } + + # we must reset the cache here since + # we are just aliasing methods, otherwise + # the modifiers go wonky. + $class->reset_package_cache_flag; +} + +sub apply_override_method_modifiers { + my ($self, $role, $class) = @_; + foreach my $method_name ($role->get_method_modifier_list('override')) { + # it if it has one already then ... + if ($class->has_method($method_name)) { + next; + } + else { + # if this is not a role, then we need to + # find the original package of the method + # so that we can tell the class were to + # find the right super() method + my $method = $role->get_override_method_modifier($method_name); + my ($package) = Class::MOP::get_code_info($method); + # if it is a class, we just add it + $class->add_override_method_modifier($method_name, $method, $package); + } + } +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $role, $class) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $method_name ($role->get_method_modifier_list($modifier_type)) { + $class->$add( + $method_name, + $_ + ) foreach $role->$get($method_name); + } +} + +1; + +# ABSTRACT: Compose a role into a class + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToClass - Compose a role into a class + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToInstance.pm b/lib/Moose/Meta/Role/Application/ToInstance.pm new file mode 100644 index 0000000..5e82c45 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToInstance.pm @@ -0,0 +1,141 @@ +package Moose::Meta::Role::Application::ToInstance; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; +use List::Util 1.33 'all'; + +use parent 'Moose::Meta::Role::Application'; + +__PACKAGE__->meta->add_attribute('rebless_params' => ( + reader => 'rebless_params', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +use constant _NEED_OVERLOAD_HACK_FOR_OBJECTS => $] < 5.008009; + +sub apply { + my ( $self, $role, $object, $args ) = @_; + + my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class'; + + # This is a special case to handle the case where the object's metaclass + # is a Class::MOP::Class, but _not_ a Moose::Meta::Class (for example, + # when applying a role to a Moose::Meta::Attribute object). + $obj_meta = 'Moose::Meta::Class' + unless $obj_meta->isa('Moose::Meta::Class'); + + my $class = $obj_meta->create_anon_class( + superclasses => [ blessed($object) ], + roles => [ $role, keys(%$args) ? ($args) : () ], + cache => (all { $_ eq '-alias' || $_ eq '-excludes' } keys %$args), + ); + + $class->rebless_instance( $object, %{ $self->rebless_params } ); + + if ( _NEED_OVERLOAD_HACK_FOR_OBJECTS + && overload::Overloaded( ref $object ) ) { + + # need to use $_[2] here to apply to the object in the caller + _reset_amagic($_[2]); + } + + return $object; +} + +1; + +# ABSTRACT: Compose a role into an instance + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToInstance - Compose a role into an instance + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<rebless_params> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToRole.pm b/lib/Moose/Meta/Role/Application/ToRole.pm new file mode 100644 index 0000000..0d8af91 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToRole.pm @@ -0,0 +1,283 @@ +package Moose::Meta::Role::Application::ToRole; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use parent 'Moose::Meta::Role::Application'; + +use Moose::Util 'throw_exception'; + +sub apply { + my ($self, $role1, $role2) = @_; + $self->SUPER::apply($role1, $role2); + $role2->add_role($role1); +} + +sub check_role_exclusions { + my ($self, $role1, $role2) = @_; + if ( $role2->excludes_role($role1->name) ) { + throw_exception( ConflictDetectedInCheckRoleExclusions => role_name => $role2->name, + excluded_role_name => $role1->name, + ); + } + foreach my $excluded_role_name ($role1->get_excluded_roles_list) { + if ( $role2->does_role($excluded_role_name) ) { + throw_exception( RoleDoesTheExcludedRole => role_name => $role2->name, + excluded_role_name => $excluded_role_name, + second_role_name => $role1->name, + ); + } + $role2->add_excluded_roles($excluded_role_name); + } +} + +sub check_required_methods { + my ($self, $role1, $role2) = @_; + foreach my $required_method ($role1->get_required_method_list) { + my $required_method_name = $required_method->name; + + next if $self->is_aliased_method($required_method_name); + + $role2->add_required_methods($required_method) + unless $role2->find_method_by_name($required_method_name); + } +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $role1, $role2) = @_; + foreach my $attribute_name ($role1->get_attribute_list) { + # it if it has one already + if ($role2->has_attribute($attribute_name) && + # make sure we haven't seen this one already too + $role2->get_attribute($attribute_name) != $role1->get_attribute($attribute_name)) { + + my $role2_name = $role2->name; + + throw_exception( AttributeConflictInRoles => role_name => $role1->name, + second_role_name => $role2->name, + attribute_name => $attribute_name + ); + } + else { + $role2->add_attribute( + $role1->get_attribute($attribute_name)->clone + ); + } + } +} + +sub apply_methods { + my ( $self, $role1, $role2 ) = @_; + foreach my $method ( $role1->_get_local_methods ) { + + my $method_name = $method->name; + + next if $method->isa('Class::MOP::Method::Meta'); + + unless ( $self->is_method_excluded($method_name) ) { + + my $role2_method = $role2->get_method($method_name); + if ( $role2_method + && $role2_method->body != $method->body ) { + + # method conflicts between roles used to result in the method + # becoming a requirement but now are permitted just like + # for classes, hence no code in this branch anymore. + } + else { + $role2->add_method( + $method_name, + $method, + ); + } + } + + next unless $self->is_method_aliased($method_name); + + my $aliased_method_name = $self->get_method_aliases->{$method_name}; + + my $role2_method = $role2->get_method($aliased_method_name); + + if ( $role2_method + && $role2_method->body != $method->body ) { + + throw_exception( CannotCreateMethodAliasLocalMethodIsPresent => aliased_method_name => $aliased_method_name, + method => $method, + role_name => $role2->name, + role_being_applied_name => $role1->name, + ); + } + + $role2->add_method( + $aliased_method_name, + $role1->get_method($method_name) + ); + + if ( !$role2->has_method($method_name) ) { + $role2->add_required_methods($method_name) + unless $self->is_method_excluded($method_name); + } + } +} + +sub apply_override_method_modifiers { + my ($self, $role1, $role2) = @_; + foreach my $method_name ($role1->get_method_modifier_list('override')) { + # it if it has one already then ... + if ($role2->has_method($method_name)) { + # if it is being composed into another role + # we have a conflict here, because you cannot + # combine an overridden method with a locally + # defined one + throw_exception( OverrideConflictInComposition => role_name => $role2->name, + role_being_applied_name => $role1->name, + method_name => $method_name + ); + } + else { + # if we are a role, we need to make sure + # we don't have a conflict with the role + # we are composing into + if ($role2->has_override_method_modifier($method_name) && + $role1->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) { + + throw_exception( OverrideConflictInComposition => role_name => $role2->name, + role_being_applied_name => $role1->name, + method_name => $method_name, + two_overrides_found => 1 + ); + } + else { + # if there is no conflict, + # just add it to the role + $role2->add_override_method_modifier( + $method_name, + $role1->get_override_method_modifier($method_name) + ); + } + } + } +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $role1, $role2) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $method_name ($role1->get_method_modifier_list($modifier_type)) { + $role2->$add( + $method_name, + $_ + ) foreach $role1->$get($method_name); + } +} + +1; + +# ABSTRACT: Compose a role into another role + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToRole - Compose a role into another role + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut |