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