t/uni/variables.t

   1 #!./perl
   2
   3 # Checks if the parser behaves correctly in edge case
   4 # (including weird syntax errors)
   5
   6 BEGIN {
   7     require './test.pl';
   8 }
   9
  10 use 5.016;
  11 use utf8;
  12 use open qw( :utf8 :std );
  13 no warnings qw(misc reserved);
  14
  15 plan (tests => 65880);
  16
  17 # ${single:colon} should not be valid syntax
  18 {
  19     no strict;
  20
  21     local $@;
  22     eval "\${\x{30cd}single:\x{30cd}colon} = 1";
  23     like($@,
  24          qr/syntax error .* near "\x{30cd}single:/,
  25          '${\x{30cd}single:\x{30cd}colon} should not be valid syntax'
  26         );
  27
  28     local $@;
  29     no utf8;
  30     evalbytes '${single:colon} = 1';
  31     like($@,
  32          qr/syntax error .* near "single:/,
  33          '...same with ${single:colon}'
  34         );
  35 }
  36
  37 # ${yadda'etc} and ${yadda::etc} should both work under strict
  38 {
  39     local $@;
  40     eval q<use strict; ${flark::fleem}>;
  41     is($@, '', q<${package::var} works>);
  42
  43     local $@;
  44     eval q<use strict; ${fleem'flark}>;
  45     is($@, '', q<...as does ${package'var}>);
  46 }
  47
  48 # The first character in ${...} should respect the rules
  49 {
  50    local $@;
  51    use utf8;
  52    eval '${☭asd} = 1';
  53    like($@, qr/\QUnrecognized character/, q(the first character in ${...} isn't special))
  54 }
  55
  56 # Checking that at least some of the special variables work
  57 for my $v (qw( ^V ; < > ( ) {^GLOBAL_PHASE} ^W _ 1 4 0 [ ] ! @ / \ = )) {
  58   SKIP: {
  59     skip_if_miniperl('No $[ under miniperl', 2) if $v eq '[';
  60     local $@;
  61     evalbytes "\$$v;";
  62     is $@, '', "No syntax error for \$$v";
  63
  64     local $@;
  65     eval "use utf8; \$$v;";
  66     is $@, '', "No syntax error for \$$v under use utf8";
  67   }
  68 }
  69
  70 # Checking if the Latin-1 range behaves as expected, and that the behavior is the
  71 # same whenever under strict or not.
  72 for ( 0x80..0xff ) {
  73     no warnings 'closure';
  74     my $chr = chr;
  75     my $esc = sprintf("%X", ord $chr);
  76     utf8::downgrade($chr);
  77     if ($chr !~ /\p{XIDS}/u) {
  78         is evalbytes "no strict; \$$chr = 10",
  79             10,
  80             sprintf("\\x%02x, part of the latin-1 range, is legal as a length-1 variable", $_);
  81
  82         utf8::upgrade($chr);
  83         local $@;
  84         eval "no strict; use utf8; \$$chr = 1";
  85         like $@,
  86             qr/\QUnrecognized character \x{\E\L$esc/,
  87             sprintf("..but is illegal as a length-1 variable under use utf8", $_);
  88     }
  89     else {
  90         {
  91             no utf8;
  92             local $@;
  93             evalbytes "no strict; \$$chr = 1";
  94             is($@, '', sprintf("\\x%02x, =~ \\p{XIDS}, latin-1, no utf8, no strict, is a valid length-1 variable", $_));
  95
  96             local $@;
  97             evalbytes "use strict; \$$chr = 1";
  98             is($@,
  99                 '',
 100                 sprintf("\\x%02x under no utf8 does not have to be required under strict, even though it matches XIDS", $_)
 101             );
 102
 103             local $@;
 104             evalbytes "\$a$chr = 1";
 105             like($@,
 106                 qr/Unrecognized character /,
 107                 sprintf("...but under no utf8, it's not allowed in two-or-more character variables")
 108             );
 109
 110             local $@;
 111             evalbytes "\$a$chr = 1";
 112             like($@,
 113                 qr/Unrecognized character /,
 114                 sprintf("...but under no utf8, it's not allowed in two-or-more character variables")
 115             );
 116         }
 117         {
 118             use utf8;
 119             my $u = $chr;
 120             utf8::upgrade($u);
 121             local $@;
 122             eval "no strict; \$$u = 1";
 123             is($@, '', sprintf("\\x%02x, =~ \\p{XIDS}, UTF-8, use utf8, no strict, is a valid length-1 variable", $_));
 124
 125             local $@;
 126             eval "use strict; \$$u = 1";
 127             like($@,
 128                 qr/Global symbol "\$$u" requires explicit package name/,
 129                 sprintf("\\x%02x under utf8 has to be required under strict", $_)
 130             );
 131         }
 132     }
 133 }
 134
 135 {
 136     use utf8;
 137     my $ret = eval "my \$c\x{327} = 100; \$c\x{327}"; # c + cedilla
 138     is($@, '', "ASCII character + combining character works as a variable name");
 139     is($ret, 100, "...and returns the correct value");
 140 }
 141
 142 # From Tom Christiansen's 'highly illegal variable names are now accidentally legal' mail
 143 for my $chr (
 144       "\N{EM DASH}", "\x{F8FF}", "\N{POUND SIGN}", "\N{SOFT HYPHEN}",
 145       "\N{THIN SPACE}", "\x{11_1111}", "\x{DC00}", "\N{COMBINING DIAERESIS}",
 146       "\N{COMBINING ENCLOSING CIRCLE BACKSLASH}",
 147    )
 148 {
 149    no warnings 'non_unicode';
 150    my $esc = sprintf("%x", ord $chr);
 151    local $@;
 152    eval "\$$chr = 1; \$$chr";
 153    like($@,
 154         qr/\QUnrecognized character \x{$esc};/,
 155         "\\x{$esc} is illegal for a length-one identifier"
 156        );
 157 }
 158
 159 for my $i (0x100..0xffff) {
 160    my $chr = chr($i);
 161    my $esc = sprintf("%x", $i);
 162    local $@;
 163    eval "my \$$chr = q<test>; \$$chr;";
 164    if ( $chr =~ /^\p{_Perl_IDStart}$/ ) {
 165       is($@, '', sprintf("\\x{%04x} is XIDS, works as a length-1 variable", $i));
 166    }
 167    else {
 168       like($@,
 169            qr/\QUnrecognized character \x{$esc};/,
 170            "\\x{$esc} isn't XIDS, illegal as a length-1 variable",
 171           )
 172    }
 173 }
 174
 175 {
 176     # Bleadperl v5.17.9-109-g3283393 breaks ZEFRAM/Module-Runtime-0.013.tar.gz
 177     # https://rt.perl.org/rt3/Public/Bug/Display.html?id=117101
 178     no strict;
 179
 180     local $@;
 181     eval <<'EOP';
 182     q{$} =~ /(.)/;
 183     is($$1, $$, q{$$1 parses as ${$1}});
 184
 185     $doof = "test";
 186     $test = "Got here";
 187     $::{+$$} = *doof;
 188
 189     is( $$$$1, $test, q{$$$$1 parses as ${${${$1}}}} );
 190 EOP
 191     is($@, '', q{$$1 parses correctly});
 192
 193     for my $chr ( q{@}, "\N{U+FF10}", "\N{U+0300}" ) {
 194         my $esc = sprintf("\\x{%x}", ord $chr);
 195         local $@;
 196         eval <<"    EOP";
 197             \$$chr = q{\$};
 198             \$\$$chr;
 199     EOP
 200
 201         like($@,
 202              qr/syntax error|Unrecognized character/,
 203              qq{\$\$$esc is a syntax error}
 204         );
 205     }
 206 }
 207
 208 {
 209     # bleadperl v5.17.9-109-g3283393 breaks JEREMY/File-Signature-1.009.tar.gz
 210     # https://rt.perl.org/rt3/Ticket/Display.html?id=117145
 211     local $@;
 212     my $var = 10;
 213     eval ' ${  var  }';
 214
 215     is(
 216         $@,
 217         '',
 218         '${  var  } works under strict'
 219     );
 220
 221     {
 222         no strict;
 223         # Silence the deprecation warning for literal controls
 224         no warnings 'deprecated';
 225
 226         for my $var ( '$', "\7LOBAL_PHASE", "^GLOBAL_PHASE", "^V" ) {
 227             eval "\${ $var}";
 228             is($@, '', "\${ $var} works" );
 229             eval "\${$var }";
 230             is($@, '', "\${$var } works" );
 231             eval "\${ $var }";
 232             is($@, '', "\${ $var } works" );
 233         }
 234     }
 235 }
 236
 237 {
 238     is(
 239         "".eval "*{\nOIN}",
 240         "*main::OIN",
 241         "Newlines at the start of an identifier should be skipped over"
 242     );
 243
 244
 245     is(
 246         "".eval "*{^JOIN}",
 247         "*main::\nOIN",
 248         "...but \$^J is still legal"
 249     );
 250
 251     no warnings 'deprecated';
 252     my $ret = eval "\${\cT\n}";
 253     is($@, "", 'No errors from using ${\n\cT\n}');
 254     is($ret, $^T, "...and we got the right value");
 255 }
 256
 257 {
 258     # Originally from t/base/lex.t, moved here since we can't
 259     # turn deprecation warnings off in that file.
 260     no strict;
 261     no warnings 'deprecated';
 262
 263     my $CX  = "\cX";
 264     $ {$CX} = 17;
 265
 266     # Does the syntax where we use the literal control character still work?
 267     is(
 268        eval "\$ {\cX}",
 269        17,
 270        "Literal control character variables work"
 271     );
 272
 273     eval "\$\cQ = 24";                 # Literal control character
 274     is($@, "", "...and they can be assigned to without error");
 275     is(${"\cQ"}, 24, "...and the assignment works");
 276     is($^Q, 24, "...even if we access the variable through the caret name");
 277     is(\${"\cQ"}, \$^Q, '\${\cQ} == \$^Q');
 278 }
 279
 280 {
 281     # Prior to 5.19.4, the following changed behavior depending
 282     # on the presence of the newline after '@{'.
 283     sub foo (&) { [1] }
 284     my %foo = (a=>2);
 285     my $ret = @{ foo { "a" } };
 286     is($ret, $foo{a}, '@{ foo { "a" } } is parsed as @foo{a}');
 287
 288     $ret = @{
 289             foo { "a" }
 290         };
 291     is($ret, $foo{a}, '@{\nfoo { "a" } } is still parsed as @foo{a}');
 292
 293 }