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