This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Deparse typed vars
[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 = 20; # 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 use constant 'c', 'stuff';
96 is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
97    'the subroutine generated by use constant deparses');
98
99 my $a = 0;
100 is($deparse->coderef2text(sub{(-1) ** $a }), "{\n    (-1) ** \$a;\n}",
101    'anon sub capturing an external lexical');
102
103 use constant cr => ['hello'];
104 my $string = "sub " . $deparse->coderef2text(\&cr);
105 my $val = (eval $string)->() or diag $string;
106 is(ref($val), 'ARRAY', 'constant array references deparse');
107 is($val->[0], 'hello', 'and return the correct value');
108
109 my $path = join " ", map { qq["-I$_"] } @INC;
110
111 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
112 $a =~ s/-e syntax OK\n//g;
113 $a =~ s/.*possible typo.*\n//;     # Remove warning line
114 $a =~ s/.*-i used with no filenames.*\n//;      # Remove warning line
115 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
116 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
117 $b = <<'EOF';
118 BEGIN { $^I = ".bak"; }
119 BEGIN { $^W = 1; }
120 BEGIN { $/ = "\n"; $\ = "\n"; }
121 LINE: while (defined($_ = <ARGV>)) {
122     chomp $_;
123     our(@F) = split(' ', $_, 0);
124     '???';
125 }
126 EOF
127 is($a, $b,
128    'command line flags deparse as BEGIN blocks setting control variables');
129
130 $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
131 $a =~ s/-e syntax OK\n//g;
132 is($a, "use constant ('PI', 4);\n",
133    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
134
135 #Re: perlbug #35857, patch #24505
136 #handle warnings::register-ed packages properly.
137 package B::Deparse::Wrapper;
138 use strict;
139 use warnings;
140 use warnings::register;
141 sub getcode {
142    my $deparser = B::Deparse->new();
143    return $deparser->coderef2text(shift);
144 }
145
146 package Moo;
147 use overload '0+' => sub { 42 };
148
149 package main;
150 use strict;
151 use warnings;
152 use constant GLIPP => 'glipp';
153 use constant PI => 4;
154 use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
155 use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
156 BEGIN { delete $::Fcntl::{O_APPEND}; }
157 use POSIX qw/O_CREAT/;
158 sub test {
159    my $val = shift;
160    my $res = B::Deparse::Wrapper::getcode($val);
161    like($res, qr/use warnings/,
162         '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
163 }
164 my ($q,$p);
165 my $x=sub { ++$q,++$p };
166 test($x);
167 eval <<EOFCODE and test($x);
168    package bar;
169    use strict;
170    use warnings;
171    use warnings::register;
172    package main;
173    1
174 EOFCODE
175
176 # Exotic sub declarations
177 $a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
178 $a =~ s/-e syntax OK\n//g;
179 is($a, <<'EOCODG', "sub :::: and sub ::::::");
180 sub :::: {
181     
182 }
183 sub :::::: {
184     
185 }
186 EOCODG
187
188 # [perl #117311]
189 $a = `$^X $path "-MO=Deparse,-l" -e "map{ eval(0) }()" 2>&1`;
190 $a =~ s/-e syntax OK\n//g;
191 is($a, <<'EOCODH', "[perl #117311] [PATCH] -l option ('#line ...') does not emit ^Ls in the output");
192 #line 1 "-e"
193 map {
194 #line 1 "-e"
195 eval 0;} ();
196 EOCODH
197
198 # [perl #33752]
199 {
200   my $code = <<"EOCODE";
201 {
202     our \$\x{1e1f}\x{14d}\x{14d};
203 }
204 EOCODE
205   my $deparsed
206    = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
207   s/$ \n//x for $deparsed, $code;
208   is $deparsed, $code, 'our $funny_Unicode_chars';
209 }
210
211 # [perl #62500]
212 $a =
213   `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
214 $a =~ s/-e syntax OK\n//g;
215 is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
216 sub BEGIN {
217     *CORE::GLOBAL::require = sub {
218         1;
219     }
220     ;
221 }
222 EOCODF
223
224 # [perl #91384]
225 $a =
226   `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`;
227 like($a, qr/-e syntax OK/,
228     "Deparse does not hang when traversing stash circularities");
229
230 # [perl #93990]
231 @] = ();
232 is($deparse->coderef2text(sub{ print "@{]}" }),
233 q<{
234     print "@{]}";
235 }>, 'curly around to interpolate "@{]}"');
236 is($deparse->coderef2text(sub{ print "@{-}" }),
237 q<{
238     print "@-";
239 }>, 'no need to curly around to interpolate "@-"');
240
241 # Strict hints in %^H are mercilessly suppressed
242 $a =
243   `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`;
244 unlike($a, qr/BEGIN/,
245     "Deparse does not emit strict hh hints");
246
247 # ambient_pragmas should not mess with strict settings.
248 SKIP: {
249     skip "requires 5.11", 1 unless $] >= 5.011;
250     eval q`
251         BEGIN {
252             # Clear out all hints
253             %^H = ();
254             $^H = 0;
255             new B::Deparse -> ambient_pragmas(strict => 'all');
256         }
257         use 5.011;  # should enable strict
258         ok !eval '$do_noT_create_a_variable_with_this_name = 1',
259           'ambient_pragmas do not mess with compiling scope';
260    `;
261 }
262
263 # multiple statements on format lines
264 $a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`;
265 $a =~ s/-e syntax OK\n//g;
266 is($a, <<'EOCODH', 'multiple statements on format lines');
267 format STDOUT =
268 @
269 x(); z()
270 .
271 EOCODH
272
273 # literal big chars under 'use utf8'
274 is($deparse->coderef2text(sub{ use utf8; /€/; }),
275 '{
276     /\x{20ac}/;
277 }',
278 "qr/euro/");
279
280
281 done_testing($tests);
282
283 __DATA__
284 # TODO [perl #120950] This succeeds when run a 2nd time
285 # y/uni/code/
286 tr/\x{345}/\x{370}/;
287 ####
288 # y/uni/code/  [perl #120950] This 2nd instance succeeds
289 tr/\x{345}/\x{370}/;
290 ####
291 # A constant
292 1;
293 ####
294 # Constants in a block
295 {
296     no warnings;
297     '???';
298     2;
299 }
300 ####
301 # Lexical and simple arithmetic
302 my $test;
303 ++$test and $test /= 2;
304 >>>>
305 my $test;
306 $test /= 2 if ++$test;
307 ####
308 # list x
309 -((1, 2) x 2);
310 ####
311 # lvalue sub
312 {
313     my $test = sub : lvalue {
314         my $x;
315     }
316     ;
317 }
318 ####
319 # method
320 {
321     my $test = sub : method {
322         my $x;
323     }
324     ;
325 }
326 ####
327 # block with continue
328 {
329     234;
330 }
331 continue {
332     123;
333 }
334 ####
335 # lexical and package scalars
336 my $x;
337 print $main::x;
338 ####
339 # lexical and package arrays
340 my @x;
341 print $main::x[1];
342 ####
343 # lexical and package hashes
344 my %x;
345 $x{warn()};
346 ####
347 # our (LIST)
348 our($foo, $bar, $baz);
349 ####
350 # CONTEXT { package Dog } use feature "state";
351 # variables with declared classes
352 my Dog $spot;
353 our Dog $spotty;
354 state Dog $spotted;
355 my Dog @spot;
356 our Dog @spotty;
357 state Dog @spotted;
358 my Dog %spot;
359 our Dog %spotty;
360 state Dog %spotted;
361 my Dog ($foo, @bar, %baz);
362 our Dog ($phoo, @barr, %bazz);
363 state Dog ($fough, @barre, %bazze);
364 ####
365 # <>
366 my $foo;
367 $_ .= <ARGV> . <$foo>;
368 ####
369 # \x{}
370 my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
371 ####
372 # s///e
373 s/x/'y';/e;
374 s/x/$a;/e;
375 s/x/complex_expression();/e;
376 ####
377 # block
378 { my $x; }
379 ####
380 # while 1
381 while (1) { my $k; }
382 ####
383 # trailing for
384 my ($x,@a);
385 $x=1 for @a;
386 >>>>
387 my($x, @a);
388 $x = 1 foreach (@a);
389 ####
390 # 2 arguments in a 3 argument for
391 for (my $i = 0; $i < 2;) {
392     my $z = 1;
393 }
394 ####
395 # 3 argument for
396 for (my $i = 0; $i < 2; ++$i) {
397     my $z = 1;
398 }
399 ####
400 # 3 argument for again
401 for (my $i = 0; $i < 2; ++$i) {
402     my $z = 1;
403 }
404 ####
405 # while/continue
406 my $i;
407 while ($i) { my $z = 1; } continue { $i = 99; }
408 ####
409 # foreach with my
410 foreach my $i (1, 2) {
411     my $z = 1;
412 }
413 ####
414 # OPTIONS -p
415 # foreach with my under -p
416 foreach my $i (1) {
417     die;
418 }
419 ####
420 # foreach
421 my $i;
422 foreach $i (1, 2) {
423     my $z = 1;
424 }
425 ####
426 # foreach, 2 mys
427 my $i;
428 foreach my $i (1, 2) {
429     my $z = 1;
430 }
431 ####
432 # foreach
433 foreach my $i (1, 2) {
434     my $z = 1;
435 }
436 ####
437 # foreach with our
438 foreach our $i (1, 2) {
439     my $z = 1;
440 }
441 ####
442 # foreach with my and our
443 my $i;
444 foreach our $i (1, 2) {
445     my $z = 1;
446 }
447 ####
448 # reverse sort
449 my @x;
450 print reverse sort(@x);
451 ####
452 # sort with cmp
453 my @x;
454 print((sort {$b cmp $a} @x));
455 ####
456 # reverse sort with block
457 my @x;
458 print((reverse sort {$b <=> $a} @x));
459 ####
460 # foreach reverse
461 our @a;
462 print $_ foreach (reverse @a);
463 ####
464 # foreach reverse (not inplace)
465 our @a;
466 print $_ foreach (reverse 1, 2..5);
467 ####
468 # bug #38684
469 our @ary;
470 @ary = split(' ', 'foo', 0);
471 ####
472 # bug #40055
473 do { () }; 
474 ####
475 # bug #40055
476 do { my $x = 1; $x }; 
477 ####
478 # <20061012113037.GJ25805@c4.convolution.nl>
479 my $f = sub {
480     +{[]};
481 } ;
482 ####
483 # bug #43010
484 '!@$%'->();
485 ####
486 # bug #43010
487 ::();
488 ####
489 # bug #43010
490 '::::'->();
491 ####
492 # bug #43010
493 &::::;
494 ####
495 # [perl #77172]
496 package rt77172;
497 sub foo {} foo & & & foo;
498 >>>>
499 package rt77172;
500 foo(&{&} & foo());
501 ####
502 # variables as method names
503 my $bar;
504 'Foo'->$bar('orz');
505 'Foo'->$bar('orz') = 'a stranger stranger than before';
506 ####
507 # constants as method names
508 'Foo'->bar('orz');
509 ####
510 # constants as method names without ()
511 'Foo'->bar;
512 ####
513 # [perl #47359] "indirect" method call notation
514 our @bar;
515 foo{@bar}+1,->foo;
516 (foo{@bar}+1),foo();
517 foo{@bar}1 xor foo();
518 >>>>
519 our @bar;
520 (foo { @bar } 1)->foo;
521 (foo { @bar } 1), foo();
522 foo { @bar } 1 xor foo();
523 ####
524 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
525 # CONTEXT use feature ':5.10';
526 # say
527 say 'foo';
528 ####
529 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
530 # CONTEXT use 5.10.0;
531 # say in the context of use 5.10.0
532 say 'foo';
533 ####
534 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
535 # say with use 5.10.0
536 use 5.10.0;
537 say 'foo';
538 >>>>
539 no feature;
540 use feature ':5.10';
541 say 'foo';
542 ####
543 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
544 # say with use feature ':5.10';
545 use feature ':5.10';
546 say 'foo';
547 >>>>
548 use feature 'say', 'state', 'switch';
549 say 'foo';
550 ####
551 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
552 # CONTEXT use feature ':5.10';
553 # say with use 5.10.0 in the context of use feature
554 use 5.10.0;
555 say 'foo';
556 >>>>
557 no feature;
558 use feature ':5.10';
559 say 'foo';
560 ####
561 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
562 # CONTEXT use 5.10.0;
563 # say with use feature ':5.10' in the context of use 5.10.0
564 use feature ':5.10';
565 say 'foo';
566 >>>>
567 say 'foo';
568 ####
569 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
570 # CONTEXT use feature ':5.15';
571 # __SUB__
572 __SUB__;
573 ####
574 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
575 # CONTEXT use 5.15.0;
576 # __SUB__ in the context of use 5.15.0
577 __SUB__;
578 ####
579 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
580 # __SUB__ with use 5.15.0
581 use 5.15.0;
582 __SUB__;
583 >>>>
584 no feature;
585 use feature ':5.16';
586 __SUB__;
587 ####
588 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
589 # __SUB__ with use feature ':5.15';
590 use feature ':5.15';
591 __SUB__;
592 >>>>
593 use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval';
594 __SUB__;
595 ####
596 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
597 # CONTEXT use feature ':5.15';
598 # __SUB__ with use 5.15.0 in the context of use feature
599 use 5.15.0;
600 __SUB__;
601 >>>>
602 no feature;
603 use feature ':5.16';
604 __SUB__;
605 ####
606 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
607 # CONTEXT use 5.15.0;
608 # __SUB__ with use feature ':5.15' in the context of use 5.15.0
609 use feature ':5.15';
610 __SUB__;
611 >>>>
612 __SUB__;
613 ####
614 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
615 # CONTEXT use feature ':5.10';
616 # state vars
617 state $x = 42;
618 ####
619 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
620 # CONTEXT use feature ':5.10';
621 # state var assignment
622 {
623     my $y = (state $x = 42);
624 }
625 ####
626 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
627 # CONTEXT use feature ':5.10';
628 # state vars in anonymous subroutines
629 $a = sub {
630     state $x;
631     return $x++;
632 }
633 ;
634 ####
635 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
636 # each @array;
637 each @ARGV;
638 each @$a;
639 ####
640 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
641 # keys @array; values @array
642 keys @$a if keys @ARGV;
643 values @ARGV if values @$a;
644 ####
645 # Anonymous arrays and hashes, and references to them
646 my $a = {};
647 my $b = \{};
648 my $c = [];
649 my $d = \[];
650 ####
651 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
652 # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
653 # implicit smartmatch in given/when
654 given ('foo') {
655     when ('bar') { continue; }
656     when ($_ ~~ 'quux') { continue; }
657     default { 0; }
658 }
659 ####
660 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
661 if ($a) { x(); }
662 elsif ($b) { x(); }
663 elsif ($a and $b) { x(); }
664 elsif ($a or $b) { x(); }
665 else { x(); }
666 ####
667 # interpolation in regexps
668 my($y, $t);
669 /x${y}z$t/;
670 ####
671 # TODO new undocumented cpan-bug #33708
672 # cpan-bug #33708
673 %{$_ || {}}
674 ####
675 # TODO hash constants not yet fixed
676 # cpan-bug #33708
677 use constant H => { "#" => 1 }; H->{"#"}
678 ####
679 # TODO optimized away 0 not yet fixed
680 # cpan-bug #33708
681 foreach my $i (@_) { 0 }
682 ####
683 # tests with not, not optimized
684 my $c;
685 x() unless $a;
686 x() if not $a and $b;
687 x() if $a and not $b;
688 x() unless not $a and $b;
689 x() unless $a and not $b;
690 x() if not $a or $b;
691 x() if $a or not $b;
692 x() unless not $a or $b;
693 x() unless $a or not $b;
694 x() if $a and not $b and $c;
695 x() if not $a and $b and not $c;
696 x() unless $a and not $b and $c;
697 x() unless not $a and $b and not $c;
698 x() if $a or not $b or $c;
699 x() if not $a or $b or not $c;
700 x() unless $a or not $b or $c;
701 x() unless not $a or $b or not $c;
702 ####
703 # tests with not, optimized
704 my $c;
705 x() if not $a;
706 x() unless not $a;
707 x() if not $a and not $b;
708 x() unless not $a and not $b;
709 x() if not $a or not $b;
710 x() unless not $a or not $b;
711 x() if not $a and not $b and $c;
712 x() unless not $a and not $b and $c;
713 x() if not $a or not $b or $c;
714 x() unless not $a or not $b or $c;
715 x() if not $a and not $b and not $c;
716 x() unless not $a and not $b and not $c;
717 x() if not $a or not $b or not $c;
718 x() unless not $a or not $b or not $c;
719 x() unless not $a or not $b or not $c;
720 >>>>
721 my $c;
722 x() unless $a;
723 x() if $a;
724 x() unless $a or $b;
725 x() if $a or $b;
726 x() unless $a and $b;
727 x() if $a and $b;
728 x() if not $a || $b and $c;
729 x() unless not $a || $b and $c;
730 x() if not $a && $b or $c;
731 x() unless not $a && $b or $c;
732 x() unless $a or $b or $c;
733 x() if $a or $b or $c;
734 x() unless $a and $b and $c;
735 x() if $a and $b and $c;
736 x() unless not $a && $b && $c;
737 ####
738 # tests that should be constant folded
739 x() if 1;
740 x() if GLIPP;
741 x() if !GLIPP;
742 x() if GLIPP && GLIPP;
743 x() if !GLIPP || GLIPP;
744 x() if do { GLIPP };
745 x() if do { no warnings 'void'; 5; GLIPP };
746 x() if do { !GLIPP };
747 if (GLIPP) { x() } else { z() }
748 if (!GLIPP) { x() } else { z() }
749 if (GLIPP) { x() } elsif (GLIPP) { z() }
750 if (!GLIPP) { x() } elsif (GLIPP) { z() }
751 if (GLIPP) { x() } elsif (!GLIPP) { z() }
752 if (!GLIPP) { x() } elsif (!GLIPP) { z() }
753 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
754 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
755 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
756 >>>>
757 x();
758 x();
759 '???';
760 x();
761 x();
762 x();
763 x();
764 do {
765     '???'
766 };
767 do {
768     x()
769 };
770 do {
771     z()
772 };
773 do {
774     x()
775 };
776 do {
777     z()
778 };
779 do {
780     x()
781 };
782 '???';
783 do {
784     t()
785 };
786 '???';
787 !1;
788 ####
789 # TODO constant deparsing has been backed out for 5.12
790 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
791 # tests that shouldn't be constant folded
792 # It might be fundamentally impossible to make this work on ithreads, in which
793 # case the TODO should become a SKIP
794 x() if $a;
795 if ($a == 1) { x() } elsif ($b == 2) { z() }
796 if (do { foo(); GLIPP }) { x() }
797 if (do { $a++; GLIPP }) { x() }
798 >>>>
799 x() if $a;
800 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
801 if (do { foo(); GLIPP }) { x(); }
802 if (do { ++$a; GLIPP }) { x(); }
803 ####
804 # TODO constant deparsing has been backed out for 5.12
805 # tests for deparsing constants
806 warn PI;
807 ####
808 # TODO constant deparsing has been backed out for 5.12
809 # tests for deparsing imported constants
810 warn O_TRUNC;
811 ####
812 # TODO constant deparsing has been backed out for 5.12
813 # tests for deparsing re-exported constants
814 warn O_CREAT;
815 ####
816 # TODO constant deparsing has been backed out for 5.12
817 # tests for deparsing imported constants that got deleted from the original namespace
818 warn O_APPEND;
819 ####
820 # TODO constant deparsing has been backed out for 5.12
821 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
822 # tests for deparsing constants which got turned into full typeglobs
823 # It might be fundamentally impossible to make this work on ithreads, in which
824 # case the TODO should become a SKIP
825 warn O_EXCL;
826 eval '@Fcntl::O_EXCL = qw/affe tiger/;';
827 warn O_EXCL;
828 ####
829 # TODO constant deparsing has been backed out for 5.12
830 # tests for deparsing of blessed constant with overloaded numification
831 warn OVERLOADED_NUMIFICATION;
832 ####
833 # strict
834 no strict;
835 print $x;
836 use strict 'vars';
837 print $main::x;
838 use strict 'subs';
839 print $main::x;
840 use strict 'refs';
841 print $main::x;
842 no strict 'vars';
843 $x;
844 ####
845 # TODO Subsets of warnings could be encoded textually, rather than as bitflips.
846 # subsets of warnings
847 no warnings 'deprecated';
848 my $x;
849 ####
850 # TODO Better test for CPAN #33708 - the deparsed code has different behaviour
851 # CPAN #33708
852 use strict;
853 no warnings;
854
855 foreach (0..3) {
856     my $x = 2;
857     {
858         my $x if 0;
859         print ++$x, "\n";
860     }
861 }
862 ####
863 # no attribute list
864 my $pi = 4;
865 ####
866 # SKIP ?$] > 5.013006 && ":= is now a syntax error"
867 # := treated as an empty attribute list
868 no warnings;
869 my $pi := 4;
870 >>>>
871 no warnings;
872 my $pi = 4;
873 ####
874 # : = empty attribute list
875 my $pi : = 4;
876 >>>>
877 my $pi = 4;
878 ####
879 # in place sort
880 our @a;
881 my @b;
882 @a = sort @a;
883 @b = sort @b;
884 ();
885 ####
886 # in place reverse
887 our @a;
888 my @b;
889 @a = reverse @a;
890 @b = reverse @b;
891 ();
892 ####
893 # #71870 Use of uninitialized value in bitwise and B::Deparse
894 my($r, $s, @a);
895 @a = split(/foo/, $s, 0);
896 $r = qr/foo/;
897 @a = split(/$r/, $s, 0);
898 ();
899 ####
900 # package declaration before label
901 {
902     package Foo;
903     label: print 123;
904 }
905 ####
906 # shift optimisation
907 shift;
908 >>>>
909 shift();
910 ####
911 # shift optimisation
912 shift @_;
913 ####
914 # shift optimisation
915 pop;
916 >>>>
917 pop();
918 ####
919 # shift optimisation
920 pop @_;
921 ####
922 #[perl #20444]
923 "foo" =~ (1 ? /foo/ : /bar/);
924 "foo" =~ (1 ? y/foo// : /bar/);
925 "foo" =~ (1 ? y/foo//r : /bar/);
926 "foo" =~ (1 ? s/foo// : /bar/);
927 >>>>
928 'foo' =~ ($_ =~ /foo/);
929 'foo' =~ ($_ =~ tr/fo//);
930 'foo' =~ ($_ =~ tr/fo//r);
931 'foo' =~ ($_ =~ s/foo//);
932 ####
933 # The fix for [perl #20444] broke this.
934 'foo' =~ do { () };
935 ####
936 # [perl #81424] match against aelemfast_lex
937 my @s;
938 print /$s[1]/;
939 ####
940 # /$#a/
941 print /$#main::a/;
942 ####
943 # [perl #91318] /regexp/applaud
944 print /a/a, s/b/c/a;
945 print /a/aa, s/b/c/aa;
946 print /a/p, s/b/c/p;
947 print /a/l, s/b/c/l;
948 print /a/u, s/b/c/u;
949 {
950     use feature "unicode_strings";
951     print /a/d, s/b/c/d;
952 }
953 {
954     use re "/u";
955     print /a/d, s/b/c/d;
956 }
957 {
958     use 5.012;
959     print /a/d, s/b/c/d;
960 }
961 >>>>
962 print /a/a, s/b/c/a;
963 print /a/aa, s/b/c/aa;
964 print /a/p, s/b/c/p;
965 print /a/l, s/b/c/l;
966 print /a/u, s/b/c/u;
967 {
968     use feature 'unicode_strings';
969     print /a/d, s/b/c/d;
970 }
971 {
972     BEGIN { $^H{'reflags'}         = '0';
973             $^H{'reflags_charset'} = '2'; }
974     print /a/d, s/b/c/d;
975 }
976 {
977     no feature;
978     use feature ':5.12';
979     print /a/d, s/b/c/d;
980 }
981 ####
982 # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
983 s/foo/\(3);/eg;
984 ####
985 # Test @threadsv_names under 5005threads
986 foreach $' (1, 2) {
987     sleep $';
988 }
989 ####
990 # y///r
991 tr/a/b/r;
992 ####
993 # [perl #90898]
994 <a,>;
995 ####
996 # [perl #91008]
997 # CONTEXT no warnings 'experimental::autoderef';
998 each $@;
999 keys $~;
1000 values $!;
1001 ####
1002 # readpipe with complex expression
1003 readpipe $a + $b;
1004 ####
1005 # aelemfast
1006 $b::a[0] = 1;
1007 ####
1008 # aelemfast for a lexical
1009 my @a;
1010 $a[0] = 1;
1011 ####
1012 # feature features without feature
1013 # CONTEXT no warnings 'experimental::smartmatch';
1014 CORE::state $x;
1015 CORE::say $x;
1016 CORE::given ($x) {
1017     CORE::when (3) {
1018         continue;
1019     }
1020     CORE::default {
1021         CORE::break;
1022     }
1023 }
1024 CORE::evalbytes '';
1025 () = CORE::__SUB__;
1026 () = CORE::fc $x;
1027 ####
1028 # feature features when feature has been disabled by use VERSION
1029 # CONTEXT no warnings 'experimental::smartmatch';
1030 use feature (sprintf(":%vd", $^V));
1031 use 1;
1032 CORE::state $x;
1033 CORE::say $x;
1034 CORE::given ($x) {
1035     CORE::when (3) {
1036         continue;
1037     }
1038     CORE::default {
1039         CORE::break;
1040     }
1041 }
1042 CORE::evalbytes '';
1043 () = CORE::__SUB__;
1044 >>>>
1045 CORE::state $x;
1046 CORE::say $x;
1047 CORE::given ($x) {
1048     CORE::when (3) {
1049         continue;
1050     }
1051     CORE::default {
1052         CORE::break;
1053     }
1054 }
1055 CORE::evalbytes '';
1056 () = CORE::__SUB__;
1057 ####
1058 # (the above test with CONTEXT, and the output is equivalent but different)
1059 # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
1060 # feature features when feature has been disabled by use VERSION
1061 use feature (sprintf(":%vd", $^V));
1062 use 1;
1063 CORE::state $x;
1064 CORE::say $x;
1065 CORE::given ($x) {
1066     CORE::when (3) {
1067         continue;
1068     }
1069     CORE::default {
1070         CORE::break;
1071     }
1072 }
1073 CORE::evalbytes '';
1074 () = CORE::__SUB__;
1075 >>>>
1076 no feature;
1077 use feature ':default';
1078 CORE::state $x;
1079 CORE::say $x;
1080 CORE::given ($x) {
1081     CORE::when (3) {
1082         continue;
1083     }
1084     CORE::default {
1085         CORE::break;
1086     }
1087 }
1088 CORE::evalbytes '';
1089 () = CORE::__SUB__;
1090 ####
1091 # Feature hints
1092 use feature 'current_sub', 'evalbytes';
1093 print;
1094 use 1;
1095 print;
1096 use 5.014;
1097 print;
1098 no feature 'unicode_strings';
1099 print;
1100 >>>>
1101 use feature 'current_sub', 'evalbytes';
1102 print $_;
1103 no feature;
1104 use feature ':default';
1105 print $_;
1106 no feature;
1107 use feature ':5.12';
1108 print $_;
1109 no feature 'unicode_strings';
1110 print $_;
1111 ####
1112 # $#- $#+ $#{%} etc.
1113 my @x;
1114 @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
1115 @x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
1116 @x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
1117 @x = ($#{;}, $#{:});
1118 ####
1119 # ${#} interpolated
1120 # It's a known TODO that warnings are deparsed as bits, not textually.
1121 no warnings;
1122 () = "${#}a";
1123 ####
1124 # [perl #86060] $( $| $) in regexps need braces
1125 /${(}/;
1126 /${|}/;
1127 /${)}/;
1128 /${(}${|}${)}/;
1129 ####
1130 # ()[...]
1131 my(@a) = ()[()];
1132 ####
1133 # sort(foo(bar))
1134 # sort(foo(bar)) is interpreted as sort &foo(bar)
1135 # sort foo(bar) is interpreted as sort foo bar
1136 # parentheses are not optional in this case
1137 print sort(foo('bar'));
1138 >>>>
1139 print sort(foo('bar'));
1140 ####
1141 # substr assignment
1142 substr(my $a, 0, 0) = (foo(), bar());
1143 $a++;
1144 ####
1145 # This following line works around an unfixed bug that we are not trying to 
1146 # test for here:
1147 # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
1148 # hint hash
1149 BEGIN { $^H{'foo'} = undef; }
1150 {
1151  BEGIN { $^H{'bar'} = undef; }
1152  {
1153   BEGIN { $^H{'baz'} = undef; }
1154   {
1155    print $_;
1156   }
1157   print $_;
1158  }
1159  print $_;
1160 }
1161 BEGIN { $^H{q[']} = '('; }
1162 print $_;
1163 ####
1164 # This following line works around an unfixed bug that we are not trying to 
1165 # test for here:
1166 # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
1167 # hint hash changes that serialise the same way with sort %hh
1168 BEGIN { $^H{'a'} = 'b'; }
1169 {
1170  BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
1171  print $_;
1172 }
1173 print $_;
1174 ####
1175 # [perl #47361] do({}) and do +{} (variants of do-file)
1176 do({});
1177 do +{};
1178 sub foo::do {}
1179 package foo;
1180 CORE::do({});
1181 CORE::do +{};
1182 >>>>
1183 do({});
1184 do({});
1185 package foo;
1186 CORE::do({});
1187 CORE::do({});
1188 ####
1189 # [perl #77096] functions that do not follow the llafr
1190 () = (return 1) + time;
1191 () = (return ($1 + $2) * $3) + time;
1192 () = (return ($a xor $b)) + time;
1193 () = (do 'file') + time;
1194 () = (do ($1 + $2) * $3) + time;
1195 () = (do ($1 xor $2)) + time;
1196 () = (goto 1) + 3;
1197 () = (require 'foo') + 3;
1198 () = (require foo) + 3;
1199 () = (CORE::dump 1) + 3;
1200 () = (last 1) + 3;
1201 () = (next 1) + 3;
1202 () = (redo 1) + 3;
1203 () = (-R $_) + 3;
1204 () = (-W $_) + 3;
1205 () = (-X $_) + 3;
1206 () = (-r $_) + 3;
1207 () = (-w $_) + 3;
1208 () = (-x $_) + 3;
1209 ####
1210 # [perl #97476] not() *does* follow the llafr
1211 $_ = ($a xor not +($1 || 2) ** 2);
1212 ####
1213 # Precedence conundrums with argument-less function calls
1214 () = (eof) + 1;
1215 () = (return) + 1;
1216 () = (return, 1);
1217 () = warn;
1218 () = warn() + 1;
1219 () = setpgrp() + 1;
1220 ####
1221 # loopexes have assignment prec
1222 () = (CORE::dump a) | 'b';
1223 () = (goto a) | 'b';
1224 () = (last a) | 'b';
1225 () = (next a) | 'b';
1226 () = (redo a) | 'b';
1227 ####
1228 # [perl #63558] open local(*FH)
1229 open local *FH;
1230 pipe local *FH, local *FH;
1231 ####
1232 # [perl #91416] open "string"
1233 open 'open';
1234 open '####';
1235 open '^A';
1236 open "\ca";
1237 >>>>
1238 open *open;
1239 open '####';
1240 open '^A';
1241 open *^A;
1242 ####
1243 # "string"->[] ->{}
1244 no strict 'vars';
1245 () = 'open'->[0]; #aelemfast
1246 () = '####'->[0];
1247 () = '^A'->[0];
1248 () = "\ca"->[0];
1249 () = 'a::]b'->[0];
1250 () = 'open'->[$_]; #aelem
1251 () = '####'->[$_];
1252 () = '^A'->[$_];
1253 () = "\ca"->[$_];
1254 () = 'a::]b'->[$_];
1255 () = 'open'->{0}; #helem
1256 () = '####'->{0};
1257 () = '^A'->{0};
1258 () = "\ca"->{0};
1259 () = 'a::]b'->{0};
1260 >>>>
1261 no strict 'vars';
1262 () = $open[0];
1263 () = '####'->[0];
1264 () = '^A'->[0];
1265 () = $^A[0];
1266 () = 'a::]b'->[0];
1267 () = $open[$_];
1268 () = '####'->[$_];
1269 () = '^A'->[$_];
1270 () = $^A[$_];
1271 () = 'a::]b'->[$_];
1272 () = $open{'0'};
1273 () = '####'->{'0'};
1274 () = '^A'->{'0'};
1275 () = $^A{'0'};
1276 () = 'a::]b'->{'0'};
1277 ####
1278 # [perl #74740] -(f()) vs -f()
1279 $_ = -(f());
1280 ####
1281 # require <binop>
1282 require 'a' . $1;
1283 ####
1284 #[perl #30504] foreach-my postfix/prefix difference
1285 $_ = 'foo' foreach my ($foo1, $bar1, $baz1);
1286 foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' }
1287 foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' }
1288 >>>>
1289 $_ = 'foo' foreach (my($foo1, $bar1, $baz1));
1290 foreach $_ (my($foo2, $bar2, $baz2)) {
1291     $_ = 'foo';
1292 }
1293 foreach my $i (my($foo3, $bar3, $baz3)) {
1294     $i = 'foo';
1295 }
1296 ####
1297 #[perl #108224] foreach with continue block
1298 foreach (1 .. 3) { print } continue { print "\n" }
1299 foreach (1 .. 3) { } continue { }
1300 foreach my $i (1 .. 3) { print $i } continue { print "\n" }
1301 foreach my $i (1 .. 3) { } continue { }
1302 >>>>
1303 foreach $_ (1 .. 3) {
1304     print $_;
1305 }
1306 continue {
1307     print "\n";
1308 }
1309 foreach $_ (1 .. 3) {
1310     ();
1311 }
1312 continue {
1313     ();
1314 }
1315 foreach my $i (1 .. 3) {
1316     print $i;
1317 }
1318 continue {
1319     print "\n";
1320 }
1321 foreach my $i (1 .. 3) {
1322     ();
1323 }
1324 continue {
1325     ();
1326 }
1327 ####
1328 # file handles
1329 no strict;
1330 my $mfh;
1331 open F;
1332 open *F;
1333 open $fh;
1334 open $mfh;
1335 open 'a+b';
1336 select *F;
1337 select F;
1338 select $f;
1339 select $mfh;
1340 select 'a+b';
1341 ####
1342 # 'my' works with padrange op
1343 my($z, @z);
1344 my $m1;
1345 $m1 = 1;
1346 $z = $m1;
1347 my $m2 = 2;
1348 my($m3, $m4);
1349 ($m3, $m4) = (1, 2);
1350 @z = ($m3, $m4);
1351 my($m5, $m6) = (1, 2);
1352 my($m7, undef, $m8) = (1, 2, 3);
1353 @z = ($m7, undef, $m8);
1354 ($m7, undef, $m8) = (1, 2, 3);
1355 ####
1356 # 'our/local' works with padrange op
1357 no strict;
1358 our($z, @z);
1359 our $o1;
1360 local $o11;
1361 $o1 = 1;
1362 local $o1 = 1;
1363 $z = $o1;
1364 $z = local $o1;
1365 our $o2 = 2;
1366 our($o3, $o4);
1367 ($o3, $o4) = (1, 2);
1368 local($o3, $o4) = (1, 2);
1369 @z = ($o3, $o4);
1370 @z = local($o3, $o4);
1371 our($o5, $o6) = (1, 2);
1372 our($o7, undef, $o8) = (1, 2, 3);
1373 @z = ($o7, undef, $o8);
1374 @z = local($o7, undef, $o8);
1375 ($o7, undef, $o8) = (1, 2, 3);
1376 local($o7, undef, $o8) = (1, 2, 3);
1377 ####
1378 # 'state' works with padrange op
1379 no strict;
1380 use feature 'state';
1381 state($z, @z);
1382 state $s1;
1383 $s1 = 1;
1384 $z = $s1;
1385 state $s2 = 2;
1386 state($s3, $s4);
1387 ($s3, $s4) = (1, 2);
1388 @z = ($s3, $s4);
1389 # assignment of state lists isn't implemented yet
1390 #state($s5, $s6) = (1, 2);
1391 #state($s7, undef, $s8) = (1, 2, 3);
1392 #@z = ($s7, undef, $s8);
1393 ($s7, undef, $s8) = (1, 2, 3);
1394 ####
1395 # anon lists with padrange
1396 my($a, $b);
1397 my $c = [$a, $b];
1398 my $d = {$a, $b};
1399 ####
1400 # slices with padrange
1401 my($a, $b);
1402 my(@x, %y);
1403 @x = @x[$a, $b];
1404 @x = @y{$a, $b};
1405 ####
1406 # binops with padrange
1407 my($a, $b, $c);
1408 $c = $a cmp $b;
1409 $c = $a + $b;
1410 $a += $b;
1411 $c = $a - $b;
1412 $a -= $b;
1413 $c = my $a1 cmp $b;
1414 $c = my $a2 + $b;
1415 $a += my $b1;
1416 $c = my $a3 - $b;
1417 $a -= my $b2;
1418 ####
1419 # 'x' with padrange
1420 my($a, $b, $c, $d, @e);
1421 $c = $a x $b;
1422 $a x= $b;
1423 @e = ($a) x $d;
1424 @e = ($a, $b) x $d;
1425 @e = ($a, $b, $c) x $d;
1426 @e = ($a, 1) x $d;
1427 ####
1428 # @_ with padrange
1429 my($a, $b, $c) = @_;
1430 ####
1431 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1432 # TODO unimplemented in B::Deparse; RT #116553
1433 # lexical subroutine
1434 use feature 'lexical_subs';
1435 no warnings "experimental::lexical_subs";
1436 my sub f {}
1437 print f();
1438 ####
1439 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1440 # TODO unimplemented in B::Deparse; RT #116553
1441 # lexical "state" subroutine
1442 use feature 'state', 'lexical_subs';
1443 no warnings 'experimental::lexical_subs';
1444 state sub f {}
1445 print f();
1446 ####
1447 # Elements of %# should not be confused with $#{ array }
1448 () = ${#}{'foo'};
1449 ####
1450 # [perl #121050] Prototypes with whitespace
1451 sub _121050(\$ \$) { }
1452 _121050($a,$b);
1453 sub _121050empty( ) {}
1454 () = _121050empty() + 1;
1455 >>>>
1456 _121050 $a, $b;
1457 () = _121050empty + 1;
1458 ####
1459 # ensure aelemfast works in the range -128..127 and that there's no
1460 # funky edge cases
1461 my $x;
1462 no strict 'vars';
1463 $x = $a[-256] + $a[-255] + $a[-129] + $a[-128] + $a[-127] + $a[-1] + $a[0];
1464 $x = $a[1] + $a[126] + $a[127] + $a[128] + $a[255] + $a[256];
1465 my @b;
1466 $x = $b[-256] + $b[-255] + $b[-129] + $b[-128] + $b[-127] + $b[-1] + $b[0];
1467 $x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256];
1468 ####
1469 # 'm' must be preserved in m??
1470 m??;