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