7 # This is a mess. The stash can supposedly handle Unicode but the behavior
8 # is literally undefined before 5.16 (with crashes beyond the basic plane),
9 # and remains unclear past 5.16 with evalbytes and feature unicode_eval
10 # In any case - Sub::Name needs to *somehow* work with this, so we will do
11 # a heuristic with ambiguous eval and looking for octets in the stash
12 use if $] >= 5.016, feature => 'unicode_eval';
14 sub compile_named_sub {
15 my ( $fullname, $body ) = @_;
16 my $sub = eval "sub $fullname { $body }" . '\\&{$fullname}';
24 my ( $sub, $expected, $type, $ord ) = @_;
26 local $Test::Builder::Level = $Test::Builder::Level + 1;
28 my $for_what = sprintf "when it contains \\x%s ( %s )", (
30 ? sprintf "{%X}", $ord
31 : sprintf "%02X", $ord
34 $ord > 255 ? unpack('H*', pack 'C0U', $ord )
35 : ($ord > 0x1f and $ord < 0x7f) ? sprintf "%c", $ord
40 $expected =~ s/'/::/g;
42 # this is apparently how things worked before 5.16
43 utf8::encode($expected) if $] < 5.016 and $ord > 255;
45 my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV;
47 is $stash_name, $expected, "stash name for $type is correct $for_what";
48 is $sub->(), $expected, "caller() in $type returns correct name $for_what";
51 #######################################################################
53 my @ordinal = ( 1 .. 255 );
55 # 5.14 is the first perl to start properly handling \0 in identifiers
59 # Unicode in 5.6 is not sane (crashes etc)
61 0x100, # LATIN CAPITAL LETTER A WITH MACRON
62 0x498, # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
63 0x2122, # TRADE MARK SIGN
64 0x1f4a9, # PILE OF POO
67 plan tests => @ordinal * 2;
69 my $legal_ident_char = "A-Z_a-z0-9'";
70 $legal_ident_char .= join '', map chr, 0x100, 0x498
73 for my $ord (@ordinal) {
75 my $pkg = sprintf 'test::SOME_%c_STASH', $ord;
76 my $subname = sprintf 'SOME_%c_NAME', $ord;
77 my $fullname = join '::', $pkg, $subname;
79 # test that we can *always* compile at least within the correct package
81 if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly
82 $expected = $fullname;
83 $sub = compile_named_sub $fullname => '(caller(0))[3]';
85 else { # not a legal identifier but at least test the package name by aliasing
86 $expected = "${pkg}::foo";
87 { no strict 'refs'; *palatable:: = *{"${pkg}::"} } # now palatable:: literally means ${pkg}::
88 $sub = compile_named_sub 'palatable::foo' => '(caller(0))[3]';
90 caller3_ok $sub, $expected, 'natively compiled sub', $ord;