Commit | Line | Data |
ea5fecfc |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | use B 'svref_2object'; |
67415d50 |
6 | BEGIN { $^P |= 0x210 } |
ea5fecfc |
7 | |
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 |
b7d49226 |
13 | use if "$]" >= 5.016, feature => 'unicode_eval'; |
ea5fecfc |
14 | |
b7d49226 |
15 | if ("$]" >= 5.008) { |
9f96c17f |
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)"; |
f81503dc |
20 | } |
21 | |
ea5fecfc |
22 | sub compile_named_sub { |
23 | my ( $fullname, $body ) = @_; |
24 | my $sub = eval "sub $fullname { $body }" . '\\&{$fullname}'; |
25 | return $sub if $sub; |
26 | my $e = $@; |
27 | require Carp; |
28 | Carp::croak $e; |
29 | } |
30 | |
31 | sub caller3_ok { |
32 | my ( $sub, $expected, $type, $ord ) = @_; |
33 | |
34 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
35 | |
36 | my $for_what = sprintf "when it contains \\x%s ( %s )", ( |
37 | ( ($ord > 255) |
38 | ? sprintf "{%X}", $ord |
39 | : sprintf "%02X", $ord |
40 | ), |
41 | ( |
42 | $ord > 255 ? unpack('H*', pack 'C0U', $ord ) |
43 | : ($ord > 0x1f and $ord < 0x7f) ? sprintf "%c", $ord |
44 | : sprintf '\%o', $ord |
45 | ), |
46 | ); |
47 | |
48 | $expected =~ s/'/::/g; |
49 | |
50 | # this is apparently how things worked before 5.16 |
b7d49226 |
51 | utf8::encode($expected) if "$]" < 5.016 and $ord > 255; |
ea5fecfc |
52 | |
53 | my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV; |
54 | |
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"; |
67415d50 |
57 | ok $DB::sub{$expected}, "%DB::sub entry for $type is correct $for_what"; |
ea5fecfc |
58 | } |
59 | |
60 | ####################################################################### |
61 | |
4d96bce5 |
62 | use Sub::Name 'subname'; |
63 | |
ea5fecfc |
64 | my @ordinal = ( 1 .. 255 ); |
65 | |
66 | # 5.14 is the first perl to start properly handling \0 in identifiers |
67 | unshift @ordinal, 0 |
b7d49226 |
68 | unless "$]" < 5.014; |
ea5fecfc |
69 | |
70 | # Unicode in 5.6 is not sane (crashes etc) |
71 | push @ordinal, |
72 | 0x100, # LATIN CAPITAL LETTER A WITH MACRON |
73 | 0x498, # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER |
74 | 0x2122, # TRADE MARK SIGN |
75 | 0x1f4a9, # PILE OF POO |
b7d49226 |
76 | unless "$]" < 5.008; |
ea5fecfc |
77 | |
67415d50 |
78 | plan tests => @ordinal * 2 * 3; |
ea5fecfc |
79 | |
80 | my $legal_ident_char = "A-Z_a-z0-9'"; |
81 | $legal_ident_char .= join '', map chr, 0x100, 0x498 |
b7d49226 |
82 | unless "$]" < 5.008; |
ea5fecfc |
83 | |
67415d50 |
84 | my $uniq = 'A000'; |
ea5fecfc |
85 | for my $ord (@ordinal) { |
86 | my $sub; |
67415d50 |
87 | $uniq++; |
88 | my $pkg = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord; |
89 | my $subname = sprintf 'SOME_%s_%c_NAME', $uniq, $ord; |
ea5fecfc |
90 | my $fullname = join '::', $pkg, $subname; |
91 | |
4d96bce5 |
92 | $sub = subname $fullname => sub { (caller(0))[3] }; |
93 | caller3_ok $sub, $fullname, 'renamed closure', $ord; |
94 | |
ea5fecfc |
95 | # test that we can *always* compile at least within the correct package |
96 | my $expected; |
97 | if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly |
67415d50 |
98 | $expected = "native::$fullname"; |
99 | $sub = compile_named_sub $expected => '(caller(0))[3]'; |
ea5fecfc |
100 | } |
101 | else { # not a legal identifier but at least test the package name by aliasing |
63be23c8 |
102 | $expected = "aliased::native::$fullname"; |
103 | { |
104 | no strict 'refs'; |
105 | *palatable:: = *{"aliased::native::${pkg}::"}; |
106 | # now palatable:: literally means aliased::native::${pkg}:: |
a24a6249 |
107 | my $encoded_sub = $subname; |
108 | utf8::encode($encoded_sub) if "$]" < 5.016 and $ord > 255; |
109 | ${"palatable::$encoded_sub"} = 1; |
110 | ${"palatable::"}{"sub"} = ${"palatable::"}{$encoded_sub}; |
63be23c8 |
111 | # and palatable::sub means aliased::native::${pkg}::${subname} |
112 | } |
113 | $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]'; |
ea5fecfc |
114 | } |
115 | caller3_ok $sub, $expected, 'natively compiled sub', $ord; |
116 | } |