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"; |
3f1762c7 |
57 | SKIP: { |
58 | skip '%DB::sub not populated when enabled at runtime', 1 |
59 | unless keys %DB::sub; |
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"; |
63 | } |
ea5fecfc |
64 | } |
65 | |
66 | ####################################################################### |
67 | |
4d96bce5 |
68 | use Sub::Name 'subname'; |
69 | |
ea5fecfc |
70 | my @ordinal = ( 1 .. 255 ); |
71 | |
72 | # 5.14 is the first perl to start properly handling \0 in identifiers |
73 | unshift @ordinal, 0 |
b7d49226 |
74 | unless "$]" < 5.014; |
ea5fecfc |
75 | |
76 | # Unicode in 5.6 is not sane (crashes etc) |
77 | push @ordinal, |
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 |
b7d49226 |
82 | unless "$]" < 5.008; |
ea5fecfc |
83 | |
67415d50 |
84 | plan tests => @ordinal * 2 * 3; |
ea5fecfc |
85 | |
86 | my $legal_ident_char = "A-Z_a-z0-9'"; |
87 | $legal_ident_char .= join '', map chr, 0x100, 0x498 |
b7d49226 |
88 | unless "$]" < 5.008; |
ea5fecfc |
89 | |
67415d50 |
90 | my $uniq = 'A000'; |
ea5fecfc |
91 | for my $ord (@ordinal) { |
92 | my $sub; |
67415d50 |
93 | $uniq++; |
94 | my $pkg = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord; |
95 | my $subname = sprintf 'SOME_%s_%c_NAME', $uniq, $ord; |
ea5fecfc |
96 | my $fullname = join '::', $pkg, $subname; |
97 | |
4d96bce5 |
98 | $sub = subname $fullname => sub { (caller(0))[3] }; |
99 | caller3_ok $sub, $fullname, 'renamed closure', $ord; |
100 | |
ea5fecfc |
101 | # test that we can *always* compile at least within the correct package |
102 | my $expected; |
103 | if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly |
67415d50 |
104 | $expected = "native::$fullname"; |
105 | $sub = compile_named_sub $expected => '(caller(0))[3]'; |
ea5fecfc |
106 | } |
107 | else { # not a legal identifier but at least test the package name by aliasing |
63be23c8 |
108 | $expected = "aliased::native::$fullname"; |
109 | { |
110 | no strict 'refs'; |
111 | *palatable:: = *{"aliased::native::${pkg}::"}; |
112 | # now palatable:: literally means aliased::native::${pkg}:: |
a24a6249 |
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}; |
63be23c8 |
117 | # and palatable::sub means aliased::native::${pkg}::${subname} |
118 | } |
119 | $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]'; |
ea5fecfc |
120 | } |
121 | caller3_ok $sub, $expected, 'natively compiled sub', $ord; |
122 | } |