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