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