1#!./perl 2 3BEGIN { 4 splice @INC, 0, 0, 't', '.'; 5 require Config; 6 if (($Config::Config{'extensions'} !~ /\bB\b/) ){ 7 print "1..0 # Skip -- Perl configured without B module\n"; 8 exit 0; 9 } 10 require 'test.pl'; 11} 12 13use warnings; 14use strict; 15 16my $tests = 52; # not counting those in the __DATA__ section 17 18use B::Deparse; 19my $deparse = B::Deparse->new(); 20isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object'); 21my %deparse; 22 23sub dummy_sub {42} 24 25$/ = "\n####\n"; 26while (<DATA>) { 27 chomp; 28 $tests ++; 29 # This code is pinched from the t/lib/common.pl for TODO. 30 # It's not clear how to avoid duplication 31 my %meta = (context => ''); 32 foreach my $what (qw(skip todo context options)) { 33 s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $1; 34 # If the SKIP reason starts ? then it's taken as a code snippet to 35 # evaluate. This provides the flexibility to have conditional SKIPs 36 if ($meta{$what} && $meta{$what} =~ s/^\?//) { 37 my $temp = eval $meta{$what}; 38 if ($@) { 39 die "# In \U$what\E code reason:\n# $meta{$what}\n$@"; 40 } 41 $meta{$what} = $temp; 42 } 43 } 44 45 s/^\s*#\s*(.*)$//mg; 46 my $desc = $1; 47 die "Missing name in test $_" unless defined $desc; 48 49 if ($meta{skip}) { 50 SKIP: { skip($meta{skip}) }; 51 next; 52 } 53 54 my ($input, $expected); 55 if (/(.*)\n>>>>\n(.*)/s) { 56 ($input, $expected) = ($1, $2); 57 } 58 else { 59 ($input, $expected) = ($_, $_); 60 } 61 62 # parse options if necessary 63 my $deparse = $meta{options} 64 ? $deparse{$meta{options}} ||= 65 new B::Deparse split /,/, $meta{options} 66 : $deparse; 67 68 my $code = "$meta{context};\n" . <<'EOC' . "sub {$input\n}"; 69# Tell B::Deparse about our ambient pragmas 70my ($hint_bits, $warning_bits, $hinthash); 71BEGIN { 72 ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); 73} 74$deparse->ambient_pragmas ( 75 hint_bits => $hint_bits, 76 warning_bits => $warning_bits, 77 '%^H' => $hinthash, 78); 79EOC 80 my $coderef = eval $code; 81 82 local $::TODO = $meta{todo}; 83 if ($@) { 84 is($@, "", "compilation of $desc") 85 or diag "=============================================\n" 86 . "CODE:\n--------\n$code\n--------\n" 87 . "=============================================\n"; 88 } 89 else { 90 my $deparsed = $deparse->coderef2text( $coderef ); 91 my $regex = $expected; 92 $regex =~ s/(\S+)/\Q$1/g; 93 $regex =~ s/\s+/\\s+/g; 94 $regex = '^\{\s*' . $regex . '\s*\}$'; 95 96 like($deparsed, qr/$regex/, $desc) 97 or diag "=============================================\n" 98 . "CODE:\n--------\n$input\n--------\n" 99 . "EXPECTED:\n--------\n{\n$expected\n}\n--------\n" 100 . "GOT:\n--------\n$deparsed\n--------\n" 101 . "=============================================\n"; 102 } 103} 104 105# Reset the ambient pragmas 106{ 107 my ($b, $w, $h); 108 BEGIN { 109 ($b, $w, $h) = ($^H, ${^WARNING_BITS}, \%^H); 110 } 111 $deparse->ambient_pragmas ( 112 hint_bits => $b, 113 warning_bits => $w, 114 '%^H' => $h, 115 ); 116} 117 118use constant 'c', 'stuff'; 119is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff', 120 'the subroutine generated by use constant deparses'); 121 122my $a = 0; 123is($deparse->coderef2text(sub{(-1) ** $a }), "{\n (-1) ** \$a;\n}", 124 'anon sub capturing an external lexical'); 125 126use constant cr => ['hello']; 127my $string = "sub " . $deparse->coderef2text(\&cr); 128my $val = (eval $string)->() or diag $string; 129is(ref($val), 'ARRAY', 'constant array references deparse'); 130is($val->[0], 'hello', 'and return the correct value'); 131 132my $path = join " ", map { qq["-I$_"] } @INC; 133 134$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`; 135$a =~ s/-e syntax OK\n//g; 136$a =~ s/.*possible typo.*\n//; # Remove warning line 137$a =~ s/.*-i used with no filenames.*\n//; # Remove warning line 138$b = quotemeta <<'EOF'; 139BEGIN { $^I = ".bak"; } 140BEGIN { $^W = 1; } 141BEGIN { $/ = "\n"; $\ = "\n"; } 142LINE: while (defined($_ = readline ARGV)) { 143 chomp $_; 144 our(@F) = split(' ', $_, 0); 145 '???'; 146} 147EOF 148$b =~ s/our\\\(\\\@F\\\)/our[( ]\@F\\)?/; # accept both our @F and our(@F) 149like($a, qr/$b/, 150 'command line flags deparse as BEGIN blocks setting control variables'); 151 152$a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`; 153$a =~ s/-e syntax OK\n//g; 154is($a, "use constant ('PI', 4);\n", 155 "Proxy Constant Subroutines must not show up as (incorrect) prototypes"); 156 157$a = `$^X $path "-MO=Deparse" -e "sub foo(){1}" 2>&1`; 158$a =~ s/-e syntax OK\n//g; 159is($a, "sub foo () {\n 1;\n}\n", 160 "Main prog consisting of just a constant (via empty proto)"); 161 162$a = readpipe qq|$^X $path "-MO=Deparse"| 163 .qq| -e "package F; sub f(){0} sub s{}"| 164 .qq| -e "#line 123 four-five-six"| 165 .qq| -e "package G; sub g(){0} sub s{}" 2>&1|; 166$a =~ s/-e syntax OK\n//g; 167like($a, qr/sub F::f \(\) \{\s*0;?\s*}/, 168 "Constant is dumped in package in which other subs are dumped"); 169unlike($a, qr/sub g/, 170 "Constant is not dumped in package in which other subs are not dumped"); 171 172#Re: perlbug #35857, patch #24505 173#handle warnings::register-ed packages properly. 174package B::Deparse::Wrapper; 175use strict; 176use warnings; 177use warnings::register; 178sub getcode { 179 my $deparser = B::Deparse->new(); 180 return $deparser->coderef2text(shift); 181} 182 183package Moo; 184use overload '0+' => sub { 42 }; 185 186package main; 187use strict; 188use warnings; 189use constant GLIPP => 'glipp'; 190use constant PI => 4; 191use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo'); 192use Fcntl qw/O_TRUNC O_APPEND O_EXCL/; 193BEGIN { delete $::Fcntl::{O_APPEND}; } 194use POSIX qw/O_CREAT/; 195sub test { 196 my $val = shift; 197 my $res = B::Deparse::Wrapper::getcode($val); 198 like($res, qr/use warnings/, 199 '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly'); 200} 201my ($q,$p); 202my $x=sub { ++$q,++$p }; 203test($x); 204eval <<EOFCODE and test($x); 205 package bar; 206 use strict; 207 use warnings; 208 use warnings::register; 209 package main; 210 1 211EOFCODE 212 213# Exotic sub declarations 214$a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`; 215$a =~ s/-e syntax OK\n//g; 216is($a, <<'EOCODG', "sub :::: and sub ::::::"); 217sub :::: { 218 219} 220sub :::::: { 221 222} 223EOCODG 224 225# [perl #117311] 226$a = `$^X $path "-MO=Deparse,-l" -e "map{ eval(0) }()" 2>&1`; 227$a =~ s/-e syntax OK\n//g; 228is($a, <<'EOCODH', "[perl #117311] [PATCH] -l option ('#line ...') does not emit ^Ls in the output"); 229#line 1 "-e" 230map { 231#line 1 "-e" 232eval 0;} (); 233EOCODH 234 235# [perl #33752] 236{ 237 my $code = <<"EOCODE"; 238{ 239 our \$\x{1e1f}\x{14d}\x{14d}; 240} 241EOCODE 242 my $deparsed 243 = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" ); 244 s/$ \n//x for $deparsed, $code; 245 is $deparsed, $code, 'our $funny_Unicode_chars'; 246} 247 248# [perl #62500] 249$a = 250 `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`; 251$a =~ s/-e syntax OK\n//g; 252is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick"); 253sub BEGIN { 254 *CORE::GLOBAL::require = sub { 255 1; 256 } 257 ; 258} 259EOCODF 260 261# [perl #91384] 262$a = 263 `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`; 264like($a, qr/-e syntax OK/, 265 "Deparse does not hang when traversing stash circularities"); 266 267# [perl #93990] 268@] = (); 269is($deparse->coderef2text(sub{ print "foo@{]}" }), 270q<{ 271 print "foo@{]}"; 272}>, 'curly around to interpolate "@{]}"'); 273is($deparse->coderef2text(sub{ print "foo@{-}" }), 274q<{ 275 print "foo@-"; 276}>, 'no need to curly around to interpolate "@-"'); 277 278# Strict hints in %^H are mercilessly suppressed 279$a = 280 `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`; 281unlike($a, qr/BEGIN/, 282 "Deparse does not emit strict hh hints"); 283 284# ambient_pragmas should not mess with strict settings. 285SKIP: { 286 skip "requires 5.11", 1 unless $] >= 5.011; 287 eval q` 288 BEGIN { 289 # Clear out all hints 290 %^H = (); 291 $^H = 0; 292 new B::Deparse -> ambient_pragmas(strict => 'all'); 293 } 294 use 5.011; # should enable strict 295 ok !eval '$do_noT_create_a_variable_with_this_name = 1', 296 'ambient_pragmas do not mess with compiling scope'; 297 `; 298} 299 300# multiple statements on format lines 301$a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`; 302$a =~ s/-e syntax OK\n//g; 303is($a, <<'EOCODH', 'multiple statements on format lines'); 304format STDOUT = 305@ 306x(); z() 307. 308EOCODH 309 310SKIP: { 311 skip("Your perl was built without taint support", 1) 312 unless $Config::Config{taint_support}; 313 314 is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-T' ], 315 prog => "format =\n\@\n\$;\n.\n"), 316 <<~'EOCODM', '$; on format line'; 317 format STDOUT = 318 @ 319 $; 320 . 321 EOCODM 322} 323 324is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse,-l', $path ], 325 prog => "format =\n\@\n\$foo\n.\n"), 326 <<'EOCODM', 'formats with -l'; 327format STDOUT = 328@ 329$foo 330. 331EOCODM 332 333is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 334 prog => "{ my \$x; format =\n\@\n\$x\n.\n}"), 335 <<'EOCODN', 'formats nested inside blocks'; 336{ 337 my $x; 338 format STDOUT = 339@ 340$x 341. 342} 343EOCODN 344 345# CORE::format 346$a = readpipe qq`$^X $path "-MO=Deparse" -e "use feature q|:all|;` 347 .qq` my sub format; CORE::format =" -e. 2>&1`; 348like($a, qr/CORE::format/, 'CORE::format when lex format sub is in scope'); 349 350# literal big chars under 'use utf8' 351is($deparse->coderef2text(sub{ use utf8; /€/; }), 352'{ 353 /\x{20ac}/; 354}', 355"qr/euro/"); 356 357# STDERR when deparsing sub calls 358# For a short while the output included 'While deparsing' 359$a = `$^X $path "-MO=Deparse" -e "foo()" 2>&1`; 360$a =~ s/-e syntax OK\n//g; 361is($a, <<'EOCODI', 'no extra output when deparsing foo()'); 362foo(); 363EOCODI 364 365# Sub calls compiled before importation 366like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 367 prog => 'BEGIN { 368 require Test::More; 369 Test::More::->import; 370 is(*foo, *foo) 371 }'), 372 qr/&is\(/, 373 'sub calls compiled before importation of prototype subs'; 374 375# [perl #121050] Prototypes with whitespace 376is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 377 prog => <<'EOCODO'), 378sub _121050(\$ \$) { } 379_121050($a,$b); 380sub _121050empty( ) {} 381() = _121050empty() + 1; 382EOCODO 383 <<'EOCODP', '[perl #121050] prototypes with whitespace'; 384sub _121050 (\$ \$) { 385 386} 387_121050 $a, $b; 388sub _121050empty ( ) { 389 390} 391() = _121050empty + 1; 392EOCODP 393 394# CORE::no 395$a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` 396 .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`; 397like($a, qr/my sub no;\n.*CORE::no less;/s, 398 'CORE::no after my sub no'); 399 400# CORE::use 401$a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` 402 .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`; 403like($a, qr/my sub use;\n.*CORE::use less;/s, 404 'CORE::use after my sub use'); 405 406# CORE::__DATA__ 407$a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` 408 .qq`"use feature q|:all|; my sub __DATA__; ` 409 .qq`CORE::__DATA__" 2>&1`; 410like($a, qr/my sub __DATA__;\n.*CORE::__DATA__/s, 411 'CORE::__DATA__ after my sub __DATA__'); 412 413# sub declarations 414$a = readpipe qq`$^X $path "-MO=Deparse" -e "sub foo{}" 2>&1`; 415like($a, qr/sub foo\s*\{\s+\}/, 'sub declarations'); 416like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 417 prog => 'sub f($); sub f($){}'), 418 qr/sub f\s*\(\$\)\s*\{\s*\}/, 419 'predeclared prototyped subs'; 420like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 421 prog => 'sub f($); 422 BEGIN { use builtin q-weaken-; weaken($_=\$::{f}) }'), 423 qr/sub f\s*\(\$\)\s*;/, 424 'prototyped stub with weak reference to the stash entry'; 425like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 426 prog => 'sub f () { 42 }'), 427 qr/sub f\s*\(\)\s*\{\s*42;\s*\}/, 428 'constant perl sub declaration'; 429 430# BEGIN blocks 431SKIP : { 432 skip "BEGIN output is wrong on old perls", 1 if $] < 5.021006; 433 my $prog = ' 434 BEGIN { pop } 435 { 436 BEGIN { pop } 437 { 438 no overloading; 439 { 440 BEGIN { pop } 441 die 442 } 443 } 444 }'; 445 $prog =~ s/\n//g; 446 $a = readpipe qq`$^X $path "-MO=Deparse" -e "$prog" 2>&1`; 447 $a =~ s/-e syntax OK\n//g; 448 is($a, <<'EOCODJ', 'BEGIN blocks'); 449sub BEGIN { 450 pop @ARGV; 451} 452{ 453 sub BEGIN { 454 pop @ARGV; 455 } 456 { 457 no overloading; 458 { 459 sub BEGIN { 460 pop @ARGV; 461 } 462 die; 463 } 464 } 465} 466EOCODJ 467} 468is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], prog => ' 469 { 470 { 471 die; 472 BEGIN { pop } 473 } 474 BEGIN { pop } 475 } 476 BEGIN { pop } 477 '), <<'EOCODL', 'BEGIN blocks at the end of their enclosing blocks'; 478{ 479 { 480 die; 481 sub BEGIN { 482 pop @ARGV; 483 } 484 } 485 sub BEGIN { 486 pop @ARGV; 487 } 488} 489sub BEGIN { 490 pop @ARGV; 491} 492EOCODL 493 494# BEGIN blocks should not be called __ANON__ 495like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 496 prog => 'sub BEGIN { } CHECK { delete $::{BEGIN} }'), 497 qr/sub BEGIN/, 'anonymised BEGIN'; 498 499# [perl #115066] 500my $prog = 'use constant FOO => do { 1 }; no overloading; die'; 501$a = readpipe qq`$^X $path "-MO=-qq,Deparse" -e "$prog" 2>&1`; 502is($a, <<'EOCODK', '[perl #115066] use statements accidentally nested'); 503use constant ('FOO', do { 504 1 505}); 506no overloading; 507die; 508EOCODK 509 510# BEGIN blocks inside predeclared subs 511like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 512 prog => ' 513 sub run_tests; 514 run_tests(); 515 sub run_tests { BEGIN { } die }'), 516 qr/sub run_tests \{\s*sub BEGIN/, 517 'BEGIN block inside predeclared sub'; 518 519like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 520 prog => 'package foo; use overload qr=>sub{}'), 521 qr/package foo;\s*use overload/, 522 'package, then use'; 523 524like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 525 prog => 'use feature lexical_subs=>; my sub f;sub main::f{}'), 526 qr/^sub main::f \{/m, 527 'sub decl when lex sub is in scope'; 528 529like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 530 prog => 'sub foo{foo()}'), 531 qr/^sub foo \{\s+foo\(\)/m, 532 'recursive sub'; 533 534like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 535 prog => 'use feature lexical_subs=>state=>; 536 state sub sb5; sub { sub sb5 { } }'), 537 qr/sub \{\s*\(\);\s*sub sb5 \{/m, 538 'state sub in anon sub but declared outside'; 539 540is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 541 prog => 'BEGIN { $::{f}=\!0 }'), 542 "sub BEGIN {\n \$main::{'f'} = \\!0;\n}\n", 543 '&PL_sv_yes constant (used to croak)'; 544 545SKIP: { 546 skip("Your perl was built without taint support", 1) 547 unless $Config::Config{taint_support}; 548 is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-T' ], 549 prog => '$x =~ (1?/$a/:0)'), 550 '$x =~ ($_ =~ /$a/);'."\n", 551 '$foo =~ <branch-folded match> under taint mode'; 552} 553 554unlike runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-w' ], 555 prog => 'BEGIN { undef &foo }'), 556 qr'Use of uninitialized value', 557 'no warnings for undefined sub'; 558 559is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 560 prog => 'sub f { 1; } BEGIN { *g = \&f; }'), 561 "sub f {\n 1;\n}\nsub BEGIN {\n *g = \\&f;\n}\n", 562 "sub glob alias shouldn't impede emitting original sub"; 563 564is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 565 prog => 'package Foo; sub f { 1; } BEGIN { *g = \&f; }'), 566 "package Foo;\nsub f {\n 1;\n}\nsub BEGIN {\n *g = \\&f;\n}\n", 567 "sub glob alias outside main shouldn't impede emitting original sub"; 568 569is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], 570 prog => 'package Foo; sub f { 1; } BEGIN { *Bar::f = \&f; }'), 571 "package Foo;\nsub f {\n 1;\n}\nsub BEGIN {\n *Bar::f = \\&f;\n}\n", 572 "sub glob alias in separate package shouldn't impede emitting original sub"; 573 574 575done_testing($tests); 576 577__DATA__ 578# [perl #120950] Previously on a 2nd instance succeeded 579# y/uni/code/ 580tr/\x{345}/\x{370}/; 581#### 582# y/uni/code/ [perl #120950] This 2nd instance succeeds 583tr/\x{345}/\x{370}/; 584#### 585# A constant 5861; 587#### 588# Constants in a block 589# CONTEXT no warnings; 590{ 591 '???'; 592 2; 593} 594#### 595# List of constants in void context 596# CONTEXT no warnings; 597(1,2,3); 5980; 599>>>> 600'???', '???', '???'; 6010; 602#### 603# Lexical and simple arithmetic 604my $test; 605++$test and $test /= 2; 606>>>> 607my $test; 608$test /= 2 if ++$test; 609#### 610# list x 611-((1, 2) x 2); 612#### 613# Assignment to list x 614((undef) x 3) = undef; 615#### 616# lvalue sub 617{ 618 my $test = sub : lvalue { 619 my $x; 620 } 621 ; 622} 623#### 624# method 625{ 626 my $test = sub : method { 627 my $x; 628 } 629 ; 630} 631#### 632# anonsub attrs at statement start 633my $x = do { +sub : lvalue { my $y; } }; 634my $z = do { foo: +sub : method { my $a; } }; 635#### 636# block with continue 637{ 638 234; 639} 640continue { 641 123; 642} 643#### 644# lexical and package scalars 645my $x; 646print $main::x; 647#### 648# lexical and package arrays 649my @x; 650print $main::x[1]; 651print \my @a; 652#### 653# lexical and package hashes 654my %x; 655$x{warn()}; 656#### 657# our (LIST) 658our($foo, $bar, $baz); 659#### 660# CONTEXT { package Dog } use feature "state"; 661# variables with declared classes 662my Dog $spot; 663our Dog $spotty; 664state Dog $spotted; 665my Dog @spot; 666our Dog @spotty; 667state Dog @spotted; 668my Dog %spot; 669our Dog %spotty; 670state Dog %spotted; 671my Dog ($foo, @bar, %baz); 672our Dog ($phoo, @barr, %bazz); 673state Dog ($fough, @barre, %bazze); 674#### 675# local our 676local our $rhubarb; 677local our($rhu, $barb); 678#### 679# <> 680my $foo; 681$_ .= <> . <ARGV> . <$foo>; 682<$foo>; 683<${foo}>; 684<$ foo>; 685>>>> 686my $foo; 687$_ .= readline(ARGV) . readline(ARGV) . readline($foo); 688readline $foo; 689glob $foo; 690glob $foo; 691#### 692# more <> 693no warnings; 694no strict; 695my $fh; 696if (dummy_sub < $fh > /bar/g) { 1 } 697>>>> 698no warnings; 699no strict; 700my $fh; 701if (dummy_sub(glob((' ' . $fh . ' ')) / 'bar' / 'g')) { 702 1; 703} 704#### 705# readline 706readline 'FH'; 707readline *$_; 708readline *{$_}; 709readline ${"a"}; 710>>>> 711readline 'FH'; 712readline *$_; 713readline *{$_;}; 714readline ${'a';}; 715#### 716# <<>> 717$_ = <<>>; 718#### 719# \x{} 720my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ"; 721my $bar = "\x{100}"; 722#### 723# Latin-1 chars 724# TODO ? ord("A") != 65 && "EBCDIC" 725my $baz = "B\366\x{100}"; 726my $bba = qr/B\366\x{100}/; 727#### 728# s///e 729s/x/'y';/e; 730s/x/$a;/e; 731s/x/complex_expression();/e; 732#### 733# block 734{ my $x; } 735#### 736# while 1 737while (1) { my $k; } 738#### 739# trailing for 740my ($x,@a); 741$x=1 for @a; 742>>>> 743my($x, @a); 744$x = 1 foreach (@a); 745#### 746# 2 arguments in a 3 argument for 747for (my $i = 0; $i < 2;) { 748 my $z = 1; 749} 750#### 751# 3 argument for 752for (my $i = 0; $i < 2; ++$i) { 753 my $z = 1; 754} 755#### 756# 3 argument for again 757for (my $i = 0; $i < 2; ++$i) { 758 my $z = 1; 759} 760#### 761# 3-argument for with inverted condition 762for (my $i; not $i;) { 763 die; 764} 765for (my $i; not $i; ++$i) { 766 die; 767} 768for (my $a; not +($1 || 2) ** 2;) { 769 die; 770} 771Something_to_put_the_loop_in_void_context(); 772#### 773# while/continue 774my $i; 775while ($i) { my $z = 1; } continue { $i = 99; } 776#### 777# foreach with my 778foreach my $i (1, 2) { 779 my $z = 1; 780} 781#### 782# OPTIONS -p 783# foreach with my under -p 784foreach my $i (1) { 785 die; 786} 787#### 788# foreach 789my $i; 790foreach $i (1, 2) { 791 my $z = 1; 792} 793#### 794# foreach, 2 mys 795my $i; 796foreach my $i (1, 2) { 797 my $z = 1; 798} 799#### 800# foreach with our 801foreach our $i (1, 2) { 802 my $z = 1; 803} 804#### 805# foreach with my and our 806my $i; 807foreach our $i (1, 2) { 808 my $z = 1; 809} 810#### 811# foreach with state 812# CONTEXT use feature "state"; 813foreach state $i (1, 2) { 814 state $z = 1; 815} 816#### 817# foreach with sub call 818foreach $_ (hcaerof()) { 819 (); 820} 821#### 822# reverse sort 823my @x; 824print reverse sort(@x); 825#### 826# sort with cmp 827my @x; 828print((sort {$b cmp $a} @x)); 829#### 830# reverse sort with block 831my @x; 832print((reverse sort {$b <=> $a} @x)); 833#### 834# foreach reverse 835our @a; 836print $_ foreach (reverse @a); 837#### 838# foreach reverse (not inplace) 839our @a; 840print $_ foreach (reverse 1, 2..5); 841#### 842# bug #38684 843our @ary; 844@ary = split(' ', 'foo', 0); 845#### 846my @ary; 847@ary = split(' ', 'foo', 0); 848#### 849# Split to our array 850our @array = split(//, 'foo', 0); 851#### 852# Split to my array 853my @array = split(//, 'foo', 0); 854#### 855our @array; 856my $c; 857@array = split(/x(?{ $c++; })y/, 'foo', 0); 858#### 859my($x, $y, $p); 860our $c; 861($x, $y) = split(/$p(?{ $c++; })y/, 'foo', 2); 862#### 863our @ary; 864my $pat; 865@ary = split(/$pat/, 'foo', 0); 866#### 867my @ary; 868our $pat; 869@ary = split(/$pat/, 'foo', 0); 870#### 871our @array; 872my $pat; 873local @array = split(/$pat/, 'foo', 0); 874#### 875our $pat; 876my @array = split(/$pat/, 'foo', 0); 877#### 878# bug #40055 879do { () }; 880#### 881# bug #40055 882do { my $x = 1; $x }; 883#### 884# <20061012113037.GJ25805@c4.convolution.nl> 885my $f = sub { 886 +{[]}; 887} ; 888#### 889# anonconst 890# CONTEXT no warnings 'experimental::const_attr'; 891my $f = sub : const { 892 123; 893} 894; 895#### 896# bug #43010 897'!@$%'->(); 898#### 899# bug #43010 900::(); 901#### 902# bug #43010 903'::::'->(); 904#### 905# bug #43010 906&::::; 907#### 908# [perl #77172] 909package rt77172; 910sub foo {} foo & & & foo; 911>>>> 912package rt77172; 913foo(&{&} & foo()); 914#### 915# variables as method names 916my $bar; 917'Foo'->$bar('orz'); 918'Foo'->$bar('orz') = 'a stranger stranger than before'; 919#### 920# constants as method names 921'Foo'->bar('orz'); 922#### 923# constants as method names without () 924'Foo'->bar; 925#### 926# [perl #47359] "indirect" method call notation 927our @bar; 928foo{@bar}+1,->foo; 929(foo{@bar}+1),foo(); 930foo{@bar}1 xor foo(); 931>>>> 932our @bar; 933(foo { @bar } 1)->foo; 934(foo { @bar } 1), foo(); 935foo { @bar } 1 xor foo(); 936#### 937# indirops with blocks 938# CONTEXT use 5.01; 939print {*STDOUT;} 'foo'; 940printf {*STDOUT;} 'foo'; 941say {*STDOUT;} 'foo'; 942system {'foo';} '-foo'; 943exec {'foo';} '-foo'; 944#### 945# SKIP ?$] < 5.010 && "say not implemented on this Perl version" 946# CONTEXT use feature ':5.10'; 947# say 948say 'foo'; 949#### 950# SKIP ?$] < 5.010 && "say not implemented on this Perl version" 951# CONTEXT use 5.10.0; 952# say in the context of use 5.10.0 953say 'foo'; 954#### 955# SKIP ?$] < 5.010 && "say not implemented on this Perl version" 956# say with use 5.10.0 957use 5.10.0; 958say 'foo'; 959>>>> 960no feature ':all'; 961use feature ':5.10'; 962say 'foo'; 963#### 964# SKIP ?$] < 5.010 && "say not implemented on this Perl version" 965# say with use feature ':5.10'; 966use feature ':5.10'; 967say 'foo'; 968>>>> 969use feature 'say', 'state', 'switch'; 970say 'foo'; 971#### 972# SKIP ?$] < 5.010 && "say not implemented on this Perl version" 973# CONTEXT use feature ':5.10'; 974# say with use 5.10.0 in the context of use feature 975use 5.10.0; 976say 'foo'; 977>>>> 978no feature ':all'; 979use feature ':5.10'; 980say 'foo'; 981#### 982# SKIP ?$] < 5.010 && "say not implemented on this Perl version" 983# CONTEXT use 5.10.0; 984# say with use feature ':5.10' in the context of use 5.10.0 985use feature ':5.10'; 986say 'foo'; 987>>>> 988say 'foo'; 989#### 990# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" 991# CONTEXT use feature ':5.15'; 992# __SUB__ 993__SUB__; 994#### 995# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" 996# CONTEXT use 5.15.0; 997# __SUB__ in the context of use 5.15.0 998__SUB__; 999#### 1000# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" 1001# __SUB__ with use 5.15.0 1002use 5.15.0; 1003__SUB__; 1004>>>> 1005no feature ':all'; 1006use feature ':5.16'; 1007__SUB__; 1008#### 1009# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" 1010# __SUB__ with use feature ':5.15'; 1011use feature ':5.15'; 1012__SUB__; 1013>>>> 1014use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval'; 1015__SUB__; 1016#### 1017# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" 1018# CONTEXT use feature ':5.15'; 1019# __SUB__ with use 5.15.0 in the context of use feature 1020use 5.15.0; 1021__SUB__; 1022>>>> 1023no feature ':all'; 1024use feature ':5.16'; 1025__SUB__; 1026#### 1027# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" 1028# CONTEXT use 5.15.0; 1029# __SUB__ with use feature ':5.15' in the context of use 5.15.0 1030use feature ':5.15'; 1031__SUB__; 1032>>>> 1033__SUB__; 1034#### 1035# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" 1036# CONTEXT use feature ':5.10'; 1037# state vars 1038state $x = 42; 1039#### 1040# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" 1041# CONTEXT use feature ':5.10'; 1042# state var assignment 1043{ 1044 my $y = (state $x = 42); 1045} 1046#### 1047# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" 1048# CONTEXT use feature ':5.10'; 1049# state vars in anonymous subroutines 1050$a = sub { 1051 state $x; 1052 return $x++; 1053} 1054; 1055#### 1056# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' 1057# each @array; 1058each @ARGV; 1059each @$a; 1060#### 1061# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' 1062# keys @array; values @array 1063keys @$a if keys @ARGV; 1064values @ARGV if values @$a; 1065#### 1066# Anonymous arrays and hashes, and references to them 1067my $a = {}; 1068my $b = \{}; 1069my $c = []; 1070my $d = \[]; 1071#### 1072# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version" 1073# CONTEXT use feature ':5.10'; no warnings 'deprecated'; 1074# implicit smartmatch in given/when 1075given ('foo') { 1076 when ('bar') { continue; } 1077 when ($_ ~~ 'quux') { continue; } 1078 default { 0; } 1079} 1080#### 1081# conditions in elsifs (regression in change #33710 which fixed bug #37302) 1082if ($a) { x(); } 1083elsif ($b) { x(); } 1084elsif ($a and $b) { x(); } 1085elsif ($a or $b) { x(); } 1086else { x(); } 1087#### 1088# interpolation in regexps 1089my($y, $t); 1090/x${y}z$t/; 1091#### 1092# TODO new undocumented cpan-bug #33708 1093# cpan-bug #33708 1094%{$_ || {}} 1095#### 1096# TODO hash constants not yet fixed 1097# cpan-bug #33708 1098use constant H => { "#" => 1 }; H->{"#"} 1099#### 1100# TODO optimized away 0 not yet fixed 1101# cpan-bug #33708 1102foreach my $i (@_) { 0 } 1103#### 1104# tests with not, not optimized 1105my $c; 1106x() unless $a; 1107x() if not $a and $b; 1108x() if $a and not $b; 1109x() unless not $a and $b; 1110x() unless $a and not $b; 1111x() if not $a or $b; 1112x() if $a or not $b; 1113x() unless not $a or $b; 1114x() unless $a or not $b; 1115x() if $a and not $b and $c; 1116x() if not $a and $b and not $c; 1117x() unless $a and not $b and $c; 1118x() unless not $a and $b and not $c; 1119x() if $a or not $b or $c; 1120x() if not $a or $b or not $c; 1121x() unless $a or not $b or $c; 1122x() unless not $a or $b or not $c; 1123#### 1124# tests with not, optimized 1125my $c; 1126x() if not $a; 1127x() unless not $a; 1128x() if not $a and not $b; 1129x() unless not $a and not $b; 1130x() if not $a or not $b; 1131x() unless not $a or not $b; 1132x() if not $a and not $b and $c; 1133x() unless not $a and not $b and $c; 1134x() if not $a or not $b or $c; 1135x() unless not $a or not $b or $c; 1136x() if not $a and not $b and not $c; 1137x() unless not $a and not $b and not $c; 1138x() if not $a or not $b or not $c; 1139x() unless not $a or not $b or not $c; 1140x() unless not $a or not $b or not $c; 1141>>>> 1142my $c; 1143x() unless $a; 1144x() if $a; 1145x() unless $a or $b; 1146x() if $a or $b; 1147x() unless $a and $b; 1148x() if $a and $b; 1149x() if not $a || $b and $c; 1150x() unless not $a || $b and $c; 1151x() if not $a && $b or $c; 1152x() unless not $a && $b or $c; 1153x() unless $a or $b or $c; 1154x() if $a or $b or $c; 1155x() unless $a and $b and $c; 1156x() if $a and $b and $c; 1157x() unless not $a && $b && $c; 1158#### 1159# tests that should be constant folded 1160x() if 1; 1161x() if GLIPP; 1162x() if !GLIPP; 1163x() if GLIPP && GLIPP; 1164x() if !GLIPP || GLIPP; 1165x() if do { GLIPP }; 1166x() if do { no warnings 'void'; 5; GLIPP }; 1167x() if do { !GLIPP }; 1168if (GLIPP) { x() } else { z() } 1169if (!GLIPP) { x() } else { z() } 1170if (GLIPP) { x() } elsif (GLIPP) { z() } 1171if (!GLIPP) { x() } elsif (GLIPP) { z() } 1172if (GLIPP) { x() } elsif (!GLIPP) { z() } 1173if (!GLIPP) { x() } elsif (!GLIPP) { z() } 1174if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() } 1175if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() } 1176if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() } 1177>>>> 1178x(); 1179x(); 1180'???'; 1181x(); 1182x(); 1183x(); 1184x(); 1185do { 1186 '???' 1187}; 1188do { 1189 x() 1190}; 1191do { 1192 z() 1193}; 1194do { 1195 x() 1196}; 1197do { 1198 z() 1199}; 1200do { 1201 x() 1202}; 1203'???'; 1204do { 1205 t() 1206}; 1207'???'; 1208!1; 1209#### 1210# TODO constant deparsing has been backed out for 5.12 1211# XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads" 1212# tests that shouldn't be constant folded 1213# It might be fundamentally impossible to make this work on ithreads, in which 1214# case the TODO should become a SKIP 1215x() if $a; 1216if ($a == 1) { x() } elsif ($b == 2) { z() } 1217if (do { foo(); GLIPP }) { x() } 1218if (do { $a++; GLIPP }) { x() } 1219>>>> 1220x() if $a; 1221if ($a == 1) { x(); } elsif ($b == 2) { z(); } 1222if (do { foo(); GLIPP }) { x(); } 1223if (do { ++$a; GLIPP }) { x(); } 1224#### 1225# TODO constant deparsing has been backed out for 5.12 1226# tests for deparsing constants 1227warn PI; 1228#### 1229# TODO constant deparsing has been backed out for 5.12 1230# tests for deparsing imported constants 1231warn O_TRUNC; 1232#### 1233# TODO constant deparsing has been backed out for 5.12 1234# tests for deparsing re-exported constants 1235warn O_CREAT; 1236#### 1237# TODO constant deparsing has been backed out for 5.12 1238# tests for deparsing imported constants that got deleted from the original namespace 1239warn O_APPEND; 1240#### 1241# TODO constant deparsing has been backed out for 5.12 1242# XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads" 1243# tests for deparsing constants which got turned into full typeglobs 1244# It might be fundamentally impossible to make this work on ithreads, in which 1245# case the TODO should become a SKIP 1246warn O_EXCL; 1247eval '@Fcntl::O_EXCL = qw/affe tiger/;'; 1248warn O_EXCL; 1249#### 1250# TODO constant deparsing has been backed out for 5.12 1251# tests for deparsing of blessed constant with overloaded numification 1252warn OVERLOADED_NUMIFICATION; 1253#### 1254# strict 1255no strict; 1256print $x; 1257use strict 'vars'; 1258print $main::x; 1259use strict 'subs'; 1260print $main::x; 1261use strict 'refs'; 1262print $main::x; 1263no strict 'vars'; 1264$x; 1265#### 1266# TODO Subsets of warnings could be encoded textually, rather than as bitflips. 1267# subsets of warnings 1268no warnings 'deprecated'; 1269my $x; 1270#### 1271# TODO Better test for CPAN #33708 - the deparsed code has different behaviour 1272# CPAN #33708 1273use strict; 1274no warnings; 1275 1276foreach (0..3) { 1277 my $x = 2; 1278 { 1279 my $x if 0; 1280 print ++$x, "\n"; 1281 } 1282} 1283#### 1284# no attribute list 1285my $pi = 4; 1286#### 1287# SKIP ?$] > 5.013006 && ":= is now a syntax error" 1288# := treated as an empty attribute list 1289no warnings; 1290my $pi := 4; 1291>>>> 1292no warnings; 1293my $pi = 4; 1294#### 1295# : = empty attribute list 1296my $pi : = 4; 1297>>>> 1298my $pi = 4; 1299#### 1300# in place sort 1301our @a; 1302my @b; 1303@a = sort @a; 1304@b = sort @b; 1305(); 1306#### 1307# in place reverse 1308our @a; 1309my @b; 1310@a = reverse @a; 1311@b = reverse @b; 1312(); 1313#### 1314# #71870 Use of uninitialized value in bitwise and B::Deparse 1315my($r, $s, @a); 1316@a = split(/foo/, $s, 0); 1317$r = qr/foo/; 1318@a = split(/$r/, $s, 0); 1319(); 1320#### 1321# package declaration before label 1322{ 1323 package Foo; 1324 label: print 123; 1325} 1326#### 1327# shift optimisation 1328shift; 1329>>>> 1330shift(); 1331#### 1332# shift optimisation 1333shift @_; 1334#### 1335# shift optimisation 1336pop; 1337>>>> 1338pop(); 1339#### 1340# shift optimisation 1341pop @_; 1342#### 1343#[perl #20444] 1344"foo" =~ (1 ? /foo/ : /bar/); 1345"foo" =~ (1 ? y/foo// : /bar/); 1346"foo" =~ (1 ? y/foo//r : /bar/); 1347"foo" =~ (1 ? s/foo// : /bar/); 1348>>>> 1349'foo' =~ ($_ =~ /foo/); 1350'foo' =~ ($_ =~ tr/fo//); 1351'foo' =~ ($_ =~ tr/fo//r); 1352'foo' =~ ($_ =~ s/foo//); 1353#### 1354# The fix for [perl #20444] broke this. 1355'foo' =~ do { () }; 1356#### 1357# [perl #81424] match against aelemfast_lex 1358my @s; 1359print /$s[1]/; 1360#### 1361# /$#a/ 1362print /$#main::a/; 1363#### 1364# /@array/ 1365our @a; 1366my @b; 1367print /@a/; 1368print /@b/; 1369print qr/@a/; 1370print qr/@b/; 1371#### 1372# =~ QR_CONSTANT 1373use constant QR_CONSTANT => qr/a/soupmix; 1374'' =~ QR_CONSTANT; 1375>>>> 1376'' =~ /a/impsux; 1377#### 1378# $lexical =~ // 1379my $x; 1380$x =~ //; 1381#### 1382# [perl #91318] /regexp/applaud 1383print /a/a, s/b/c/a; 1384print /a/aa, s/b/c/aa; 1385print /a/p, s/b/c/p; 1386print /a/l, s/b/c/l; 1387print /a/u, s/b/c/u; 1388{ 1389 use feature "unicode_strings"; 1390 print /a/d, s/b/c/d; 1391} 1392{ 1393 use re "/u"; 1394 print /a/d, s/b/c/d; 1395} 1396{ 1397 use 5.012; 1398 print /a/d, s/b/c/d; 1399} 1400>>>> 1401print /a/a, s/b/c/a; 1402print /a/aa, s/b/c/aa; 1403print /a/p, s/b/c/p; 1404print /a/l, s/b/c/l; 1405print /a/u, s/b/c/u; 1406{ 1407 use feature 'unicode_strings'; 1408 print /a/d, s/b/c/d; 1409} 1410{ 1411 BEGIN { $^H{'reflags'} = '0'; 1412 $^H{'reflags_charset'} = '2'; } 1413 print /a/d, s/b/c/d; 1414} 1415{ 1416 no feature ':all'; 1417 use feature ':5.12'; 1418 print /a/d, s/b/c/d; 1419} 1420#### 1421# all the flags (qr//) 1422$_ = qr/X/m; 1423$_ = qr/X/s; 1424$_ = qr/X/i; 1425$_ = qr/X/x; 1426$_ = qr/X/p; 1427$_ = qr/X/o; 1428$_ = qr/X/u; 1429$_ = qr/X/a; 1430$_ = qr/X/l; 1431$_ = qr/X/n; 1432#### 1433use feature 'unicode_strings'; 1434$_ = qr/X/d; 1435#### 1436# all the flags (m//) 1437/X/m; 1438/X/s; 1439/X/i; 1440/X/x; 1441/X/p; 1442/X/o; 1443/X/u; 1444/X/a; 1445/X/l; 1446/X/n; 1447/X/g; 1448/X/cg; 1449#### 1450use feature 'unicode_strings'; 1451/X/d; 1452#### 1453# all the flags (s///) 1454s/X//m; 1455s/X//s; 1456s/X//i; 1457s/X//x; 1458s/X//p; 1459s/X//o; 1460s/X//u; 1461s/X//a; 1462s/X//l; 1463s/X//n; 1464s/X//g; 1465s/X/'';/e; 1466s/X//r; 1467#### 1468use feature 'unicode_strings'; 1469s/X//d; 1470#### 1471# tr/// with all the flags: empty replacement 1472tr/B-G//; 1473tr/B-G//c; 1474tr/B-G//d; 1475tr/B-G//s; 1476tr/B-G//cd; 1477tr/B-G//ds; 1478tr/B-G//cs; 1479tr/B-G//cds; 1480tr/B-G//r; 1481#### 1482# tr/// with all the flags: short replacement 1483tr/B-G/b/; 1484tr/B-G/b/c; 1485tr/B-G/b/d; 1486tr/B-G/b/s; 1487tr/B-G/b/cd; 1488tr/B-G/b/ds; 1489tr/B-G/b/cs; 1490tr/B-G/b/cds; 1491tr/B-G/b/r; 1492#### 1493# tr/// with all the flags: equal length replacement 1494tr/B-G/b-g/; 1495tr/B-G/b-g/c; 1496tr/B-G/b-g/s; 1497tr/B-G/b-g/cs; 1498tr/B-G/b-g/r; 1499#### 1500# tr with extended table (/c) 1501tr/\000-\375/AB/c; 1502tr/\000-\375/A-C/c; 1503tr/\000-\375/A-D/c; 1504tr/\000-\375/A-I/c; 1505tr/\000-\375/AB/cd; 1506tr/\000-\375/A-C/cd; 1507tr/\000-\375/A-D/cd; 1508tr/\000-\375/A-I/cd; 1509tr/\000-\375/AB/cds; 1510tr/\000-\375/A-C/cds; 1511tr/\000-\375/A-D/cds; 1512tr/\000-\375/A-I/cds; 1513#### 1514# tr/// with all the flags: empty replacement 1515tr/\x{101}-\x{106}//; 1516tr/\x{101}-\x{106}//c; 1517tr/\x{101}-\x{106}//d; 1518tr/\x{101}-\x{106}//s; 1519tr/\x{101}-\x{106}//cd; 1520tr/\x{101}-\x{106}//ds; 1521tr/\x{101}-\x{106}//cs; 1522tr/\x{101}-\x{106}//cds; 1523tr/\x{101}-\x{106}//r; 1524#### 1525# tr/// with all the flags: short replacement 1526tr/\x{101}-\x{106}/\x{111}/; 1527tr/\x{101}-\x{106}/\x{111}/c; 1528tr/\x{101}-\x{106}/\x{111}/d; 1529tr/\x{101}-\x{106}/\x{111}/s; 1530tr/\x{101}-\x{106}/\x{111}/cd; 1531tr/\x{101}-\x{106}/\x{111}/ds; 1532tr/\x{101}-\x{106}/\x{111}/cs; 1533tr/\x{101}-\x{106}/\x{111}/cds; 1534tr/\x{101}-\x{106}/\x{111}/r; 1535#### 1536# tr/// with all the flags: equal length replacement 1537tr/\x{101}-\x{106}/\x{111}-\x{116}/; 1538tr/\x{101}-\x{106}/\x{111}-\x{116}/c; 1539tr/\x{101}-\x{106}/\x{111}-\x{116}/s; 1540tr/\x{101}-\x{106}/\x{111}-\x{116}/cs; 1541tr/\x{101}-\x{106}/\x{111}-\x{116}/r; 1542#### 1543# tr across 255/256 boundary, complemented 1544tr/\cA-\x{100}/AB/c; 1545tr/\cA-\x{100}/A-C/c; 1546tr/\cA-\x{100}/A-D/c; 1547tr/\cA-\x{100}/A-I/c; 1548tr/\cA-\x{100}/AB/cd; 1549tr/\cA-\x{100}/A-C/cd; 1550tr/\cA-\x{100}/A-D/cd; 1551tr/\cA-\x{100}/A-I/cd; 1552tr/\cA-\x{100}/AB/cds; 1553tr/\cA-\x{100}/A-C/cds; 1554tr/\cA-\x{100}/A-D/cds; 1555tr/\cA-\x{100}/A-I/cds; 1556#### 1557# [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns) 1558s/foo/\(3);/eg; 1559#### 1560# [perl #115256] 1561"" =~ /a(?{ print q| 1562|})/; 1563>>>> 1564'' =~ /a(?{ print "\n"; })/; 1565#### 1566# [perl #123217] 1567$_ = qr/(??{<<END})/ 1568f.o 1569b.r 1570END 1571>>>> 1572$_ = qr/(??{ "f.o\nb.r\n"; })/; 1573#### 1574# More regexp code block madness 1575my($b, @a); 1576/(?{ die $b; })/; 1577/a(?{ die $b; })a/; 1578/$a(?{ die $b; })/; 1579/@a(?{ die $b; })/; 1580/(??{ die $b; })/; 1581/a(??{ die $b; })a/; 1582/$a(??{ die $b; })/; 1583/@a(??{ die $b; })/; 1584qr/(?{ die $b; })/; 1585qr/a(?{ die $b; })a/; 1586qr/$a(?{ die $b; })/; 1587qr/@a(?{ die $b; })/; 1588qr/(??{ die $b; })/; 1589qr/a(??{ die $b; })a/; 1590qr/$a(??{ die $b; })/; 1591qr/@a(??{ die $b; })/; 1592s/(?{ die $b; })//; 1593s/a(?{ die $b; })a//; 1594s/$a(?{ die $b; })//; 1595s/@a(?{ die $b; })//; 1596s/(??{ die $b; })//; 1597s/a(??{ die $b; })a//; 1598s/$a(??{ die $b; })//; 1599s/@a(??{ die $b; })//; 1600#### 1601# /(?x)<newline><tab>/ 1602/(?x) 1603 /; 1604#### 1605# y///r 1606tr/a/b/r + $a =~ tr/p/q/r; 1607#### 1608# y///d in list [perl #119815] 1609() = tr/a//d; 1610#### 1611# [perl #90898] 1612<a,>; 1613glob 'a,'; 1614>>>> 1615glob 'a,'; 1616glob 'a,'; 1617#### 1618# [perl #91008] 1619# SKIP ?$] >= 5.023 && "autoderef deleted in this Perl version" 1620# CONTEXT no warnings 'experimental::autoderef'; 1621each $@; 1622keys $~; 1623values $!; 1624#### 1625# readpipe with complex expression 1626readpipe $a + $b; 1627#### 1628# aelemfast 1629$b::a[0] = 1; 1630#### 1631# aelemfast for a lexical 1632my @a; 1633$a[0] = 1; 1634#### 1635# feature features without feature 1636# CONTEXT no warnings 'deprecated'; 1637CORE::state $x; 1638CORE::say $x; 1639CORE::given ($x) { 1640 CORE::when (3) { 1641 continue; 1642 } 1643 CORE::default { 1644 CORE::break; 1645 } 1646} 1647CORE::evalbytes ''; 1648() = CORE::__SUB__; 1649() = CORE::fc $x; 1650#### 1651# feature features when feature has been disabled by use VERSION 1652# CONTEXT no warnings 'deprecated'; 1653use feature (sprintf(":%vd", $^V)); 1654use 1; 1655CORE::say $_; 1656CORE::state $x; 1657CORE::given ($x) { 1658 CORE::when (3) { 1659 continue; 1660 } 1661 CORE::default { 1662 CORE::break; 1663 } 1664} 1665CORE::evalbytes ''; 1666() = CORE::__SUB__; 1667>>>> 1668CORE::say $_; 1669CORE::state $x; 1670CORE::given ($x) { 1671 CORE::when (3) { 1672 continue; 1673 } 1674 CORE::default { 1675 CORE::break; 1676 } 1677} 1678CORE::evalbytes ''; 1679() = CORE::__SUB__; 1680#### 1681# (the above test with CONTEXT, and the output is equivalent but different) 1682# CONTEXT use feature ':5.10'; no warnings 'deprecated'; 1683# feature features when feature has been disabled by use VERSION 1684use feature (sprintf(":%vd", $^V)); 1685use 1; 1686CORE::say $_; 1687CORE::state $x; 1688CORE::given ($x) { 1689 CORE::when (3) { 1690 continue; 1691 } 1692 CORE::default { 1693 CORE::break; 1694 } 1695} 1696CORE::evalbytes ''; 1697() = CORE::__SUB__; 1698>>>> 1699no feature ':all'; 1700use feature ':default'; 1701CORE::say $_; 1702CORE::state $x; 1703CORE::given ($x) { 1704 CORE::when (3) { 1705 continue; 1706 } 1707 CORE::default { 1708 CORE::break; 1709 } 1710} 1711CORE::evalbytes ''; 1712() = CORE::__SUB__; 1713#### 1714# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" 1715# lexical subroutines and keywords of the same name 1716# CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental'; no warnings 'deprecated'; 1717my sub default; 1718my sub else; 1719my sub elsif; 1720my sub for; 1721my sub foreach; 1722my sub given; 1723my sub if; 1724my sub m; 1725my sub no; 1726my sub package; 1727my sub q; 1728my sub qq; 1729my sub qr; 1730my sub qx; 1731my sub require; 1732my sub s; 1733my sub sub; 1734my sub tr; 1735my sub unless; 1736my sub until; 1737my sub use; 1738my sub when; 1739my sub while; 1740CORE::default { die; } 1741CORE::if ($1) { die; } 1742CORE::if ($1) { die; } 1743CORE::elsif ($1) { die; } 1744CORE::else { die; } 1745CORE::for (die; $1; die) { die; } 1746CORE::foreach $_ (1 .. 10) { die; } 1747die CORE::foreach (1); 1748CORE::given ($1) { die; } 1749CORE::m[/]; 1750CORE::m?/?; 1751CORE::package foo; 1752CORE::no strict; 1753() = (CORE::q['], CORE::qq["$_], CORE::qr//, CORE::qx[`]); 1754CORE::require 1; 1755CORE::s///; 1756() = CORE::sub { die; } ; 1757CORE::tr///; 1758CORE::unless ($1) { die; } 1759CORE::until ($1) { die; } 1760die CORE::until $1; 1761CORE::use strict; 1762CORE::when ($1 ~~ $2) { die; } 1763CORE::while ($1) { die; } 1764die CORE::while $1; 1765#### 1766# Feature hints 1767use feature 'current_sub', 'evalbytes'; 1768print; 1769use 1; 1770print; 1771use 5.014; 1772print; 1773no feature 'unicode_strings'; 1774print; 1775>>>> 1776use feature 'current_sub', 'evalbytes'; 1777print $_; 1778no feature ':all'; 1779use feature ':default'; 1780print $_; 1781no feature ':all'; 1782use feature ':5.12'; 1783print $_; 1784no feature 'unicode_strings'; 1785print $_; 1786#### 1787# $#- $#+ $#{%} etc. 1788my @x; 1789@x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*}); 1790@x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,}); 1791@x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-); 1792@x = ($#{;}, $#{:}, $#{1}), $#_; 1793#### 1794# [perl #86060] $( $| $) in regexps need braces 1795/${(}/; 1796/${|}/; 1797/${)}/; 1798/${(}${|}${)}/; 1799/@{+}@{-}/; 1800#### 1801# ()[...] 1802my(@a) = ()[()]; 1803#### 1804# sort(foo(bar)) 1805# sort(foo(bar)) is interpreted as sort &foo(bar) 1806# sort foo(bar) is interpreted as sort foo bar 1807# parentheses are not optional in this case 1808print sort(foo('bar')); 1809>>>> 1810print sort(foo('bar')); 1811#### 1812# substr assignment 1813substr(my $a, 0, 0) = (foo(), bar()); 1814$a++; 1815#### 1816# This following line works around an unfixed bug that we are not trying to 1817# test for here: 1818# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised 1819# hint hash 1820BEGIN { $^H{'foo'} = undef; } 1821{ 1822 BEGIN { $^H{'bar'} = undef; } 1823 { 1824 BEGIN { $^H{'baz'} = undef; } 1825 { 1826 print $_; 1827 } 1828 print $_; 1829 } 1830 print $_; 1831} 1832BEGIN { $^H{q[']} = '('; } 1833print $_; 1834#### 1835# This following line works around an unfixed bug that we are not trying to 1836# test for here: 1837# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised 1838# hint hash changes that serialise the same way with sort %hh 1839BEGIN { $^H{'a'} = 'b'; } 1840{ 1841 BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; } 1842 print $_; 1843} 1844print $_; 1845#### 1846# [perl #47361] do({}) and do +{} (variants of do-file) 1847do({}); 1848do +{}; 1849sub foo::do {} 1850package foo; 1851CORE::do({}); 1852CORE::do +{}; 1853>>>> 1854do({}); 1855do({}); 1856package foo; 1857CORE::do({}); 1858CORE::do({}); 1859#### 1860# [perl #77096] functions that do not follow the llafr 1861() = (return 1) + time; 1862() = (return ($1 + $2) * $3) + time; 1863() = (return ($a xor $b)) + time; 1864() = (do 'file') + time; 1865() = (do ($1 + $2) * $3) + time; 1866() = (do ($1 xor $2)) + time; 1867() = (goto 1) + 3; 1868() = (require 'foo') + 3; 1869() = (require foo) + 3; 1870() = (CORE::dump 1) + 3; 1871() = (last 1) + 3; 1872() = (next 1) + 3; 1873() = (redo 1) + 3; 1874() = (-R $_) + 3; 1875() = (-W $_) + 3; 1876() = (-X $_) + 3; 1877() = (-r $_) + 3; 1878() = (-w $_) + 3; 1879() = (-x $_) + 3; 1880#### 1881# require(foo()) and do(foo()) 1882require (foo()); 1883do (foo()); 1884goto (foo()); 1885CORE::dump (foo()); 1886last (foo()); 1887next (foo()); 1888redo (foo()); 1889#### 1890# require vstring 1891require v5.16; 1892#### 1893# [perl #97476] not() *does* follow the llafr 1894$_ = ($a xor not +($1 || 2) ** 2); 1895#### 1896# Precedence conundrums with argument-less function calls 1897() = (eof) + 1; 1898() = (return) + 1; 1899() = (return, 1); 1900() = warn; 1901() = warn() + 1; 1902() = setpgrp() + 1; 1903#### 1904# loopexes have assignment prec 1905() = (CORE::dump a) | 'b'; 1906() = (goto a) | 'b'; 1907() = (last a) | 'b'; 1908() = (next a) | 'b'; 1909() = (redo a) | 'b'; 1910#### 1911# [perl #63558] open local(*FH) 1912open local *FH; 1913pipe local *FH, local *FH; 1914#### 1915# [perl #91416] open "string" 1916open 'open'; 1917open '####'; 1918open '^A'; 1919open "\ca"; 1920>>>> 1921open *open; 1922open '####'; 1923open '^A'; 1924open *^A; 1925#### 1926# "string"->[] ->{} 1927no strict 'vars'; 1928() = 'open'->[0]; #aelemfast 1929() = '####'->[0]; 1930() = '^A'->[0]; 1931() = "\ca"->[0]; 1932() = 'a::]b'->[0]; 1933() = 'open'->[$_]; #aelem 1934() = '####'->[$_]; 1935() = '^A'->[$_]; 1936() = "\ca"->[$_]; 1937() = 'a::]b'->[$_]; 1938() = 'open'->{0}; #helem 1939() = '####'->{0}; 1940() = '^A'->{0}; 1941() = "\ca"->{0}; 1942() = 'a::]b'->{0}; 1943>>>> 1944no strict 'vars'; 1945() = $open[0]; 1946() = '####'->[0]; 1947() = '^A'->[0]; 1948() = $^A[0]; 1949() = 'a::]b'->[0]; 1950() = $open[$_]; 1951() = '####'->[$_]; 1952() = '^A'->[$_]; 1953() = $^A[$_]; 1954() = 'a::]b'->[$_]; 1955() = $open{'0'}; 1956() = '####'->{'0'}; 1957() = '^A'->{'0'}; 1958() = $^A{'0'}; 1959() = 'a::]b'->{'0'}; 1960#### 1961# [perl #74740] -(f()) vs -f() 1962$_ = -(f()); 1963#### 1964# require <binop> 1965require 'a' . $1; 1966#### 1967#[perl #30504] foreach-my postfix/prefix difference 1968$_ = 'foo' foreach my ($foo1, $bar1, $baz1); 1969foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' } 1970foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' } 1971>>>> 1972$_ = 'foo' foreach (my($foo1, $bar1, $baz1)); 1973foreach $_ (my($foo2, $bar2, $baz2)) { 1974 $_ = 'foo'; 1975} 1976foreach my $i (my($foo3, $bar3, $baz3)) { 1977 $i = 'foo'; 1978} 1979#### 1980#[perl #108224] foreach with continue block 1981foreach (1 .. 3) { print } continue { print "\n" } 1982foreach (1 .. 3) { } continue { } 1983foreach my $i (1 .. 3) { print $i } continue { print "\n" } 1984foreach my $i (1 .. 3) { } continue { } 1985>>>> 1986foreach $_ (1 .. 3) { 1987 print $_; 1988} 1989continue { 1990 print "\n"; 1991} 1992foreach $_ (1 .. 3) { 1993 (); 1994} 1995continue { 1996 (); 1997} 1998foreach my $i (1 .. 3) { 1999 print $i; 2000} 2001continue { 2002 print "\n"; 2003} 2004foreach my $i (1 .. 3) { 2005 (); 2006} 2007continue { 2008 (); 2009} 2010#### 2011# file handles 2012no strict; 2013my $mfh; 2014open F; 2015open *F; 2016open $fh; 2017open $mfh; 2018open 'a+b'; 2019select *F; 2020select F; 2021select $f; 2022select $mfh; 2023select 'a+b'; 2024#### 2025# 'my' works with padrange op 2026my($z, @z); 2027my $m1; 2028$m1 = 1; 2029$z = $m1; 2030my $m2 = 2; 2031my($m3, $m4); 2032($m3, $m4) = (1, 2); 2033@z = ($m3, $m4); 2034my($m5, $m6) = (1, 2); 2035my($m7, undef, $m8) = (1, 2, 3); 2036@z = ($m7, undef, $m8); 2037($m7, undef, $m8) = (1, 2, 3); 2038#### 2039# 'our/local' works with padrange op 2040our($z, @z); 2041our $o1; 2042no strict; 2043local $o11; 2044$o1 = 1; 2045local $o1 = 1; 2046$z = $o1; 2047$z = local $o1; 2048our $o2 = 2; 2049our($o3, $o4); 2050($o3, $o4) = (1, 2); 2051local($o3, $o4) = (1, 2); 2052@z = ($o3, $o4); 2053@z = local($o3, $o4); 2054our($o5, $o6) = (1, 2); 2055our($o7, undef, $o8) = (1, 2, 3); 2056@z = ($o7, undef, $o8); 2057@z = local($o7, undef, $o8); 2058($o7, undef, $o8) = (1, 2, 3); 2059local($o7, undef, $o8) = (1, 2, 3); 2060#### 2061# 'state' works with padrange op 2062# CONTEXT no strict; use feature 'state'; 2063state($z, @z); 2064state $s1; 2065$s1 = 1; 2066$z = $s1; 2067state $s2 = 2; 2068state($s3, $s4); 2069($s3, $s4) = (1, 2); 2070@z = ($s3, $s4); 2071# assignment of state lists isn't implemented yet 2072#state($s5, $s6) = (1, 2); 2073#state($s7, undef, $s8) = (1, 2, 3); 2074#@z = ($s7, undef, $s8); 2075($s7, undef, $s8) = (1, 2, 3); 2076#### 2077# anon arrays with padrange 2078my($a, $b); 2079my $c = [$a, $b]; 2080my $d = {$a, $b}; 2081#### 2082# slices with padrange 2083my($a, $b); 2084my(@x, %y); 2085@x = @x[$a, $b]; 2086@x = @y{$a, $b}; 2087#### 2088# binops with padrange 2089my($a, $b, $c); 2090$c = $a cmp $b; 2091$c = $a + $b; 2092$a += $b; 2093$c = $a - $b; 2094$a -= $b; 2095$c = my $a1 cmp $b; 2096$c = my $a2 + $b; 2097$a += my $b1; 2098$c = my $a3 - $b; 2099$a -= my $b2; 2100#### 2101# 'x' with padrange 2102my($a, $b, $c, $d, @e); 2103$c = $a x $b; 2104$a x= $b; 2105@e = ($a) x $d; 2106@e = ($a, $b) x $d; 2107@e = ($a, $b, $c) x $d; 2108@e = ($a, 1) x $d; 2109#### 2110# @_ with padrange 2111my($a, $b, $c) = @_; 2112#### 2113# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" 2114# lexical subroutine 2115# CONTEXT use feature 'lexical_subs'; 2116no warnings "experimental::lexical_subs"; 2117my sub f {} 2118print f(); 2119>>>> 2120my sub f { 2121 2122} 2123print f(); 2124#### 2125# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" 2126# lexical "state" subroutine 2127# CONTEXT use feature 'state', 'lexical_subs'; 2128no warnings 'experimental::lexical_subs'; 2129state sub f {} 2130print f(); 2131>>>> 2132state sub f { 2133 2134} 2135print f(); 2136#### 2137# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" 2138# lexical subroutine scoping 2139# CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs'; 2140{ 2141 { 2142 my sub a { die; } 2143 { 2144 foo(); 2145 my sub b; 2146 b; 2147 main::b(); 2148 &main::b; 2149 &main::b(); 2150 my $b = \&main::b; 2151 sub b { $b; } 2152 } 2153 } 2154 b(); 2155} 2156#### 2157# self-referential lexical subroutine 2158# CONTEXT use feature 'lexical_subs', 'state'; no warnings 'experimental::lexical_subs'; 2159(); 2160state sub sb2; 2161sub sb2 { 2162 sb2; 2163} 2164#### 2165# lexical subroutine with outer declaration and inner definition 2166# CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs'; 2167(); 2168my sub f; 2169my sub g { 2170 (); 2171 sub f { } 2172} 2173#### 2174# TODO only partially fixed 2175# lexical state subroutine with outer declaration and inner definition 2176# CONTEXT use feature 'lexical_subs', 'state'; no warnings 'experimental::lexical_subs'; 2177(); 2178state sub sb4; 2179state sub a { 2180 (); 2181 sub sb4 { } 2182} 2183state sub sb5; 2184sub { 2185 (); 2186 sub sb5 { } 2187} ; 2188#### 2189# Elements of %# should not be confused with $#{ array } 2190() = ${#}{'foo'}; 2191#### 2192# $; [perl #123357] 2193$_ = $;; 2194do { 2195 $; 2196}; 2197#### 2198# Ampersand calls and scalar context 2199# OPTIONS -P 2200package prototest; 2201sub foo($$); 2202foo(bar(),baz()); 2203>>>> 2204package prototest; 2205&foo(scalar bar(), scalar baz()); 2206#### 2207# coderef2text and prototyped sub calls [perl #123435] 2208is 'foo', 'oo'; 2209#### 2210# prototypes with unary precedence 2211package prototest; 2212sub dollar($) {} 2213sub optdollar(;$) {} 2214sub optoptdollar(;;$) {} 2215sub splat(*) {} 2216sub optsplat(;*) {} 2217sub optoptsplat(;;*) {} 2218sub bar(_) {} 2219sub optbar(;_) {} 2220sub optoptbar(;;_) {} 2221sub plus(+) {} 2222sub optplus(;+) {} 2223sub optoptplus(;;+) {} 2224sub wack(\$) {} 2225sub optwack(;\$) {} 2226sub optoptwack(;;\$) {} 2227sub wackbrack(\[$]) {} 2228sub optwackbrack(;\[$]) {} 2229sub optoptwackbrack(;;\[$]) {} 2230dollar($a < $b); 2231optdollar($a < $b); 2232optoptdollar($a < $b); 2233splat($a < $b); # Some of these deparse with ‘&’; if that changes, just 2234optsplat($a < $b); # change the tests. 2235optoptsplat($a < $b); 2236bar($a < $b); 2237optbar($a < $b); 2238optoptbar($a < $b); 2239plus($a < $b); 2240optplus($a < $b); 2241optoptplus($a < $b); 2242wack($a = $b); 2243optwack($a = $b); 2244optoptwack($a = $b); 2245wackbrack($a = $b); 2246optwackbrack($a = $b); 2247optoptwackbrack($a = $b); 2248optbar; 2249optoptbar; 2250optplus; 2251optoptplus; 2252optwack; 2253optoptwack; 2254optwackbrack; 2255optoptwackbrack; 2256>>>> 2257package prototest; 2258dollar($a < $b); 2259optdollar($a < $b); 2260optoptdollar($a < $b); 2261&splat($a < $b); 2262&optsplat($a < $b); 2263&optoptsplat($a < $b); 2264bar($a < $b); 2265optbar($a < $b); 2266optoptbar($a < $b); 2267plus($a < $b); 2268optplus($a < $b); 2269optoptplus($a < $b); 2270&wack(\($a = $b)); 2271&optwack(\($a = $b)); 2272&optoptwack(\($a = $b)); 2273&wackbrack(\($a = $b)); 2274&optwackbrack(\($a = $b)); 2275&optoptwackbrack(\($a = $b)); 2276optbar; 2277optoptbar; 2278optplus; 2279optoptplus; 2280optwack; 2281optoptwack; 2282optwackbrack; 2283optoptwackbrack; 2284#### 2285# enreferencing prototypes: @ 2286# CONTEXT sub wackat(\@) {} sub optwackat(;\@) {} sub wackbrackat(\[@]) {} sub optwackbrackat(;\[@]) {} 2287wackat(my @a0); 2288wackat(@a0); 2289wackat(@ARGV); 2290wackat(@{['t'];}); 2291optwackat; 2292optwackat(my @a1); 2293optwackat(@a1); 2294optwackat(@ARGV); 2295optwackat(@{['t'];}); 2296wackbrackat(my @a2); 2297wackbrackat(@a2); 2298wackbrackat(@ARGV); 2299wackbrackat(@{['t'];}); 2300optwackbrackat; 2301optwackbrackat(my @a3); 2302optwackbrackat(@a3); 2303optwackbrackat(@ARGV); 2304optwackbrackat(@{['t'];}); 2305#### 2306# enreferencing prototypes: % 2307# CONTEXT sub wackperc(\%) {} sub optwackperc(;\%) {} sub wackbrackperc(\[%]) {} sub optwackbrackperc(;\[%]) {} 2308wackperc(my %a0); 2309wackperc(%a0); 2310wackperc(%ARGV); 2311wackperc(%{+{'t', 1};}); 2312optwackperc; 2313optwackperc(my %a1); 2314optwackperc(%a1); 2315optwackperc(%ARGV); 2316optwackperc(%{+{'t', 1};}); 2317wackbrackperc(my %a2); 2318wackbrackperc(%a2); 2319wackbrackperc(%ARGV); 2320wackbrackperc(%{+{'t', 1};}); 2321optwackbrackperc; 2322optwackbrackperc(my %a3); 2323optwackbrackperc(%a3); 2324optwackbrackperc(%ARGV); 2325optwackbrackperc(%{+{'t', 1};}); 2326#### 2327# enreferencing prototypes: + 2328# CONTEXT sub plus(+) {} sub optplus(;+) {} 2329plus('hi'); 2330plus(my @a0); 2331plus(my %h0); 2332plus(\@a0); 2333plus(\%h0); 2334optplus; 2335optplus('hi'); 2336optplus(my @a1); 2337optplus(my %h1); 2338optplus(\@a1); 2339optplus(\%h1); 2340>>>> 2341plus('hi'); 2342plus(my @a0); 2343plus(my %h0); 2344plus(@a0); 2345plus(%h0); 2346optplus; 2347optplus('hi'); 2348optplus(my @a1); 2349optplus(my %h1); 2350optplus(@a1); 2351optplus(%h1); 2352#### 2353# ensure aelemfast works in the range -128..127 and that there's no 2354# funky edge cases 2355my $x; 2356no strict 'vars'; 2357$x = $a[-256] + $a[-255] + $a[-129] + $a[-128] + $a[-127] + $a[-1] + $a[0]; 2358$x = $a[1] + $a[126] + $a[127] + $a[128] + $a[255] + $a[256]; 2359my @b; 2360$x = $b[-256] + $b[-255] + $b[-129] + $b[-128] + $b[-127] + $b[-1] + $b[0]; 2361$x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256]; 2362#### 2363# 'm' must be preserved in m?? 2364m??; 2365#### 2366# \(@array) and \(..., (@array), ...) 2367my(@array, %hash, @a, @b, %c, %d); 2368() = \(@array); 2369() = \(%hash); 2370() = \(@a, (@b), (%c), %d); 2371() = \(@Foo::array); 2372() = \(%Foo::hash); 2373() = \(@Foo::a, (@Foo::b), (%Foo::c), %Foo::d); 2374#### 2375# subs synonymous with keywords 2376main::our(); 2377main::pop(); 2378state(); 2379use feature 'state'; 2380main::state(); 2381#### 2382# lvalue references 2383# CONTEXT use feature "state", 'refaliasing', 'lexical_subs'; no warnings 'experimental'; 2384our $x; 2385\$x = \$x; 2386my $m; 2387\$m = \$x; 2388\my $n = \$x; 2389(\$x) = @_; 2390\($x) = @_; 2391\($m) = @_; 2392(\$m) = @_; 2393\my($p) = @_; 2394(\my $r) = @_; 2395\($x, my $a) = @{[\$x, \$x]}; 2396(\$x, \my $b) = @{[\$x, \$x]}; 2397\local $x = \3; 2398\local($x) = \3; 2399\state $c = \3; 2400\state($d) = \3; 2401\our $e = \3; 2402\our($f) = \3; 2403\$_[0] = foo(); 2404\($_[1]) = foo(); 2405my @a; 2406\$a[0] = foo(); 2407\($a[1]) = foo(); 2408\local($a[1]) = foo(); 2409\@a[0,1] = foo(); 2410\(@a[2,3]) = foo(); 2411\local @a[0,1] = (\$a)x2; 2412\$_{a} = foo(); 2413\($_{b}) = foo(); 2414my %h; 2415\$h{a} = foo(); 2416\($h{b}) = foo(); 2417\local $h{a} = \$x; 2418\local($h{b}) = \$x; 2419\@h{'a','b'} = foo(); 2420\(@h{2,3}) = foo(); 2421\local @h{'a','b'} = (\$x)x2; 2422\@_ = foo(); 2423\@a = foo(); 2424(\@_) = foo(); 2425(\@a) = foo(); 2426\my @c = foo(); 2427(\my @d) = foo(); 2428\(@_) = foo(); 2429\(@a) = foo(); 2430\my(@g) = foo(); 2431\local @_ = \@_; 2432(\local @_) = \@_; 2433\state @e = [1..3]; 2434\state(@f) = \3; 2435\our @i = [1..3]; 2436\our(@h) = \3; 2437\%_ = foo(); 2438\%h = foo(); 2439(\%_) = foo(); 2440(\%h) = foo(); 2441\my %c = foo(); 2442(\my %d) = foo(); 2443\local %_ = \%h; 2444(\local %_) = \%h; 2445\state %y = {1,2}; 2446\our %z = {1,2}; 2447(\our %zz) = {1,2}; 2448\&a = foo(); 2449(\&a) = foo(); 2450\(&a) = foo(); 2451{ 2452 my sub a; 2453 \&a = foo(); 2454 (\&a) = foo(); 2455 \(&a) = foo(); 2456} 2457(\$_, $_) = \(1, 2); 2458$_ == 3 ? \$_ : $_ = \3; 2459$_ == 3 ? \$_ : \$x = \3; 2460\($_ == 3 ? $_ : $x) = \3; 2461for \my $topic (\$1, \$2) { 2462 die; 2463} 2464for \state $topic (\$1, \$2) { 2465 die; 2466} 2467for \our $topic (\$1, \$2) { 2468 die; 2469} 2470for \$_ (\$1, \$2) { 2471 die; 2472} 2473for \my @a ([1,2], [3,4]) { 2474 die; 2475} 2476for \state @a ([1,2], [3,4]) { 2477 die; 2478} 2479for \our @a ([1,2], [3,4]) { 2480 die; 2481} 2482for \@_ ([1,2], [3,4]) { 2483 die; 2484} 2485for \my %a ({5,6}, {7,8}) { 2486 die; 2487} 2488for \our %a ({5,6}, {7,8}) { 2489 die; 2490} 2491for \state %a ({5,6}, {7,8}) { 2492 die; 2493} 2494for \%_ ({5,6}, {7,8}) { 2495 die; 2496} 2497{ 2498 my sub a; 2499 for \&a (sub { 9; }, sub { 10; }) { 2500 die; 2501 } 2502} 2503for \&a (sub { 9; }, sub { 10; }) { 2504 die; 2505} 2506>>>> 2507our $x; 2508\$x = \$x; 2509my $m; 2510\$m = \$x; 2511\my $n = \$x; 2512(\$x) = @_; 2513(\$x) = @_; 2514(\$m) = @_; 2515(\$m) = @_; 2516(\my $p) = @_; 2517(\my $r) = @_; 2518(\$x, \my $a) = @{[\$x, \$x];}; 2519(\$x, \my $b) = @{[\$x, \$x];}; 2520\local $x = \3; 2521(\local $x) = \3; 2522\state $c = \3; 2523(\state $d) = \3; 2524\our $e = \3; 2525(\our $f) = \3; 2526\$_[0] = foo(); 2527(\$_[1]) = foo(); 2528my @a; 2529\$a[0] = foo(); 2530(\$a[1]) = foo(); 2531(\local $a[1]) = foo(); 2532(\@a[0, 1]) = foo(); 2533(\@a[2, 3]) = foo(); 2534(\local @a[0, 1]) = (\$a) x 2; 2535\$_{'a'} = foo(); 2536(\$_{'b'}) = foo(); 2537my %h; 2538\$h{'a'} = foo(); 2539(\$h{'b'}) = foo(); 2540\local $h{'a'} = \$x; 2541(\local $h{'b'}) = \$x; 2542(\@h{'a', 'b'}) = foo(); 2543(\@h{2, 3}) = foo(); 2544(\local @h{'a', 'b'}) = (\$x) x 2; 2545\@_ = foo(); 2546\@a = foo(); 2547(\@_) = foo(); 2548(\@a) = foo(); 2549\my @c = foo(); 2550(\my @d) = foo(); 2551(\(@_)) = foo(); 2552(\(@a)) = foo(); 2553(\(my @g)) = foo(); 2554\local @_ = \@_; 2555(\local @_) = \@_; 2556\state @e = [1..3]; 2557(\(state @f)) = \3; 2558\our @i = [1..3]; 2559(\(our @h)) = \3; 2560\%_ = foo(); 2561\%h = foo(); 2562(\%_) = foo(); 2563(\%h) = foo(); 2564\my %c = foo(); 2565(\my %d) = foo(); 2566\local %_ = \%h; 2567(\local %_) = \%h; 2568\state %y = {1, 2}; 2569\our %z = {1, 2}; 2570(\our %zz) = {1, 2}; 2571\&a = foo(); 2572(\&a) = foo(); 2573(\&a) = foo(); 2574{ 2575 my sub a; 2576 \&a = foo(); 2577 (\&a) = foo(); 2578 (\&a) = foo(); 2579} 2580(\$_, $_) = \(1, 2); 2581$_ == 3 ? \$_ : $_ = \3; 2582$_ == 3 ? \$_ : \$x = \3; 2583($_ == 3 ? \$_ : \$x) = \3; 2584foreach \my $topic (\$1, \$2) { 2585 die; 2586} 2587foreach \state $topic (\$1, \$2) { 2588 die; 2589} 2590foreach \our $topic (\$1, \$2) { 2591 die; 2592} 2593foreach \$_ (\$1, \$2) { 2594 die; 2595} 2596foreach \my @a ([1, 2], [3, 4]) { 2597 die; 2598} 2599foreach \state @a ([1, 2], [3, 4]) { 2600 die; 2601} 2602foreach \our @a ([1, 2], [3, 4]) { 2603 die; 2604} 2605foreach \@_ ([1, 2], [3, 4]) { 2606 die; 2607} 2608foreach \my %a ({5, 6}, {7, 8}) { 2609 die; 2610} 2611foreach \our %a ({5, 6}, {7, 8}) { 2612 die; 2613} 2614foreach \state %a ({5, 6}, {7, 8}) { 2615 die; 2616} 2617foreach \%_ ({5, 6}, {7, 8}) { 2618 die; 2619} 2620{ 2621 my sub a; 2622 foreach \&a (sub { 9; } , sub { 10; } ) { 2623 die; 2624 } 2625} 2626foreach \&a (sub { 9; } , sub { 10; } ) { 2627 die; 2628} 2629#### 2630# CONTEXT no warnings 'experimental::for_list'; 2631my %hash; 2632foreach my ($key, $value) (%hash) { 2633 study $_; 2634} 2635#### 2636# CONTEXT no warnings 'experimental::for_list'; 2637my @ducks; 2638foreach my ($tick, $trick, $track) (@ducks) { 2639 study $_; 2640} 2641#### 2642# join $foo, pos 2643my $foo; 2644$_ = join $foo, pos 2645>>>> 2646my $foo; 2647$_ = join('???', pos $_); 2648#### 2649# exists $a[0] 2650our @a; 2651exists $a[0]; 2652#### 2653# my @a; exists $a[0] 2654my @a; 2655exists $a[0]; 2656#### 2657# delete $a[0] 2658our @a; 2659delete $a[0]; 2660#### 2661# my @a; delete $a[0] 2662my @a; 2663delete $a[0]; 2664#### 2665# $_[0][$_[1]] 2666$_[0][$_[1]]; 2667#### 2668# f($a[0]); 2669my @a; 2670f($a[0]); 2671#### 2672#qr/\Q$h{'key'}\E/; 2673my %h; 2674qr/\Q$h{'key'}\E/; 2675#### 2676# my $x = "$h{foo}"; 2677my %h; 2678my $x = "$h{'foo'}"; 2679#### 2680# weird constant hash key 2681my %h; 2682my $x = $h{"\000\t\x{100}"}; 2683#### 2684# multideref and packages 2685package foo; 2686my(%bar) = ('a', 'b'); 2687our(@bar) = (1, 2); 2688$bar{'k'} = $bar[200]; 2689$main::bar{'k'} = $main::bar[200]; 2690$foo::bar{'k'} = $foo::bar[200]; 2691package foo2; 2692$bar{'k'} = $bar[200]; 2693$main::bar{'k'} = $main::bar[200]; 2694$foo::bar{'k'} = $foo::bar[200]; 2695>>>> 2696package foo; 2697my(%bar) = ('a', 'b'); 2698our(@bar) = (1, 2); 2699$bar{'k'} = $bar[200]; 2700$main::bar{'k'} = $main::bar[200]; 2701$foo::bar{'k'} = $bar[200]; 2702package foo2; 2703$bar{'k'} = $foo::bar[200]; 2704$main::bar{'k'} = $main::bar[200]; 2705$foo::bar{'k'} = $foo::bar[200]; 2706#### 2707# multideref and local 2708my %h; 2709local $h{'foo'}[0] = 1; 2710#### 2711# multideref and exists 2712my(%h, $i); 2713my $e = exists $h{'foo'}[$i]; 2714#### 2715# multideref and delete 2716my(%h, $i); 2717my $e = delete $h{'foo'}[$i]; 2718#### 2719# multideref with leading expression 2720my $r; 2721my $x = +($r // [])->{'foo'}[0]; 2722#### 2723# multideref with complex middle index 2724my(%h, $i, $j, $k); 2725my $x = $h{'foo'}[$i + $j]{$k}; 2726#### 2727# multideref with trailing non-simple index that initially looks simple 2728# (i.e. the constant "3") 2729my($r, $i, $j, $k); 2730my $x = +($r || {})->{'foo'}[$i + $j]{3 + $k}; 2731#### 2732# chdir 2733chdir 'file'; 2734chdir FH; 2735chdir; 2736#### 2737# 5.22 bitops 2738# CONTEXT use feature "bitwise"; no warnings "experimental::bitwise"; 2739$_ = $_ | $_; 2740$_ = $_ & $_; 2741$_ = $_ ^ $_; 2742$_ = ~$_; 2743$_ = $_ |. $_; 2744$_ = $_ &. $_; 2745$_ = $_ ^. $_; 2746$_ = ~.$_; 2747$_ |= $_; 2748$_ &= $_; 2749$_ ^= $_; 2750$_ |.= $_; 2751$_ &.= $_; 2752$_ ^.= $_; 2753#### 2754#### 2755# Should really use 'no warnings "experimental::signatures"', 2756# but it doesn't yet deparse correctly. 2757# anon subs used because this test framework doesn't deparse named subs 2758# in the DATA code snippets. 2759# 2760# general signature 2761no warnings; 2762use feature 'signatures'; 2763my $x; 2764sub ($a, $, $b = $glo::bal, $c = $a, $d = 'foo', $e = -37, $f = 0, $g = 1, $h = undef, $i = $a + 1, $j = /foo/, @) { 2765 $x++; 2766} 2767; 2768$x++; 2769#### 2770# Signature and prototype 2771no warnings; 2772use feature 'signatures'; 2773my $x; 2774my $f = sub : prototype($$) ($a, $b) { 2775 $x++; 2776} 2777; 2778$x++; 2779#### 2780# Signature and prototype and attrs 2781no warnings; 2782use feature 'signatures'; 2783my $x; 2784my $f = sub : prototype($$) lvalue ($a, $b) { 2785 $x++; 2786} 2787; 2788$x++; 2789#### 2790# Signature and attrs 2791no warnings; 2792use feature 'signatures'; 2793my $x; 2794my $f = sub : lvalue method ($a, $b) { 2795 $x++; 2796} 2797; 2798$x++; 2799#### 2800# named array slurp, null body 2801no warnings; 2802use feature 'signatures'; 2803sub (@a) { 2804 ; 2805} 2806; 2807#### 2808# named hash slurp 2809no warnings; 2810use feature 'signatures'; 2811sub ($key, %h) { 2812 $h{$key}; 2813} 2814; 2815#### 2816# anon hash slurp 2817no warnings; 2818use feature 'signatures'; 2819sub ($a, %) { 2820 $a; 2821} 2822; 2823#### 2824# parenthesised default arg 2825no warnings; 2826use feature 'signatures'; 2827sub ($a, $b = (/foo/), $c = 1) { 2828 $a + $b + $c; 2829} 2830; 2831#### 2832# parenthesised default arg with TARGMY 2833no warnings; 2834use feature 'signatures'; 2835sub ($a, $b = ($a + 1), $c = 1) { 2836 $a + $b + $c; 2837} 2838; 2839#### 2840# empty default 2841no warnings; 2842use feature 'signatures'; 2843sub ($a, $=) { 2844 $a; 2845} 2846; 2847#### 2848# defined-or default 2849no warnings; 2850use feature 'signatures'; 2851sub ($a //= 'default') { 2852 $a; 2853} 2854; 2855#### 2856# logical-or default 2857no warnings; 2858use feature 'signatures'; 2859sub ($a ||= 'default') { 2860 $a; 2861} 2862; 2863#### 2864# padrange op within pattern code blocks 2865/(?{ my($x, $y) = (); })/; 2866my $a; 2867/$a(?{ my($x, $y) = (); })/; 2868my $r1 = qr/(?{ my($x, $y) = (); })/; 2869my $r2 = qr/$a(?{ my($x, $y) = (); })/; 2870#### 2871# don't remove pattern whitespace escapes 2872/a\ b/; 2873/a\ b/x; 2874/a\ b/; 2875/a\ b/x; 2876#### 2877# my attributes 2878my $s1 :foo(f1, f2) bar(b1, b2); 2879my @a1 :foo(f1, f2) bar(b1, b2); 2880my %h1 :foo(f1, f2) bar(b1, b2); 2881my($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2); 2882#### 2883# my class attributes 2884package Foo::Bar; 2885my Foo::Bar $s1 :foo(f1, f2) bar(b1, b2); 2886my Foo::Bar @a1 :foo(f1, f2) bar(b1, b2); 2887my Foo::Bar %h1 :foo(f1, f2) bar(b1, b2); 2888my Foo::Bar ($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2); 2889package main; 2890my Foo::Bar $s3 :foo(f1, f2) bar(b1, b2); 2891my Foo::Bar @a3 :foo(f1, f2) bar(b1, b2); 2892my Foo::Bar %h3 :foo(f1, f2) bar(b1, b2); 2893my Foo::Bar ($s4, @a4, %h4) :foo(f1, f2) bar(b1, b2); 2894#### 2895# avoid false positives in my $x :attribute 2896'attributes'->import('main', \my $x1, 'foo(bar)'), my $y1; 2897'attributes'->import('Fooo', \my $x2, 'foo(bar)'), my $y2; 2898#### 2899# hash slices and hash key/value slices 2900my(@a, %h); 2901our(@oa, %oh); 2902@a = @h{'foo', 'bar'}; 2903@a = %h{'foo', 'bar'}; 2904@a = delete @h{'foo', 'bar'}; 2905@a = delete %h{'foo', 'bar'}; 2906@oa = @oh{'foo', 'bar'}; 2907@oa = %oh{'foo', 'bar'}; 2908@oa = delete @oh{'foo', 'bar'}; 2909@oa = delete %oh{'foo', 'bar'}; 2910#### 2911# keys optimised away in void and scalar context 2912no warnings; 2913; 2914our %h1; 2915my($x, %h2); 2916%h1; 2917keys %h1; 2918$x = %h1; 2919$x = keys %h1; 2920%h2; 2921keys %h2; 2922$x = %h2; 2923$x = keys %h2; 2924#### 2925# eq,const optimised away for (index() == -1) 2926my($a, $b); 2927our $c; 2928$c = index($a, $b) == 2; 2929$c = rindex($a, $b) == 2; 2930$c = index($a, $b) == -1; 2931$c = rindex($a, $b) == -1; 2932$c = index($a, $b) != -1; 2933$c = rindex($a, $b) != -1; 2934$c = (index($a, $b) == -1); 2935$c = (rindex($a, $b) == -1); 2936$c = (index($a, $b) != -1); 2937$c = (rindex($a, $b) != -1); 2938#### 2939# eq,const,sassign,madmy optimised away for (index() == -1) 2940my($a, $b); 2941my $c; 2942$c = index($a, $b) == 2; 2943$c = rindex($a, $b) == 2; 2944$c = index($a, $b) == -1; 2945$c = rindex($a, $b) == -1; 2946$c = index($a, $b) != -1; 2947$c = rindex($a, $b) != -1; 2948$c = (index($a, $b) == -1); 2949$c = (rindex($a, $b) == -1); 2950$c = (index($a, $b) != -1); 2951$c = (rindex($a, $b) != -1); 2952#### 2953# plain multiconcat 2954my($a, $b, $c, $d, @a); 2955$d = length $a . $b . $c; 2956$d = length($a) . $b . $c; 2957print '' . $a; 2958push @a, ($a . '') * $b; 2959unshift @a, "$a" * ($b . ''); 2960print $a . 'x' . $b . $c; 2961print $a . 'x' . $b . $c, $d; 2962print $b . $c . ($a . $b); 2963print $b . $c . ($a . $b); 2964print $b . $c . @a; 2965print $a . "\x{100}"; 2966#### 2967# double-quoted multiconcat 2968my($a, $b, $c, $d, @a); 2969print "${a}x\x{100}$b$c"; 2970print "$a\Q$b\E$c\Ua$a\E\Lb$b\uc$c\E$a${b}c$c"; 2971print "A=$a[length 'b' . $c . 'd'] b=$b"; 2972print "A=@a B=$b"; 2973print "\x{101}$a\x{100}"; 2974$a = qr/\Q 2975$b $c 2976\x80 2977\x{100} 2978\E$c 2979/; 2980#### 2981# sprintf multiconcat 2982my($a, $b, $c, $d, @a); 2983print sprintf("%s%s%%%sx%s\x{100}%s", $a, $b, $c, scalar @a, $d); 2984#### 2985# multiconcat with lexical assign 2986my($a, $b, $c, $d, $e, @a); 2987$d = 'foo' . $a; 2988$d = "foo$a"; 2989$d = $a . ''; 2990$d = 'foo' . $a . 'bar'; 2991$d = $a . $b; 2992$d = $a . $b . $c; 2993$d = $a . $b . $c . @a; 2994$e = ($d = $a . $b . $c); 2995$d = !$a . $b . $c; 2996$a = $b . $c . ($a . $b); 2997$e = f($d = !$a . $b) . $c; 2998$d = "${a}x\x{100}$b$c"; 2999f($d = !$a . $b . $c); 3000#### 3001# multiconcat with lexical my 3002my($a, $b, $c, $d, $e, @a); 3003my $d1 = 'foo' . $a; 3004my $d2 = "foo$a"; 3005my $d3 = $a . ''; 3006my $d4 = 'foo' . $a . 'bar'; 3007my $d5 = $a . $b; 3008my $d6 = $a . $b . $c; 3009my $e7 = ($d = $a . $b . $c); 3010my $d8 = !$a . $b . $c; 3011my $d9 = $b . $c . ($a . $b); 3012my $da = f($d = !$a . $b) . $c; 3013my $dc = "${a}x\x{100}$b$c"; 3014f(my $db = !$a . $b . $c); 3015my $dd = $a . $b . $c . @a; 3016#### 3017# multiconcat with lexical append 3018my($a, $b, $c, $d, $e, @a); 3019$d .= ''; 3020$d .= $a; 3021$d .= "$a"; 3022$d .= 'foo' . $a; 3023$d .= "foo$a"; 3024$d .= $a . ''; 3025$d .= 'foo' . $a . 'bar'; 3026$d .= $a . $b; 3027$d .= $a . $b . $c; 3028$d .= $a . $b . @a; 3029$e .= ($d = $a . $b . $c); 3030$d .= !$a . $b . $c; 3031$a .= $b . $c . ($a . $b); 3032$e .= f($d .= !$a . $b) . $c; 3033f($d .= !$a . $b . $c); 3034$d .= "${a}x\x{100}$b$c"; 3035#### 3036# multiconcat with expression assign 3037my($a, $b, $c, @a); 3038our($d, $e); 3039$d = 'foo' . $a; 3040$d = "foo$a"; 3041$d = $a . ''; 3042$d = 'foo' . $a . 'bar'; 3043$d = $a . $b; 3044$d = $a . $b . $c; 3045$d = $a . $b . @a; 3046$e = ($d = $a . $b . $c); 3047$a["-$b-"] = !$a . $b . $c; 3048$a[$b]{$c}{$d ? $a : $b . $c} = !$a . $b . $c; 3049$a = $b . $c . ($a . $b); 3050$e = f($d = !$a . $b) . $c; 3051$d = "${a}x\x{100}$b$c"; 3052f($d = !$a . $b . $c); 3053#### 3054# multiconcat with expression concat 3055my($a, $b, $c, @a); 3056our($d, $e); 3057$d .= 'foo' . $a; 3058$d .= "foo$a"; 3059$d .= $a . ''; 3060$d .= 'foo' . $a . 'bar'; 3061$d .= $a . $b; 3062$d .= $a . $b . $c; 3063$d .= $a . $b . @a; 3064$e .= ($d .= $a . $b . $c); 3065$a["-$b-"] .= !$a . $b . $c; 3066$a[$b]{$c}{$d ? $a : $b . $c} .= !$a . $b . $c; 3067$a .= $b . $c . ($a . $b); 3068$e .= f($d .= !$a . $b) . $c; 3069$d .= "${a}x\x{100}$b$c"; 3070f($d .= !$a . $b . $c); 3071#### 3072# multiconcat with CORE::sprintf 3073# CONTEXT sub sprintf {} 3074my($a, $b); 3075my $x = CORE::sprintf('%s%s', $a, $b); 3076#### 3077# multiconcat with backticks 3078my($a, $b); 3079our $x; 3080$x = `$a-$b`; 3081#### 3082# multiconcat within qr// 3083my($r, $a, $b); 3084$r = qr/abc\Q$a-$b\Exyz/; 3085#### 3086# tr with unprintable characters 3087my $str; 3088$str = 'foo'; 3089$str =~ tr/\cA//; 3090#### 3091# CORE::foo special case in bareword parsing 3092print $CORE::foo, $CORE::foo::bar; 3093print @CORE::foo, @CORE::foo::bar; 3094print %CORE::foo, %CORE::foo::bar; 3095print $CORE::foo{'a'}, $CORE::foo::bar{'a'}; 3096print &CORE::foo, &CORE::foo::bar; 3097print &CORE::foo(), &CORE::foo::bar(); 3098print \&CORE::foo, \&CORE::foo::bar; 3099print *CORE::foo, *CORE::foo::bar; 3100print stat CORE::foo::, stat CORE::foo::bar; 3101print CORE::foo:: 1; 3102print CORE::foo::bar 2; 3103#### 3104# trailing colons on glob names 3105no strict 'vars'; 3106$Foo::::baz = 1; 3107print $foo, $foo::, $foo::::; 3108print @foo, @foo::, @foo::::; 3109print %foo, %foo::, %foo::::; 3110print $foo{'a'}, $foo::{'a'}, $foo::::{'a'}; 3111print &foo, &foo::, &foo::::; 3112print &foo(), &foo::(), &foo::::(); 3113print \&foo, \&foo::, \&foo::::; 3114print *foo, *foo::, *foo::::; 3115print stat Foo, stat Foo::::; 3116print Foo 1; 3117print Foo:::: 2; 3118#### 3119# trailing colons mixed with CORE 3120no strict 'vars'; 3121print $CORE, $CORE::, $CORE::::; 3122print @CORE, @CORE::, @CORE::::; 3123print %CORE, %CORE::, %CORE::::; 3124print $CORE{'a'}, $CORE::{'a'}, $CORE::::{'a'}; 3125print &CORE, &CORE::, &CORE::::; 3126print &CORE(), &CORE::(), &CORE::::(); 3127print \&CORE, \&CORE::, \&CORE::::; 3128print *CORE, *CORE::, *CORE::::; 3129print stat CORE, stat CORE::::; 3130print CORE 1; 3131print CORE:::: 2; 3132print $CORE::foo, $CORE::foo::, $CORE::foo::::; 3133print @CORE::foo, @CORE::foo::, @CORE::foo::::; 3134print %CORE::foo, %CORE::foo::, %CORE::foo::::; 3135print $CORE::foo{'a'}, $CORE::foo::{'a'}, $CORE::foo::::{'a'}; 3136print &CORE::foo, &CORE::foo::, &CORE::foo::::; 3137print &CORE::foo(), &CORE::foo::(), &CORE::foo::::(); 3138print \&CORE::foo, \&CORE::foo::, \&CORE::foo::::; 3139print *CORE::foo, *CORE::foo::, *CORE::foo::::; 3140print stat CORE::foo::, stat CORE::foo::::; 3141print CORE::foo:: 1; 3142print CORE::foo:::: 2; 3143#### 3144# \&foo 3145my sub foo { 3146 1; 3147} 3148no strict 'vars'; 3149print \&main::foo; 3150print \&{foo}; 3151print \&bar; 3152use strict 'vars'; 3153print \&main::foo; 3154print \&{foo}; 3155print \&main::bar; 3156#### 3157# exists(&foo) 3158my sub foo { 3159 1; 3160} 3161no strict 'vars'; 3162print exists &main::foo; 3163print exists &{foo}; 3164print exists &bar; 3165use strict 'vars'; 3166print exists &main::foo; 3167print exists &{foo}; 3168print exists &main::bar; 3169# precedence of optimised-away 'keys' (OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS) 3170my($r1, %h1, $res); 3171our($r2, %h2); 3172$res = keys %h1; 3173$res = keys %h2; 3174$res = keys %$r1; 3175$res = keys %$r2; 3176$res = keys(%h1) / 2 - 1; 3177$res = keys(%h2) / 2 - 1; 3178$res = keys(%$r1) / 2 - 1; 3179$res = keys(%$r2) / 2 - 1; 3180#### 3181# ditto in presence of sub keys {} 3182# CONTEXT sub keys {} 3183no warnings; 3184my($r1, %h1, $res); 3185our($r2, %h2); 3186CORE::keys %h1; 3187CORE::keys(%h1) / 2; 3188$res = CORE::keys %h1; 3189$res = CORE::keys %h2; 3190$res = CORE::keys %$r1; 3191$res = CORE::keys %$r2; 3192$res = CORE::keys(%h1) / 2 - 1; 3193$res = CORE::keys(%h2) / 2 - 1; 3194$res = CORE::keys(%$r1) / 2 - 1; 3195$res = CORE::keys(%$r2) / 2 - 1; 3196#### 3197# concat: STACKED: ambiguity between .= and optimised nested 3198my($a, $b); 3199$b = $a . $a . $a; 3200(($a .= $a) .= $a) .= $a; 3201#### 3202# multiconcat: $$ within string 3203my($a, $x); 3204$x = "${$}abc"; 3205$x = "\$$a"; 3206#### 3207# single state aggregate assignment 3208# CONTEXT use feature "state"; 3209state @a = (1, 2, 3); 3210state %h = ('a', 1, 'b', 2); 3211#### 3212# state var with attribute 3213# CONTEXT use feature "state"; 3214state $x :shared; 3215state $y :shared = 1; 3216state @a :shared; 3217state @b :shared = (1, 2); 3218state %h :shared; 3219state %i :shared = ('a', 1, 'b', 2); 3220#### 3221# \our @a shouldn't be a list 3222my $r = \our @a; 3223my(@l) = \our((@b)); 3224@l = \our(@c, @d); 3225#### 3226# postfix $# 3227our(@b, $s, $l); 3228$l = (\my @a)->$#*; 3229(\@b)->$#* = 1; 3230++(\my @c)->$#*; 3231$l = $#a; 3232$#a = 1; 3233$l = $#b; 3234$#b = 1; 3235my $r; 3236$l = $r->$#*; 3237$r->$#* = 1; 3238$l = $#{@$r;}; 3239$#{$r;} = 1; 3240$l = $s->$#*; 3241$s->$#* = 1; 3242$l = $#{@$s;}; 3243$#{$s;} = 1; 3244#### 3245# TODO doesn't preserve backslash 3246my @a; 3247my $s = "$a[0]\[1]"; 3248#### 3249# GH #17301 aux_list() sometimes returned wrong #args 3250my($r, $h); 3251$r = $h->{'i'}; 3252$r = $h->{'i'}{'j'}; 3253$r = $h->{'i'}{'j'}{'k'}; 3254$r = $h->{'i'}{'j'}{'k'}{'l'}; 3255$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}; 3256$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}; 3257$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}; 3258$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}; 3259$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}; 3260$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}; 3261$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}{'s'}; 3262$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}{'s'}{'t'}; 3263#### 3264# chained comparison 3265my($a, $b, $c, $d, $e, $f, $g); 3266$a = $b gt $c >= $d; 3267$a = $b < $c <= $d > $e; 3268$a = $b == $c != $d; 3269$a = $b eq $c ne $d == $e; 3270$a = $b << $c < $d << $e <= $f << $g; 3271$a = int $b < int $c <= int $d; 3272$a = ($b < $c) < ($d < $e) <= ($f < $g); 3273$a = ($b == $c) < ($d == $e) <= ($f == $g); 3274$a = ($b & $c) < ($d & $e) <= ($f & $g); 3275$a = $b << $c == $d << $e != $f << $g; 3276$a = int $b == int $c != int $d; 3277$a = $b < $c == $d < $e != $f < $g; 3278$a = ($b == $c) == ($d == $e) != ($f == $g); 3279$a = ($b & $c) == ($d & $e) != ($f & $g); 3280$a = $b << ($c < $d <= $e); 3281$a = int($c < $d <= $e); 3282$a = $b < ($c < $d <= $e); 3283$a = $b == $c < $d <= $e; 3284$a = $b & $c < $d <= $e; 3285$a = $b << ($c == $d != $e); 3286$a = int($c == $d != $e); 3287$a = $b < ($c == $d != $e); 3288$a = $b == ($c == $d != $e); 3289$a = $b & $c == $d != $e; 3290#### 3291# try/catch 3292# CONTEXT use feature 'try'; no warnings 'experimental::try'; 3293try { 3294 FIRST(); 3295} 3296catch($var) { 3297 SECOND(); 3298} 3299#### 3300# CONTEXT use feature 'try'; no warnings 'experimental::try'; 3301try { 3302 FIRST(); 3303} 3304catch($var) { 3305 my $x; 3306 SECOND(); 3307} 3308#### 3309# CONTEXT use feature 'try'; no warnings 'experimental::try'; 3310try { 3311 FIRST(); 3312} 3313catch($var) { 3314 SECOND(); 3315} 3316finally { 3317 THIRD(); 3318} 3319#### 3320# defer blocks 3321# CONTEXT use feature "defer"; no warnings 'experimental::defer'; 3322defer { 3323 $a = 123; 3324} 3325#### 3326# builtin:: functions 3327# CONTEXT no warnings 'experimental::builtin'; 3328my $x; 3329$x = builtin::is_bool(undef); 3330$x = builtin::is_weak(undef); 3331builtin::weaken($x); 3332builtin::unweaken($x); 3333$x = builtin::blessed(undef); 3334$x = builtin::refaddr(undef); 3335$x = builtin::reftype(undef); 3336$x = builtin::ceil($x); 3337$x = builtin::floor($x); 3338$x = builtin::is_tainted($x); 3339#### 3340# boolean true preserved 3341my $x = !0; 3342#### 3343# boolean false preserved 3344my $x = !1; 3345#### 3346# const NV: NV-ness preserved 3347my(@x) = (-2.0, -1.0, -0.0, 0.0, 1.0, 2.0); 3348#### 3349# PADSV_STORE optimised my should be handled 3350() = (my $s = 1); 3351#### 3352# PADSV_STORE optimised state should be handled 3353# CONTEXT use feature "state"; 3354() = (state $s = 1); 3355