1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
use strict;
use warnings;
use Test::More;
use B 'svref_2object';
BEGIN { $^P |= 0x210 }
# This is a mess. The stash can supposedly handle Unicode but the behavior
# is literally undefined before 5.16 (with crashes beyond the basic plane),
# and remains unclear past 5.16 with evalbytes and feature unicode_eval
# In any case - Sub::Name needs to *somehow* work with this, so we will do
# a heuristic with ambiguous eval and looking for octets in the stash
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 = $@;
require Carp;
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 )
: (chr $ord =~ /[[:print:]]/) ? sprintf "%c", $ord
: sprintf '\%o', $ord
),
);
$expected =~ s/'/::/g if $] < 5.037009 || $] >= 5.041_004;
# this is apparently how things worked before 5.16
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";
}
}
#######################################################################
use Sub::Util 'set_subname';
my @ordinal = (
# 5.14 is the first perl to start properly handling \0 in identifiers
($] >= 5.014 ? ( 0 ) : ()),
1 .. 38,
# single quote ' separators are deprecated in 5.37.9
($] < 5.037009 || $] >= 5.041_004 ? ( 39 ) : ()),
40 .. 255,
# Unicode in 5.6 is not sane (crashes etc)
($] >= 5.008 ? (
0x100, # LATIN CAPITAL LETTER A WITH MACRON
0x498, # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
0x2122, # TRADE MARK SIGN
0x1f4a9, # PILE OF POO
) : ()),
);
my $legal_ident_char = join('',
"A-Z_a-z0-9",
($] < 5.037009 || $] >= 5.041_004 ? q['] : ()),
($] > 5.008 ? (
map chr, 0x100, 0x498
) : ()),
);
plan tests => @ordinal * 2 * 3;
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;
# test that we can *always* compile at least within the correct package
my $expected;
if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly
$expected = "native::$fullname";
$sub = compile_named_sub $expected => '(caller(0))[3]';
}
else { # not a legal identifier but at least test the package name by aliasing
$expected = "aliased::native::$fullname";
{
no strict 'refs';
*palatable:: = *{"aliased::native::${pkg}::"};
# now palatable:: literally means 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};
# and palatable::sub means aliased::native::${pkg}::${subname}
}
$sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]';
}
caller3_ok $sub, $expected, 'natively compiled sub', $ord;
}
|
