t/exotic_names.t

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