$Moose::Meta::Role::Application::ToRole::VERSION
=
'2.1400'
;
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) {
if
(
$role2
->has_attribute(
$attribute_name
) &&
$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 ) {
}
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'
)) {
if
(
$role2
->has_method(
$method_name
)) {
throw_exception(
OverrideConflictInComposition
=>
role_name
=>
$role2
->name,
role_being_applied_name
=>
$role1
->name,
method_name
=>
$method_name
);
}
else
{
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
{
$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;