our
$VERSION
=
'2.2207'
;
my
%EXPORT_SPEC
;
sub
setup_import_methods {
my
(
$class
,
%args
) =
@_
;
$args
{exporting_package} ||=
caller
();
$class
->build_import_methods(
%args
,
install
=> [
qw(import unimport init_meta)
]
);
}
sub
build_import_methods {
my
(
$class
,
%args
) =
@_
;
my
$exporting_package
=
$args
{exporting_package} ||=
caller
();
my
$meta_lookup
=
$args
{meta_lookup} ||
sub
{ Class::MOP::class_of(
shift
) };
$EXPORT_SPEC
{
$exporting_package
} = \
%args
;
my
@exports_from
=
$class
->_follow_also(
$exporting_package
);
my
$export_recorder
= {};
my
$is_reexport
= {};
my
$exports
=
$class
->_make_sub_exporter_params(
[
$exporting_package
,
@exports_from
],
$export_recorder
,
$is_reexport
,
$args
{meta_lookup},
);
my
$exporter
=
$class
->_make_exporter(
$exports
,
$is_reexport
,
$meta_lookup
,
);
my
%methods
;
$methods
{
import
} =
$class
->_make_import_sub(
$exporting_package
,
$exporter
,
\
@exports_from
,
$is_reexport
,
$meta_lookup
,
);
$methods
{unimport} =
$class
->_make_unimport_sub(
$exporting_package
,
$exports
,
$export_recorder
,
$is_reexport
,
$meta_lookup
,
);
$methods
{init_meta} =
$class
->_make_init_meta(
$exporting_package
,
\
%args
,
$meta_lookup
,
);
my
$package
= Class::MOP::Package->initialize(
$exporting_package
);
for
my
$to_install
( @{
$args
{install} || [] } ) {
my
$symbol
=
'&'
.
$to_install
;
next
unless
$methods
{
$to_install
}
&& !
$package
->has_package_symbol(
$symbol
);
$package
->add_package_symbol(
$symbol
,
set_subname(
$exporting_package
.
'::'
.
$to_install
=>
$methods
{
$to_install
} )
);
}
return
(
$methods
{
import
},
$methods
{unimport},
$methods
{init_meta} );
}
sub
_make_exporter {
my
(
$class
,
$exports
,
$is_reexport
,
$meta_lookup
) =
@_
;
return
Sub::Exporter::build_exporter(
{
exports
=>
$exports
,
groups
=> {
default
=> [
':all'
] },
installer
=>
sub
{
my
(
$arg
,
$to_export
) =
@_
;
my
$meta
=
$meta_lookup
->(
$arg
->{into});
goto
&Sub::Exporter::default_installer
unless
$meta
;
my
@filtered_to_export
;
my
%installed
;
for
(
my
$i
= 0;
$i
< @{
$to_export
};
$i
+= 2) {
my
(
$as
,
$cv
) = @{
$to_export
}[
$i
,
$i
+ 1];
next
if
!
ref
(
$as
)
&&
$meta
->has_package_symbol(
'&'
.
$as
)
&&
$meta
->get_package_symbol(
'&'
.
$as
) ==
$cv
;
push
@filtered_to_export
,
$as
,
$cv
;
$installed
{
$as
} = 1
unless
ref
$as
;
}
Sub::Exporter::default_installer(
$arg
, \
@filtered_to_export
);
for
my
$name
(
keys
%{
$is_reexport
} ) {
no
strict
'refs'
;
no
warnings
'once'
;
next
unless
exists
$installed
{
$name
};
_flag_as_reexport( \*{
join
q{::}
,
$arg
->{into},
$name
} );
}
},
}
);
}
sub
_follow_also {
my
$class
=
shift
;
my
$exporting_package
=
shift
;
_die_if_cycle_found_in_also_list_for_package(
$exporting_package
);
return
uniq( _follow_also_real(
$exporting_package
) );
}
sub
_follow_also_real {
my
$exporting_package
=
shift
;
my
@also
= _also_list_for_package(
$exporting_package
);
return
map
{
$_
, _follow_also_real(
$_
) }
@also
;
}
sub
_also_list_for_package {
my
$package
=
shift
;
if
( !
exists
$EXPORT_SPEC
{
$package
} ) {
my
$loaded
= is_class_loaded(
$package
);
throw_exception(
PackageDoesNotUseMooseExporter
=>
package
=>
$package
,
is_loaded
=>
$loaded
);
}
my
$also
=
$EXPORT_SPEC
{
$package
}{also};
return
unless
defined
$also
;
return
ref
$also
?
@$also
:
$also
;
}
sub
_die_if_cycle_found_in_also_list_for_package {
my
$package
=
shift
;
_die_if_also_list_cycles_back_to_existing_stack(
[ _also_list_for_package(
$package
) ],
[
$package
],
);
}
sub
_die_if_also_list_cycles_back_to_existing_stack {
my
(
$also_list
,
$existing_stack
) =
@_
;
return
unless
@$also_list
&&
@$existing_stack
;
for
my
$also_member
(
@$also_list
) {
for
my
$stack_member
(
@$existing_stack
) {
next
unless
$also_member
eq
$stack_member
;
throw_exception(
CircularReferenceInAlso
=>
also_parameter
=>
$also_member
,
stack
=>
$existing_stack
);
}
_die_if_also_list_cycles_back_to_existing_stack(
[ _also_list_for_package(
$also_member
) ],
[
$also_member
,
@$existing_stack
],
);
}
}
sub
_parse_trait_aliases {
my
$class
=
shift
;
my
(
$package
,
$aliases
) =
@_
;
my
@ret
;
for
my
$alias
(
@$aliases
) {
my
$name
;
if
(
ref
(
$alias
)) {
reftype(
$alias
) eq
'ARRAY'
or throw_exception(
InvalidArgumentsToTraitAliases
=>
class_name
=>
$class
,
package_name
=>
$package
,
alias
=>
$alias
);
(
$alias
,
$name
) =
@$alias
;
}
else
{
(
$name
=
$alias
) =~ s/.*:://;
}
push
@ret
, set_subname(
"${package}::${name}"
=>
sub
() {
$alias
} );
}
return
@ret
;
}
sub
_make_sub_exporter_params {
my
$class
=
shift
;
my
$packages
=
shift
;
my
$export_recorder
=
shift
;
my
$is_reexport
=
shift
;
my
$meta_lookup_override
=
shift
;
my
%exports
;
my
$current_meta_lookup
;
for
my
$package
( @{
$packages
} ) {
my
$args
=
$EXPORT_SPEC
{
$package
}
or
die
"The $package package does not use Moose::Exporter\n"
;
$current_meta_lookup
=
$meta_lookup_override
||
$args
->{meta_lookup};
$meta_lookup_override
=
$current_meta_lookup
;
my
$meta_lookup
=
$current_meta_lookup
||
sub
{ Class::MOP::class_of(
shift
) };
for
my
$name
( @{
$args
->{with_meta} } ) {
my
$sub
=
$class
->_sub_from_package(
$package
,
$name
)
or
next
;
my
$fq_name
=
$package
.
'::'
.
$name
;
$exports
{
$name
} =
$class
->_make_wrapped_sub_with_meta(
$fq_name
,
$sub
,
$export_recorder
,
$meta_lookup
,
)
unless
exists
$exports
{
$name
};
}
for
my
$name
( @{
$args
->{with_caller} } ) {
my
$sub
=
$class
->_sub_from_package(
$package
,
$name
)
or
next
;
my
$fq_name
=
$package
.
'::'
.
$name
;
$exports
{
$name
} =
$class
->_make_wrapped_sub(
$fq_name
,
$sub
,
$export_recorder
,
)
unless
exists
$exports
{
$name
};
}
my
@extra_exports
=
$class
->_parse_trait_aliases(
$package
,
$args
->{trait_aliases},
);
for
my
$name
( @{
$args
->{as_is} },
@extra_exports
) {
my
(
$sub
,
$coderef_name
);
if
(
ref
$name
) {
$sub
=
$name
;
my
$coderef_pkg
;
(
$coderef_pkg
,
$coderef_name
)
= Class::MOP::get_code_info(
$name
);
if
(
$coderef_pkg
ne
$package
) {
$is_reexport
->{
$coderef_name
} = 1;
}
}
elsif
(
$name
=~ /^(.*)::([^:]+)$/ ) {
$sub
=
$class
->_sub_from_package(
"$1"
,
"$2"
)
or
next
;
$coderef_name
=
"$2"
;
if
( $1 ne
$package
) {
$is_reexport
->{
$coderef_name
} = 1;
}
}
else
{
$sub
=
$class
->_sub_from_package(
$package
,
$name
)
or
next
;
$coderef_name
=
$name
;
}
$export_recorder
->{
$sub
} = 1;
$exports
{
$coderef_name
} =
sub
{
$sub
}
unless
exists
$exports
{
$coderef_name
};
}
}
return
\
%exports
;
}
sub
_sub_from_package {
my
$sclass
=
shift
;
my
$package
=
shift
;
my
$name
=
shift
;
my
$sub
=
do
{
no
strict
'refs'
;
\&{
$package
.
'::'
.
$name
};
};
return
$sub
if
defined
&$sub
;
Carp::cluck
"Trying to export undefined sub ${package}::${name}"
;
return
;
}
our
$CALLER
;
sub
_make_wrapped_sub {
my
$self
=
shift
;
my
$fq_name
=
shift
;
my
$sub
=
shift
;
my
$export_recorder
=
shift
;
return
sub
{
my
$caller
=
$CALLER
;
my
$wrapper
=
$self
->_curry_wrapper(
$sub
,
$fq_name
,
$caller
);
my
$sub
= set_subname(
$fq_name
=>
$wrapper
);
$export_recorder
->{
$sub
} = 1;
return
$sub
;
};
}
sub
_make_wrapped_sub_with_meta {
my
$self
=
shift
;
my
$fq_name
=
shift
;
my
$sub
=
shift
;
my
$export_recorder
=
shift
;
my
$meta_lookup
=
shift
;
return
sub
{
my
$caller
=
$CALLER
;
my
$wrapper
=
$self
->_late_curry_wrapper(
$sub
,
$fq_name
,
$meta_lookup
=>
$caller
);
my
$sub
= set_subname(
$fq_name
=>
$wrapper
);
$export_recorder
->{
$sub
} = 1;
return
$sub
;
};
}
sub
_curry_wrapper {
my
$class
=
shift
;
my
$sub
=
shift
;
my
$fq_name
=
shift
;
my
@extra
=
@_
;
my
$wrapper
=
sub
{
$sub
->(
@extra
,
@_
) };
if
(
my
$proto
=
prototype
$sub
) {
&Scalar::Util::set_prototype
(
$wrapper
,
$proto
);
}
return
$wrapper
;
}
sub
_late_curry_wrapper {
my
$class
=
shift
;
my
$sub
=
shift
;
my
$fq_name
=
shift
;
my
$extra
=
shift
;
my
@ex_args
=
@_
;
my
$wrapper
=
sub
{
my
@curry
= (
$extra
->(
@ex_args
) );
return
$sub
->(
@curry
,
@_
);
};
if
(
my
$proto
=
prototype
$sub
) {
&Scalar::Util::set_prototype
(
$wrapper
,
$proto
);
}
return
$wrapper
;
}
sub
_make_import_sub {
shift
;
my
$exporting_package
=
shift
;
my
$exporter
=
shift
;
my
$exports_from
=
shift
;
my
$is_reexport
=
shift
;
my
$meta_lookup
=
shift
;
return
sub
{
my
$traits
;
(
$traits
,
@_
) = _strip_traits(
@_
);
my
$metaclass
;
(
$metaclass
,
@_
) = _strip_metaclass(
@_
);
$metaclass
= Moose::Util::resolve_metaclass_alias(
'Class'
=>
$metaclass
)
if
defined
$metaclass
&&
length
$metaclass
;
my
$meta_name
;
(
$meta_name
,
@_
) = _strip_meta_name(
@_
);
my
$class
=
$exporting_package
;
$CALLER
= _get_caller(
@_
);
strict->
import
;
warnings->
import
;
my
$did_init_meta
;
for
my
$c
(
grep
{
$_
->can(
'init_meta'
) }
$class
, @{
$exports_from
} ) {
local
$CALLER
=
$CALLER
;
$c
->init_meta(
for_class
=>
$CALLER
,
metaclass
=>
$metaclass
,
meta_name
=>
$meta_name
,
);
$did_init_meta
= 1;
}
{
local
$CALLER
=
$CALLER
;
_apply_metaroles(
$CALLER
,
[
$class
,
@$exports_from
],
$meta_lookup
);
}
if
(
$did_init_meta
&& @{
$traits
} ) {
local
$CALLER
=
$CALLER
;
_apply_meta_traits(
$CALLER
,
$traits
,
$meta_lookup
);
}
elsif
( @{
$traits
} ) {
throw_exception(
ClassDoesNotHaveInitMeta
=>
class_name
=>
$class
,
traits
=>
$traits
);
}
my
(
undef
,
@args
) =
@_
;
my
$extra
=
shift
@args
if
ref
$args
[0] eq
'HASH'
;
$extra
||= {};
if
( !
$extra
->{into} ) {
$extra
->{into_level} ||= 0;
$extra
->{into_level}++;
}
$class
->
$exporter
(
$extra
,
@args
);
};
}
sub
_strip_option {
my
$option_name
=
shift
;
my
$default
=
shift
;
for
my
$i
( 0 ..
$#_
- 1 ) {
if
((
$_
[
$i
] ||
''
) eq
$option_name
) {
(
undef
,
my
$value
) =
splice
@_
,
$i
, 2;
return
(
$value
,
@_
);
}
}
return
(
$default
,
@_
);
}
sub
_strip_traits {
my
(
$traits
,
@other
) = _strip_option(
'-traits'
, [],
@_
);
$traits
=
ref
$traits
?
$traits
: [
$traits
];
return
(
$traits
,
@other
);
}
sub
_strip_metaclass {
_strip_option(
'-metaclass'
,
undef
,
@_
);
}
sub
_strip_meta_name {
_strip_option(
'-meta_name'
,
'meta'
,
@_
);
}
sub
_apply_metaroles {
my
(
$class
,
$exports_from
,
$meta_lookup
) =
@_
;
my
$metaroles
= _collect_metaroles(
$exports_from
);
my
$base_class_roles
=
delete
$metaroles
->{base_class_roles};
my
$meta
=
$meta_lookup
->(
$class
);
return
unless
$meta
;
Moose::Util::MetaRole::apply_metaroles(
for
=>
$meta
,
%$metaroles
,
)
if
keys
%$metaroles
;
Moose::Util::MetaRole::apply_base_class_roles(
for
=>
$meta
,
roles
=>
$base_class_roles
,
)
if
$meta
->isa(
'Class::MOP::Class'
)
&&
$base_class_roles
&&
@$base_class_roles
;
}
sub
_collect_metaroles {
my
(
$exports_from
) =
@_
;
my
@old_style_role_types
=
map
{
"${_}_roles"
}
qw(
metaclass
attribute_metaclass
method_metaclass
wrapped_method_metaclass
instance_metaclass
constructor_class
destructor_class
error_class
)
;
my
%class_metaroles
;
my
%role_metaroles
;
my
@base_class_roles
;
my
%old_style_roles
;
for
my
$exporter
(
@$exports_from
) {
my
$data
=
$EXPORT_SPEC
{
$exporter
};
if
(
exists
$data
->{class_metaroles}) {
for
my
$type
(
keys
%{
$data
->{class_metaroles} }) {
push
@{
$class_metaroles
{
$type
} ||= [] },
@{
$data
->{class_metaroles}{
$type
} };
}
}
if
(
exists
$data
->{role_metaroles}) {
for
my
$type
(
keys
%{
$data
->{role_metaroles} }) {
push
@{
$role_metaroles
{
$type
} ||= [] },
@{
$data
->{role_metaroles}{
$type
} };
}
}
if
(
exists
$data
->{base_class_roles}) {
push
@base_class_roles
, @{
$data
->{base_class_roles} };
}
for
my
$type
(
@old_style_role_types
) {
if
(
exists
$data
->{
$type
}) {
push
@{
$old_style_roles
{
$type
} ||= [] },
@{
$data
->{
$type
} };
}
}
}
return
{
(
keys
(
%class_metaroles
)
? (
class_metaroles
=> \
%class_metaroles
)
: ()),
(
keys
(
%role_metaroles
)
? (
role_metaroles
=> \
%role_metaroles
)
: ()),
(
@base_class_roles
? (
base_class_roles
=> \
@base_class_roles
)
: ()),
%old_style_roles
,
};
}
sub
_apply_meta_traits {
my
(
$class
,
$traits
,
$meta_lookup
) =
@_
;
return
unless
@{
$traits
};
my
$meta
=
$meta_lookup
->(
$class
);
my
$type
=
$meta
->isa(
'Moose::Meta::Role'
) ?
'Role'
:
$meta
->isa(
'Class::MOP::Class'
) ?
'Class'
: confess(
'Cannot determine metaclass type for '
.
'trait application. Meta isa '
.
ref
$meta
);
my
@resolved_traits
=
map
{
ref
$_
?
$_
: Moose::Util::resolve_metatrait_alias(
$type
=>
$_
)
}
@$traits
;
return
unless
@resolved_traits
;
my
%args
= (
for
=>
$class
);
if
(
$meta
->isa(
'Moose::Meta::Role'
) ) {
$args
{role_metaroles} = {
role
=> \
@resolved_traits
};
}
else
{
$args
{class_metaroles} = {
class
=> \
@resolved_traits
};
}
Moose::Util::MetaRole::apply_metaroles(
%args
);
}
sub
_get_caller {
my
$offset
= 1;
return
(
ref
$_
[1] &&
defined
$_
[1]->{into} ) ?
$_
[1]->{into}
: (
ref
$_
[1] &&
defined
$_
[1]->{into_level} )
?
caller
(
$offset
+
$_
[1]->{into_level} )
:
caller
(
$offset
);
}
sub
_make_unimport_sub {
shift
;
my
$exporting_package
=
shift
;
my
$exports
=
shift
;
my
$export_recorder
=
shift
;
my
$is_reexport
=
shift
;
my
$meta_lookup
=
shift
;
return
sub
{
my
$caller
= _get_caller(
@_
);
Moose::Exporter->_remove_keywords(
$caller
,
[
keys
%{
$exports
} ],
$export_recorder
,
$is_reexport
,
);
};
}
sub
_remove_keywords {
shift
;
my
$package
=
shift
;
my
$keywords
=
shift
;
my
$recorded_exports
=
shift
;
my
$is_reexport
=
shift
;
no
strict
'refs'
;
foreach
my
$name
( @{
$keywords
} ) {
if
(
defined
&{
$package
.
'::'
.
$name
} ) {
my
$sub
= \&{
$package
.
'::'
.
$name
};
next
unless
$recorded_exports
->{
$sub
};
if
(
$is_reexport
->{
$name
} ) {
no
strict
'refs'
;
next
unless
_export_is_flagged(
\*{
join
q{::}
=>
$package
,
$name
} );
}
delete
${
$package
.
'::'
}{
$name
};
}
}
}
sub
_make_init_meta {
shift
;
my
$class
=
shift
;
my
$args
=
shift
;
my
$meta_lookup
=
shift
;
my
%old_style_roles
;
for
my
$role
(
map
{
"${_}_roles"
}
qw(
metaclass
attribute_metaclass
method_metaclass
wrapped_method_metaclass
instance_metaclass
constructor_class
destructor_class
error_class
)
) {
$old_style_roles
{
$role
} =
$args
->{
$role
}
if
exists
$args
->{
$role
};
}
my
%base_class_roles
;
%base_class_roles
= (
roles
=>
$args
->{base_class_roles} )
if
exists
$args
->{base_class_roles};
my
%new_style_roles
=
map
{
$_
=>
$args
->{
$_
} }
grep
{
exists
$args
->{
$_
} }
qw( class_metaroles role_metaroles )
;
return
unless
%new_style_roles
||
%old_style_roles
||
%base_class_roles
;
return
sub
{
shift
;
my
%opts
=
@_
;
$meta_lookup
->(
$opts
{for_class});
};
}
sub
import
{
strict->
import
;
warnings->
import
;
}
1;