our
$VERSION
=
'0.73'
;
$VERSION
=
eval
$VERSION
;
our
$AUTHORITY
=
'cpan:STEVAN'
;
sub
initialize {
my
(
$class
,
@args
) =
@_
;
unshift
@args
,
"package"
if
@args
% 2;
my
%options
=
@args
;
my
$package_name
=
$options
{
package
};
if
(
my
$meta
= Class::MOP::get_metaclass_by_name(
$package_name
) ) {
return
$meta
;
}
else
{
my
$meta
= (
ref
$class
||
$class
)->_new({
'package'
=>
$package_name
,
%options
,
});
Class::MOP::store_metaclass_by_name(
$package_name
,
$meta
);
return
$meta
;
}
}
sub
reinitialize {
my
(
$class
,
@args
) =
@_
;
unshift
@args
,
"package"
if
@args
% 2;
my
%options
=
@args
;
my
$package_name
=
delete
$options
{
package
};
(
defined
$package_name
&&
$package_name
&& !blessed(
$package_name
))
|| confess
"You must pass a package name and it cannot be blessed"
;
Class::MOP::remove_metaclass_by_name(
$package_name
);
$class
->initialize(
$package_name
,
%options
);
}
sub
_new {
my
$class
=
shift
;
my
$options
=
@_
== 1 ?
$_
[0] : {
@_
};
$options
->{namespace} ||= \
undef
;
bless
$options
,
$class
;
}
sub
name {
$_
[0]->{
'package'
} }
sub
namespace {
no
strict
'refs'
;
\%{
$_
[0]->{
'package'
} .
'::'
}
}
{
my
%SIGIL_MAP
= (
'$'
=>
'SCALAR'
,
'@'
=>
'ARRAY'
,
'%'
=>
'HASH'
,
'&'
=>
'CODE'
,
);
sub
_deconstruct_variable_name {
my
(
$self
,
$variable
) =
@_
;
(
defined
$variable
)
|| confess
"You must pass a variable name"
;
my
$sigil
=
substr
(
$variable
, 0, 1,
''
);
(
defined
$sigil
)
|| confess
"The variable name must include a sigil"
;
(
exists
$SIGIL_MAP
{
$sigil
})
|| confess
"I do not recognize that sigil '$sigil'"
;
return
(
$variable
,
$sigil
,
$SIGIL_MAP
{
$sigil
});
}
}
sub
add_package_symbol {
my
(
$self
,
$variable
,
$initial_value
) =
@_
;
my
(
$name
,
$sigil
,
$type
) =
ref
$variable
eq
'HASH'
? @{
$variable
}{
qw[name sigil type]
}
:
$self
->_deconstruct_variable_name(
$variable
);
my
$pkg
=
$self
->{
'package'
};
no
strict
'refs'
;
no
warnings
'redefine'
,
'misc'
;
*{
$pkg
.
'::'
.
$name
} =
ref
$initial_value
?
$initial_value
: \
$initial_value
;
}
sub
remove_package_glob {
my
(
$self
,
$name
) =
@_
;
no
strict
'refs'
;
delete
${
$self
->name .
'::'
}{
$name
};
}
sub
has_package_symbol {
my
(
$self
,
$variable
) =
@_
;
my
(
$name
,
$sigil
,
$type
) =
ref
$variable
eq
'HASH'
? @{
$variable
}{
qw[name sigil type]
}
:
$self
->_deconstruct_variable_name(
$variable
);
my
$namespace
=
$self
->namespace;
return
0
unless
exists
$namespace
->{
$name
};
if
(
ref
(
$namespace
->{
$name
}) eq
'SCALAR'
) {
return
(
$type
eq
'CODE'
);
}
elsif
(
$type
eq
'SCALAR'
) {
my
$val
= *{
$namespace
->{
$name
}}{
$type
};
return
defined
(${
$val
});
}
else
{
defined
(*{
$namespace
->{
$name
}}{
$type
});
}
}
sub
get_package_symbol {
my
(
$self
,
$variable
) =
@_
;
my
(
$name
,
$sigil
,
$type
) =
ref
$variable
eq
'HASH'
? @{
$variable
}{
qw[name sigil type]
}
:
$self
->_deconstruct_variable_name(
$variable
);
my
$namespace
=
$self
->namespace;
$self
->add_package_symbol(
$variable
)
unless
exists
$namespace
->{
$name
};
if
(
ref
(
$namespace
->{
$name
}) eq
'SCALAR'
) {
if
(
$type
eq
'CODE'
) {
no
strict
'refs'
;
return
\&{
$self
->name.
'::'
.
$name
};
}
else
{
return
undef
;
}
}
else
{
return
*{
$namespace
->{
$name
}}{
$type
};
}
}
sub
remove_package_symbol {
my
(
$self
,
$variable
) =
@_
;
my
(
$name
,
$sigil
,
$type
) =
ref
$variable
eq
'HASH'
? @{
$variable
}{
qw[name sigil type]
}
:
$self
->_deconstruct_variable_name(
$variable
);
my
(
$scalar_desc
,
$array_desc
,
$hash_desc
,
$code_desc
) = (
{
sigil
=>
'$'
,
type
=>
'SCALAR'
,
name
=>
$name
},
{
sigil
=>
'@'
,
type
=>
'ARRAY'
,
name
=>
$name
},
{
sigil
=>
'%'
,
type
=>
'HASH'
,
name
=>
$name
},
{
sigil
=>
'&'
,
type
=>
'CODE'
,
name
=>
$name
},
);
my
(
$scalar
,
$array
,
$hash
,
$code
);
if
(
$type
eq
'SCALAR'
) {
$array
=
$self
->get_package_symbol(
$array_desc
)
if
$self
->has_package_symbol(
$array_desc
);
$hash
=
$self
->get_package_symbol(
$hash_desc
)
if
$self
->has_package_symbol(
$hash_desc
);
$code
=
$self
->get_package_symbol(
$code_desc
)
if
$self
->has_package_symbol(
$code_desc
);
}
elsif
(
$type
eq
'ARRAY'
) {
$scalar
=
$self
->get_package_symbol(
$scalar_desc
)
if
$self
->has_package_symbol(
$scalar_desc
);
$hash
=
$self
->get_package_symbol(
$hash_desc
)
if
$self
->has_package_symbol(
$hash_desc
);
$code
=
$self
->get_package_symbol(
$code_desc
)
if
$self
->has_package_symbol(
$code_desc
);
}
elsif
(
$type
eq
'HASH'
) {
$scalar
=
$self
->get_package_symbol(
$scalar_desc
)
if
$self
->has_package_symbol(
$scalar_desc
);
$array
=
$self
->get_package_symbol(
$array_desc
)
if
$self
->has_package_symbol(
$array_desc
);
$code
=
$self
->get_package_symbol(
$code_desc
)
if
$self
->has_package_symbol(
$code_desc
);
}
elsif
(
$type
eq
'CODE'
) {
$scalar
=
$self
->get_package_symbol(
$scalar_desc
)
if
$self
->has_package_symbol(
$scalar_desc
);
$array
=
$self
->get_package_symbol(
$array_desc
)
if
$self
->has_package_symbol(
$array_desc
);
$hash
=
$self
->get_package_symbol(
$hash_desc
)
if
$self
->has_package_symbol(
$hash_desc
);
}
else
{
confess
"This should never ever ever happen"
;
}
$self
->remove_package_glob(
$name
);
$self
->add_package_symbol(
$scalar_desc
=>
$scalar
)
if
defined
$scalar
;
$self
->add_package_symbol(
$array_desc
=>
$array
)
if
defined
$array
;
$self
->add_package_symbol(
$hash_desc
=>
$hash
)
if
defined
$hash
;
$self
->add_package_symbol(
$code_desc
=>
$code
)
if
defined
$code
;
}
sub
list_all_package_symbols {
my
(
$self
,
$type_filter
) =
@_
;
my
$namespace
=
$self
->namespace;
return
keys
%{
$namespace
}
unless
defined
$type_filter
;
if
(
$type_filter
eq
'CODE'
) {
return
grep
{
(
ref
(
$namespace
->{
$_
})
? (
ref
(
$namespace
->{
$_
}) eq
'SCALAR'
)
: (
ref
(\
$namespace
->{
$_
}) eq
'GLOB'
&&
defined
(*{
$namespace
->{
$_
}}{CODE})));
}
keys
%{
$namespace
};
}
else
{
return
grep
{ *{
$namespace
->{
$_
}}{
$type_filter
} }
keys
%{
$namespace
};
}
}
sub
get_all_package_symbols {
my
(
$self
,
$type_filter
) =
@_
;
die
"Cannot call get_all_package_symbols as a class method"
unless
ref
$self
;
my
$namespace
=
$self
->namespace;
if
(
wantarray
) {
warn
'Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead.'
;
}
return
(
wantarray
?
%$namespace
:
$namespace
)
unless
defined
$type_filter
;
my
%ret
;
if
(
$type_filter
eq
'CODE'
) {
my
$pkg
;
no
strict
'refs'
;
%ret
=
map
{
(
ref
(
$namespace
->{
$_
})
? (
$_
=> \&{
$pkg
||=
$self
->name .
"::$_"
} )
: (
ref
\
$namespace
->{
$_
} eq
'GLOB'
&& (*{
$namespace
->{
$_
}}{CODE})
? (
$_
=> *{
$namespace
->{
$_
}}{CODE} )
: (
do
{
my
$sym
= B::svref_2object(\
$namespace
->{
$_
});
my
$svt
=
ref
$sym
if
$sym
;
(
$sym
&& (
$svt
eq
'B::PV'
||
$svt
eq
'B::IV'
))
? (
$_
=> (
$pkg
||=
$self
->name)->can(
$_
))
: () }) ) )
}
keys
%$namespace
;
}
else
{
%ret
=
map
{
$_
=> *{
$namespace
->{
$_
}}{
$type_filter
}
}
grep
{
!
ref
(
$namespace
->{
$_
}) && *{
$namespace
->{
$_
}}{
$type_filter
}
}
keys
%$namespace
;
}
return
wantarray
?
%ret
: \
%ret
;
}
1;