BEGIN {
$Moose::Meta::Class::AUTHORITY
=
'cpan:STEVAN'
;
}
BEGIN {
$Moose::Meta::Class::VERSION
=
'2.0009'
;
}
Class::MOP::MiniTrait::apply(__PACKAGE__,
'Moose::Meta::Object::Trait'
);
__PACKAGE__->meta->add_attribute(
'roles'
=> (
reader
=>
'roles'
,
default
=>
sub
{ [] }
));
__PACKAGE__->meta->add_attribute(
'role_applications'
=> (
reader
=>
'_get_role_applications'
,
default
=>
sub
{ [] }
));
__PACKAGE__->meta->add_attribute(
Class::MOP::Attribute->new(
'immutable_trait'
=> (
accessor
=>
"immutable_trait"
,
default
=>
'Moose::Meta::Class::Immutable::Trait'
,
))
);
__PACKAGE__->meta->add_attribute(
'constructor_class'
=> (
accessor
=>
'constructor_class'
,
default
=>
'Moose::Meta::Method::Constructor'
,
));
__PACKAGE__->meta->add_attribute(
'destructor_class'
=> (
accessor
=>
'destructor_class'
,
default
=>
'Moose::Meta::Method::Destructor'
,
));
__PACKAGE__->meta->add_attribute(
'error_class'
=> (
accessor
=>
'error_class'
,
default
=>
'Moose::Error::Default'
,
));
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'
)
||
$class
->throw_error(
"You must pass an ARRAY ref of roles"
,
data
=>
$options
{roles})
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'
,
val_test
=>
sub
{
ref
(
$_
[0]) eq
'HASH'
},
});
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
) {
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
error_class
)
;
}
return
$self
->SUPER::reinitialize(
$pkg
,
%existing_classes
,
@_
,
);
}
sub
add_role {
my
(
$self
,
$role
) =
@_
;
(blessed(
$role
) &&
$role
->isa(
'Moose::Meta::Role'
))
||
$self
->throw_error(
"Roles must be instances of Moose::Meta::Role"
,
data
=>
$role
);
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'
))
||
$self
->throw_error(
"Role applications must be instances of Moose::Meta::Role::Application::ToClass"
,
data
=>
$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
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
)
||
$self
->throw_error(
"You must supply a role name to look for"
);
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
)
||
$self
->throw_error(
"You must supply a role name to look for"
);
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_error(
'"Single parameters to new() must be a HASH ref"'
,
'data => $_[0]'
,
) .
';'
,
'}'
,
'$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;
return
(
'if (!exists $params->{\''
.
$attr
->init_arg .
'\'}) {'
,
$self
->_inline_throw_error(
'"Attribute ('
.
quotemeta
(
$attr
->name) .
') is required"'
) .
';'
,
'}'
,
);
}
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_constraints['
.
$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_constraints['
.
$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
.
'\'}) {'
,
'$attrs->['
.
$i
.
']->trigger->('
,
'$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'
);
my
@BUILD_calls
;
foreach
my
$method
(
@methods
) {
push
@BUILD_calls
,
'$instance->'
.
$method
->{class} .
'::BUILD($params);'
;
}
return
@BUILD_calls
;
}
sub
superclasses {
my
$self
=
shift
;
my
$supers
= Data::OptList::mkopt(\
@_
);
foreach
my
$super
(@{
$supers
}) {
my
(
$name
,
$opts
) = @{
$super
};
Class::MOP::load_class(
$name
,
$opts
);
my
$meta
= Class::MOP::class_of(
$name
);
$self
->throw_error(
"You cannot inherit from a Moose Role ($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
) =
@_
;
(!
$self
->has_method(
$name
))
||
$self
->throw_error(
"Cannot add an override method if a local method is already present"
);
$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
) =
@_
;
(!
$self
->has_method(
$name
))
||
$self
->throw_error(
"Cannot add an augment method if a local method is already present"
);
$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
,
error_class
=>
'Moose::Error::Default'
,
);
}
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)
|| confess
"Can't fix metaclass incompatibility for "
.
$self
->name
.
" because it is not pristine."
;
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)
|| confess
"Can't fix metaclass incompatibility for "
.
$self
->name
.
" because it is not pristine."
;
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
)
||
$self
->throw_error(
"Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}"
,
data
=>
$attr_name
);
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
throw_error {
my
(
$self
,
@args
) =
@_
;
local
$error_level
= (
$error_level
|| 0) + 1;
$self
->raise_error(
$self
->create_error(
@args
));
}
sub
_inline_throw_error {
my
(
$self
,
$msg
,
$args
) =
@_
;
"\$meta->throw_error($msg"
. (
$args
?
", $args"
:
""
) .
")"
;
}
sub
raise_error {
my
(
$self
,
@args
) =
@_
;
die
@args
;
}
sub
create_error {
my
(
$self
,
@args
) =
@_
;
local
$error_level
= (
$error_level
|| 0 ) + 1;
if
(
@args
% 2 == 1 ) {
unshift
@args
,
"message"
;
}
my
%args
= (
metaclass
=>
$self
,
last_error
=> $@,
@args
);
$args
{depth} +=
$error_level
;
my
$class
=
ref
$self
?
$self
->error_class :
"Moose::Error::Default"
;
Class::MOP::load_class(
$class
);
$class
->new(
Carp::caller_info(
$args
{depth}),
%args
);
}
1;