BEGIN {
$Moose::Util::AUTHORITY
=
'cpan:STEVAN'
;
}
BEGIN {
$Moose::Util::VERSION
=
'2.0103'
;
}
my
@exports
=
qw[
find_meta
does_role
search_class_by_role
ensure_all_roles
apply_all_roles
with_traits
get_all_init_args
get_all_attribute_values
resolve_metatrait_alias
resolve_metaclass_alias
add_method_modifier
english_list
meta_attribute_alias
meta_class_alias
]
;
Sub::Exporter::setup_exporter({
exports
=> \
@exports
,
groups
=> {
all
=> \
@exports
}
});
sub
find_meta { Class::MOP::class_of(
@_
) }
sub
does_role {
my
(
$class_or_obj
,
$role
) =
@_
;
my
$meta
= find_meta(
$class_or_obj
);
return
unless
defined
$meta
;
return
unless
$meta
->can(
'does_role'
);
return
1
if
$meta
->does_role(
$role
);
return
;
}
sub
search_class_by_role {
my
(
$class_or_obj
,
$role
) =
@_
;
my
$meta
= find_meta(
$class_or_obj
);
return
unless
defined
$meta
;
my
$role_name
= blessed
$role
?
$role
->name :
$role
;
foreach
my
$class
(
$meta
->class_precedence_list) {
my
$_meta
= find_meta(
$class
);
next
unless
defined
$_meta
;
foreach
my
$role
(@{
$_meta
->roles || [] }) {
return
$class
if
$role
->name eq
$role_name
;
}
}
return
;
}
sub
ensure_all_roles {
my
$applicant
=
shift
;
_apply_all_roles(
$applicant
,
sub
{ !does_role(
$applicant
,
$_
) },
@_
);
}
sub
apply_all_roles {
my
$applicant
=
shift
;
_apply_all_roles(
$applicant
,
undef
,
@_
);
}
sub
_apply_all_roles {
my
$applicant
=
shift
;
my
$role_filter
=
shift
;
unless
(
@_
) {
Moose->throw_error(
"Must specify at least one role to apply to $applicant"
);
}
my
$roles
= Data::OptList::mkopt( [
@_
], {
moniker
=>
'role'
,
name_test
=>
sub
{
!
ref
$_
[0] or blessed(
$_
[0]) &&
$_
[0]->isa(
'Moose::Meta::Role'
)
}
});
my
@role_metas
;
foreach
my
$role
(
@$roles
) {
my
$meta
;
if
( blessed
$role
->[0] ) {
$meta
=
$role
->[0];
}
else
{
Class::MOP::load_class(
$role
->[0] ,
$role
->[1] );
$meta
= find_meta(
$role
->[0] );
}
unless
(
$meta
&&
$meta
->isa(
'Moose::Meta::Role'
) ) {
Moose->throw_error(
"You can only consume roles, "
.
$role
->[0]
.
" is not a Moose role"
);
}
push
@role_metas
, [
$meta
,
$role
->[1] ];
}
if
(
defined
$role_filter
) {
@role_metas
=
grep
{
local
$_
=
$_
->[0];
$role_filter
->() }
@role_metas
;
}
return
unless
@role_metas
;
Class::MOP::load_class(
$applicant
)
unless
blessed(
$applicant
);
my
$meta
= ( blessed
$applicant
?
$applicant
: Moose::Meta::Class->initialize(
$applicant
) );
if
(
scalar
@role_metas
== 1 ) {
my
(
$role
,
$params
) = @{
$role_metas
[0] };
$role
->apply(
$meta
, (
defined
$params
?
%$params
: () ) );
}
else
{
Moose::Meta::Role->combine(
@role_metas
)->apply(
$meta
);
}
}
sub
with_traits {
my
(
$class
,
@roles
) =
@_
;
return
$class
unless
@roles
;
return
Moose::Meta::Class->create_anon_class(
superclasses
=> [
$class
],
roles
=> \
@roles
,
cache
=> 1,
)->name;
}
sub
get_all_attribute_values {
my
(
$class
,
$instance
) =
@_
;
return
+{
map
{
$_
->
name
=>
$_
->get_value(
$instance
) }
grep
{
$_
->has_value(
$instance
) }
$class
->get_all_attributes
};
}
sub
get_all_init_args {
my
(
$class
,
$instance
) =
@_
;
return
+{
map
{
$_
->
init_arg
=>
$_
->get_value(
$instance
) }
grep
{
$_
->has_value(
$instance
) }
grep
{
defined
(
$_
->init_arg) }
$class
->get_all_attributes
};
}
sub
resolve_metatrait_alias {
return
resolve_metaclass_alias(
@_
,
trait
=> 1 );
}
sub
_build_alias_package_name {
my
(
$type
,
$name
,
$trait
) =
@_
;
return
'Moose::Meta::'
.
$type
.
'::Custom::'
. (
$trait
?
'Trait::'
:
''
)
.
$name
;
}
{
my
%cache
;
sub
resolve_metaclass_alias {
my
(
$type
,
$metaclass_name
,
%options
) =
@_
;
my
$cache_key
=
$type
.
q{ }
. (
$options
{trait} ?
'-Trait'
:
''
);
return
$cache
{
$cache_key
}{
$metaclass_name
}
if
$cache
{
$cache_key
}{
$metaclass_name
};
my
$possible_full_name
= _build_alias_package_name(
$type
,
$metaclass_name
,
$options
{trait}
);
my
$loaded_class
= Class::MOP::load_first_existing_class(
$possible_full_name
,
$metaclass_name
);
return
$cache
{
$cache_key
}{
$metaclass_name
}
=
$loaded_class
->can(
'register_implementation'
)
?
$loaded_class
->register_implementation
:
$loaded_class
;
}
}
sub
add_method_modifier {
my
(
$class_or_obj
,
$modifier_name
,
$args
) =
@_
;
my
$meta
=
$class_or_obj
->can(
'add_before_method_modifier'
)
?
$class_or_obj
: find_meta(
$class_or_obj
);
my
$code
=
pop
@{
$args
};
my
$add_modifier_method
=
'add_'
.
$modifier_name
.
'_method_modifier'
;
if
(
my
$method_modifier_type
=
ref
( @{
$args
}[0] ) ) {
if
(
$method_modifier_type
eq
'Regexp'
) {
my
@all_methods
=
$meta
->get_all_methods;
my
@matched_methods
=
grep
{
$_
->name =~ @{
$args
}[0] }
@all_methods
;
$meta
->
$add_modifier_method
(
$_
->name,
$code
)
for
@matched_methods
;
}
elsif
(
$method_modifier_type
eq
'ARRAY'
) {
$meta
->
$add_modifier_method
(
$_
,
$code
)
for
@{
$args
->[0]};
}
else
{
$meta
->throw_error(
sprintf
(
"Methods passed to %s must be provided as a list, arrayref or regex, not %s"
,
$modifier_name
,
$method_modifier_type
,
)
);
}
}
else
{
$meta
->
$add_modifier_method
(
$_
,
$code
)
for
@{
$args
};
}
}
sub
english_list {
my
@items
=
sort
@_
;
return
$items
[0]
if
@items
== 1;
return
"$items[0] and $items[1]"
if
@items
== 2;
my
$tail
=
pop
@items
;
my
$list
=
join
', '
,
@items
;
$list
.=
', and '
.
$tail
;
return
$list
;
}
sub
_caller_info {
my
$level
=
@_
? (
$_
[0] + 1) : 2;
my
%info
;
@info
{
qw(package file line)
} =
caller
(
$level
);
return
\
%info
;
}
sub
_create_alias {
my
(
$type
,
$name
,
$trait
,
$for
) =
@_
;
my
$package
= _build_alias_package_name(
$type
,
$name
,
$trait
);
Class::MOP::Class->initialize(
$package
)->add_method(
register_implementation
=>
sub
{
$for
}
);
}
sub
meta_attribute_alias {
my
(
$to
,
$from
) =
@_
;
$from
||=
caller
;
my
$meta
= Class::MOP::class_of(
$from
);
my
$trait
=
$meta
->isa(
'Moose::Meta::Role'
);
_create_alias(
'Attribute'
,
$to
,
$trait
,
$from
);
}
sub
meta_class_alias {
my
(
$to
,
$from
) =
@_
;
$from
||=
caller
;
my
$meta
= Class::MOP::class_of(
$from
);
my
$trait
=
$meta
->isa(
'Moose::Meta::Role'
);
_create_alias(
'Class'
,
$to
,
$trait
,
$from
);
}
sub
_STRINGLIKE0 ($) {
return
_STRING(
$_
[0] )
|| (
defined
$_
[0]
&&
$_
[0] eq
q{}
)
|| ( blessed
$_
[0]
&& overload::Method(
$_
[0],
q{""}
)
&&
length
"$_[0]"
);
}
sub
_reconcile_roles_for_metaclass {
my
(
$class_meta_name
,
$super_meta_name
) =
@_
;
my
@role_differences
= _role_differences(
$class_meta_name
,
$super_meta_name
,
);
return
$super_meta_name
unless
@role_differences
;
return
Moose::Meta::Class->create_anon_class(
superclasses
=> [
$super_meta_name
],
roles
=> [
map
{
$_
->name }
@role_differences
],
cache
=> 1,
)->name;
}
sub
_role_differences {
my
(
$class_meta_name
,
$super_meta_name
) =
@_
;
my
@super_role_metas
=
grep
{ !
$_
->isa(
'Moose::Meta::Role::Composite'
) }
$super_meta_name
->meta->can(
'calculate_all_roles_with_inheritance'
)
?
$super_meta_name
->meta->calculate_all_roles_with_inheritance
:
$super_meta_name
->meta->can(
'calculate_all_roles'
)
?
$super_meta_name
->meta->calculate_all_roles
: ();
my
@role_metas
=
grep
{ !
$_
->isa(
'Moose::Meta::Role::Composite'
) }
$class_meta_name
->meta->can(
'calculate_all_roles_with_inheritance'
)
?
$class_meta_name
->meta->calculate_all_roles_with_inheritance
:
$class_meta_name
->meta->can(
'calculate_all_roles'
)
?
$class_meta_name
->meta->calculate_all_roles
: ();
my
@differences
;
for
my
$role_meta
(
@role_metas
) {
push
@differences
,
$role_meta
unless
any {
$_
->name eq
$role_meta
->name }
@super_role_metas
;
}
return
@differences
;
}
sub
_classes_differ_by_roles_only {
my
(
$self_meta_name
,
$super_meta_name
) =
@_
;
my
$common_base_name
= _find_common_base(
$self_meta_name
,
$super_meta_name
);
return
unless
defined
$common_base_name
;
my
@super_meta_name_ancestor_names
= _get_ancestors_until(
$super_meta_name
,
$common_base_name
);
my
@class_meta_name_ancestor_names
= _get_ancestors_until(
$self_meta_name
,
$common_base_name
);
return
unless
all { _is_role_only_subclass(
$_
) }
@super_meta_name_ancestor_names
,
@class_meta_name_ancestor_names
;
return
1;
}
sub
_find_common_base {
my
(
$meta1
,
$meta2
) =
map
{ Class::MOP::class_of(
$_
) }
@_
;
return
unless
defined
$meta1
&&
defined
$meta2
;
my
%meta1_parents
=
map
{
$_
=> 1 }
$meta1
->linearized_isa;
return
first {
$meta1_parents
{
$_
} }
$meta2
->linearized_isa;
}
sub
_get_ancestors_until {
my
(
$start_name
,
$until_name
) =
@_
;
my
@ancestor_names
;
for
my
$ancestor_name
(Class::MOP::class_of(
$start_name
)->linearized_isa) {
last
if
$ancestor_name
eq
$until_name
;
push
@ancestor_names
,
$ancestor_name
;
}
return
@ancestor_names
;
}
sub
_is_role_only_subclass {
my
(
$meta_name
) =
@_
;
my
$meta
= Class::MOP::Class->initialize(
$meta_name
);
my
@parent_names
=
$meta
->superclasses;
return
unless
@parent_names
== 1;
my
(
$parent_name
) =
@parent_names
;
my
$parent_meta
= Class::MOP::Class->initialize(
$parent_name
);
my
@roles
=
$meta
->can(
'calculate_all_roles'
)
?
$meta
->calculate_all_roles
: ();
return
unless
@roles
;
for
my
$method
(
$meta
->_get_local_methods ) {
next
if
$method
->isa(
'Class::MOP::Method::Meta'
);
next
if
$method
->can(
'associated_attribute'
);
next
if
$meta
->can(
'does_role'
)
&&
$meta
->does_role(
$method
->original_package_name);
next
if
$method
->isa(
'Class::MOP::Method::Wrapped'
)
&& (
(!
scalar
(
$method
->around_modifiers)
|| any {
$_
->has_around_method_modifiers(
$method
->name) }
@roles
)
&& (!
scalar
(
$method
->before_modifiers)
|| any {
$_
->has_before_method_modifiers(
$method
->name) }
@roles
)
&& (!
scalar
(
$method
->after_modifiers)
|| any {
$_
->has_after_method_modifiers(
$method
->name) }
@roles
)
);
return
0;
}
for
my
$attr
(
map
{
$meta
->get_attribute(
$_
) }
$meta
->get_attribute_list) {
next
if
any {
$_
->has_attribute(
$attr
->name) }
@roles
;
return
0;
}
return
1;
}
1;