This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #122782] map{no strict;...} etc.
[perl5.git] / 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     chdir 't' if -d 't';
8     require './test.pl';
9     skip_all_without_unicode_tables();
10 }
11
12 use 5.016;
13 use utf8;
14 use open qw( :utf8 :std );
15 no warnings qw(misc reserved);
16
17 plan (tests => 66900);
18
19 # ${single:colon} should not be treated as a simple variable, but as a
20 # block with a label inside.
21 {
22     no strict;
23
24     local $@;
25     eval "\${\x{30cd}single:\x{30cd}colon} = 'label, not var'";
26     is ${"\x{30cd}colon"}, 'label, not var',
27          '${\x{30cd}single:\x{30cd}colon} should be block-label';
28
29     local $@;
30     no utf8;
31     evalbytes '${single:colon} = "block/label, not var"';
32     is($::colon,
33          'block/label, not var',
34          '...same with ${single:colon}'
35         );
36 }
37
38 # ${yadda'etc} and ${yadda::etc} should both work under strict
39 {
40     local $@;
41     eval q<use strict; ${flark::fleem}>;
42     is($@, '', q<${package::var} works>);
43
44     local $@;
45     eval q<use strict; ${fleem'flark}>;
46     is($@, '', q<...as does ${package'var}>);
47 }
48
49 # The first character in ${...} should respect the rules
50 {
51    local $@;
52    use utf8;
53    eval '${☭asd} = 1';
54    like($@, qr/\QUnrecognized character/, q(the first character in ${...} isn't special))
55 }
56
57 # Checking that at least some of the special variables work
58 for my $v (qw( ^V ; < > ( ) {^GLOBAL_PHASE} ^W _ 1 4 0 [ ] ! @ / \ = )) {
59   SKIP: {
60     skip_if_miniperl('No $[ under miniperl', 2) if $v eq '[';
61     local $@;
62     evalbytes "\$$v;";
63     is $@, '', "No syntax error for \$$v";
64
65     local $@;
66     eval "use utf8; \$$v;";
67     is $@, '', "No syntax error for \$$v under 'use utf8'";
68   }
69 }
70
71 # Checking if the Latin-1 range behaves as expected, and that the behavior is the
72 # same whenever under strict or not.
73 for ( 0x0 .. 0xff ) {
74     my @warnings;
75     local $SIG {__WARN__} = sub {push @warnings, @_ };
76     my $ord = utf8::unicode_to_native($_);
77     my $chr = chr $ord;
78     my $syntax_error = 0;   # Do we expect this code point to generate a
79                             # syntax error?  Assume not, for now
80     my $deprecated = 0;
81     my $name;
82
83     # A different number of tests are run depending on the branches in this
84     # loop iteration.  This allows us to add skips to make the reported total
85     # the same for each iteration.
86     my $tests = 0;
87     my $max_tests = 6;
88
89     if ($chr =~ /[[:graph:]]/a) {
90         $name = "'$chr'";
91         $syntax_error = 1 if $chr eq '{';
92     }
93     elsif ($chr =~ /[[:space:]]/a) {
94         $name = sprintf "\\x%02x, an ASCII space character", $ord;
95         $syntax_error = 1;
96     }
97     elsif ($chr =~ /[[:cntrl:]]/a) {
98         if ($chr eq "\N{NULL}") {
99             $name = sprintf "\\x%02x, NUL", $ord;
100             $syntax_error = 1;
101         }
102         else {
103             $name = sprintf "\\x%02x, an ASCII control", $ord;
104             $syntax_error = $::IS_EBCDIC;
105             $deprecated = ! $syntax_error;
106         }
107     }
108     elsif ($chr =~ /\pC/) {
109         if ($chr eq "\N{SHY}") {
110             $name = sprintf "\\x%02x, SHY", $ord;
111         }
112         else {
113             $name = sprintf "\\x%02x, a C1 control", $ord;
114         }
115         $syntax_error = $::IS_EBCDIC;
116         $deprecated = ! $syntax_error;
117     }
118     elsif ($chr =~ /\p{XIDStart}/) {
119         $name = sprintf "\\x%02x, a non-ASCII XIDS character", $ord;
120     }
121     elsif ($chr =~ /\p{XPosixSpace}/) {
122         $name = sprintf "\\x%02x, a non-ASCII space character", $ord;
123         $syntax_error = $::IS_EBCDIC;
124         $deprecated = ! $syntax_error;
125     }
126     else {
127         $name = sprintf "\\x%02x, a non-ASCII, non-XIDS graphic character", $ord;
128     }
129     no warnings 'closure';
130     my $esc = sprintf("%X", $ord);
131     utf8::downgrade($chr);
132     if ($chr !~ /\p{XIDS}/u) {
133         if ($syntax_error) {
134             evalbytes "\$$chr";
135             like($@, qr/ syntax\ error | Unrecognized\ character /x,
136                      "$name as a length-1 variable generates a syntax error");
137             $tests++;
138         }
139         elsif ($ord < 32 || chr =~ /[[:punct:][:digit:]]/a) {
140
141             # Unlike other variables, we dare not try setting the length-1
142             # variables that are \cX (for all valid X) nor ASCII ones that are
143             # punctuation nor digits.  This is because many of these variables
144             # have meaning to the system, and setting them could have side
145             # effects or not work as expected (And using fresh_perl() doesn't
146             # always help.) For example, setting $^D (to use a visible
147             # representation of code point 0x04) turns on tracing, and setting
148             # $^E sets an error number, but what gets printed is instead a
149             # string associated with that number.  For all these we just
150             # verify that they don't generate a syntax error.
151             local $@;
152             evalbytes "\$$chr;";
153             is $@, '', "$name as a length-1 variable doesn't generate a syntax error";
154             $tests++;
155             utf8::upgrade($chr);
156             evalbytes "no strict; use utf8; \$$chr;",
157             is $@, '', "  ... and the same under 'use utf8'";
158             $tests++;
159         }
160         else {
161             is evalbytes "no strict; \$$chr = 10",
162                 10,
163                 "$name is legal as a length-1 variable";
164             $tests++;
165             if ($chr =~ /[[:ascii:]]/) {
166                 utf8::upgrade($chr);
167                 is evalbytes "no strict; use utf8; \$$chr = 1",
168                     1,
169                     "  ... and is legal under 'use utf8'";
170                 $tests++;
171             }
172             else {
173                 utf8::upgrade($chr);
174                 local $@;
175                 eval "no strict; use utf8; \$$chr = 1";
176                 like $@,
177                     qr/\QUnrecognized character \x{\E\L$esc/,
178                     "  ... but is illegal as a length-1 variable under 'use utf8'";
179                 $tests++;
180             }
181         }
182     }
183     else {
184         {
185             no utf8;
186             local $@;
187             evalbytes "no strict; \$$chr = 1";
188             is($@, '', "$name under 'no utf8', 'no strict', is a valid length-1 variable");
189             $tests++;
190
191             if ($chr !~ /[[:ascii:]]/) {
192                 local $@;
193                 evalbytes "use strict; \$$chr = 1";
194                 is($@,
195                     '',
196                     "  ... and under 'no utf8' does not have to be required under strict, even though it matches XIDS"
197                 );
198                 $tests++;
199
200                 local $@;
201                 evalbytes "\$a$chr = 1";
202                 like($@,
203                     qr/Unrecognized character /,
204                     "  ... but under 'no utf8', it's not allowed in length-2+ variables"
205                 );
206                 $tests++;
207             }
208         }
209         {
210             use utf8;
211             my $utf8 = $chr;
212             utf8::upgrade($utf8);
213             local $@;
214             eval "no strict; \$$utf8 = 1";
215             is($@, '', "  ... and under 'use utf8', 'no strict', is a valid length-1 variable");
216             $tests++;
217
218             local $@;
219             eval "use strict; \$$utf8 = 1";
220             if ($chr =~ /[ab]/) {   # These are special, for sort()
221                 is($@, '', "  ... and under 'use utf8', 'use strict',"
222                     . " is a valid length-1 variable (\$a and \$b are special)");
223                 $tests++;
224             }
225             else {
226                 like($@,
227                     qr/Global symbol "\$$utf8" requires explicit package name/,
228                     "  ... and under utf8 has to be required under strict"
229                 );
230                 $tests++;
231             }
232         }
233     }
234
235     if (! $deprecated) {
236         if ($chr =~ /[#*]/) {
237
238             # Length-1 variables with these two characters used to be used by
239             # Perl, but now their generates a warning that they're gone.
240             # Ignore such warnings.
241             for (my $i = @warnings - 1; $i >= 0; $i--) {
242                 splice @warnings, $i, 1 if $warnings[$i] =~ /is no longer supported/;
243             }
244         }
245         ok(@warnings == 0, "  ... and doesn't generate any warnings");
246         $tests++;
247     }
248     elsif (! @warnings) {
249         fail("  ... and generates deprecation warnings (since is deprecated)");
250         $tests++;
251     }
252     else {
253         ok((scalar @warnings == grep { $_ =~ /deprecated/ } @warnings),
254            "  ... and generates deprecation warnings (only)");
255         $tests++;
256     }
257
258     SKIP: {
259         die "Wrong max count for tests" if $tests > $max_tests;
260         skip("untaken tests", $max_tests - $tests) if $max_tests > $tests;
261     }
262 }
263
264 {
265     use utf8;
266     my $ret = eval "my \$c\x{327} = 100; \$c\x{327}"; # c + cedilla
267     is($@, '', "ASCII character + combining character works as a variable name");
268     is($ret, 100, "  ... and returns the correct value");
269 }
270
271 # From Tom Christiansen's 'highly illegal variable names are now accidentally legal' mail
272 for my $chr (
273       "\N{EM DASH}", "\x{F8FF}", "\N{POUND SIGN}", "\N{SOFT HYPHEN}",
274       "\N{THIN SPACE}", "\x{11_1111}", "\x{DC00}", "\N{COMBINING DIAERESIS}",
275       "\N{COMBINING ENCLOSING CIRCLE BACKSLASH}",
276    )
277 {
278    no warnings 'non_unicode';
279    my $esc = sprintf("%x", ord $chr);
280    local $@;
281    eval "\$$chr = 1; \$$chr";
282    like($@,
283         qr/\QUnrecognized character \x{$esc};/,
284         "\\x{$esc} is illegal for a length-one identifier"
285        );
286 }
287
288 for my $i (0x100..0xffff) {
289    my $chr = chr($i);
290    my $esc = sprintf("%x", $i);
291    local $@;
292    eval "my \$$chr = q<test>; \$$chr;";
293    if ( $chr =~ /^\p{_Perl_IDStart}$/ ) {
294       is($@, '', sprintf("\\x{%04x} is XIDS, works as a length-1 variable", $i));
295    }
296    else {
297       like($@,
298            qr/\QUnrecognized character \x{$esc};/,
299            "\\x{$esc} isn't XIDS, illegal as a length-1 variable",
300           )
301    }
302 }
303
304 {
305     # Bleadperl v5.17.9-109-g3283393 breaks ZEFRAM/Module-Runtime-0.013.tar.gz
306     # https://rt.perl.org/rt3/Public/Bug/Display.html?id=117101
307     no strict;
308
309     local $@;
310     eval <<'EOP';
311     q{$} =~ /(.)/;
312     is($$1, $$, q{$$1 parses as ${$1}});
313
314     $doof = "test";
315     $test = "Got here";
316     $::{+$$} = *doof;
317
318     is( $$$$1, $test, q{$$$$1 parses as ${${${$1}}}} );
319 EOP
320     is($@, '', q{$$1 parses correctly});
321
322     for my $chr ( q{@}, "\N{U+FF10}", "\N{U+0300}" ) {
323         my $esc = sprintf("\\x{%x}", ord $chr);
324         local $@;
325         eval <<"    EOP";
326             \$$chr = q{\$};
327             \$\$$chr;
328     EOP
329
330         like($@,
331              qr/syntax error|Unrecognized character/,
332              qq{\$\$$esc is a syntax error}
333         );
334     }
335 }
336
337 {    
338     # bleadperl v5.17.9-109-g3283393 breaks JEREMY/File-Signature-1.009.tar.gz
339     # https://rt.perl.org/rt3/Ticket/Display.html?id=117145
340     local $@;
341     my $var = 10;
342     eval ' ${  var  }';
343
344     is(
345         $@,
346         '',
347         '${  var  } works under strict'
348     );
349
350     {
351         no strict;
352         # Silence the deprecation warning for literal controls
353         no warnings 'deprecated';
354
355         for my $var ( '$', "\7LOBAL_PHASE", "^GLOBAL_PHASE", "^V" ) {
356           SKIP: {
357             skip("Literal control characters in variable names forbidden on EBCDIC", 3)
358                              if ($::IS_EBCDIC && ord substr($var, 0, 1) < 32);
359             eval "\${ $var}";
360             is($@, '', "\${ $var} works" );
361             eval "\${$var }";
362             is($@, '', "\${$var } works" );
363             eval "\${ $var }";
364             is($@, '', "\${ $var } works" );
365           }
366         }
367     }
368 }
369
370 {
371     is(
372         "".eval "*{\nOIN}",
373         "*main::OIN",
374         "Newlines at the start of an identifier should be skipped over"
375     );
376     
377     
378     SKIP: {
379         skip('Is $^U on EBCDIC 1047, BC; nothing works on 0037', 1)
380                                                                 if $::IS_EBCDIC;
381         is(
382             "".eval "*{^JOIN}",
383             "*main::\nOIN",
384             "  ... but \$^J is still legal"
385         );
386     }
387     
388   SKIP: {
389     skip("Literal control characters in variable names forbidden on EBCDIC", 2)
390                                                                 if $::IS_EBCDIC;
391     no warnings 'deprecated';
392     my $ret = eval "\${\cT\n}";
393     is($@, "", 'No errors from using ${\n\cT\n}');
394     is($ret, $^T, "  ... and we got the right value");
395   }
396 }
397
398 SKIP: {
399     skip("Literal control characters in variable names forbidden on EBCDIC", 5)
400                                                                 if $::IS_EBCDIC;
401
402     # Originally from t/base/lex.t, moved here since we can't
403     # turn deprecation warnings off in that file.
404     no strict;
405     no warnings 'deprecated';
406     
407     my $CX  = "\cX";
408     $ {$CX} = 17;
409     
410     # Does the syntax where we use the literal control character still work?
411     is(
412        eval "\$ {\cX}",
413        17,
414        "Literal control character variables work"
415     );
416
417     eval "\$\cQ = 24";                 # Literal control character
418     is($@, "", "  ... and they can be assigned to without error");
419     is(${"\cQ"}, 24, "  ... and the assignment works");
420     is($^Q, 24, "  ... even if we access the variable through the caret name");
421     is(\${"\cQ"}, \$^Q, '\${\cQ} == \$^Q');
422 }
423
424 {
425     # Prior to 5.19.4, the following changed behavior depending
426     # on the presence of the newline after '@{'.
427     sub foo (&) { [1] }
428     my %foo = (a=>2);
429     my $ret = @{ foo { "a" } };
430     is($ret, $foo{a}, '@{ foo { "a" } } is parsed as @foo{a}');
431     
432     $ret = @{
433             foo { "a" }
434         };
435     is($ret, $foo{a}, '@{\nfoo { "a" } } is still parsed as @foo{a}');
436
437 }