8 # This is a mess. The stash can supposedly handle Unicode but the behavior
9 # is literally undefined before 5.16 (with crashes beyond the basic plane),
10 # and remains unclear past 5.16 with evalbytes and feature unicode_eval
11 # In any case - Sub::Name needs to *somehow* work with this, so we will do
12 # a heuristic with ambiguous eval and looking for octets in the stash
13 use if "$]" >= 5.016, feature => 'unicode_eval';
16 my $builder = Test::More->builder;
17 binmode $builder->output, ":encoding(utf8)";
18 binmode $builder->failure_output, ":encoding(utf8)";
19 binmode $builder->todo_output, ":encoding(utf8)";
22 sub compile_named_sub {
23 my ( $fullname, $body ) = @_;
24 my $sub = eval "sub $fullname { $body }" . '\\&{$fullname}';
32 my ( $sub, $expected, $type, $ord ) = @_;
34 local $Test::Builder::Level = $Test::Builder::Level + 1;
36 my $for_what = sprintf "when it contains \\x%s ( %s )", (
38 ? sprintf "{%X}", $ord
39 : sprintf "%02X", $ord
42 $ord > 255 ? unpack('H*', pack 'C0U', $ord )
43 : ($ord > 0x1f and $ord < 0x7f) ? sprintf "%c", $ord
48 $expected =~ s/'/::/g;
50 # this is apparently how things worked before 5.16
51 utf8::encode($expected) if "$]" < 5.016 and $ord > 255;
53 my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV;
55 is $stash_name, $expected, "stash name for $type is correct $for_what";
56 is $sub->(), $expected, "caller() in $type returns correct name $for_what";
58 skip '%DB::sub not populated when enabled at runtime', 1
60 my ($prefix) = $expected =~ /^(.*?test::[^:]+::)/;
61 my ($db_found) = grep /^$prefix/, keys %DB::sub;
62 is $db_found, $expected, "%DB::sub entry for $type is correct $for_what";
66 #######################################################################
68 use Sub::Name 'subname';
70 my @ordinal = ( 1 .. 255 );
72 # 5.14 is the first perl to start properly handling \0 in identifiers
76 # Unicode in 5.6 is not sane (crashes etc)
78 0x100, # LATIN CAPITAL LETTER A WITH MACRON
79 0x498, # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
80 0x2122, # TRADE MARK SIGN
81 0x1f4a9, # PILE OF POO
84 plan tests => @ordinal * 2 * 3;
86 my $legal_ident_char = "A-Z_a-z0-9'";
87 $legal_ident_char .= join '', map chr, 0x100, 0x498
91 for my $ord (@ordinal) {
94 my $pkg = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord;
95 my $subname = sprintf 'SOME_%s_%c_NAME', $uniq, $ord;
96 my $fullname = join '::', $pkg, $subname;
98 $sub = subname $fullname => sub { (caller(0))[3] };
99 caller3_ok $sub, $fullname, 'renamed closure', $ord;
101 # test that we can *always* compile at least within the correct package
103 if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly
104 $expected = "native::$fullname";
105 $sub = compile_named_sub $expected => '(caller(0))[3]';
107 else { # not a legal identifier but at least test the package name by aliasing
108 $expected = "aliased::native::$fullname";
111 *palatable:: = *{"aliased::native::${pkg}::"};
112 # now palatable:: literally means aliased::native::${pkg}::
113 my $encoded_sub = $subname;
114 utf8::encode($encoded_sub) if "$]" < 5.016 and $ord > 255;
115 ${"palatable::$encoded_sub"} = 1;
116 ${"palatable::"}{"sub"} = ${"palatable::"}{$encoded_sub};
117 # and palatable::sub means aliased::native::${pkg}::${subname}
119 $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]';
121 caller3_ok $sub, $expected, 'natively compiled sub', $ord;