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