1use strict;
2use warnings;
3
4use Test::More;
5use B 'svref_2object';
6BEGIN { $^P |= 0x210 }
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
13use if $] >= 5.016, feature => 'unicode_eval';
14
15if ($] >= 5.008) {
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)";
20}
21
22sub 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
31sub 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
51    utf8::encode($expected) if $] < 5.016 and $ord > 255;
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";
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    }
64}
65
66#######################################################################
67
68use Sub::Util 'set_subname';
69
70my @ordinal = ( 1 .. 255 );
71
72# 5.14 is the first perl to start properly handling \0 in identifiers
73unshift @ordinal, 0
74    unless $] < 5.014;
75
76# Unicode in 5.6 is not sane (crashes etc)
77push @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
82    unless $] < 5.008;
83
84plan tests => @ordinal * 2 * 3;
85
86my $legal_ident_char = "A-Z_a-z0-9'";
87$legal_ident_char .= join '', map chr, 0x100, 0x498
88    unless $] < 5.008;
89
90my $uniq = 'A000';
91for my $ord (@ordinal) {
92    my $sub;
93    $uniq++;
94    my $pkg      = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord;
95    my $subname  = sprintf 'SOME_%s_%c_NAME', $uniq, $ord;
96    my $fullname = join '::', $pkg, $subname;
97
98    $sub = set_subname $fullname => sub { (caller(0))[3] };
99    caller3_ok $sub, $fullname, 'renamed closure', $ord;
100
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
104        $expected = "native::$fullname";
105        $sub = compile_named_sub $expected => '(caller(0))[3]';
106    }
107    else { # not a legal identifier but at least test the package name by aliasing
108        $expected = "aliased::native::$fullname";
109        {
110          no strict 'refs';
111          *palatable:: = *{"aliased::native::${pkg}::"};
112          # now palatable:: literally means aliased::native::${pkg}::
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};
117          # and palatable::sub means aliased::native::${pkg}::${subname}
118        }
119        $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]';
120    }
121    caller3_ok $sub, $expected, 'natively compiled sub', $ord;
122}
123