t/exotic_names.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use if $ENV{AUTHOR_TESTING}, 'Test::Warnings';
   6 use B 'svref_2object';
   7 BEGIN { $^P |= 0x210 }
   8
   9 # This is a mess. The stash can supposedly handle Unicode but the behavior
  10 # is literally undefined before 5.16 (with crashes beyond the basic plane),
  11 # and remains unclear past 5.16 with evalbytes and feature unicode_eval
  12 # In any case - Sub::Name needs to *somehow* work with this, so we will do
  13 # a heuristic with ambiguous eval and looking for octets in the stash
  14 use if "$]" >= 5.016, feature => 'unicode_eval';
  15
  16 if ("$]" >= 5.008) {
  17     my $builder = Test::More->builder;
  18     binmode $builder->output,         ":encoding(utf8)";
  19     binmode $builder->failure_output, ":encoding(utf8)";
  20     binmode $builder->todo_output,    ":encoding(utf8)";
  21 }
  22
  23 sub compile_named_sub {
  24     my ( $fullname, $body ) = @_;
  25     my $sub = eval "sub $fullname { $body }" . '\\&{$fullname}';
  26     return $sub if $sub;
  27     my $e = $@;
  28     require Carp;
  29     Carp::croak $e;
  30 }
  31
  32 sub caller3_ok {
  33     my ( $sub, $expected, $type, $ord ) = @_;
  34
  35     local $Test::Builder::Level = $Test::Builder::Level + 1;
  36
  37     my $for_what = sprintf "when it contains \\x%s ( %s )", (
  38         ( ($ord > 255)
  39             ? sprintf "{%X}", $ord
  40             : sprintf "%02X", $ord
  41         ),
  42         (
  43             $ord > 255                    ? unpack('H*', pack 'C0U', $ord )
  44             : ($ord > 0x1f and $ord < 0x7f) ? sprintf "%c", $ord
  45             :                                 sprintf '\%o', $ord
  46         ),
  47     );
  48
  49     $expected =~ s/'/::/g;
  50
  51     # this is apparently how things worked before 5.16
  52     utf8::encode($expected) if "$]" < 5.016 and $ord > 255;
  53
  54     my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV;
  55
  56     is $stash_name, $expected, "stash name for $type is correct $for_what";
  57     is $sub->(), $expected, "caller() in $type returns correct name $for_what";
  58     SKIP: {
  59       skip '%DB::sub not populated when enabled at runtime', 1
  60         unless keys %DB::sub;
  61       my ($prefix) = $expected =~ /^(.*?test::[^:]+::)/;
  62       my ($db_found) = grep /^$prefix/, keys %DB::sub;
  63       is $db_found, $expected, "%DB::sub entry for $type is correct $for_what";
  64     }
  65 }
  66
  67 #######################################################################
  68
  69 use Sub::Name 'subname';
  70
  71 my @ordinal = ( 1 .. 255 );
  72
  73 # 5.14 is the first perl to start properly handling \0 in identifiers
  74 unshift @ordinal, 0
  75     unless "$]" < 5.014;
  76
  77 # Unicode in 5.6 is not sane (crashes etc)
  78 push @ordinal,
  79     0x100,    # LATIN CAPITAL LETTER A WITH MACRON
  80     0x498,    # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
  81     0x2122,   # TRADE MARK SIGN
  82     0x1f4a9,  # PILE OF POO
  83     unless "$]" < 5.008;
  84
  85 my $legal_ident_char = "A-Z_a-z0-9'";
  86 $legal_ident_char .= join '', map chr, 0x100, 0x498
  87     unless "$]" < 5.008;
  88
  89 my $uniq = 'A000';
  90 for my $ord (@ordinal) {
  91     my $sub;
  92     $uniq++;
  93     my $pkg      = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord;
  94     my $subname  = sprintf 'SOME_%s_%c_NAME', $uniq, $ord;
  95     my $fullname = join '::', $pkg, $subname;
  96
  97     $sub = subname $fullname => sub { (caller(0))[3] };
  98     caller3_ok $sub, $fullname, 'renamed closure', $ord;
  99
 100     # test that we can *always* compile at least within the correct package
 101     my $expected;
 102   SKIP: {
 103     skip 'single quote as a package separator has been '.
 104         ("$]" > 5.041001 ? 'removed' : 'deprecated'), 3
 105         if $ord == 39 and "$]" > 5.037009;
 106
 107     if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly
 108         $expected = "native::$fullname";
 109         $sub = compile_named_sub $expected => '(caller(0))[3]';
 110     }
 111     else { # not a legal identifier but at least test the package name by aliasing
 112         $expected = "aliased::native::$fullname";
 113         {
 114           no strict 'refs';
 115           *palatable:: = *{"aliased::native::${pkg}::"};
 116           # now palatable:: literally means aliased::native::${pkg}::
 117           my $encoded_sub = $subname;
 118           utf8::encode($encoded_sub) if "$]" < 5.016 and $ord > 255;
 119           ${"palatable::$encoded_sub"} = 1;
 120           ${"palatable::"}{"sub"} = ${"palatable::"}{$encoded_sub};
 121           # and palatable::sub means aliased::native::${pkg}::${subname}
 122         }
 123         $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]';
 124     }
 125     caller3_ok $sub, $expected, 'natively compiled sub', $ord;
 126   }
 127 }
 128
 129 done_testing;