BEGIN { $^P |= 0x210 }
use
if
$] >= 5.016,
feature
=>
'unicode_eval'
;
if
($] >= 5.008) {
my
$builder
= Test::More->builder;
binmode
$builder
->output,
":encoding(utf8)"
;
binmode
$builder
->failure_output,
":encoding(utf8)"
;
binmode
$builder
->todo_output,
":encoding(utf8)"
;
}
sub
compile_named_sub {
my
(
$fullname
,
$body
) =
@_
;
my
$sub
=
eval
"sub $fullname { $body }"
.
'\\&{$fullname}'
;
return
$sub
if
$sub
;
my
$e
= $@;
Carp::croak
$e
;
}
sub
caller3_ok {
my
(
$sub
,
$expected
,
$type
,
$ord
) =
@_
;
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
$for_what
=
sprintf
"when it contains \\x%s ( %s )"
, (
( (
$ord
> 255)
?
sprintf
"{%X}"
,
$ord
:
sprintf
"%02X"
,
$ord
),
(
$ord
> 255 ?
unpack
(
'H*'
,
pack
'C0U'
,
$ord
)
: (
$ord
> 0x1f and
$ord
< 0x7f) ?
sprintf
"%c"
,
$ord
:
sprintf
'\%o'
,
$ord
),
);
$expected
=~ s/'/::/g;
utf8::encode(
$expected
)
if
$] < 5.016 and
$ord
> 255;
my
$stash_name
=
join
'::'
,
map
{
$_
->STASH->NAME,
$_
->NAME } svref_2object(
$sub
)->GV;
is
$stash_name
,
$expected
,
"stash name for $type is correct $for_what"
;
is
$sub
->(),
$expected
,
"caller() in $type returns correct name $for_what"
;
SKIP: {
skip
'%DB::sub not populated when enabled at runtime'
, 1
unless
keys
%DB::sub
;
my
(
$prefix
) =
$expected
=~ /^(.*?test::[^:]+::)/;
my
(
$db_found
) =
grep
/^
$prefix
/,
keys
%DB::sub
;
is
$db_found
,
$expected
,
"%DB::sub entry for $type is correct $for_what"
;
}
}
my
@ordinal
= ( 1 .. 255 );
unshift
@ordinal
, 0
unless
$] < 5.014;
push
@ordinal
,
0x100,
0x498,
0x2122,
0x1f4a9,
unless
$] < 5.008;
plan
tests
=>
@ordinal
* 2 * 3;
my
$legal_ident_char
=
"A-Z_a-z0-9'"
;
$legal_ident_char
.=
join
''
,
map
chr
, 0x100, 0x498
unless
$] < 5.008;
my
$uniq
=
'A000'
;
for
my
$ord
(
@ordinal
) {
my
$sub
;
$uniq
++;
my
$pkg
=
sprintf
'test::%s::SOME_%c_STASH'
,
$uniq
,
$ord
;
my
$subname
=
sprintf
'SOME_%s_%c_NAME'
,
$uniq
,
$ord
;
my
$fullname
=
join
'::'
,
$pkg
,
$subname
;
$sub
= set_subname
$fullname
=>
sub
{ (
caller
(0))[3] };
caller3_ok
$sub
,
$fullname
,
'renamed closure'
,
$ord
;
my
$expected
;
if
(
chr
(
$ord
) =~ m/^[
$legal_ident_char
]$/o ) {
$expected
=
"native::$fullname"
;
$sub
= compile_named_sub
$expected
=>
'(caller(0))[3]'
;
}
else
{
$expected
=
"aliased::native::$fullname"
;
{
no
strict
'refs'
;
*palatable::
= *{
"aliased::native::${pkg}::"
};
my
$encoded_sub
=
$subname
;
utf8::encode(
$encoded_sub
)
if
"$]"
< 5.016 and
$ord
> 255;
${
"palatable::$encoded_sub"
} = 1;
${
"palatable::"
}{
"sub"
} = ${
"palatable::"
}{
$encoded_sub
};
}
$sub
= compile_named_sub
'palatable::sub'
=>
'(caller(0))[3]'
;
}
caller3_ok
$sub
,
$expected
,
'natively compiled sub'
,
$ord
;
}