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