our
$VERSION
=
'1.302208'
;
our
@EXPORT_OK
=
qw{
get_stash
get_glob
get_symbol
parse_symbol
purge_symbol
slot_to_sig sig_to_slot
}
;
my
%SIGMAP
= (
'&'
=>
'CODE'
,
'$'
=>
'SCALAR'
,
'%'
=>
'HASH'
,
'@'
=>
'ARRAY'
,
);
my
%SLOTMAP
=
reverse
%SIGMAP
;
sub
slot_to_sig {
$SLOTMAP
{
$_
[0]} || croak
"unsupported slot: '$_[0]'"
}
sub
sig_to_slot {
$SIGMAP
{
$_
[0]} || croak
"unsupported sigil: $_[0]"
}
sub
get_stash {
my
$package
=
shift
||
caller
;
no
strict
'refs'
;
return
\%{
"${package}\::"
};
}
sub
get_glob {
my
$sym
= _parse_symbol(
scalar
(
caller
),
@_
);
no
strict
'refs'
;
no
warnings
'once'
;
return
\*{
"$sym->{package}\::$sym->{name}"
};
}
sub
parse_symbol { _parse_symbol(
scalar
(
caller
),
@_
) }
sub
_parse_symbol {
my
(
$caller
,
$symbol
,
$package
) =
@_
;
if
(
ref
(
$symbol
)) {
my
$pkg
=
$symbol
->{
package
};
croak
"Symbol package ($pkg) and package argument ($package) do not match"
if
$pkg
&&
$package
&&
$pkg
ne
$package
;
$symbol
->{
package
} ||=
$caller
;
return
$symbol
;
}
utf8::downgrade(
$symbol
)
if
$] == 5.010000;
my
(
$sig
,
$pkg
,
$name
) = (
$symbol
=~ m/^(\W?)(.*::)?([^:]+)$/)
or croak
"Invalid symbol: '$symbol'"
;
$pkg
=
$pkg
?
$pkg
eq
'::'
?
'main'
:
substr
(
$pkg
, 0, -2)
:
undef
;
croak
"Symbol package ($pkg) and package argument ($package) do not match"
if
$pkg
&&
$package
&&
$pkg
ne
$package
;
$sig
||=
'&'
;
my
$type
=
$SIGMAP
{
$sig
} || croak
"unsupported sigil: '$sig'"
;
my
$real_package
=
$package
||
$pkg
||
$caller
;
return
{
name
=>
$name
,
sigil
=>
$sig
,
type
=>
$type
,
symbol
=>
"${sig}${real_package}::${name}"
,
package
=>
$real_package
,
};
}
sub
get_symbol {
my
$sym
= _parse_symbol(
scalar
(
caller
),
@_
);
my
$name
=
$sym
->{name};
my
$type
=
$sym
->{type};
my
$package
=
$sym
->{
package
};
my
$symbol
=
$sym
->{symbol};
my
$stash
= get_stash(
$package
);
return
undef
unless
exists
$stash
->{
$name
};
my
$glob
= get_glob(
$sym
);
return
*{
$glob
}{
$type
}
if
$type
ne
'SCALAR'
&&
defined
(*{
$glob
}{
$type
});
if
($] < 5.010) {
return
undef
unless
defined
(*{
$glob
}{
$type
});
{
local
($@, $!);
local
$SIG
{__WARN__} =
sub
{ 1 };
return
*{
$glob
}{
$type
}
if
eval
"package $package; my \$y = $symbol; 1"
;
}
return
undef
unless
defined
*{
$glob
}{
$type
};
return
*{
$glob
}{
$type
}
if
defined
${*{
$glob
}{
$type
}};
return
undef
;
}
my
$sv
= B::svref_2object(
$glob
)->SV;
return
*{
$glob
}{
$type
}
if
$sv
->isa(
'B::SV'
);
return
undef
unless
$sv
->isa(
'B::SPECIAL'
);
return
*{
$glob
}{
$type
}
if
$B::specialsv_name
[
$$sv
] ne
'Nullsv'
;
return
undef
;
}
sub
purge_symbol {
my
$sym
= _parse_symbol(
scalar
(
caller
),
@_
);
local
*GLOBCLONE
= *{get_glob(
$sym
)};
delete
get_stash(
$sym
->{
package
})->{
$sym
->{name}};
my
$new_glob
= get_glob(
$sym
);
for
my
$type
(
qw/CODE SCALAR HASH ARRAY FORMAT IO/
) {
next
if
$type
eq
$sym
->{type};
my
$ref
= get_symbol({
type
=>
$type
,
name
=>
'GLOBCLONE'
,
sigil
=>
$SLOTMAP
{
$type
}}, __PACKAGE__);
next
unless
$ref
;
*$new_glob
=
$ref
;
}
return
*GLOBCLONE
{
$sym
->{type}};
}
1;