sub
get_linear_isa($;$);
sub
install_subroutines {
my
$into
=
shift
;
while
(
my
(
$name
,
$code
) =
splice
@_
, 0, 2){
no
strict
'refs'
;
no
warnings
'once'
,
'redefine'
;
*{
$into
.
'::'
.
$name
} = \&{
$code
};
}
return
;
}
BEGIN{
Mouse::Exporter->setup_import_methods(
as_is
=> [
qw(
find_meta
does_role
resolve_metaclass_alias
apply_all_roles
english_list
load_class
is_class_loaded
get_linear_isa
get_code_info
get_code_package
get_code_ref
not_supported
does meta throw_error dump
)
],
groups
=> {
default
=> [],
meta
=> [
qw(does meta dump throw_error)
],
},
);
use
version;
our
$VERSION
= version->declare(
'v2.5.11'
);
my
$xs
= !(
defined
(
&is_valid_class_name
) ||
$ENV
{MOUSE_PUREPERL} ||
$ENV
{PERL_ONLY});
if
(
$xs
){
(
my
$hack_mouse_file
= __FILE__) =~ s/.Util//;
$xs
=
eval
sprintf
(
"#line %d %s\n"
, __LINE__,
$hack_mouse_file
) .
q{
local $^W = 0; # workaround 'redefine' warning to &install_subroutines
no warnings 'redefine';
require XSLoader;
XSLoader::load('Mouse', $VERSION);
Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }
,
':meta'
);
Mouse::Util->
import
({
into
=>
'Mouse::Meta::Method::Destructor::XS'
},
':meta'
);
Mouse::Util->
import
({
into
=>
'Mouse::Meta::Method::Accessor::XS'
},
':meta'
);
return
1;
} || 0;
warn
$@
if
$@ &&
$ENV
{MOUSE_XS};
}
if
(!
$xs
){
require
'Mouse/PurePerl.pm'
;
}
{
my
$value
=
$xs
;
*MOUSE_XS
=
sub
(){
$value
};
}
my
$get_linear_isa
;
if
($] >= 5.010_000) {
require
'mro.pm'
;
$get_linear_isa
= \
&mro::get_linear_isa
;
}
else
{
my
$_get_linear_isa_dfs
;
$_get_linear_isa_dfs
=
sub
{
my
(
$classname
) =
@_
;
my
@lin
= (
$classname
);
my
%stored
;
no
strict
'refs'
;
foreach
my
$parent
(@{
"$classname\::ISA"
}) {
foreach
my
$p
(@{
$_get_linear_isa_dfs
->(
$parent
) }) {
next
if
exists
$stored
{
$p
};
push
(
@lin
,
$p
);
$stored
{
$p
} = 1;
}
}
return
\
@lin
;
};
{
package
Class::C3;
our
%MRO
;
}
$get_linear_isa
=
sub
($;$){
my
(
$classname
,
$type
) =
@_
;
if
(!
defined
$type
){
$type
=
exists
$Class::C3::MRO
{
$classname
} ?
'c3'
:
'dfs'
;
}
if
(
$type
eq
'c3'
){
return
[Class::C3::calculateMRO(
$classname
)];
}
else
{
return
$_get_linear_isa_dfs
->(
$classname
);
}
};
}
*get_linear_isa
=
$get_linear_isa
;
}
{
*class_of
= \
&Mouse::Meta::Module::_class_of
;
*get_metaclass_by_name
= \
&Mouse::Meta::Module::_get_metaclass_by_name
;
*get_all_metaclass_instances
= \
&Mouse::Meta::Module::_get_all_metaclass_instances
;
*get_all_metaclass_names
= \
&Mouse::Meta::Module::_get_all_metaclass_names
;
*Mouse::load_class
= \
&load_class
;
*Mouse::is_class_loaded
= \
&is_class_loaded
;
generate_can_predicate_for([
'_compiled_type_constraint'
] =>
'is_a_type_constraint'
);
generate_can_predicate_for([
'create_anon_class'
] =>
'is_a_metaclass'
);
generate_can_predicate_for([
'create_anon_role'
] =>
'is_a_metarole'
);
}
sub
in_global_destruction;
if
(
defined
${^GLOBAL_PHASE}) {
*in_global_destruction
=
sub
{
return
${^GLOBAL_PHASE} eq
'DESTRUCT'
;
};
}
else
{
my
$in_global_destruction
= 0;
END {
$in_global_destruction
= 1 }
*in_global_destruction
=
sub
{
return
$in_global_destruction
;
};
}
sub
find_meta{
return
class_of(
$_
[0] );
}
sub
_does_role_impl {
my
(
$class_or_obj
,
$role_name
) =
@_
;
my
$meta
= class_of(
$class_or_obj
);
(
defined
$role_name
)
|| (
$meta
||
'Mouse::Meta::Class'
)->throw_error(
"You must supply a role name to does()"
);
return
defined
(
$meta
) &&
$meta
->does_role(
$role_name
);
}
sub
does_role {
my
(
$thing
,
$role_name
) =
@_
;
if
( (Scalar::Util::blessed(
$thing
) || is_class_loaded(
$thing
))
&&
$thing
->can(
'does'
)) {
return
$thing
->does(
$role_name
);
}
goto
&_does_role_impl
;
}
{
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
} ||=
do
{
my
$possible_full_name
=
join
'::'
,
'Mouse::Meta'
,
$type
,
'Custom'
, (
$options
{trait} ?
'Trait'
: ()),
$metaclass_name
;
my
$loaded_class
= load_first_existing_class(
$possible_full_name
,
$metaclass_name
);
$loaded_class
->can(
'register_implementation'
)
?
$loaded_class
->register_implementation
:
$loaded_class
;
};
}
}
sub
module_notional_filename {
my
$class
=
shift
;
$class
=~ s{::}{/}g;
return
$class
.
'.pm'
;
}
sub
get_code_info;
sub
get_code_package;
sub
is_valid_class_name;
sub
is_class_loaded;
sub
load_first_existing_class {
my
@classes
=
@_
or
return
;
my
%exceptions
;
for
my
$class
(
@classes
) {
my
$e
= _try_load_one_class(
$class
);
if
(
$e
) {
$exceptions
{
$class
} =
$e
;
}
else
{
return
$class
;
}
}
Carp::confess
join
(
"\n"
,
map
{
sprintf
(
"Could not load class (%s) because : %s"
,
$_
,
$exceptions
{
$_
} )
}
@classes
);
}
sub
_try_load_one_class {
my
$class
=
shift
;
unless
( is_valid_class_name(
$class
) ) {
my
$display
=
defined
(
$class
) ?
$class
:
'undef'
;
Carp::confess
"Invalid class name ($display)"
;
}
return
''
if
is_class_loaded(
$class
);
my
$filename
= module_notional_filename(
$class
);
return
do
{
local
$@;
eval
{
require
$filename
};
$@;
};
}
sub
load_class {
my
$class
=
shift
;
my
$e
= _try_load_one_class(
$class
);
Carp::confess
"Could not load class ($class) because : $e"
if
$e
;
return
$class
;
}
sub
apply_all_roles {
my
$consumer
= Scalar::Util::blessed(
$_
[0])
?
$_
[0]
: Mouse::Meta::Class->initialize(
$_
[0]);
my
@roles
;
my
$max
=
scalar
(
@_
);
for
(
my
$i
= 1;
$i
<
$max
;
$i
++) {
my
$role
=
$_
[
$i
];
my
$role_name
;
if
(
ref
$role
) {
$role_name
=
$role
->name;
}
else
{
$role_name
=
$role
;
load_class(
$role_name
);
$role
= get_metaclass_by_name(
$role_name
);
}
if
(
$i
+ 1 <
$max
&&
ref
(
$_
[
$i
+ 1]) eq
'HASH'
) {
push
@roles
, [
$role
=>
$_
[++
$i
] ];
}
else
{
push
@roles
, [
$role
=>
undef
];
}
is_a_metarole(
$role
)
||
$consumer
->meta->throw_error(
"You can only consume roles, $role_name is not a Mouse role"
);
}
if
(
scalar
@roles
== 1 ) {
my
(
$role
,
$params
) = @{
$roles
[0] };
$role
->apply(
$consumer
,
defined
$params
?
$params
: () );
}
else
{
Mouse::Meta::Role->combine(
@roles
)->apply(
$consumer
);
}
return
;
}
sub
english_list {
return
$_
[0]
if
@_
== 1;
my
@items
=
sort
@_
;
return
"$items[0] and $items[1]"
if
@items
== 2;
my
$tail
=
pop
@items
;
return
join
q{, }
,
@items
,
"and $tail"
;
}
sub
quoted_english_list {
return
english_list(
map
{
qq{'$_'}
}
@_
);
}
sub
not_supported{
my
(
$feature
) =
@_
;
$feature
||= (
caller
(1) )[3] .
'()'
;
local
$Carp::CarpLevel
=
$Carp::CarpLevel
+ 1;
Carp::confess(
"Mouse does not currently support $feature"
);
}
sub
meta :method{
return
Mouse::Meta::Class->initialize(
ref
(
$_
[0]) ||
$_
[0]);
}
sub
throw_error :method {
my
(
$self
,
$message
,
%args
) =
@_
;
local
$Carp::CarpLevel
=
$Carp::CarpLevel
+ 1 + (
$args
{depth} || 0);
local
$Carp::MaxArgNums
= 20;
if
(
exists
$args
{longmess} && !
$args
{longmess}) {
Carp::croak(
$message
);
}
else
{
Carp::confess(
$message
);
}
}
sub
dump
:method {
my
(
$self
,
$maxdepth
) =
@_
;
require
'Data/Dumper.pm'
;
my
$dd
= Data::Dumper->new([
$self
]);
$dd
->Maxdepth(
defined
(
$maxdepth
) ?
$maxdepth
: 3);
$dd
->Indent(1);
$dd
->Sortkeys(1);
$dd
->Quotekeys(0);
return
$dd
->Dump();
}
sub
does :method {
goto
&_does_role_impl
;
}
1;