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';
15 use if "$]" >= 5.008, open => ':std', ':encoding(UTF-8)'; # force stdin, stdout, stderr into utf8
17 sub compile_named_sub {
18 my ( $fullname, $body ) = @_;
19 my $sub = eval "sub $fullname { $body }" . '\\&{$fullname}';
27 my ( $sub, $expected, $type, $ord ) = @_;
29 local $Test::Builder::Level = $Test::Builder::Level + 1;
31 my $for_what = sprintf "when it contains \\x%s ( %s )", (
33 ? sprintf "{%X}", $ord
34 : sprintf "%02X", $ord
37 $ord > 255 ? unpack('H*', pack 'C0U', $ord )
38 : ($ord > 0x1f and $ord < 0x7f) ? sprintf "%c", $ord
43 $expected =~ s/'/::/g;
45 # this is apparently how things worked before 5.16
46 utf8::encode($expected) if "$]" < 5.016 and $ord > 255;
48 my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV;
50 is $stash_name, $expected, "stash name for $type is correct $for_what";
51 is $sub->(), $expected, "caller() in $type returns correct name $for_what";
53 skip '%DB::sub not populated when enabled at runtime', 1
55 my ($prefix) = $expected =~ /^(.*?test::[^:]+::)/;
56 my ($db_found) = grep /^$prefix/, keys %DB::sub;
57 is $db_found, $expected, "%DB::sub entry for $type is correct $for_what";
61 #######################################################################
63 use Sub::Name 'subname';
65 my @ordinal = ( 1 .. 255 );
67 # 5.14 is the first perl to start properly handling \0 in identifiers
71 # Unicode in 5.6 is not sane (crashes etc)
73 0x100, # LATIN CAPITAL LETTER A WITH MACRON
74 0x498, # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
75 0x2122, # TRADE MARK SIGN
76 0x1f4a9, # PILE OF POO
79 plan tests => @ordinal * 2 * 3;
81 my $legal_ident_char = "A-Z_a-z0-9'";
82 $legal_ident_char .= join '', map chr, 0x100, 0x498
86 for my $ord (@ordinal) {
89 my $pkg = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord;
90 my $subname = sprintf 'SOME_%s_%c_NAME', $uniq, $ord;
91 my $fullname = join '::', $pkg, $subname;
93 $sub = subname $fullname => sub { (caller(0))[3] };
94 caller3_ok $sub, $fullname, 'renamed closure', $ord;
96 # test that we can *always* compile at least within the correct package
98 if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly
99 $expected = "native::$fullname";
100 $sub = compile_named_sub $expected => '(caller(0))[3]';
102 else { # not a legal identifier but at least test the package name by aliasing
103 $expected = "aliased::native::$fullname";
106 *palatable:: = *{"aliased::native::${pkg}::"};
107 # now palatable:: literally means aliased::native::${pkg}::
108 my $encoded_sub = $subname;
109 utf8::encode($encoded_sub) if "$]" < 5.016 and $ord > 255;
110 ${"palatable::$encoded_sub"} = 1;
111 ${"palatable::"}{"sub"} = ${"palatable::"}{$encoded_sub};
112 # and palatable::sub means aliased::native::${pkg}::${subname}
114 $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]';
116 caller3_ok $sub, $expected, 'natively compiled sub', $ord;