This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Deparse pipe(local *FH, local *FH) correctly
[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 BEGIN {
15     # BEGIN block is actually a subroutine :-)
16     return unless $] > 5.009;
17     require feature;
18     feature->import(':5.10');
19 }
20 use Test::More;
21 use Config ();
22
23 use B::Deparse;
24 my $deparse = B::Deparse->new();
25 isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object');
26
27 # Tell B::Deparse about our ambient pragmas
28 { my ($hint_bits, $warning_bits, $hinthash);
29  BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); }
30  $deparse->ambient_pragmas (
31      hint_bits    => $hint_bits,
32      warning_bits => $warning_bits,
33      '%^H'        => $hinthash,
34  );
35 }
36
37 $/ = "\n####\n";
38 while (<DATA>) {
39     chomp;
40     # This code is pinched from the t/lib/common.pl for TODO.
41     # It's not clear how to avoid duplication
42     # Now tweaked a bit to do skip or todo
43     my %reason;
44     foreach my $what (qw(skip todo)) {
45         s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1;
46         # If the SKIP reason starts ? then it's taken as a code snippet to
47         # evaluate. This provides the flexibility to have conditional SKIPs
48         if ($reason{$what} && $reason{$what} =~ s/^\?//) {
49             my $temp = eval $reason{$what};
50             if ($@) {
51                 die "# In \U$what\E code reason:\n# $reason{$what}\n$@";
52             }
53             $reason{$what} = $temp;
54         }
55     }
56
57     s/^\s*#\s*(.*)$//mg;
58     my $desc = $1;
59     die "Missing name in test $_" unless defined $desc;
60
61     if ($reason{skip}) {
62         # Like this to avoid needing a label SKIP:
63        Test::More->builder->skip($reason{skip});
64         next;
65     }
66
67     my ($input, $expected);
68     if (/(.*)\n>>>>\n(.*)/s) {
69         ($input, $expected) = ($1, $2);
70     }
71     else {
72         ($input, $expected) = ($_, $_);
73     }
74
75     my $coderef = eval "sub {$input}";
76
77     if ($@) {
78         is($@, "", "compilation of $desc");
79     }
80     else {
81         my $deparsed = $deparse->coderef2text( $coderef );
82         my $regex = $expected;
83         $regex =~ s/(\S+)/\Q$1/g;
84         $regex =~ s/\s+/\\s+/g;
85         $regex = '^\{\s*' . $regex . '\s*\}$';
86
87         local $::TODO = $reason{todo};
88         like($deparsed, qr/$regex/, $desc);
89     }
90 }
91
92 use constant 'c', 'stuff';
93 is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
94    'the subroutine generated by use constant deparses');
95
96 my $a = 0;
97 is($deparse->coderef2text(sub{(-1) ** $a }), "{\n    (-1) ** \$a;\n}",
98    'anon sub capturing an external lexical');
99
100 use constant cr => ['hello'];
101 my $string = "sub " . $deparse->coderef2text(\&cr);
102 my $val = (eval $string)->() or diag $string;
103 is(ref($val), 'ARRAY', 'constant array references deparse');
104 is($val->[0], 'hello', 'and return the correct value');
105
106 my $path = join " ", map { qq["-I$_"] } @INC;
107
108 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
109 $a =~ s/-e syntax OK\n//g;
110 $a =~ s/.*possible typo.*\n//;     # Remove warning line
111 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
112 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
113 $b = <<'EOF';
114 BEGIN { $^I = ".bak"; }
115 BEGIN { $^W = 1; }
116 BEGIN { $/ = "\n"; $\ = "\n"; }
117 LINE: while (defined($_ = <ARGV>)) {
118     chomp $_;
119     our(@F) = split(' ', $_, 0);
120     '???';
121 }
122 EOF
123 is($a, $b,
124    'command line flags deparse as BEGIN blocks setting control variables');
125
126 $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
127 $a =~ s/-e syntax OK\n//g;
128 is($a, "use constant ('PI', 4);\n",
129    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
130
131 #Re: perlbug #35857, patch #24505
132 #handle warnings::register-ed packages properly.
133 package B::Deparse::Wrapper;
134 use strict;
135 use warnings;
136 use warnings::register;
137 sub getcode {
138    my $deparser = B::Deparse->new();
139    return $deparser->coderef2text(shift);
140 }
141
142 package Moo;
143 use overload '0+' => sub { 42 };
144
145 package main;
146 use strict;
147 use warnings;
148 use constant GLIPP => 'glipp';
149 use constant PI => 4;
150 use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
151 use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
152 BEGIN { delete $::Fcntl::{O_APPEND}; }
153 use POSIX qw/O_CREAT/;
154 sub test {
155    my $val = shift;
156    my $res = B::Deparse::Wrapper::getcode($val);
157    like($res, qr/use warnings/,
158         '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
159 }
160 my ($q,$p);
161 my $x=sub { ++$q,++$p };
162 test($x);
163 eval <<EOFCODE and test($x);
164    package bar;
165    use strict;
166    use warnings;
167    use warnings::register;
168    package main;
169    1
170 EOFCODE
171
172 # Exotic sub declarations
173 $a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
174 $a =~ s/-e syntax OK\n//g;
175 is($a, <<'EOCODG', "sub :::: and sub ::::::");
176 sub :::: {
177     
178 }
179 sub :::::: {
180     
181 }
182 EOCODG
183
184 # [perl #33752]
185 {
186   my $code = <<"EOCODE";
187 {
188     our \$\x{1e1f}\x{14d}\x{14d};
189 }
190 EOCODE
191   my $deparsed
192    = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
193   s/$ \n//x for $deparsed, $code;
194   is $deparsed, $code, 'our $funny_Unicode_chars';
195 }
196
197 # [perl #62500]
198 $a =
199   `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
200 $a =~ s/-e syntax OK\n//g;
201 is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
202 sub BEGIN {
203     *CORE::GLOBAL::require = sub {
204         1;
205     }
206     ;
207 }
208 EOCODF
209
210 # [perl #93990]
211 @* = ();
212 is($deparse->coderef2text(sub{ print "@{*}" }),
213 q<{
214     print "@{*}";
215 }>, 'curly around to interpolate "@{*}"');
216 is($deparse->coderef2text(sub{ print "@{-}" }),
217 q<{
218     print "@-";
219 }>, 'no need to curly around to interpolate "@-"');
220
221 done_testing();
222
223 __DATA__
224 # A constant
225 1;
226 ####
227 # Constants in a block
228 {
229     no warnings;
230     '???';
231     2;
232 }
233 ####
234 # Lexical and simple arithmetic
235 my $test;
236 ++$test and $test /= 2;
237 >>>>
238 my $test;
239 $test /= 2 if ++$test;
240 ####
241 # list x
242 -((1, 2) x 2);
243 ####
244 # lvalue sub
245 {
246     my $test = sub : lvalue {
247         my $x;
248     }
249     ;
250 }
251 ####
252 # method
253 {
254     my $test = sub : method {
255         my $x;
256     }
257     ;
258 }
259 ####
260 # block with continue
261 {
262     234;
263 }
264 continue {
265     123;
266 }
267 ####
268 # lexical and package scalars
269 my $x;
270 print $main::x;
271 ####
272 # lexical and package arrays
273 my @x;
274 print $main::x[1];
275 ####
276 # lexical and package hashes
277 my %x;
278 $x{warn()};
279 ####
280 # <>
281 my $foo;
282 $_ .= <ARGV> . <$foo>;
283 ####
284 # \x{}
285 my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
286 ####
287 # s///e
288 s/x/'y';/e;
289 ####
290 # block
291 { my $x; }
292 ####
293 # while 1
294 while (1) { my $k; }
295 ####
296 # trailing for
297 my ($x,@a);
298 $x=1 for @a;
299 >>>>
300 my($x, @a);
301 $x = 1 foreach (@a);
302 ####
303 # 2 arguments in a 3 argument for
304 for (my $i = 0; $i < 2;) {
305     my $z = 1;
306 }
307 ####
308 # 3 argument for
309 for (my $i = 0; $i < 2; ++$i) {
310     my $z = 1;
311 }
312 ####
313 # 3 argument for again
314 for (my $i = 0; $i < 2; ++$i) {
315     my $z = 1;
316 }
317 ####
318 # while/continue
319 my $i;
320 while ($i) { my $z = 1; } continue { $i = 99; }
321 ####
322 # foreach with my
323 foreach my $i (1, 2) {
324     my $z = 1;
325 }
326 ####
327 # foreach
328 my $i;
329 foreach $i (1, 2) {
330     my $z = 1;
331 }
332 ####
333 # foreach, 2 mys
334 my $i;
335 foreach my $i (1, 2) {
336     my $z = 1;
337 }
338 ####
339 # foreach
340 foreach my $i (1, 2) {
341     my $z = 1;
342 }
343 ####
344 # foreach with our
345 foreach our $i (1, 2) {
346     my $z = 1;
347 }
348 ####
349 # foreach with my and our
350 my $i;
351 foreach our $i (1, 2) {
352     my $z = 1;
353 }
354 ####
355 # reverse sort
356 my @x;
357 print reverse sort(@x);
358 ####
359 # sort with cmp
360 my @x;
361 print((sort {$b cmp $a} @x));
362 ####
363 # reverse sort with block
364 my @x;
365 print((reverse sort {$b <=> $a} @x));
366 ####
367 # foreach reverse
368 our @a;
369 print $_ foreach (reverse @a);
370 ####
371 # foreach reverse (not inplace)
372 our @a;
373 print $_ foreach (reverse 1, 2..5);
374 ####
375 # bug #38684
376 our @ary;
377 @ary = split(' ', 'foo', 0);
378 ####
379 # bug #40055
380 do { () }; 
381 ####
382 # bug #40055
383 do { my $x = 1; $x }; 
384 ####
385 # <20061012113037.GJ25805@c4.convolution.nl>
386 my $f = sub {
387     +{[]};
388 } ;
389 ####
390 # bug #43010
391 '!@$%'->();
392 ####
393 # bug #43010
394 ::();
395 ####
396 # bug #43010
397 '::::'->();
398 ####
399 # bug #43010
400 &::::;
401 ####
402 # variables as method names
403 my $bar;
404 'Foo'->$bar('orz');
405 'Foo'->$bar('orz') = 'a stranger stranger than before';
406 ####
407 # constants as method names
408 'Foo'->bar('orz');
409 ####
410 # constants as method names without ()
411 'Foo'->bar;
412 ####
413 # [perl #47359] "indirect" method call notation
414 our @bar;
415 foo{@bar}+1,->foo;
416 (foo{@bar}+1),foo();
417 foo{@bar}1 xor foo();
418 >>>>
419 our @bar;
420 (foo { @bar } 1)->foo;
421 (foo { @bar } 1), foo();
422 foo { @bar } 1 xor foo();
423 ####
424 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
425 # say
426 say 'foo';
427 ####
428 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
429 # state vars
430 state $x = 42;
431 ####
432 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
433 # state var assignment
434 {
435     my $y = (state $x = 42);
436 }
437 ####
438 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
439 # state vars in anonymous subroutines
440 $a = sub {
441     state $x;
442     return $x++;
443 }
444 ;
445 ####
446 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
447 # each @array;
448 each @ARGV;
449 each @$a;
450 ####
451 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
452 # keys @array; values @array
453 keys @$a if keys @ARGV;
454 values @ARGV if values @$a;
455 ####
456 # Anonymous arrays and hashes, and references to them
457 my $a = {};
458 my $b = \{};
459 my $c = [];
460 my $d = \[];
461 ####
462 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
463 # implicit smartmatch in given/when
464 given ('foo') {
465     when ('bar') { continue; }
466     when ($_ ~~ 'quux') { continue; }
467     default { 0; }
468 }
469 ####
470 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
471 if ($a) { x(); }
472 elsif ($b) { x(); }
473 elsif ($a and $b) { x(); }
474 elsif ($a or $b) { x(); }
475 else { x(); }
476 ####
477 # interpolation in regexps
478 my($y, $t);
479 /x${y}z$t/;
480 ####
481 # TODO new undocumented cpan-bug #33708
482 # cpan-bug #33708
483 %{$_ || {}}
484 ####
485 # TODO hash constants not yet fixed
486 # cpan-bug #33708
487 use constant H => { "#" => 1 }; H->{"#"}
488 ####
489 # TODO optimized away 0 not yet fixed
490 # cpan-bug #33708
491 foreach my $i (@_) { 0 }
492 ####
493 # tests with not, not optimized
494 my $c;
495 x() unless $a;
496 x() if not $a and $b;
497 x() if $a and not $b;
498 x() unless not $a and $b;
499 x() unless $a and not $b;
500 x() if not $a or $b;
501 x() if $a or not $b;
502 x() unless not $a or $b;
503 x() unless $a or not $b;
504 x() if $a and not $b and $c;
505 x() if not $a and $b and not $c;
506 x() unless $a and not $b and $c;
507 x() unless not $a and $b and not $c;
508 x() if $a or not $b or $c;
509 x() if not $a or $b or not $c;
510 x() unless $a or not $b or $c;
511 x() unless not $a or $b or not $c;
512 ####
513 # tests with not, optimized
514 my $c;
515 x() if not $a;
516 x() unless not $a;
517 x() if not $a and not $b;
518 x() unless not $a and not $b;
519 x() if not $a or not $b;
520 x() unless not $a or not $b;
521 x() if not $a and not $b and $c;
522 x() unless not $a and not $b and $c;
523 x() if not $a or not $b or $c;
524 x() unless not $a or not $b or $c;
525 x() if not $a and not $b and not $c;
526 x() unless not $a and not $b and not $c;
527 x() if not $a or not $b or not $c;
528 x() unless not $a or not $b or not $c;
529 x() unless not $a or not $b or not $c;
530 >>>>
531 my $c;
532 x() unless $a;
533 x() if $a;
534 x() unless $a or $b;
535 x() if $a or $b;
536 x() unless $a and $b;
537 x() if $a and $b;
538 x() if not $a || $b and $c;
539 x() unless not $a || $b and $c;
540 x() if not $a && $b or $c;
541 x() unless not $a && $b or $c;
542 x() unless $a or $b or $c;
543 x() if $a or $b or $c;
544 x() unless $a and $b and $c;
545 x() if $a and $b and $c;
546 x() unless not $a && $b && $c;
547 ####
548 # tests that should be constant folded
549 x() if 1;
550 x() if GLIPP;
551 x() if !GLIPP;
552 x() if GLIPP && GLIPP;
553 x() if !GLIPP || GLIPP;
554 x() if do { GLIPP };
555 x() if do { no warnings 'void'; 5; GLIPP };
556 x() if do { !GLIPP };
557 if (GLIPP) { x() } else { z() }
558 if (!GLIPP) { x() } else { z() }
559 if (GLIPP) { x() } elsif (GLIPP) { z() }
560 if (!GLIPP) { x() } elsif (GLIPP) { z() }
561 if (GLIPP) { x() } elsif (!GLIPP) { z() }
562 if (!GLIPP) { x() } elsif (!GLIPP) { z() }
563 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
564 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
565 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
566 >>>>
567 x();
568 x();
569 '???';
570 x();
571 x();
572 x();
573 x();
574 do {
575     '???'
576 };
577 do {
578     x()
579 };
580 do {
581     z()
582 };
583 do {
584     x()
585 };
586 do {
587     z()
588 };
589 do {
590     x()
591 };
592 '???';
593 do {
594     t()
595 };
596 '???';
597 !1;
598 ####
599 # TODO constant deparsing has been backed out for 5.12
600 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
601 # tests that shouldn't be constant folded
602 # It might be fundamentally impossible to make this work on ithreads, in which
603 # case the TODO should become a SKIP
604 x() if $a;
605 if ($a == 1) { x() } elsif ($b == 2) { z() }
606 if (do { foo(); GLIPP }) { x() }
607 if (do { $a++; GLIPP }) { x() }
608 >>>>
609 x() if $a;
610 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
611 if (do { foo(); GLIPP }) { x(); }
612 if (do { ++$a; GLIPP }) { x(); }
613 ####
614 # TODO constant deparsing has been backed out for 5.12
615 # tests for deparsing constants
616 warn PI;
617 ####
618 # TODO constant deparsing has been backed out for 5.12
619 # tests for deparsing imported constants
620 warn O_TRUNC;
621 ####
622 # TODO constant deparsing has been backed out for 5.12
623 # tests for deparsing re-exported constants
624 warn O_CREAT;
625 ####
626 # TODO constant deparsing has been backed out for 5.12
627 # tests for deparsing imported constants that got deleted from the original namespace
628 warn O_APPEND;
629 ####
630 # TODO constant deparsing has been backed out for 5.12
631 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
632 # tests for deparsing constants which got turned into full typeglobs
633 # It might be fundamentally impossible to make this work on ithreads, in which
634 # case the TODO should become a SKIP
635 warn O_EXCL;
636 eval '@Fcntl::O_EXCL = qw/affe tiger/;';
637 warn O_EXCL;
638 ####
639 # TODO constant deparsing has been backed out for 5.12
640 # tests for deparsing of blessed constant with overloaded numification
641 warn OVERLOADED_NUMIFICATION;
642 ####
643 # TODO Only strict 'refs' currently supported
644 # strict
645 no strict;
646 $x;
647 ####
648 # TODO Subsets of warnings could be encoded textually, rather than as bitflips.
649 # subsets of warnings
650 no warnings 'deprecated';
651 my $x;
652 ####
653 # TODO Better test for CPAN #33708 - the deparsed code has different behaviour
654 # CPAN #33708
655 use strict;
656 no warnings;
657
658 foreach (0..3) {
659     my $x = 2;
660     {
661         my $x if 0;
662         print ++$x, "\n";
663     }
664 }
665 ####
666 # no attribute list
667 my $pi = 4;
668 ####
669 # SKIP ?$] > 5.013006 && ":= is now a syntax error"
670 # := treated as an empty attribute list
671 no warnings;
672 my $pi := 4;
673 >>>>
674 no warnings;
675 my $pi = 4;
676 ####
677 # : = empty attribute list
678 my $pi : = 4;
679 >>>>
680 my $pi = 4;
681 ####
682 # in place sort
683 our @a;
684 my @b;
685 @a = sort @a;
686 @b = sort @b;
687 ();
688 ####
689 # in place reverse
690 our @a;
691 my @b;
692 @a = reverse @a;
693 @b = reverse @b;
694 ();
695 ####
696 # #71870 Use of uninitialized value in bitwise and B::Deparse
697 my($r, $s, @a);
698 @a = split(/foo/, $s, 0);
699 $r = qr/foo/;
700 @a = split(/$r/, $s, 0);
701 ();
702 ####
703 # package declaration before label
704 {
705     package Foo;
706     label: print 123;
707 }
708 ####
709 # shift optimisation
710 shift;
711 >>>>
712 shift();
713 ####
714 # shift optimisation
715 shift @_;
716 ####
717 # shift optimisation
718 pop;
719 >>>>
720 pop();
721 ####
722 # shift optimisation
723 pop @_;
724 ####
725 #[perl #20444]
726 "foo" =~ (1 ? /foo/ : /bar/);
727 "foo" =~ (1 ? y/foo// : /bar/);
728 "foo" =~ (1 ? y/foo//r : /bar/);
729 "foo" =~ (1 ? s/foo// : /bar/);
730 >>>>
731 'foo' =~ ($_ =~ /foo/);
732 'foo' =~ ($_ =~ tr/fo//);
733 'foo' =~ ($_ =~ tr/fo//r);
734 'foo' =~ ($_ =~ s/foo//);
735 ####
736 # The fix for [perl #20444] broke this.
737 'foo' =~ do { () };
738 ####
739 # Test @threadsv_names under 5005threads
740 foreach $' (1, 2) {
741     sleep $';
742 }
743 ####
744 # y///r
745 tr/a/b/r;
746 ####
747 # y/uni/code/
748 tr/\x{345}/\x{370}/;
749 ####
750 # [perl #90898]
751 <a,>;
752 ####
753 # [perl #91008]
754 each $@;
755 keys $~;
756 values $!;
757 ####
758 # readpipe with complex expression
759 readpipe $a + $b;
760 ####
761 # aelemfast
762 $b::a[0] = 1;
763 ####
764 # aelemfast for a lexical
765 my @a;
766 $a[0] = 1;
767 ####
768 # feature features without feature
769 BEGIN {
770     delete $^H{'feature_say'};
771     delete $^H{'feature_state'};
772     delete $^H{'feature_switch'};
773 }
774 CORE::state $x;
775 CORE::say $x;
776 CORE::given ($x) {
777     CORE::when (3) {
778         continue;
779     }
780     CORE::default {
781         CORE::break;
782     }
783 }
784 CORE::evalbytes '';
785 () = CORE::__SUB__;
786 ####
787 # $#- $#+ $#{%} etc.
788 my @x;
789 @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
790 @x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
791 @x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
792 @x = ($#{;}, $#{:});
793 ####
794 # ${#} interpolated (the first line magically disables the warning)
795 () = *#;
796 () = "${#}a";
797 ####
798 # ()[...]
799 my(@a) = ()[()];
800 ####
801 # sort(foo(bar))
802 # sort(foo(bar)) is interpreted as sort &foo(bar)
803 # sort foo(bar) is interpreted as sort foo bar
804 # parentheses are not optional in this case
805 print sort(foo('bar'));
806 >>>>
807 print sort(foo('bar'));
808 ####
809 # substr assignment
810 substr(my $a, 0, 0) = (foo(), bar());
811 $a++;
812 ####
813 # hint hash
814 BEGIN { $^H{'foo'} = undef; }
815 {
816  BEGIN { $^H{'bar'} = undef; }
817  {
818   BEGIN { $^H{'baz'} = undef; }
819   {
820    print $_;
821   }
822   print $_;
823  }
824  print $_;
825 }
826 BEGIN { $^H{q[']} = '('; }
827 print $_;
828 ####
829 # hint hash changes that serialise the same way with sort %hh
830 BEGIN { $^H{'a'} = 'b'; }
831 {
832  BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
833  print $_;
834 }
835 print $_;
836 ####
837 # [perl #47361] do({}) and do +{} (variants of do-file)
838 do({});
839 do +{};
840 sub foo::do {}
841 package foo;
842 CORE::do({});
843 CORE::do +{};
844 >>>>
845 do({});
846 do({});
847 package foo;
848 CORE::do({});
849 CORE::do({});
850 ####
851 # [perl #77096] functions that do not follow the llafr
852 () = (return 1) + time;
853 () = (return ($1 + $2) * $3) + time;
854 () = (return ($a xor $b)) + time;
855 () = (do 'file') + time;
856 () = (do ($1 + $2) * $3) + time;
857 () = (do ($1 xor $2)) + time;
858 () = (goto 1) + 3;
859 () = (require 'foo') + 3;
860 () = (require foo) + 3;
861 () = (CORE::dump 1) + 3;
862 () = (last 1) + 3;
863 () = (next 1) + 3;
864 () = (redo 1) + 3;
865 () = (-R $_) + 3;
866 () = (-W $_) + 3;
867 () = (-X $_) + 3;
868 () = (-r $_) + 3;
869 () = (-w $_) + 3;
870 () = (-x $_) + 3;
871 ####
872 # Precedence conundrums with argument-less function calls
873 () = (eof) + 1;
874 () = (return) + 1;
875 () = (return, 1);
876 () = setpgrp() + 1;
877 ####
878 # [perl #63558] open local(*FH)
879 open local *FH;
880 pipe local *FH, local *FH;