This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Deparse stash subs stores as RVs
[perl5.git] / lib / B / Deparse.t
1 #!./perl
2
3 BEGIN {
4     unshift @INC, '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 }
11
12 use warnings;
13 use strict;
14 use Test::More;
15
16 my $tests = 26; # not counting those in the __DATA__ section
17
18 use B::Deparse;
19 my $deparse = B::Deparse->new();
20 isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object');
21 my %deparse;
22
23 $/ = "\n####\n";
24 while (<DATA>) {
25     chomp;
26     $tests ++;
27     # This code is pinched from the t/lib/common.pl for TODO.
28     # It's not clear how to avoid duplication
29     my %meta = (context => '');
30     foreach my $what (qw(skip todo context options)) {
31         s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $1;
32         # If the SKIP reason starts ? then it's taken as a code snippet to
33         # evaluate. This provides the flexibility to have conditional SKIPs
34         if ($meta{$what} && $meta{$what} =~ s/^\?//) {
35             my $temp = eval $meta{$what};
36             if ($@) {
37                 die "# In \U$what\E code reason:\n# $meta{$what}\n$@";
38             }
39             $meta{$what} = $temp;
40         }
41     }
42
43     s/^\s*#\s*(.*)$//mg;
44     my $desc = $1;
45     die "Missing name in test $_" unless defined $desc;
46
47     if ($meta{skip}) {
48         # Like this to avoid needing a label SKIP:
49         Test::More->builder->skip($meta{skip});
50         next;
51     }
52
53     my ($input, $expected);
54     if (/(.*)\n>>>>\n(.*)/s) {
55         ($input, $expected) = ($1, $2);
56     }
57     else {
58         ($input, $expected) = ($_, $_);
59     }
60
61     # parse options if necessary
62     my $deparse = $meta{options}
63         ? $deparse{$meta{options}} ||=
64             new B::Deparse split /,/, $meta{options}
65         : $deparse;
66
67     my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input}";
68 # Tell B::Deparse about our ambient pragmas
69 my ($hint_bits, $warning_bits, $hinthash);
70 BEGIN {
71     ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H);
72 }
73 $deparse->ambient_pragmas (
74     hint_bits    => $hint_bits,
75     warning_bits => $warning_bits,
76     '%^H'        => $hinthash,
77 );
78 EOC
79
80     if ($@) {
81         is($@, "", "compilation of $desc");
82     }
83     else {
84         my $deparsed = $deparse->coderef2text( $coderef );
85         my $regex = $expected;
86         $regex =~ s/(\S+)/\Q$1/g;
87         $regex =~ s/\s+/\\s+/g;
88         $regex = '^\{\s*' . $regex . '\s*\}$';
89
90         local $::TODO = $meta{todo};
91         like($deparsed, qr/$regex/, $desc);
92     }
93 }
94
95 # Reset the ambient pragmas
96 {
97     my ($b, $w, $h);
98     BEGIN {
99         ($b, $w, $h) = ($^H, ${^WARNING_BITS}, \%^H);
100     }
101     $deparse->ambient_pragmas (
102         hint_bits    => $b,
103         warning_bits => $w,
104         '%^H'        => $h,
105     );
106 }
107
108 use constant 'c', 'stuff';
109 is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
110    'the subroutine generated by use constant deparses');
111
112 my $a = 0;
113 is($deparse->coderef2text(sub{(-1) ** $a }), "{\n    (-1) ** \$a;\n}",
114    'anon sub capturing an external lexical');
115
116 use constant cr => ['hello'];
117 my $string = "sub " . $deparse->coderef2text(\&cr);
118 my $val = (eval $string)->() or diag $string;
119 is(ref($val), 'ARRAY', 'constant array references deparse');
120 is($val->[0], 'hello', 'and return the correct value');
121
122 my $path = join " ", map { qq["-I$_"] } @INC;
123
124 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
125 $a =~ s/-e syntax OK\n//g;
126 $a =~ s/.*possible typo.*\n//;     # Remove warning line
127 $a =~ s/.*-i used with no filenames.*\n//;      # Remove warning line
128 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
129 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
130 $b = quotemeta <<'EOF';
131 BEGIN { $^I = ".bak"; }
132 BEGIN { $^W = 1; }
133 BEGIN { $/ = "\n"; $\ = "\n"; }
134 LINE: while (defined($_ = <ARGV>)) {
135     chomp $_;
136     our(@F) = split(' ', $_, 0);
137     '???';
138 }
139 EOF
140 $b =~ s/our\\\(\\\@F\\\)/our[( ]\@F\\)?/; # accept both our @F and our(@F)
141 like($a, qr/$b/,
142    'command line flags deparse as BEGIN blocks setting control variables');
143
144 $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
145 $a =~ s/-e syntax OK\n//g;
146 is($a, "use constant ('PI', 4);\n",
147    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
148
149 #Re: perlbug #35857, patch #24505
150 #handle warnings::register-ed packages properly.
151 package B::Deparse::Wrapper;
152 use strict;
153 use warnings;
154 use warnings::register;
155 sub getcode {
156    my $deparser = B::Deparse->new();
157    return $deparser->coderef2text(shift);
158 }
159
160 package Moo;
161 use overload '0+' => sub { 42 };
162
163 package main;
164 use strict;
165 use warnings;
166 use constant GLIPP => 'glipp';
167 use constant PI => 4;
168 use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
169 use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
170 BEGIN { delete $::Fcntl::{O_APPEND}; }
171 use POSIX qw/O_CREAT/;
172 sub test {
173    my $val = shift;
174    my $res = B::Deparse::Wrapper::getcode($val);
175    like($res, qr/use warnings/,
176         '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
177 }
178 my ($q,$p);
179 my $x=sub { ++$q,++$p };
180 test($x);
181 eval <<EOFCODE and test($x);
182    package bar;
183    use strict;
184    use warnings;
185    use warnings::register;
186    package main;
187    1
188 EOFCODE
189
190 # Exotic sub declarations
191 $a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
192 $a =~ s/-e syntax OK\n//g;
193 is($a, <<'EOCODG', "sub :::: and sub ::::::");
194 sub :::: {
195     
196 }
197 sub :::::: {
198     
199 }
200 EOCODG
201
202 # [perl #117311]
203 $a = `$^X $path "-MO=Deparse,-l" -e "map{ eval(0) }()" 2>&1`;
204 $a =~ s/-e syntax OK\n//g;
205 is($a, <<'EOCODH', "[perl #117311] [PATCH] -l option ('#line ...') does not emit ^Ls in the output");
206 #line 1 "-e"
207 map {
208 #line 1 "-e"
209 eval 0;} ();
210 EOCODH
211
212 # [perl #33752]
213 {
214   my $code = <<"EOCODE";
215 {
216     our \$\x{1e1f}\x{14d}\x{14d};
217 }
218 EOCODE
219   my $deparsed
220    = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
221   s/$ \n//x for $deparsed, $code;
222   is $deparsed, $code, 'our $funny_Unicode_chars';
223 }
224
225 # [perl #62500]
226 $a =
227   `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
228 $a =~ s/-e syntax OK\n//g;
229 is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
230 sub BEGIN {
231     *CORE::GLOBAL::require = sub {
232         1;
233     }
234     ;
235 }
236 EOCODF
237
238 # [perl #91384]
239 $a =
240   `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`;
241 like($a, qr/-e syntax OK/,
242     "Deparse does not hang when traversing stash circularities");
243
244 # [perl #93990]
245 @] = ();
246 is($deparse->coderef2text(sub{ print "foo@{]}" }),
247 q<{
248     print "foo@{]}";
249 }>, 'curly around to interpolate "@{]}"');
250 is($deparse->coderef2text(sub{ print "foo@{-}" }),
251 q<{
252     print "foo@-";
253 }>, 'no need to curly around to interpolate "@-"');
254
255 # Strict hints in %^H are mercilessly suppressed
256 $a =
257   `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`;
258 unlike($a, qr/BEGIN/,
259     "Deparse does not emit strict hh hints");
260
261 # ambient_pragmas should not mess with strict settings.
262 SKIP: {
263     skip "requires 5.11", 1 unless $] >= 5.011;
264     eval q`
265         BEGIN {
266             # Clear out all hints
267             %^H = ();
268             $^H = 0;
269             new B::Deparse -> ambient_pragmas(strict => 'all');
270         }
271         use 5.011;  # should enable strict
272         ok !eval '$do_noT_create_a_variable_with_this_name = 1',
273           'ambient_pragmas do not mess with compiling scope';
274    `;
275 }
276
277 # multiple statements on format lines
278 $a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`;
279 $a =~ s/-e syntax OK\n//g;
280 is($a, <<'EOCODH', 'multiple statements on format lines');
281 format STDOUT =
282 @
283 x(); z()
284 .
285 EOCODH
286
287 # CORE::format
288 $a = readpipe qq`$^X $path "-MO=Deparse" -e "use feature q|:all|;`
289              .qq` my sub format; CORE::format =" -e. 2>&1`;
290 like($a, qr/CORE::format/, 'CORE::format when lex format sub is in scope');
291
292 # literal big chars under 'use utf8'
293 is($deparse->coderef2text(sub{ use utf8; /€/; }),
294 '{
295     /\x{20ac}/;
296 }',
297 "qr/euro/");
298
299 # STDERR when deparsing sub calls
300 # For a short while the output included 'While deparsing'
301 $a = `$^X $path "-MO=Deparse" -e "foo()" 2>&1`;
302 $a =~ s/-e syntax OK\n//g;
303 is($a, <<'EOCODI', 'no extra output when deparsing foo()');
304 foo();
305 EOCODI
306
307 # CORE::no
308 $a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
309              .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`;
310 like($a, qr/my sub no;\n\(\);\nCORE::no less;/,
311     'CORE::no after my sub no');
312
313 # CORE::use
314 $a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
315              .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`;
316 like($a, qr/my sub use;\n\(\);\nCORE::use less;/,
317     'CORE::use after my sub use');
318
319 # CORE::__DATA__
320 $a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
321              .qq`"use feature q|:all|; my sub __DATA__; `
322              .qq`CORE::__DATA__" 2>&1`;
323 like($a, qr/my sub __DATA__;\n\(\);\nCORE::__DATA__/,
324     'CORE::__DATA__ after my sub __DATA__');
325
326 # sub declarations
327 $a = readpipe qq`$^X $path "-MO=Deparse" -e "sub foo{}" 2>&1`;
328 like($a, qr/^sub foo\s*\{\s+\}/, 'sub declarations');
329
330
331 done_testing($tests);
332
333 __DATA__
334 # TODO [perl #120950] This succeeds when run a 2nd time
335 # y/uni/code/
336 tr/\x{345}/\x{370}/;
337 ####
338 # y/uni/code/  [perl #120950] This 2nd instance succeeds
339 tr/\x{345}/\x{370}/;
340 ####
341 # A constant
342 1;
343 ####
344 # Constants in a block
345 # CONTEXT no warnings;
346 {
347     '???';
348     2;
349 }
350 ####
351 # Lexical and simple arithmetic
352 my $test;
353 ++$test and $test /= 2;
354 >>>>
355 my $test;
356 $test /= 2 if ++$test;
357 ####
358 # list x
359 -((1, 2) x 2);
360 ####
361 # lvalue sub
362 {
363     my $test = sub : lvalue {
364         my $x;
365     }
366     ;
367 }
368 ####
369 # method
370 {
371     my $test = sub : method {
372         my $x;
373     }
374     ;
375 }
376 ####
377 # block with continue
378 {
379     234;
380 }
381 continue {
382     123;
383 }
384 ####
385 # lexical and package scalars
386 my $x;
387 print $main::x;
388 ####
389 # lexical and package arrays
390 my @x;
391 print $main::x[1];
392 ####
393 # lexical and package hashes
394 my %x;
395 $x{warn()};
396 ####
397 # our (LIST)
398 our($foo, $bar, $baz);
399 ####
400 # CONTEXT { package Dog } use feature "state";
401 # variables with declared classes
402 my Dog $spot;
403 our Dog $spotty;
404 state Dog $spotted;
405 my Dog @spot;
406 our Dog @spotty;
407 state Dog @spotted;
408 my Dog %spot;
409 our Dog %spotty;
410 state Dog %spotted;
411 my Dog ($foo, @bar, %baz);
412 our Dog ($phoo, @barr, %bazz);
413 state Dog ($fough, @barre, %bazze);
414 ####
415 # local our
416 local our $rhubarb;
417 local our($rhu, $barb);
418 ####
419 # <>
420 my $foo;
421 $_ .= <ARGV> . <$foo>;
422 ####
423 # \x{}
424 my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
425 ####
426 # s///e
427 s/x/'y';/e;
428 s/x/$a;/e;
429 s/x/complex_expression();/e;
430 ####
431 # block
432 { my $x; }
433 ####
434 # while 1
435 while (1) { my $k; }
436 ####
437 # trailing for
438 my ($x,@a);
439 $x=1 for @a;
440 >>>>
441 my($x, @a);
442 $x = 1 foreach (@a);
443 ####
444 # 2 arguments in a 3 argument for
445 for (my $i = 0; $i < 2;) {
446     my $z = 1;
447 }
448 ####
449 # 3 argument for
450 for (my $i = 0; $i < 2; ++$i) {
451     my $z = 1;
452 }
453 ####
454 # 3 argument for again
455 for (my $i = 0; $i < 2; ++$i) {
456     my $z = 1;
457 }
458 ####
459 # 3-argument for with inverted condition
460 for (my $i; not $i;) {
461     die;
462 }
463 for (my $i; not $i; ++$i) {
464     die;
465 }
466 for (my $a; not +($1 || 2) ** 2;) {
467     die;
468 }
469 Something_to_put_the_loop_in_void_context();
470 ####
471 # while/continue
472 my $i;
473 while ($i) { my $z = 1; } continue { $i = 99; }
474 ####
475 # foreach with my
476 foreach my $i (1, 2) {
477     my $z = 1;
478 }
479 ####
480 # OPTIONS -p
481 # foreach with my under -p
482 foreach my $i (1) {
483     die;
484 }
485 ####
486 # foreach
487 my $i;
488 foreach $i (1, 2) {
489     my $z = 1;
490 }
491 ####
492 # foreach, 2 mys
493 my $i;
494 foreach my $i (1, 2) {
495     my $z = 1;
496 }
497 ####
498 # foreach with our
499 foreach our $i (1, 2) {
500     my $z = 1;
501 }
502 ####
503 # foreach with my and our
504 my $i;
505 foreach our $i (1, 2) {
506     my $z = 1;
507 }
508 ####
509 # foreach with state
510 # CONTEXT use feature "state";
511 foreach state $i (1, 2) {
512     state $z = 1;
513 }
514 ####
515 # reverse sort
516 my @x;
517 print reverse sort(@x);
518 ####
519 # sort with cmp
520 my @x;
521 print((sort {$b cmp $a} @x));
522 ####
523 # reverse sort with block
524 my @x;
525 print((reverse sort {$b <=> $a} @x));
526 ####
527 # foreach reverse
528 our @a;
529 print $_ foreach (reverse @a);
530 ####
531 # foreach reverse (not inplace)
532 our @a;
533 print $_ foreach (reverse 1, 2..5);
534 ####
535 # bug #38684
536 our @ary;
537 @ary = split(' ', 'foo', 0);
538 ####
539 # Split to our array
540 our @array = split(//, 'foo', 0);
541 ####
542 # Split to my array
543 my @array  = split(//, 'foo', 0);
544 ####
545 # bug #40055
546 do { () }; 
547 ####
548 # bug #40055
549 do { my $x = 1; $x }; 
550 ####
551 # <20061012113037.GJ25805@c4.convolution.nl>
552 my $f = sub {
553     +{[]};
554 } ;
555 ####
556 # bug #43010
557 '!@$%'->();
558 ####
559 # bug #43010
560 ::();
561 ####
562 # bug #43010
563 '::::'->();
564 ####
565 # bug #43010
566 &::::;
567 ####
568 # [perl #77172]
569 package rt77172;
570 sub foo {} foo & & & foo;
571 >>>>
572 package rt77172;
573 foo(&{&} & foo());
574 ####
575 # variables as method names
576 my $bar;
577 'Foo'->$bar('orz');
578 'Foo'->$bar('orz') = 'a stranger stranger than before';
579 ####
580 # constants as method names
581 'Foo'->bar('orz');
582 ####
583 # constants as method names without ()
584 'Foo'->bar;
585 ####
586 # [perl #47359] "indirect" method call notation
587 our @bar;
588 foo{@bar}+1,->foo;
589 (foo{@bar}+1),foo();
590 foo{@bar}1 xor foo();
591 >>>>
592 our @bar;
593 (foo { @bar } 1)->foo;
594 (foo { @bar } 1), foo();
595 foo { @bar } 1 xor foo();
596 ####
597 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
598 # CONTEXT use feature ':5.10';
599 # say
600 say 'foo';
601 ####
602 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
603 # CONTEXT use 5.10.0;
604 # say in the context of use 5.10.0
605 say 'foo';
606 ####
607 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
608 # say with use 5.10.0
609 use 5.10.0;
610 say 'foo';
611 >>>>
612 no feature;
613 use feature ':5.10';
614 say 'foo';
615 ####
616 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
617 # say with use feature ':5.10';
618 use feature ':5.10';
619 say 'foo';
620 >>>>
621 use feature 'say', 'state', 'switch';
622 say 'foo';
623 ####
624 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
625 # CONTEXT use feature ':5.10';
626 # say with use 5.10.0 in the context of use feature
627 use 5.10.0;
628 say 'foo';
629 >>>>
630 no feature;
631 use feature ':5.10';
632 say 'foo';
633 ####
634 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
635 # CONTEXT use 5.10.0;
636 # say with use feature ':5.10' in the context of use 5.10.0
637 use feature ':5.10';
638 say 'foo';
639 >>>>
640 say 'foo';
641 ####
642 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
643 # CONTEXT use feature ':5.15';
644 # __SUB__
645 __SUB__;
646 ####
647 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
648 # CONTEXT use 5.15.0;
649 # __SUB__ in the context of use 5.15.0
650 __SUB__;
651 ####
652 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
653 # __SUB__ with use 5.15.0
654 use 5.15.0;
655 __SUB__;
656 >>>>
657 no feature;
658 use feature ':5.16';
659 __SUB__;
660 ####
661 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
662 # __SUB__ with use feature ':5.15';
663 use feature ':5.15';
664 __SUB__;
665 >>>>
666 use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval';
667 __SUB__;
668 ####
669 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
670 # CONTEXT use feature ':5.15';
671 # __SUB__ with use 5.15.0 in the context of use feature
672 use 5.15.0;
673 __SUB__;
674 >>>>
675 no feature;
676 use feature ':5.16';
677 __SUB__;
678 ####
679 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
680 # CONTEXT use 5.15.0;
681 # __SUB__ with use feature ':5.15' in the context of use 5.15.0
682 use feature ':5.15';
683 __SUB__;
684 >>>>
685 __SUB__;
686 ####
687 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
688 # CONTEXT use feature ':5.10';
689 # state vars
690 state $x = 42;
691 ####
692 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
693 # CONTEXT use feature ':5.10';
694 # state var assignment
695 {
696     my $y = (state $x = 42);
697 }
698 ####
699 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
700 # CONTEXT use feature ':5.10';
701 # state vars in anonymous subroutines
702 $a = sub {
703     state $x;
704     return $x++;
705 }
706 ;
707 ####
708 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
709 # each @array;
710 each @ARGV;
711 each @$a;
712 ####
713 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
714 # keys @array; values @array
715 keys @$a if keys @ARGV;
716 values @ARGV if values @$a;
717 ####
718 # Anonymous arrays and hashes, and references to them
719 my $a = {};
720 my $b = \{};
721 my $c = [];
722 my $d = \[];
723 ####
724 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
725 # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
726 # implicit smartmatch in given/when
727 given ('foo') {
728     when ('bar') { continue; }
729     when ($_ ~~ 'quux') { continue; }
730     default { 0; }
731 }
732 ####
733 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
734 if ($a) { x(); }
735 elsif ($b) { x(); }
736 elsif ($a and $b) { x(); }
737 elsif ($a or $b) { x(); }
738 else { x(); }
739 ####
740 # interpolation in regexps
741 my($y, $t);
742 /x${y}z$t/;
743 ####
744 # TODO new undocumented cpan-bug #33708
745 # cpan-bug #33708
746 %{$_ || {}}
747 ####
748 # TODO hash constants not yet fixed
749 # cpan-bug #33708
750 use constant H => { "#" => 1 }; H->{"#"}
751 ####
752 # TODO optimized away 0 not yet fixed
753 # cpan-bug #33708
754 foreach my $i (@_) { 0 }
755 ####
756 # tests with not, not optimized
757 my $c;
758 x() unless $a;
759 x() if not $a and $b;
760 x() if $a and not $b;
761 x() unless not $a and $b;
762 x() unless $a and not $b;
763 x() if not $a or $b;
764 x() if $a or not $b;
765 x() unless not $a or $b;
766 x() unless $a or not $b;
767 x() if $a and not $b and $c;
768 x() if not $a and $b and not $c;
769 x() unless $a and not $b and $c;
770 x() unless not $a and $b and not $c;
771 x() if $a or not $b or $c;
772 x() if not $a or $b or not $c;
773 x() unless $a or not $b or $c;
774 x() unless not $a or $b or not $c;
775 ####
776 # tests with not, optimized
777 my $c;
778 x() if not $a;
779 x() unless not $a;
780 x() if not $a and not $b;
781 x() unless not $a and not $b;
782 x() if not $a or not $b;
783 x() unless not $a or not $b;
784 x() if not $a and not $b and $c;
785 x() unless not $a and not $b and $c;
786 x() if not $a or not $b or $c;
787 x() unless not $a or not $b or $c;
788 x() if not $a and not $b and not $c;
789 x() unless not $a and not $b and not $c;
790 x() if not $a or not $b or not $c;
791 x() unless not $a or not $b or not $c;
792 x() unless not $a or not $b or not $c;
793 >>>>
794 my $c;
795 x() unless $a;
796 x() if $a;
797 x() unless $a or $b;
798 x() if $a or $b;
799 x() unless $a and $b;
800 x() if $a and $b;
801 x() if not $a || $b and $c;
802 x() unless not $a || $b and $c;
803 x() if not $a && $b or $c;
804 x() unless not $a && $b or $c;
805 x() unless $a or $b or $c;
806 x() if $a or $b or $c;
807 x() unless $a and $b and $c;
808 x() if $a and $b and $c;
809 x() unless not $a && $b && $c;
810 ####
811 # tests that should be constant folded
812 x() if 1;
813 x() if GLIPP;
814 x() if !GLIPP;
815 x() if GLIPP && GLIPP;
816 x() if !GLIPP || GLIPP;
817 x() if do { GLIPP };
818 x() if do { no warnings 'void'; 5; GLIPP };
819 x() if do { !GLIPP };
820 if (GLIPP) { x() } else { z() }
821 if (!GLIPP) { x() } else { z() }
822 if (GLIPP) { x() } elsif (GLIPP) { z() }
823 if (!GLIPP) { x() } elsif (GLIPP) { z() }
824 if (GLIPP) { x() } elsif (!GLIPP) { z() }
825 if (!GLIPP) { x() } elsif (!GLIPP) { z() }
826 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
827 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
828 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
829 >>>>
830 x();
831 x();
832 '???';
833 x();
834 x();
835 x();
836 x();
837 do {
838     '???'
839 };
840 do {
841     x()
842 };
843 do {
844     z()
845 };
846 do {
847     x()
848 };
849 do {
850     z()
851 };
852 do {
853     x()
854 };
855 '???';
856 do {
857     t()
858 };
859 '???';
860 !1;
861 ####
862 # TODO constant deparsing has been backed out for 5.12
863 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
864 # tests that shouldn't be constant folded
865 # It might be fundamentally impossible to make this work on ithreads, in which
866 # case the TODO should become a SKIP
867 x() if $a;
868 if ($a == 1) { x() } elsif ($b == 2) { z() }
869 if (do { foo(); GLIPP }) { x() }
870 if (do { $a++; GLIPP }) { x() }
871 >>>>
872 x() if $a;
873 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
874 if (do { foo(); GLIPP }) { x(); }
875 if (do { ++$a; GLIPP }) { x(); }
876 ####
877 # TODO constant deparsing has been backed out for 5.12
878 # tests for deparsing constants
879 warn PI;
880 ####
881 # TODO constant deparsing has been backed out for 5.12
882 # tests for deparsing imported constants
883 warn O_TRUNC;
884 ####
885 # TODO constant deparsing has been backed out for 5.12
886 # tests for deparsing re-exported constants
887 warn O_CREAT;
888 ####
889 # TODO constant deparsing has been backed out for 5.12
890 # tests for deparsing imported constants that got deleted from the original namespace
891 warn O_APPEND;
892 ####
893 # TODO constant deparsing has been backed out for 5.12
894 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
895 # tests for deparsing constants which got turned into full typeglobs
896 # It might be fundamentally impossible to make this work on ithreads, in which
897 # case the TODO should become a SKIP
898 warn O_EXCL;
899 eval '@Fcntl::O_EXCL = qw/affe tiger/;';
900 warn O_EXCL;
901 ####
902 # TODO constant deparsing has been backed out for 5.12
903 # tests for deparsing of blessed constant with overloaded numification
904 warn OVERLOADED_NUMIFICATION;
905 ####
906 # strict
907 no strict;
908 print $x;
909 use strict 'vars';
910 print $main::x;
911 use strict 'subs';
912 print $main::x;
913 use strict 'refs';
914 print $main::x;
915 no strict 'vars';
916 $x;
917 ####
918 # TODO Subsets of warnings could be encoded textually, rather than as bitflips.
919 # subsets of warnings
920 no warnings 'deprecated';
921 my $x;
922 ####
923 # TODO Better test for CPAN #33708 - the deparsed code has different behaviour
924 # CPAN #33708
925 use strict;
926 no warnings;
927
928 foreach (0..3) {
929     my $x = 2;
930     {
931         my $x if 0;
932         print ++$x, "\n";
933     }
934 }
935 ####
936 # no attribute list
937 my $pi = 4;
938 ####
939 # SKIP ?$] > 5.013006 && ":= is now a syntax error"
940 # := treated as an empty attribute list
941 no warnings;
942 my $pi := 4;
943 >>>>
944 no warnings;
945 my $pi = 4;
946 ####
947 # : = empty attribute list
948 my $pi : = 4;
949 >>>>
950 my $pi = 4;
951 ####
952 # in place sort
953 our @a;
954 my @b;
955 @a = sort @a;
956 @b = sort @b;
957 ();
958 ####
959 # in place reverse
960 our @a;
961 my @b;
962 @a = reverse @a;
963 @b = reverse @b;
964 ();
965 ####
966 # #71870 Use of uninitialized value in bitwise and B::Deparse
967 my($r, $s, @a);
968 @a = split(/foo/, $s, 0);
969 $r = qr/foo/;
970 @a = split(/$r/, $s, 0);
971 ();
972 ####
973 # package declaration before label
974 {
975     package Foo;
976     label: print 123;
977 }
978 ####
979 # shift optimisation
980 shift;
981 >>>>
982 shift();
983 ####
984 # shift optimisation
985 shift @_;
986 ####
987 # shift optimisation
988 pop;
989 >>>>
990 pop();
991 ####
992 # shift optimisation
993 pop @_;
994 ####
995 #[perl #20444]
996 "foo" =~ (1 ? /foo/ : /bar/);
997 "foo" =~ (1 ? y/foo// : /bar/);
998 "foo" =~ (1 ? y/foo//r : /bar/);
999 "foo" =~ (1 ? s/foo// : /bar/);
1000 >>>>
1001 'foo' =~ ($_ =~ /foo/);
1002 'foo' =~ ($_ =~ tr/fo//);
1003 'foo' =~ ($_ =~ tr/fo//r);
1004 'foo' =~ ($_ =~ s/foo//);
1005 ####
1006 # The fix for [perl #20444] broke this.
1007 'foo' =~ do { () };
1008 ####
1009 # [perl #81424] match against aelemfast_lex
1010 my @s;
1011 print /$s[1]/;
1012 ####
1013 # /$#a/
1014 print /$#main::a/;
1015 ####
1016 # [perl #91318] /regexp/applaud
1017 print /a/a, s/b/c/a;
1018 print /a/aa, s/b/c/aa;
1019 print /a/p, s/b/c/p;
1020 print /a/l, s/b/c/l;
1021 print /a/u, s/b/c/u;
1022 {
1023     use feature "unicode_strings";
1024     print /a/d, s/b/c/d;
1025 }
1026 {
1027     use re "/u";
1028     print /a/d, s/b/c/d;
1029 }
1030 {
1031     use 5.012;
1032     print /a/d, s/b/c/d;
1033 }
1034 >>>>
1035 print /a/a, s/b/c/a;
1036 print /a/aa, s/b/c/aa;
1037 print /a/p, s/b/c/p;
1038 print /a/l, s/b/c/l;
1039 print /a/u, s/b/c/u;
1040 {
1041     use feature 'unicode_strings';
1042     print /a/d, s/b/c/d;
1043 }
1044 {
1045     BEGIN { $^H{'reflags'}         = '0';
1046             $^H{'reflags_charset'} = '2'; }
1047     print /a/d, s/b/c/d;
1048 }
1049 {
1050     no feature;
1051     use feature ':5.12';
1052     print /a/d, s/b/c/d;
1053 }
1054 ####
1055 # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
1056 s/foo/\(3);/eg;
1057 ####
1058 # y///r
1059 tr/a/b/r;
1060 ####
1061 # [perl #90898]
1062 <a,>;
1063 ####
1064 # [perl #91008]
1065 # CONTEXT no warnings 'experimental::autoderef';
1066 each $@;
1067 keys $~;
1068 values $!;
1069 ####
1070 # readpipe with complex expression
1071 readpipe $a + $b;
1072 ####
1073 # aelemfast
1074 $b::a[0] = 1;
1075 ####
1076 # aelemfast for a lexical
1077 my @a;
1078 $a[0] = 1;
1079 ####
1080 # feature features without feature
1081 # CONTEXT no warnings 'experimental::smartmatch';
1082 CORE::state $x;
1083 CORE::say $x;
1084 CORE::given ($x) {
1085     CORE::when (3) {
1086         continue;
1087     }
1088     CORE::default {
1089         CORE::break;
1090     }
1091 }
1092 CORE::evalbytes '';
1093 () = CORE::__SUB__;
1094 () = CORE::fc $x;
1095 ####
1096 # feature features when feature has been disabled by use VERSION
1097 # CONTEXT no warnings 'experimental::smartmatch';
1098 use feature (sprintf(":%vd", $^V));
1099 use 1;
1100 CORE::say $_;
1101 CORE::state $x;
1102 CORE::given ($x) {
1103     CORE::when (3) {
1104         continue;
1105     }
1106     CORE::default {
1107         CORE::break;
1108     }
1109 }
1110 CORE::evalbytes '';
1111 () = CORE::__SUB__;
1112 >>>>
1113 CORE::say $_;
1114 CORE::state $x;
1115 CORE::given ($x) {
1116     CORE::when (3) {
1117         continue;
1118     }
1119     CORE::default {
1120         CORE::break;
1121     }
1122 }
1123 CORE::evalbytes '';
1124 () = CORE::__SUB__;
1125 ####
1126 # (the above test with CONTEXT, and the output is equivalent but different)
1127 # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
1128 # feature features when feature has been disabled by use VERSION
1129 use feature (sprintf(":%vd", $^V));
1130 use 1;
1131 CORE::say $_;
1132 CORE::state $x;
1133 CORE::given ($x) {
1134     CORE::when (3) {
1135         continue;
1136     }
1137     CORE::default {
1138         CORE::break;
1139     }
1140 }
1141 CORE::evalbytes '';
1142 () = CORE::__SUB__;
1143 >>>>
1144 no feature;
1145 use feature ':default';
1146 CORE::say $_;
1147 CORE::state $x;
1148 CORE::given ($x) {
1149     CORE::when (3) {
1150         continue;
1151     }
1152     CORE::default {
1153         CORE::break;
1154     }
1155 }
1156 CORE::evalbytes '';
1157 () = CORE::__SUB__;
1158 ####
1159 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1160 # lexical subroutines and keywords of the same name
1161 # CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental';
1162 my sub default;
1163 my sub else;
1164 my sub elsif;
1165 my sub for;
1166 my sub foreach;
1167 my sub given;
1168 my sub if;
1169 my sub m;
1170 my sub no;
1171 my sub package;
1172 my sub q;
1173 my sub qq;
1174 my sub qr;
1175 my sub qx;
1176 my sub require;
1177 my sub s;
1178 my sub sub;
1179 my sub tr;
1180 my sub unless;
1181 my sub until;
1182 my sub use;
1183 my sub when;
1184 my sub while;
1185 CORE::default { die; }
1186 CORE::if ($1) { die; }
1187 CORE::if ($1) { die; }
1188 CORE::elsif ($1) { die; }
1189 CORE::else { die; }
1190 CORE::for (die; $1; die) { die; }
1191 CORE::foreach $_ (1 .. 10) { die; }
1192 die CORE::foreach (1);
1193 CORE::given ($1) { die; }
1194 CORE::m[/];
1195 CORE::m?/?;
1196 CORE::package foo;
1197 CORE::no strict;
1198 () = (CORE::q['], CORE::qq["$_], CORE::qr//, CORE::qx[`]);
1199 CORE::require 1;
1200 CORE::s///;
1201 () = CORE::sub { die; } ;
1202 CORE::tr///;
1203 CORE::unless ($1) { die; }
1204 CORE::until ($1) { die; }
1205 die CORE::until $1;
1206 CORE::use strict;
1207 CORE::when ($1 ~~ $2) { die; }
1208 CORE::while ($1) { die; }
1209 die CORE::while $1;
1210 ####
1211 # Feature hints
1212 use feature 'current_sub', 'evalbytes';
1213 print;
1214 use 1;
1215 print;
1216 use 5.014;
1217 print;
1218 no feature 'unicode_strings';
1219 print;
1220 >>>>
1221 use feature 'current_sub', 'evalbytes';
1222 print $_;
1223 no feature;
1224 use feature ':default';
1225 print $_;
1226 no feature;
1227 use feature ':5.12';
1228 print $_;
1229 no feature 'unicode_strings';
1230 print $_;
1231 ####
1232 # $#- $#+ $#{%} etc.
1233 my @x;
1234 @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
1235 @x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
1236 @x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
1237 @x = ($#{;}, $#{:});
1238 ####
1239 # ${#} interpolated
1240 # It's a known TODO that warnings are deparsed as bits, not textually.
1241 no warnings;
1242 () = "${#}a";
1243 ####
1244 # [perl #86060] $( $| $) in regexps need braces
1245 /${(}/;
1246 /${|}/;
1247 /${)}/;
1248 /${(}${|}${)}/;
1249 ####
1250 # ()[...]
1251 my(@a) = ()[()];
1252 ####
1253 # sort(foo(bar))
1254 # sort(foo(bar)) is interpreted as sort &foo(bar)
1255 # sort foo(bar) is interpreted as sort foo bar
1256 # parentheses are not optional in this case
1257 print sort(foo('bar'));
1258 >>>>
1259 print sort(foo('bar'));
1260 ####
1261 # substr assignment
1262 substr(my $a, 0, 0) = (foo(), bar());
1263 $a++;
1264 ####
1265 # This following line works around an unfixed bug that we are not trying to 
1266 # test for here:
1267 # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
1268 # hint hash
1269 BEGIN { $^H{'foo'} = undef; }
1270 {
1271  BEGIN { $^H{'bar'} = undef; }
1272  {
1273   BEGIN { $^H{'baz'} = undef; }
1274   {
1275    print $_;
1276   }
1277   print $_;
1278  }
1279  print $_;
1280 }
1281 BEGIN { $^H{q[']} = '('; }
1282 print $_;
1283 ####
1284 # This following line works around an unfixed bug that we are not trying to 
1285 # test for here:
1286 # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
1287 # hint hash changes that serialise the same way with sort %hh
1288 BEGIN { $^H{'a'} = 'b'; }
1289 {
1290  BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
1291  print $_;
1292 }
1293 print $_;
1294 ####
1295 # [perl #47361] do({}) and do +{} (variants of do-file)
1296 do({});
1297 do +{};
1298 sub foo::do {}
1299 package foo;
1300 CORE::do({});
1301 CORE::do +{};
1302 >>>>
1303 do({});
1304 do({});
1305 package foo;
1306 CORE::do({});
1307 CORE::do({});
1308 ####
1309 # [perl #77096] functions that do not follow the llafr
1310 () = (return 1) + time;
1311 () = (return ($1 + $2) * $3) + time;
1312 () = (return ($a xor $b)) + time;
1313 () = (do 'file') + time;
1314 () = (do ($1 + $2) * $3) + time;
1315 () = (do ($1 xor $2)) + time;
1316 () = (goto 1) + 3;
1317 () = (require 'foo') + 3;
1318 () = (require foo) + 3;
1319 () = (CORE::dump 1) + 3;
1320 () = (last 1) + 3;
1321 () = (next 1) + 3;
1322 () = (redo 1) + 3;
1323 () = (-R $_) + 3;
1324 () = (-W $_) + 3;
1325 () = (-X $_) + 3;
1326 () = (-r $_) + 3;
1327 () = (-w $_) + 3;
1328 () = (-x $_) + 3;
1329 ####
1330 # [perl #97476] not() *does* follow the llafr
1331 $_ = ($a xor not +($1 || 2) ** 2);
1332 ####
1333 # Precedence conundrums with argument-less function calls
1334 () = (eof) + 1;
1335 () = (return) + 1;
1336 () = (return, 1);
1337 () = warn;
1338 () = warn() + 1;
1339 () = setpgrp() + 1;
1340 ####
1341 # loopexes have assignment prec
1342 () = (CORE::dump a) | 'b';
1343 () = (goto a) | 'b';
1344 () = (last a) | 'b';
1345 () = (next a) | 'b';
1346 () = (redo a) | 'b';
1347 ####
1348 # [perl #63558] open local(*FH)
1349 open local *FH;
1350 pipe local *FH, local *FH;
1351 ####
1352 # [perl #91416] open "string"
1353 open 'open';
1354 open '####';
1355 open '^A';
1356 open "\ca";
1357 >>>>
1358 open *open;
1359 open '####';
1360 open '^A';
1361 open *^A;
1362 ####
1363 # "string"->[] ->{}
1364 no strict 'vars';
1365 () = 'open'->[0]; #aelemfast
1366 () = '####'->[0];
1367 () = '^A'->[0];
1368 () = "\ca"->[0];
1369 () = 'a::]b'->[0];
1370 () = 'open'->[$_]; #aelem
1371 () = '####'->[$_];
1372 () = '^A'->[$_];
1373 () = "\ca"->[$_];
1374 () = 'a::]b'->[$_];
1375 () = 'open'->{0}; #helem
1376 () = '####'->{0};
1377 () = '^A'->{0};
1378 () = "\ca"->{0};
1379 () = 'a::]b'->{0};
1380 >>>>
1381 no strict 'vars';
1382 () = $open[0];
1383 () = '####'->[0];
1384 () = '^A'->[0];
1385 () = $^A[0];
1386 () = 'a::]b'->[0];
1387 () = $open[$_];
1388 () = '####'->[$_];
1389 () = '^A'->[$_];
1390 () = $^A[$_];
1391 () = 'a::]b'->[$_];
1392 () = $open{'0'};
1393 () = '####'->{'0'};
1394 () = '^A'->{'0'};
1395 () = $^A{'0'};
1396 () = 'a::]b'->{'0'};
1397 ####
1398 # [perl #74740] -(f()) vs -f()
1399 $_ = -(f());
1400 ####
1401 # require <binop>
1402 require 'a' . $1;
1403 ####
1404 #[perl #30504] foreach-my postfix/prefix difference
1405 $_ = 'foo' foreach my ($foo1, $bar1, $baz1);
1406 foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' }
1407 foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' }
1408 >>>>
1409 $_ = 'foo' foreach (my($foo1, $bar1, $baz1));
1410 foreach $_ (my($foo2, $bar2, $baz2)) {
1411     $_ = 'foo';
1412 }
1413 foreach my $i (my($foo3, $bar3, $baz3)) {
1414     $i = 'foo';
1415 }
1416 ####
1417 #[perl #108224] foreach with continue block
1418 foreach (1 .. 3) { print } continue { print "\n" }
1419 foreach (1 .. 3) { } continue { }
1420 foreach my $i (1 .. 3) { print $i } continue { print "\n" }
1421 foreach my $i (1 .. 3) { } continue { }
1422 >>>>
1423 foreach $_ (1 .. 3) {
1424     print $_;
1425 }
1426 continue {
1427     print "\n";
1428 }
1429 foreach $_ (1 .. 3) {
1430     ();
1431 }
1432 continue {
1433     ();
1434 }
1435 foreach my $i (1 .. 3) {
1436     print $i;
1437 }
1438 continue {
1439     print "\n";
1440 }
1441 foreach my $i (1 .. 3) {
1442     ();
1443 }
1444 continue {
1445     ();
1446 }
1447 ####
1448 # file handles
1449 no strict;
1450 my $mfh;
1451 open F;
1452 open *F;
1453 open $fh;
1454 open $mfh;
1455 open 'a+b';
1456 select *F;
1457 select F;
1458 select $f;
1459 select $mfh;
1460 select 'a+b';
1461 ####
1462 # 'my' works with padrange op
1463 my($z, @z);
1464 my $m1;
1465 $m1 = 1;
1466 $z = $m1;
1467 my $m2 = 2;
1468 my($m3, $m4);
1469 ($m3, $m4) = (1, 2);
1470 @z = ($m3, $m4);
1471 my($m5, $m6) = (1, 2);
1472 my($m7, undef, $m8) = (1, 2, 3);
1473 @z = ($m7, undef, $m8);
1474 ($m7, undef, $m8) = (1, 2, 3);
1475 ####
1476 # 'our/local' works with padrange op
1477 our($z, @z);
1478 our $o1;
1479 no strict;
1480 local $o11;
1481 $o1 = 1;
1482 local $o1 = 1;
1483 $z = $o1;
1484 $z = local $o1;
1485 our $o2 = 2;
1486 our($o3, $o4);
1487 ($o3, $o4) = (1, 2);
1488 local($o3, $o4) = (1, 2);
1489 @z = ($o3, $o4);
1490 @z = local($o3, $o4);
1491 our($o5, $o6) = (1, 2);
1492 our($o7, undef, $o8) = (1, 2, 3);
1493 @z = ($o7, undef, $o8);
1494 @z = local($o7, undef, $o8);
1495 ($o7, undef, $o8) = (1, 2, 3);
1496 local($o7, undef, $o8) = (1, 2, 3);
1497 ####
1498 # 'state' works with padrange op
1499 # CONTEXT no strict; use feature 'state';
1500 state($z, @z);
1501 state $s1;
1502 $s1 = 1;
1503 $z = $s1;
1504 state $s2 = 2;
1505 state($s3, $s4);
1506 ($s3, $s4) = (1, 2);
1507 @z = ($s3, $s4);
1508 # assignment of state lists isn't implemented yet
1509 #state($s5, $s6) = (1, 2);
1510 #state($s7, undef, $s8) = (1, 2, 3);
1511 #@z = ($s7, undef, $s8);
1512 ($s7, undef, $s8) = (1, 2, 3);
1513 ####
1514 # anon lists with padrange
1515 my($a, $b);
1516 my $c = [$a, $b];
1517 my $d = {$a, $b};
1518 ####
1519 # slices with padrange
1520 my($a, $b);
1521 my(@x, %y);
1522 @x = @x[$a, $b];
1523 @x = @y{$a, $b};
1524 ####
1525 # binops with padrange
1526 my($a, $b, $c);
1527 $c = $a cmp $b;
1528 $c = $a + $b;
1529 $a += $b;
1530 $c = $a - $b;
1531 $a -= $b;
1532 $c = my $a1 cmp $b;
1533 $c = my $a2 + $b;
1534 $a += my $b1;
1535 $c = my $a3 - $b;
1536 $a -= my $b2;
1537 ####
1538 # 'x' with padrange
1539 my($a, $b, $c, $d, @e);
1540 $c = $a x $b;
1541 $a x= $b;
1542 @e = ($a) x $d;
1543 @e = ($a, $b) x $d;
1544 @e = ($a, $b, $c) x $d;
1545 @e = ($a, 1) x $d;
1546 ####
1547 # @_ with padrange
1548 my($a, $b, $c) = @_;
1549 ####
1550 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1551 # TODO unimplemented in B::Deparse; RT #116553
1552 # lexical subroutine
1553 use feature 'lexical_subs';
1554 no warnings "experimental::lexical_subs";
1555 my sub f {}
1556 print f();
1557 ####
1558 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1559 # TODO unimplemented in B::Deparse; RT #116553
1560 # lexical "state" subroutine
1561 use feature 'state', 'lexical_subs';
1562 no warnings 'experimental::lexical_subs';
1563 state sub f {}
1564 print f();
1565 ####
1566 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1567 # TODO unimplemented in B::Deparse; RT #116553
1568 # lexical subroutine scoping
1569 # CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
1570 {
1571   {
1572     my sub a { die; }
1573     {
1574       foo();
1575       my sub b;
1576       b();
1577       main::b();
1578       my $b;
1579       sub b { $b }
1580     }
1581   }
1582   b();
1583 }
1584 ####
1585 # Elements of %# should not be confused with $#{ array }
1586 () = ${#}{'foo'};
1587 ####
1588 # [perl #121050] Prototypes with whitespace
1589 sub _121050(\$ \$) { }
1590 _121050($a,$b);
1591 sub _121050empty( ) {}
1592 () = _121050empty() + 1;
1593 >>>>
1594 _121050 $a, $b;
1595 () = _121050empty + 1;
1596 ####
1597 # ensure aelemfast works in the range -128..127 and that there's no
1598 # funky edge cases
1599 my $x;
1600 no strict 'vars';
1601 $x = $a[-256] + $a[-255] + $a[-129] + $a[-128] + $a[-127] + $a[-1] + $a[0];
1602 $x = $a[1] + $a[126] + $a[127] + $a[128] + $a[255] + $a[256];
1603 my @b;
1604 $x = $b[-256] + $b[-255] + $b[-129] + $b[-128] + $b[-127] + $b[-1] + $b[0];
1605 $x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256];
1606 ####
1607 # 'm' must be preserved in m??
1608 m??;
1609 ####
1610 # \(@array) and \(..., (@array), ...)
1611 my(@array, %hash, @a, @b, %c, %d);
1612 () = \(@array);
1613 () = \(%hash);
1614 () = \(@a, (@b), (%c), %d);
1615 () = \(@Foo::array);
1616 () = \(%Foo::hash);
1617 () = \(@Foo::a, (@Foo::b), (%Foo::c), %Foo::d);
1618 ####
1619 # subs synonymous with keywords
1620 main::our();
1621 main::pop();
1622 state();
1623 use feature 'state';
1624 main::state();
1625 ####
1626 # lvalue references
1627 # CONTEXT use feature "state", 'refaliasing', 'lexical_subs'; no warnings 'experimental';
1628 our $x;
1629 \$x = \$x;
1630 my $m;
1631 \$m = \$x;
1632 \my $n = \$x;
1633 (\$x) = @_;
1634 \($x) = @_;
1635 \($m) = @_;
1636 (\$m) = @_;
1637 \my($p) = @_;
1638 (\my $r) = @_;
1639 \($x, my $a) = @{[\$x, \$x]};
1640 (\$x, \my $b) = @{[\$x, \$x]};
1641 \local $x = \3;
1642 \local($x) = \3;
1643 \state $c = \3;
1644 \state($d) = \3;
1645 \our $e = \3;
1646 \our($f) = \3;
1647 \$_[0] = foo();
1648 \($_[1]) = foo();
1649 my @a;
1650 \$a[0] = foo();
1651 \($a[1]) = foo();
1652 \local($a[1]) = foo();
1653 \@a[0,1] = foo();
1654 \(@a[2,3]) = foo();
1655 \local @a[0,1] = (\$a)x2;
1656 \$_{a} = foo();
1657 \($_{b}) = foo();
1658 my %h;
1659 \$h{a} = foo();
1660 \($h{b}) = foo();
1661 \local $h{a} = \$x;
1662 \local($h{b}) = \$x;
1663 \@h{'a','b'} = foo();
1664 \(@h{2,3}) = foo();
1665 \local @h{'a','b'} = (\$x)x2;
1666 \@_ = foo();
1667 \@a = foo();
1668 (\@_) = foo();
1669 (\@a) = foo();
1670 \my @c = foo();
1671 (\my @d) = foo();
1672 \(@_) = foo();
1673 \(@a) = foo();
1674 \my(@g) = foo();
1675 \local @_ = \@_;
1676 (\local @_) = \@_;
1677 \state @e = [1..3];
1678 \state(@f) = \3;
1679 \our @i = [1..3];
1680 \our(@h) = \3;
1681 \%_ = foo();
1682 \%h = foo();
1683 (\%_) = foo();
1684 (\%h) = foo();
1685 \my %c = foo();
1686 (\my %d) = foo();
1687 \local %_ = \%h;
1688 (\local %_) = \%h;
1689 \state %y = {1,2};
1690 \our %z = {1,2};
1691 (\our %zz) = {1,2};
1692 \&a = foo();
1693 (\&a) = foo();
1694 \(&a) = foo();
1695 {
1696   my sub a;
1697   \&a = foo();
1698   (\&a) = foo();
1699   \(&a) = foo();
1700 }
1701 (\$_, $_) = \(1, 2);
1702 $_ == 3 ? \$_ : $_ = \3;
1703 $_ == 3 ? \$_ : \$x = \3;
1704 \($_ == 3 ? $_ : $x) = \3;
1705 for \my $topic (\$1, \$2) {
1706     die;
1707 }
1708 for \state $topic (\$1, \$2) {
1709     die;
1710 }
1711 for \our $topic (\$1, \$2) {
1712     die;
1713 }
1714 for \$_ (\$1, \$2) {
1715     die;
1716 }
1717 for \my @a ([1,2], [3,4]) {
1718     die;
1719 }
1720 for \state @a ([1,2], [3,4]) {
1721     die;
1722 }
1723 for \our @a ([1,2], [3,4]) {
1724     die;
1725 }
1726 for \@_ ([1,2], [3,4]) {
1727     die;
1728 }
1729 for \my %a ({5,6}, {7,8}) {
1730     die;
1731 }
1732 for \our %a ({5,6}, {7,8}) {
1733     die;
1734 }
1735 for \state %a ({5,6}, {7,8}) {
1736     die;
1737 }
1738 for \%_ ({5,6}, {7,8}) {
1739     die;
1740 }
1741 {
1742     my sub a;
1743     for \&a (sub { 9; }, sub { 10; }) {
1744         die;
1745     }
1746 }
1747 for \&a (sub { 9; }, sub { 10; }) {
1748     die;
1749 }
1750 >>>>
1751 our $x;
1752 \$x = \$x;
1753 my $m;
1754 \$m = \$x;
1755 \my $n = \$x;
1756 (\$x) = @_;
1757 (\$x) = @_;
1758 (\$m) = @_;
1759 (\$m) = @_;
1760 (\my $p) = @_;
1761 (\my $r) = @_;
1762 (\$x, \my $a) = @{[\$x, \$x];};
1763 (\$x, \my $b) = @{[\$x, \$x];};
1764 \local $x = \3;
1765 (\local $x) = \3;
1766 \state $c = \3;
1767 (\state $d) = \3;
1768 \our $e = \3;
1769 (\our $f) = \3;
1770 \$_[0] = foo();
1771 (\$_[1]) = foo();
1772 my @a;
1773 \$a[0] = foo();
1774 (\$a[1]) = foo();
1775 (\local $a[1]) = foo();
1776 (\@a[0, 1]) = foo();
1777 (\@a[2, 3]) = foo();
1778 (\local @a[0, 1]) = (\$a) x 2;
1779 \$_{'a'} = foo();
1780 (\$_{'b'}) = foo();
1781 my %h;
1782 \$h{'a'} = foo();
1783 (\$h{'b'}) = foo();
1784 \local $h{'a'} = \$x;
1785 (\local $h{'b'}) = \$x;
1786 (\@h{'a', 'b'}) = foo();
1787 (\@h{2, 3}) = foo();
1788 (\local @h{'a', 'b'}) = (\$x) x 2;
1789 \@_ = foo();
1790 \@a = foo();
1791 (\@_) = foo();
1792 (\@a) = foo();
1793 \my @c = foo();
1794 (\my @d) = foo();
1795 (\(@_)) = foo();
1796 (\(@a)) = foo();
1797 (\(my @g)) = foo();
1798 \local @_ = \@_;
1799 (\local @_) = \@_;
1800 \state @e = [1..3];
1801 (\(state @f)) = \3;
1802 \our @i = [1..3];
1803 (\(our @h)) = \3;
1804 \%_ = foo();
1805 \%h = foo();
1806 (\%_) = foo();
1807 (\%h) = foo();
1808 \my %c = foo();
1809 (\my %d) = foo();
1810 \local %_ = \%h;
1811 (\local %_) = \%h;
1812 \state %y = {1, 2};
1813 \our %z = {1, 2};
1814 (\our %zz) = {1, 2};
1815 \&a = foo();
1816 (\&a) = foo();
1817 (\&a) = foo();
1818 {
1819   my sub a;
1820   \&a = foo();
1821   (\&a) = foo();
1822   (\&a) = foo();
1823 }
1824 (\$_, $_) = \(1, 2);
1825 $_ == 3 ? \$_ : $_ = \3;
1826 $_ == 3 ? \$_ : \$x = \3;
1827 ($_ == 3 ? \$_ : \$x) = \3;
1828 foreach \my $topic (\$1, \$2) {
1829     die;
1830 }
1831 foreach \state $topic (\$1, \$2) {
1832     die;
1833 }
1834 foreach \our $topic (\$1, \$2) {
1835     die;
1836 }
1837 foreach \$_ (\$1, \$2) {
1838     die;
1839 }
1840 foreach \my @a ([1, 2], [3, 4]) {
1841     die;
1842 }
1843 foreach \state @a ([1, 2], [3, 4]) {
1844     die;
1845 }
1846 foreach \our @a ([1, 2], [3, 4]) {
1847     die;
1848 }
1849 foreach \@_ ([1, 2], [3, 4]) {
1850     die;
1851 }
1852 foreach \my %a ({5, 6}, {7, 8}) {
1853     die;
1854 }
1855 foreach \our %a ({5, 6}, {7, 8}) {
1856     die;
1857 }
1858 foreach \state %a ({5, 6}, {7, 8}) {
1859     die;
1860 }
1861 foreach \%_ ({5, 6}, {7, 8}) {
1862     die;
1863 }
1864 {
1865     my sub a;
1866     foreach \&a (sub { 9; } , sub { 10; } ) {
1867         die;
1868     }
1869 }
1870 foreach \&a (sub { 9; } , sub { 10; } ) {
1871     die;
1872 }
1873 ####
1874 # join $foo, pos
1875 my $foo;
1876 $_ = join $foo, pos
1877 >>>>
1878 my $foo;
1879 $_ = join('???', pos $_);