our
$VERSION
=
'2.2207'
;
Class::MOP::MiniTrait::apply(__PACKAGE__,
'Moose::Meta::Object::Trait'
);
__PACKAGE__->meta->add_attribute(
'roles'
=> (
reader
=>
'roles'
,
default
=>
sub
{ [] },
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute(
'role_applications'
=> (
reader
=>
'_get_role_applications'
,
default
=>
sub
{ [] },
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute(
Class::MOP::Attribute->new(
'immutable_trait'
=> (
accessor
=>
"immutable_trait"
,
default
=>
'Moose::Meta::Class::Immutable::Trait'
,
Class::MOP::_definition_context(),
))
);
__PACKAGE__->meta->add_attribute(
'constructor_class'
=> (
accessor
=>
'constructor_class'
,
default
=>
'Moose::Meta::Method::Constructor'
,
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute(
'destructor_class'
=> (
accessor
=>
'destructor_class'
,
default
=>
'Moose::Meta::Method::Destructor'
,
Class::MOP::_definition_context(),
));
sub
initialize {
my
$class
=
shift
;
my
@args
=
@_
;
unshift
@args
,
'package'
if
@args
% 2;
my
%opts
=
@args
;
my
$package
=
delete
$opts
{
package
};
return
Class::MOP::get_metaclass_by_name(
$package
)
||
$class
->SUPER::initialize(
$package
,
'attribute_metaclass'
=>
'Moose::Meta::Attribute'
,
'method_metaclass'
=>
'Moose::Meta::Method'
,
'instance_metaclass'
=>
'Moose::Meta::Instance'
,
%opts
,
);
}
sub
create {
my
$class
=
shift
;
my
@args
=
@_
;
unshift
@args
,
'package'
if
@args
% 2 == 1;
my
%options
=
@args
;
(
ref
$options
{roles} eq
'ARRAY'
)
|| throw_exception(
RolesInCreateTakesAnArrayRef
=>
params
=> \
%options
)
if
exists
$options
{roles};
my
$package
=
delete
$options
{
package
};
my
$roles
=
delete
$options
{roles};
my
$new_meta
=
$class
->SUPER::create(
$package
,
%options
);
if
(
$roles
) {
Moose::Util::apply_all_roles(
$new_meta
,
@$roles
);
}
return
$new_meta
;
}
sub
_meta_method_class {
'Moose::Meta::Method::Meta'
}
sub
_anon_package_prefix {
'Moose::Meta::Class::__ANON__::SERIAL::'
}
sub
_anon_cache_key {
my
$class
=
shift
;
my
%options
=
@_
;
my
$superclass_key
=
join
(
'|'
,
map
{
$_
->[0] } @{ Data::OptList::mkopt(
$options
{superclasses} || []) }
);
my
$roles
= Data::OptList::mkopt((
$options
{roles} || []), {
moniker
=>
'role'
,
name_test
=>
sub
{
!
ref
$_
[0] or blessed(
$_
[0]) &&
$_
[0]->isa(
'Moose::Meta::Role'
)
},
});
my
@role_keys
;
for
my
$role_spec
(
@$roles
) {
my
(
$role
,
$params
) =
@$role_spec
;
$params
= {
%$params
}
if
$params
;
my
$key
= blessed(
$role
) ?
$role
->name :
$role
;
if
(
$params
&&
%$params
) {
my
$alias
=
delete
$params
->{
'-alias'
}
||
delete
$params
->{
'alias'
}
|| {};
my
$excludes
=
delete
$params
->{
'-excludes'
}
||
delete
$params
->{
'excludes'
}
|| [];
$excludes
= [
$excludes
]
unless
ref
(
$excludes
) eq
'ARRAY'
;
if
(
%$params
) {
warn
"Roles with parameters cannot be cached. Consider "
.
"applying the parameters before calling "
.
"create_anon_class, or using 'weaken => 0' instead"
;
return
;
}
my
$alias_key
=
join
(
'%'
,
map
{
$_
=>
$alias
->{
$_
} }
sort
keys
%$alias
);
my
$excludes_key
=
join
(
'%'
,
sort
@$excludes
);
$key
.=
'<'
.
join
(
'+'
,
'a'
,
$alias_key
,
'e'
,
$excludes_key
) .
'>'
;
}
push
@role_keys
,
$key
;
}
my
$role_key
=
join
(
'|'
,
sort
@role_keys
);
return
join
(
'='
,
$superclass_key
,
$role_key
);
}
sub
reinitialize {
my
$self
=
shift
;
my
$pkg
=
shift
;
my
$meta
= blessed
$pkg
?
$pkg
: Class::MOP::class_of(
$pkg
);
my
%existing_classes
;
if
(
$meta
) {
%existing_classes
=
map
{
$_
=>
$meta
->
$_
() }
qw(
attribute_metaclass
method_metaclass
wrapped_method_metaclass
instance_metaclass
constructor_class
destructor_class
)
;
}
return
$self
->SUPER::reinitialize(
$pkg
,
%existing_classes
,
@_
,
);
}
sub
add_role {
my
(
$self
,
$role
) =
@_
;
(blessed(
$role
) &&
$role
->isa(
'Moose::Meta::Role'
))
|| throw_exception(
AddRoleTakesAMooseMetaRoleInstance
=>
role_to_be_added
=>
$role
,
class_name
=>
$self
->name,
);
push
@{
$self
->roles} =>
$role
;
}
sub
role_applications {
my
(
$self
) =
@_
;
return
@{
$self
->_get_role_applications};
}
sub
add_role_application {
my
(
$self
,
$application
) =
@_
;
(blessed(
$application
) &&
$application
->isa(
'Moose::Meta::Role::Application::ToClass'
))
|| throw_exception(
InvalidRoleApplication
=>
class_name
=>
$self
->name,
application
=>
$application
,
);
push
@{
$self
->_get_role_applications} =>
$application
;
}
sub
calculate_all_roles {
my
$self
=
shift
;
my
%seen
;
grep
{ !
$seen
{
$_
->name}++ }
map
{
$_
->calculate_all_roles } @{
$self
->roles };
}
sub
_roles_with_inheritance {
my
$self
=
shift
;
my
%seen
;
grep
{ !
$seen
{
$_
->name}++ }
map
{ Class::MOP::class_of(
$_
)->can(
'roles'
)
? @{ Class::MOP::class_of(
$_
)->roles }
: () }
$self
->linearized_isa;
}
sub
calculate_all_roles_with_inheritance {
my
$self
=
shift
;
my
%seen
;
grep
{ !
$seen
{
$_
->name}++ }
map
{ Class::MOP::class_of(
$_
)->can(
'calculate_all_roles'
)
? Class::MOP::class_of(
$_
)->calculate_all_roles
: () }
$self
->linearized_isa;
}
sub
does_role {
my
(
$self
,
$role_name
) =
@_
;
(
defined
$role_name
)
|| throw_exception(
RoleNameRequired
=>
class_name
=>
$self
->name );
foreach
my
$class
(
$self
->class_precedence_list) {
my
$meta
= Class::MOP::class_of(
$class
);
next
unless
$meta
&&
$meta
->can(
'roles'
);
foreach
my
$role
(@{
$meta
->roles}) {
return
1
if
$role
->does_role(
$role_name
);
}
}
return
0;
}
sub
excludes_role {
my
(
$self
,
$role_name
) =
@_
;
(
defined
$role_name
)
|| throw_exception(
RoleNameRequired
=>
class_name
=>
$self
->name );
foreach
my
$class
(
$self
->class_precedence_list) {
my
$meta
= Class::MOP::class_of(
$class
);
next
unless
$meta
&&
$meta
->can(
'roles'
);
foreach
my
$role
(@{
$meta
->roles}) {
return
1
if
$role
->excludes_role(
$role_name
);
}
}
return
0;
}
sub
new_object {
my
$self
=
shift
;
my
$params
=
@_
== 1 ?
$_
[0] : {
@_
};
my
$object
=
$self
->SUPER::new_object(
$params
);
$self
->_call_all_triggers(
$object
,
$params
);
$object
->BUILDALL(
$params
)
if
$object
->can(
'BUILDALL'
);
return
$object
;
}
sub
_call_all_triggers {
my
(
$self
,
$object
,
$params
) =
@_
;
foreach
my
$attr
(
$self
->get_all_attributes() ) {
next
unless
$attr
->can(
'has_trigger'
) &&
$attr
->has_trigger;
my
$init_arg
=
$attr
->init_arg;
next
unless
defined
$init_arg
;
next
unless
exists
$params
->{
$init_arg
};
$attr
->trigger->(
$object
,
(
$attr
->should_coerce
?
$attr
->get_read_method_ref->(
$object
)
:
$params
->{
$init_arg
}
),
);
}
}
sub
_generate_fallback_constructor {
my
$self
=
shift
;
my
(
$class
) =
@_
;
return
$class
.
'->Moose::Object::new(@_)'
}
sub
_inline_params {
my
$self
=
shift
;
my
(
$params
,
$class
) =
@_
;
return
(
'my '
.
$params
.
' = '
,
$self
->_inline_BUILDARGS(
$class
,
'@_'
),
';'
,
);
}
sub
_inline_BUILDARGS {
my
$self
=
shift
;
my
(
$class
,
$args
) =
@_
;
my
$buildargs
=
$self
->find_method_by_name(
"BUILDARGS"
);
if
(
$args
eq
'@_'
&& (!
$buildargs
or
$buildargs
->body == \
&Moose::Object::BUILDARGS
)) {
return
(
'do {'
,
'my $params;'
,
'if (scalar @_ == 1) {'
,
'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {'
,
$self
->_inline_throw_exception(
'SingleParamsToNewMustBeHashRef'
) .
';'
,
'}'
,
'$params = { %{ $_[0] } };'
,
'}'
,
'elsif (@_ % 2) {'
,
'Carp::carp('
,
'"The new() method for '
.
$class
.
' expects a '
.
'hash reference or a key/value list. You passed an '
.
'odd number of arguments"'
,
');'
,
'$params = {@_, undef};'
,
'}'
,
'else {'
,
'$params = {@_};'
,
'}'
,
'$params;'
,
'}'
,
);
}
else
{
return
$class
.
'->BUILDARGS('
.
$args
.
')'
;
}
}
sub
_inline_slot_initializer {
my
$self
=
shift
;
my
(
$attr
,
$idx
) =
@_
;
return
(
'## '
.
$attr
->name,
$self
->_inline_check_required_attr(
$attr
),
$self
->SUPER::_inline_slot_initializer(
@_
),
);
}
sub
_inline_check_required_attr {
my
$self
=
shift
;
my
(
$attr
) =
@_
;
return
unless
defined
$attr
->init_arg;
return
unless
$attr
->can(
'is_required'
) &&
$attr
->is_required;
return
if
$attr
->has_default ||
$attr
->has_builder;
my
$throw
=
$self
->_inline_throw_exception(
'AttributeIsRequired'
,
sprintf
(
<<'EOF', quotemeta( $attr->name ), quotemeta( $attr->init_arg ) ), );
params => $params,
class_name => $class_name,
attribute_name => "%s",
attribute_init_arg => "%s",
EOF
return
sprintf
(
<<'EOF', quotemeta( $attr->init_arg ), $throw )
if ( !exists $params->{"%s"} ) {
%s;
}
EOF
}
sub
_inline_init_attr_from_constructor {
my
$self
=
shift
;
my
(
$attr
,
$idx
) =
@_
;
my
@initial_value
=
$attr
->_inline_set_value(
'$instance'
,
'$params->{\''
.
$attr
->init_arg .
'\'}'
,
'$type_constraint_bodies['
.
$idx
.
']'
,
'$type_coercions['
.
$idx
.
']'
,
'$type_constraint_messages['
.
$idx
.
']'
,
'for constructor'
,
);
push
@initial_value
, (
'$attrs->['
.
$idx
.
']->set_initial_value('
,
'$instance,'
,
$attr
->_inline_instance_get(
'$instance'
),
');'
,
)
if
$attr
->has_initializer;
return
@initial_value
;
}
sub
_inline_init_attr_from_default {
my
$self
=
shift
;
my
(
$attr
,
$idx
) =
@_
;
return
if
$attr
->can(
'is_lazy'
) &&
$attr
->is_lazy;
my
$default
=
$self
->_inline_default_value(
$attr
,
$idx
);
return
unless
$default
;
my
@initial_value
= (
'my $default = '
.
$default
.
';'
,
$attr
->_inline_set_value(
'$instance'
,
'$default'
,
'$type_constraint_bodies['
.
$idx
.
']'
,
'$type_coercions['
.
$idx
.
']'
,
'$type_constraint_messages['
.
$idx
.
']'
,
'for constructor'
,
),
);
push
@initial_value
, (
'$attrs->['
.
$idx
.
']->set_initial_value('
,
'$instance,'
,
$attr
->_inline_instance_get(
'$instance'
),
');'
,
)
if
$attr
->has_initializer;
return
@initial_value
;
}
sub
_inline_extra_init {
my
$self
=
shift
;
return
(
$self
->_inline_triggers,
$self
->_inline_BUILDALL,
);
}
sub
_inline_triggers {
my
$self
=
shift
;
my
@trigger_calls
;
my
@attrs
=
sort
{
$a
->name cmp
$b
->name }
$self
->get_all_attributes;
for
my
$i
(0 ..
$#attrs
) {
my
$attr
=
$attrs
[
$i
];
next
unless
$attr
->can(
'has_trigger'
) &&
$attr
->has_trigger;
my
$init_arg
=
$attr
->init_arg;
next
unless
defined
$init_arg
;
push
@trigger_calls
,
'if (exists $params->{\''
.
$init_arg
.
'\'}) {'
,
'$triggers->['
.
$i
.
']->('
,
'$instance,'
,
$attr
->_inline_instance_get(
'$instance'
) .
','
,
');'
,
'}'
;
}
return
@trigger_calls
;
}
sub
_inline_BUILDALL {
my
$self
=
shift
;
my
@methods
=
reverse
$self
->find_all_methods_by_name(
'BUILD'
);
return
()
unless
@methods
;
my
@BUILD_calls
;
foreach
my
$method
(
@methods
) {
push
@BUILD_calls
,
'$instance->'
.
$method
->{class} .
'::BUILD($params);'
;
}
return
(
'if (!$params->{__no_BUILD__}) {'
,
@BUILD_calls
,
'}'
,
);
}
sub
_eval_environment {
my
$self
=
shift
;
my
@attrs
=
sort
{
$a
->name cmp
$b
->name }
$self
->get_all_attributes;
my
$triggers
= [
map
{
$_
->can(
'has_trigger'
) &&
$_
->has_trigger ?
$_
->trigger :
undef
}
@attrs
];
my
@type_constraints
=
map
{
$_
->can(
'type_constraint'
) ?
$_
->type_constraint :
undef
}
@attrs
;
my
@type_constraint_bodies
=
map
{
defined
$_
?
$_
->_compiled_type_constraint :
undef
;
}
@type_constraints
;
my
@type_coercions
=
map
{
defined
$_
&&
$_
->has_coercion
?
$_
->coercion->_compiled_type_coercion
:
undef
}
@type_constraints
;
my
@type_constraint_messages
=
map
{
defined
$_
? (
$_
->has_message ?
$_
->message :
$_
->_default_message)
:
undef
}
@type_constraints
;
return
{
%{
$self
->SUPER::_eval_environment },
((any {
defined
&&
$_
->has_initializer }
@attrs
)
? (
'$attrs'
=> \[
@attrs
])
: ()),
'$triggers'
=> \
$triggers
,
'@type_coercions'
=> \
@type_coercions
,
'@type_constraint_bodies'
=> \
@type_constraint_bodies
,
'@type_constraint_messages'
=> \
@type_constraint_messages
,
(
map
{
defined
(
$_
) ? %{
$_
->inline_environment } : () }
@type_constraints
),
'$meta'
=> \
$self
,
'$class_name'
=> \(
$self
->name),
};
}
sub
superclasses {
my
$self
=
shift
;
my
$supers
= Data::OptList::mkopt(\
@_
);
foreach
my
$super
(@{
$supers
}) {
my
(
$name
,
$opts
) = @{
$super
};
Moose::Util::_load_user_class(
$name
,
$opts
);
my
$meta
= Class::MOP::class_of(
$name
);
throw_exception(
CanExtendOnlyClasses
=>
role_name
=>
$meta
->name )
if
$meta
&&
$meta
->isa(
'Moose::Meta::Role'
)
}
return
$self
->SUPER::superclasses(
map
{
$_
->[0] } @{
$supers
});
}
sub
add_attribute {
my
$self
=
shift
;
my
$attr
=
(blessed
$_
[0] &&
$_
[0]->isa(
'Class::MOP::Attribute'
)
?
$_
[0]
:
$self
->_process_attribute(
@_
));
$self
->SUPER::add_attribute(
$attr
);
if
(
$attr
->can(
'_check_associated_methods'
)) {
$attr
->_check_associated_methods;
}
return
$attr
;
}
sub
add_override_method_modifier {
my
(
$self
,
$name
,
$method
,
$_super_package
) =
@_
;
my
$existing_method
=
$self
->get_method(
$name
);
(!
$existing_method
)
|| throw_exception(
CannotOverrideLocalMethodIsPresent
=>
class_name
=>
$self
->name,
method
=>
$existing_method
,
);
$self
->add_method(
$name
=> Moose::Meta::Method::Overridden->new(
method
=>
$method
,
class
=>
$self
,
package
=>
$_super_package
,
name
=>
$name
,
));
}
sub
add_augment_method_modifier {
my
(
$self
,
$name
,
$method
) =
@_
;
my
$existing_method
=
$self
->get_method(
$name
);
throw_exception(
CannotAugmentIfLocalMethodPresent
=>
class_name
=>
$self
->name,
method
=>
$existing_method
,
)
if
(
$existing_method
);
$self
->add_method(
$name
=> Moose::Meta::Method::Augmented->new(
method
=>
$method
,
class
=>
$self
,
name
=>
$name
,
));
}
sub
_find_next_method_by_name_which_is_not_overridden {
my
(
$self
,
$name
) =
@_
;
foreach
my
$method
(
$self
->find_all_methods_by_name(
$name
)) {
return
$method
->{code}
if
blessed(
$method
->{code}) && !
$method
->{code}->isa(
'Moose::Meta::Method::Overridden'
);
}
return
undef
;
}
sub
_base_metaclasses {
my
$self
=
shift
;
my
%metaclasses
=
$self
->SUPER::_base_metaclasses;
for
my
$class
(
keys
%metaclasses
) {
$metaclasses
{
$class
} =~ s/^Class::MOP/Moose::Meta/;
}
return
(
%metaclasses
,
);
}
sub
_fix_class_metaclass_incompatibility {
my
$self
=
shift
;
my
(
$super_meta
) =
@_
;
$self
->SUPER::_fix_class_metaclass_incompatibility(
@_
);
if
(
$self
->_class_metaclass_can_be_made_compatible(
$super_meta
)) {
(
$self
->is_pristine)
|| throw_exception(
CannotFixMetaclassCompatibility
=>
class
=>
$self
,
superclass
=>
$super_meta
);
my
$super_meta_name
=
$super_meta
->_real_ref_name;
my
$class_meta_subclass_meta_name
= Moose::Util::_reconcile_roles_for_metaclass(blessed(
$self
),
$super_meta_name
);
my
$new_self
=
$class_meta_subclass_meta_name
->reinitialize(
$self
->name,
);
$self
->_replace_self(
$new_self
,
$class_meta_subclass_meta_name
);
}
}
sub
_fix_single_metaclass_incompatibility {
my
$self
=
shift
;
my
(
$metaclass_type
,
$super_meta
) =
@_
;
$self
->SUPER::_fix_single_metaclass_incompatibility(
@_
);
if
(
$self
->_single_metaclass_can_be_made_compatible(
$super_meta
,
$metaclass_type
)) {
(
$self
->is_pristine)
|| throw_exception(
CannotFixMetaclassCompatibility
=>
class
=>
$self
,
superclass
=>
$super_meta
,
metaclass_type
=>
$metaclass_type
);
my
$super_meta_name
=
$super_meta
->_real_ref_name;
my
$class_specific_meta_subclass_meta_name
= Moose::Util::_reconcile_roles_for_metaclass(
$self
->
$metaclass_type
,
$super_meta
->
$metaclass_type
);
my
$new_self
=
$super_meta
->reinitialize(
$self
->name,
$metaclass_type
=>
$class_specific_meta_subclass_meta_name
,
);
$self
->_replace_self(
$new_self
,
$super_meta_name
);
}
}
sub
_replace_self {
my
$self
=
shift
;
my
(
$new_self
,
$new_class
) =
@_
;
%$self
=
%$new_self
;
bless
$self
,
$new_class
;
my
$weaken
= Class::MOP::metaclass_is_weak(
$self
->name );
Class::MOP::store_metaclass_by_name(
$self
->name,
$self
);
Class::MOP::weaken_metaclass(
$self
->name )
if
$weaken
;
}
sub
_process_attribute {
my
(
$self
,
$name
,
@args
) =
@_
;
@args
= %{
$args
[0]}
if
scalar
@args
== 1 &&
ref
(
$args
[0]) eq
'HASH'
;
if
((
$name
||
''
) =~ /^\+(.*)/) {
return
$self
->_process_inherited_attribute($1,
@args
);
}
else
{
return
$self
->_process_new_attribute(
$name
,
@args
);
}
}
sub
_process_new_attribute {
my
(
$self
,
$name
,
@args
) =
@_
;
$self
->attribute_metaclass->interpolate_class_and_new(
$name
,
@args
);
}
sub
_process_inherited_attribute {
my
(
$self
,
$attr_name
,
%options
) =
@_
;
my
$inherited_attr
=
$self
->find_attribute_by_name(
$attr_name
);
(
defined
$inherited_attr
)
|| throw_exception(
NoAttributeFoundInSuperClass
=>
class_name
=>
$self
->name,
attribute_name
=>
$attr_name
,
params
=> \
%options
);
if
(
$inherited_attr
->isa(
'Moose::Meta::Attribute'
)) {
return
$inherited_attr
->clone_and_inherit_options(
%options
);
}
else
{
return
$inherited_attr
->Moose::Meta::Attribute::clone_and_inherit_options(
%options
);
}
}
sub
_restore_metaobjects_from {
my
$self
=
shift
;
my
(
$old_meta
) =
@_
;
$self
->SUPER::_restore_metaobjects_from(
$old_meta
);
for
my
$role
( @{
$old_meta
->roles } ) {
$self
->add_role(
$role
);
}
for
my
$application
( @{
$old_meta
->_get_role_applications } ) {
$application
->class(
$self
);
$self
->add_role_application (
$application
);
}
}
sub
_immutable_options {
my
(
$self
,
@args
) =
@_
;
$self
->SUPER::_immutable_options(
inline_destructor
=> 1,
inline_accessors
=> 0,
@args
,
);
}
sub
_fixup_attributes_after_rebless {
my
$self
=
shift
;
my
(
$instance
,
$rebless_from
,
%params
) =
@_
;
$self
->SUPER::_fixup_attributes_after_rebless(
$instance
,
$rebless_from
,
%params
);
$self
->_call_all_triggers(
$instance
, \
%params
);
}
our
$error_level
;
sub
_inline_throw_exception {
my
(
$self
,
$exception_type
,
$throw_args
) =
@_
;
return
'die Module::Runtime::use_module("Moose::Exception::'
.
$exception_type
.
'")->new('
. (
$throw_args
||
''
) .
')'
;
}
1;