This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
B::Deparse: loopexes have assignment prec
[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
d8cf01c3 16my $tests = 17; # 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
d8cf01c3 246done_testing($tests);
507a68aa 247
ad46c0be 248__DATA__
507a68aa 249# A constant
ad46c0be
RH
2501;
251####
507a68aa 252# Constants in a block
ad46c0be
RH
253{
254 no warnings;
255 '???';
256 2;
257}
258####
507a68aa 259# Lexical and simple arithmetic
ad46c0be
RH
260my $test;
261++$test and $test /= 2;
262>>>>
263my $test;
264$test /= 2 if ++$test;
265####
507a68aa 266# list x
ad46c0be
RH
267-((1, 2) x 2);
268####
507a68aa 269# lvalue sub
ad46c0be
RH
270{
271 my $test = sub : lvalue {
272 my $x;
273 }
274 ;
275}
276####
507a68aa 277# method
ad46c0be
RH
278{
279 my $test = sub : method {
280 my $x;
281 }
282 ;
283}
284####
507a68aa 285# block with continue
87a42246 286{
ad46c0be 287 234;
f99a63a2 288}
ad46c0be
RH
289continue {
290 123;
87a42246 291}
ce4e655d 292####
507a68aa 293# lexical and package scalars
ce4e655d
RH
294my $x;
295print $main::x;
296####
507a68aa 297# lexical and package arrays
ce4e655d
RH
298my @x;
299print $main::x[1];
14a55f98 300####
507a68aa 301# lexical and package hashes
14a55f98
RH
302my %x;
303$x{warn()};
ad8caead 304####
507a68aa 305# <>
ad8caead
RGS
306my $foo;
307$_ .= <ARGV> . <$foo>;
cef22867 308####
507a68aa 309# \x{}
11454c59 310my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
4ae52e81 311####
507a68aa 312# s///e
4ae52e81 313s/x/'y';/e;
241416b8 314####
507a68aa 315# block
241416b8
DM
316{ my $x; }
317####
507a68aa 318# while 1
241416b8
DM
319while (1) { my $k; }
320####
507a68aa 321# trailing for
241416b8
DM
322my ($x,@a);
323$x=1 for @a;
324>>>>
325my($x, @a);
0bb5f065 326$x = 1 foreach (@a);
241416b8 327####
507a68aa 328# 2 arguments in a 3 argument for
241416b8
DM
329for (my $i = 0; $i < 2;) {
330 my $z = 1;
331}
332####
507a68aa 333# 3 argument for
241416b8
DM
334for (my $i = 0; $i < 2; ++$i) {
335 my $z = 1;
336}
337####
507a68aa 338# 3 argument for again
241416b8
DM
339for (my $i = 0; $i < 2; ++$i) {
340 my $z = 1;
341}
342####
507a68aa 343# while/continue
241416b8
DM
344my $i;
345while ($i) { my $z = 1; } continue { $i = 99; }
346####
507a68aa 347# foreach with my
09d856fb 348foreach my $i (1, 2) {
241416b8
DM
349 my $z = 1;
350}
351####
507a68aa 352# foreach
241416b8
DM
353my $i;
354foreach $i (1, 2) {
355 my $z = 1;
356}
357####
507a68aa 358# foreach, 2 mys
241416b8
DM
359my $i;
360foreach my $i (1, 2) {
361 my $z = 1;
362}
363####
507a68aa 364# foreach
241416b8
DM
365foreach my $i (1, 2) {
366 my $z = 1;
367}
368####
507a68aa 369# foreach with our
241416b8
DM
370foreach our $i (1, 2) {
371 my $z = 1;
372}
373####
507a68aa 374# foreach with my and our
241416b8
DM
375my $i;
376foreach our $i (1, 2) {
377 my $z = 1;
378}
3ac6e0f9 379####
507a68aa 380# reverse sort
3ac6e0f9
RGS
381my @x;
382print reverse sort(@x);
383####
507a68aa 384# sort with cmp
3ac6e0f9
RGS
385my @x;
386print((sort {$b cmp $a} @x));
387####
507a68aa 388# reverse sort with block
3ac6e0f9
RGS
389my @x;
390print((reverse sort {$b <=> $a} @x));
36d57d93 391####
507a68aa 392# foreach reverse
36d57d93
RGS
393our @a;
394print $_ foreach (reverse @a);
aae53c41 395####
507a68aa 396# foreach reverse (not inplace)
aae53c41
RGS
397our @a;
398print $_ foreach (reverse 1, 2..5);
f86ea535 399####
507a68aa 400# bug #38684
f86ea535
SM
401our @ary;
402@ary = split(' ', 'foo', 0);
31c6271a 403####
507a68aa 404# bug #40055
31c6271a
RD
405do { () };
406####
507a68aa 407# bug #40055
31c6271a 408do { my $x = 1; $x };
d9002312 409####
507a68aa 410# <20061012113037.GJ25805@c4.convolution.nl>
d9002312
SM
411my $f = sub {
412 +{[]};
413} ;
8b2d6640 414####
507a68aa 415# bug #43010
8b2d6640
FC
416'!@$%'->();
417####
507a68aa 418# bug #43010
8b2d6640
FC
419::();
420####
507a68aa 421# bug #43010
8b2d6640
FC
422'::::'->();
423####
507a68aa 424# bug #43010
8b2d6640 425&::::;
09d856fb 426####
1b38d782
FC
427# [perl #77172]
428package rt77172;
429sub foo {} foo & & & foo;
430>>>>
431package rt77172;
432foo(&{&} & foo());
433####
507a68aa 434# variables as method names
09d856fb
CK
435my $bar;
436'Foo'->$bar('orz');
35a99a08 437'Foo'->$bar('orz') = 'a stranger stranger than before';
09d856fb 438####
507a68aa 439# constants as method names
09d856fb
CK
440'Foo'->bar('orz');
441####
507a68aa 442# constants as method names without ()
09d856fb 443'Foo'->bar;
0ced6c29 444####
28bfcb02 445# [perl #47359] "indirect" method call notation
1bf8bbb0
FC
446our @bar;
447foo{@bar}+1,->foo;
448(foo{@bar}+1),foo();
449foo{@bar}1 xor foo();
450>>>>
451our @bar;
452(foo { @bar } 1)->foo;
453(foo { @bar } 1), foo();
454foo { @bar } 1 xor foo();
455####
e9c69003 456# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
205fef88 457# CONTEXT use feature ':5.10';
507a68aa 458# say
7ddd1a01
NC
459say 'foo';
460####
8f57bb34 461# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
8f57bb34
NC
462# CONTEXT use 5.10.0;
463# say in the context of use 5.10.0
464say 'foo';
465####
466# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
8f57bb34
NC
467# say with use 5.10.0
468use 5.10.0;
469say 'foo';
470>>>>
471no feature;
472use feature ':5.10';
473say 'foo';
474####
475# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
476# say with use feature ':5.10';
477use feature ':5.10';
478say 'foo';
479>>>>
480use feature 'say', 'state', 'switch';
481say 'foo';
482####
483# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
8f57bb34
NC
484# CONTEXT use feature ':5.10';
485# say with use 5.10.0 in the context of use feature
486use 5.10.0;
487say 'foo';
488>>>>
489no feature;
490use feature ':5.10';
491say 'foo';
492####
493# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
494# CONTEXT use 5.10.0;
495# say with use feature ':5.10' in the context of use 5.10.0
496use feature ':5.10';
497say 'foo';
498>>>>
499say 'foo';
500####
501# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
502# CONTEXT use feature ':5.15';
503# __SUB__
504__SUB__;
505####
506# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
8f57bb34
NC
507# CONTEXT use 5.15.0;
508# __SUB__ in the context of use 5.15.0
509__SUB__;
510####
511# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
8f57bb34
NC
512# __SUB__ with use 5.15.0
513use 5.15.0;
514__SUB__;
515>>>>
516no feature;
517use feature ':5.16';
518__SUB__;
519####
520# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
521# __SUB__ with use feature ':5.15';
522use feature ':5.15';
523__SUB__;
524>>>>
525use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval';
526__SUB__;
527####
528# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
8f57bb34
NC
529# CONTEXT use feature ':5.15';
530# __SUB__ with use 5.15.0 in the context of use feature
531use 5.15.0;
532__SUB__;
533>>>>
534no feature;
535use feature ':5.16';
536__SUB__;
537####
538# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
539# CONTEXT use 5.15.0;
540# __SUB__ with use feature ':5.15' in the context of use 5.15.0
541use feature ':5.15';
542__SUB__;
543>>>>
544__SUB__;
545####
e9c69003 546# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
205fef88 547# CONTEXT use feature ':5.10';
507a68aa 548# state vars
0ced6c29
RGS
549state $x = 42;
550####
e9c69003 551# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
205fef88 552# CONTEXT use feature ':5.10';
507a68aa 553# state var assignment
7ddd1a01
NC
554{
555 my $y = (state $x = 42);
556}
557####
e9c69003 558# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
205fef88 559# CONTEXT use feature ':5.10';
c4a6f826 560# state vars in anonymous subroutines
7ddd1a01
NC
561$a = sub {
562 state $x;
563 return $x++;
564}
565;
644741fd
NC
566####
567# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
507a68aa 568# each @array;
644741fd
NC
569each @ARGV;
570each @$a;
571####
572# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
507a68aa 573# keys @array; values @array
644741fd
NC
574keys @$a if keys @ARGV;
575values @ARGV if values @$a;
35925e80 576####
507a68aa 577# Anonymous arrays and hashes, and references to them
35925e80
RGS
578my $a = {};
579my $b = \{};
580my $c = [];
581my $d = \[];
9210de83
FR
582####
583# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
205fef88 584# CONTEXT use feature ':5.10';
507a68aa 585# implicit smartmatch in given/when
9210de83
FR
586given ('foo') {
587 when ('bar') { continue; }
588 when ($_ ~~ 'quux') { continue; }
589 default { 0; }
590}
7ecdd211 591####
507a68aa 592# conditions in elsifs (regression in change #33710 which fixed bug #37302)
7ecdd211
PJ
593if ($a) { x(); }
594elsif ($b) { x(); }
595elsif ($a and $b) { x(); }
596elsif ($a or $b) { x(); }
597else { x(); }
03b22f1b 598####
507a68aa 599# interpolation in regexps
03b22f1b
RGS
600my($y, $t);
601/x${y}z$t/;
227375e1 602####
4a4b8592 603# TODO new undocumented cpan-bug #33708
507a68aa 604# cpan-bug #33708
227375e1
RU
605%{$_ || {}}
606####
4a4b8592 607# TODO hash constants not yet fixed
507a68aa 608# cpan-bug #33708
227375e1
RU
609use constant H => { "#" => 1 }; H->{"#"}
610####
4a4b8592 611# TODO optimized away 0 not yet fixed
507a68aa 612# cpan-bug #33708
227375e1 613foreach my $i (@_) { 0 }
edbe35ea 614####
507a68aa 615# tests with not, not optimized
07f3cdf5 616my $c;
edbe35ea
VP
617x() unless $a;
618x() if not $a and $b;
619x() if $a and not $b;
620x() unless not $a and $b;
621x() unless $a and not $b;
622x() if not $a or $b;
623x() if $a or not $b;
624x() unless not $a or $b;
625x() unless $a or not $b;
07f3cdf5
VP
626x() if $a and not $b and $c;
627x() if not $a and $b and not $c;
628x() unless $a and not $b and $c;
629x() unless not $a and $b and not $c;
630x() if $a or not $b or $c;
631x() if not $a or $b or not $c;
632x() unless $a or not $b or $c;
633x() unless not $a or $b or not $c;
edbe35ea 634####
507a68aa 635# tests with not, optimized
07f3cdf5 636my $c;
edbe35ea
VP
637x() if not $a;
638x() unless not $a;
639x() if not $a and not $b;
640x() unless not $a and not $b;
641x() if not $a or not $b;
642x() unless not $a or not $b;
07f3cdf5
VP
643x() if not $a and not $b and $c;
644x() unless not $a and not $b and $c;
645x() if not $a or not $b or $c;
646x() unless not $a or not $b or $c;
647x() if not $a and not $b and not $c;
648x() unless not $a and not $b and not $c;
649x() if not $a or not $b or not $c;
650x() unless not $a or not $b or not $c;
651x() unless not $a or not $b or not $c;
edbe35ea 652>>>>
07f3cdf5 653my $c;
edbe35ea
VP
654x() unless $a;
655x() if $a;
656x() unless $a or $b;
657x() if $a or $b;
658x() unless $a and $b;
07f3cdf5
VP
659x() if $a and $b;
660x() if not $a || $b and $c;
661x() unless not $a || $b and $c;
662x() if not $a && $b or $c;
663x() unless not $a && $b or $c;
664x() unless $a or $b or $c;
665x() if $a or $b or $c;
666x() unless $a and $b and $c;
667x() if $a and $b and $c;
668x() unless not $a && $b && $c;
71c4dbc3 669####
507a68aa 670# tests that should be constant folded
71c4dbc3
VP
671x() if 1;
672x() if GLIPP;
673x() if !GLIPP;
674x() if GLIPP && GLIPP;
675x() if !GLIPP || GLIPP;
676x() if do { GLIPP };
677x() if do { no warnings 'void'; 5; GLIPP };
678x() if do { !GLIPP };
679if (GLIPP) { x() } else { z() }
680if (!GLIPP) { x() } else { z() }
681if (GLIPP) { x() } elsif (GLIPP) { z() }
682if (!GLIPP) { x() } elsif (GLIPP) { z() }
683if (GLIPP) { x() } elsif (!GLIPP) { z() }
684if (!GLIPP) { x() } elsif (!GLIPP) { z() }
685if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
686if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
687if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
688>>>>
689x();
690x();
691'???';
692x();
693x();
694x();
695x();
696do {
697 '???'
698};
699do {
700 x()
701};
702do {
703 z()
704};
705do {
706 x()
707};
708do {
709 z()
710};
711do {
712 x()
713};
714'???';
715do {
716 t()
717};
718'???';
719!1;
720####
719c50dc
RGS
721# TODO constant deparsing has been backed out for 5.12
722# XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
507a68aa 723# tests that shouldn't be constant folded
ac0f1413
NC
724# It might be fundamentally impossible to make this work on ithreads, in which
725# case the TODO should become a SKIP
71c4dbc3
VP
726x() if $a;
727if ($a == 1) { x() } elsif ($b == 2) { z() }
728if (do { foo(); GLIPP }) { x() }
729if (do { $a++; GLIPP }) { x() }
730>>>>
731x() if $a;
732if ($a == 1) { x(); } elsif ($b == 2) { z(); }
2990415a
FR
733if (do { foo(); GLIPP }) { x(); }
734if (do { ++$a; GLIPP }) { x(); }
735####
0fa4a265 736# TODO constant deparsing has been backed out for 5.12
507a68aa 737# tests for deparsing constants
2990415a
FR
738warn PI;
739####
0fa4a265 740# TODO constant deparsing has been backed out for 5.12
507a68aa 741# tests for deparsing imported constants
3779476a 742warn O_TRUNC;
2990415a 743####
0fa4a265 744# TODO constant deparsing has been backed out for 5.12
507a68aa 745# tests for deparsing re-exported constants
2990415a
FR
746warn O_CREAT;
747####
0fa4a265 748# TODO constant deparsing has been backed out for 5.12
507a68aa 749# tests for deparsing imported constants that got deleted from the original namespace
aaf9c2b2 750warn O_APPEND;
2990415a 751####
0fa4a265
DM
752# TODO constant deparsing has been backed out for 5.12
753# XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
507a68aa 754# tests for deparsing constants which got turned into full typeglobs
ac0f1413
NC
755# It might be fundamentally impossible to make this work on ithreads, in which
756# case the TODO should become a SKIP
2990415a
FR
757warn O_EXCL;
758eval '@Fcntl::O_EXCL = qw/affe tiger/;';
759warn O_EXCL;
760####
0fa4a265 761# TODO constant deparsing has been backed out for 5.12
507a68aa 762# tests for deparsing of blessed constant with overloaded numification
2990415a 763warn OVERLOADED_NUMIFICATION;
79289e05 764####
507a68aa 765# strict
79289e05 766no strict;
415d4c68
FC
767print $x;
768use strict 'vars';
769print $main::x;
770use strict 'subs';
771print $main::x;
772use strict 'refs';
773print $main::x;
774no strict 'vars';
79289e05
NC
775$x;
776####
777# TODO Subsets of warnings could be encoded textually, rather than as bitflips.
507a68aa 778# subsets of warnings
79289e05
NC
779no warnings 'deprecated';
780my $x;
781####
782# TODO Better test for CPAN #33708 - the deparsed code has different behaviour
507a68aa 783# CPAN #33708
79289e05
NC
784use strict;
785no warnings;
786
787foreach (0..3) {
788 my $x = 2;
789 {
790 my $x if 0;
791 print ++$x, "\n";
792 }
793}
d83f38d8 794####
507a68aa 795# no attribute list
d83f38d8
NC
796my $pi = 4;
797####
2dc78664
NC
798# SKIP ?$] > 5.013006 && ":= is now a syntax error"
799# := treated as an empty attribute list
d83f38d8
NC
800no warnings;
801my $pi := 4;
802>>>>
803no warnings;
804my $pi = 4;
805####
507a68aa 806# : = empty attribute list
d83f38d8
NC
807my $pi : = 4;
808>>>>
809my $pi = 4;
689e417f 810####
507a68aa 811# in place sort
689e417f
VP
812our @a;
813my @b;
814@a = sort @a;
815@b = sort @b;
816();
817####
507a68aa 818# in place reverse
689e417f
VP
819our @a;
820my @b;
821@a = reverse @a;
822@b = reverse @b;
823();
06fc6867 824####
507a68aa 825# #71870 Use of uninitialized value in bitwise and B::Deparse
06fc6867
VP
826my($r, $s, @a);
827@a = split(/foo/, $s, 0);
828$r = qr/foo/;
829@a = split(/$r/, $s, 0);
830();
98a1a137 831####
507a68aa 832# package declaration before label
98a1a137
Z
833{
834 package Foo;
835 label: print 123;
836}
538f5756 837####
507a68aa 838# shift optimisation
538f5756
RZ
839shift;
840>>>>
841shift();
842####
507a68aa 843# shift optimisation
538f5756
RZ
844shift @_;
845####
507a68aa 846# shift optimisation
538f5756
RZ
847pop;
848>>>>
849pop();
850####
507a68aa 851# shift optimisation
538f5756 852pop @_;
a539498a 853####
507a68aa 854#[perl #20444]
a539498a
FC
855"foo" =~ (1 ? /foo/ : /bar/);
856"foo" =~ (1 ? y/foo// : /bar/);
5e5a1632 857"foo" =~ (1 ? y/foo//r : /bar/);
a539498a
FC
858"foo" =~ (1 ? s/foo// : /bar/);
859>>>>
860'foo' =~ ($_ =~ /foo/);
861'foo' =~ ($_ =~ tr/fo//);
5e5a1632 862'foo' =~ ($_ =~ tr/fo//r);
a539498a 863'foo' =~ ($_ =~ s/foo//);
e0ab66ad 864####
5e5a1632
FC
865# The fix for [perl #20444] broke this.
866'foo' =~ do { () };
867####
4b58603b
FC
868# [perl #81424] match against aelemfast_lex
869my @s;
870print /$s[1]/;
871####
36727b53
FC
872# /$#a/
873print /$#main::a/;
874####
b9bc576f 875# [perl #91318] /regexp/applaud
09622ee2
FC
876print /a/a, s/b/c/a;
877print /a/aa, s/b/c/aa;
878print /a/p, s/b/c/p;
879print /a/l, s/b/c/l;
880print /a/u, s/b/c/u;
b9bc576f
FC
881{
882 use feature "unicode_strings";
09622ee2 883 print /a/d, s/b/c/d;
b9bc576f
FC
884}
885{
886 use re "/u";
09622ee2 887 print /a/d, s/b/c/d;
b9bc576f 888}
dff5ffe4
FC
889{
890 use 5.012;
891 print /a/d, s/b/c/d;
892}
b9bc576f 893>>>>
09622ee2
FC
894print /a/a, s/b/c/a;
895print /a/aa, s/b/c/aa;
896print /a/p, s/b/c/p;
897print /a/l, s/b/c/l;
898print /a/u, s/b/c/u;
b9bc576f 899{
a8095af7 900 use feature 'unicode_strings';
09622ee2 901 print /a/d, s/b/c/d;
b9bc576f
FC
902}
903{
0bb01b05
FC
904 BEGIN { $^H{'reflags'} = '0';
905 $^H{'reflags_charset'} = '2'; }
09622ee2 906 print /a/d, s/b/c/d;
b9bc576f 907}
dff5ffe4
FC
908{
909 no feature;
910 use feature ':5.12';
911 print /a/d, s/b/c/d;
912}
b9bc576f 913####
e0ab66ad
NC
914# Test @threadsv_names under 5005threads
915foreach $' (1, 2) {
916 sleep $';
917}
e7afc405
FC
918####
919# y///r
920tr/a/b/r;
cb8157e3
FC
921####
922# y/uni/code/
923tr/\x{345}/\x{370}/;
cb8578ff
FC
924####
925# [perl #90898]
f4002a4b 926<a,>;
09dcfa7d
FC
927####
928# [perl #91008]
929each $@;
930keys $~;
931values $!;
5d8c42c2
FC
932####
933# readpipe with complex expression
934readpipe $a + $b;
93bad3fd
NC
935####
936# aelemfast
937$b::a[0] = 1;
938####
939# aelemfast for a lexical
940my @a;
941$a[0] = 1;
80e3f4ad
FC
942####
943# feature features without feature
80e3f4ad 944CORE::state $x;
223b1722
FC
945CORE::say $x;
946CORE::given ($x) {
947 CORE::when (3) {
948 continue;
949 }
950 CORE::default {
951 CORE::break;
952 }
953}
954CORE::evalbytes '';
955() = CORE::__SUB__;
838f2281 956() = CORE::fc $x;
223b1722
FC
957####
958# feature features when feature has been disabled by use VERSION
959use feature (sprintf(":%vd", $^V));
960use 1;
961CORE::state $x;
962CORE::say $x;
963CORE::given ($x) {
964 CORE::when (3) {
965 continue;
966 }
967 CORE::default {
968 CORE::break;
969 }
970}
971CORE::evalbytes '';
972() = CORE::__SUB__;
973>>>>
205fef88
NC
974CORE::state $x;
975CORE::say $x;
976CORE::given ($x) {
977 CORE::when (3) {
978 continue;
979 }
980 CORE::default {
981 CORE::break;
982 }
983}
984CORE::evalbytes '';
985() = CORE::__SUB__;
986####
987# (the above test with CONTEXT, and the output is equivalent but different)
988# CONTEXT use feature ':5.10';
989# feature features when feature has been disabled by use VERSION
990use feature (sprintf(":%vd", $^V));
991use 1;
992CORE::state $x;
993CORE::say $x;
994CORE::given ($x) {
995 CORE::when (3) {
996 continue;
997 }
998 CORE::default {
999 CORE::break;
1000 }
1001}
1002CORE::evalbytes '';
1003() = CORE::__SUB__;
1004>>>>
0bb01b05
FC
1005no feature;
1006use feature ':default';
223b1722 1007CORE::state $x;
80e3f4ad
FC
1008CORE::say $x;
1009CORE::given ($x) {
1010 CORE::when (3) {
1011 continue;
1012 }
1013 CORE::default {
e36901c8 1014 CORE::break;
80e3f4ad
FC
1015 }
1016}
7d789282 1017CORE::evalbytes '';
84ed0108 1018() = CORE::__SUB__;
6ec73527 1019####
0bb01b05
FC
1020# Feature hints
1021use feature 'current_sub', 'evalbytes';
1022print;
1023use 1;
1024print;
1025use 5.014;
1026print;
1027no feature 'unicode_strings';
1028print;
1029>>>>
a8095af7 1030use feature 'current_sub', 'evalbytes';
0bb01b05
FC
1031print $_;
1032no feature;
1033use feature ':default';
1034print $_;
1035no feature;
1036use feature ':5.12';
1037print $_;
a8095af7 1038no feature 'unicode_strings';
0bb01b05
FC
1039print $_;
1040####
6ec73527
FC
1041# $#- $#+ $#{%} etc.
1042my @x;
1043@x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
1044@x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
1045@x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
1046@x = ($#{;}, $#{:});
61154ac0
FC
1047####
1048# ${#} interpolated (the first line magically disables the warning)
1049() = *#;
1050() = "${#}a";
958ed56b 1051####
337d7381
FC
1052# [perl #86060] $( $| $) in regexps need braces
1053/${(}/;
1054/${|}/;
1055/${)}/;
1056/${(}${|}${)}/;
1057####
958ed56b
FC
1058# ()[...]
1059my(@a) = ()[()];
521795fe
FC
1060####
1061# sort(foo(bar))
1062# sort(foo(bar)) is interpreted as sort &foo(bar)
1063# sort foo(bar) is interpreted as sort foo bar
1064# parentheses are not optional in this case
1065print sort(foo('bar'));
1066>>>>
1067print sort(foo('bar'));
24fcb59f
FC
1068####
1069# substr assignment
1070substr(my $a, 0, 0) = (foo(), bar());
1071$a++;
04be0204 1072####
d1718a7c
FC
1073# This following line works around an unfixed bug that we are not trying to
1074# test for here:
1075# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
04be0204
FC
1076# hint hash
1077BEGIN { $^H{'foo'} = undef; }
1078{
1079 BEGIN { $^H{'bar'} = undef; }
1080 {
1081 BEGIN { $^H{'baz'} = undef; }
1082 {
1083 print $_;
1084 }
1085 print $_;
1086 }
1087 print $_;
1088}
035146a3
FC
1089BEGIN { $^H{q[']} = '('; }
1090print $_;
c306e834 1091####
d1718a7c
FC
1092# This following line works around an unfixed bug that we are not trying to
1093# test for here:
1094# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
c306e834
FC
1095# hint hash changes that serialise the same way with sort %hh
1096BEGIN { $^H{'a'} = 'b'; }
1097{
1098 BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
1099 print $_;
1100}
1101print $_;
94bb57f9
FC
1102####
1103# [perl #47361] do({}) and do +{} (variants of do-file)
1104do({});
1105do +{};
8b46c09b
FC
1106sub foo::do {}
1107package foo;
1108CORE::do({});
1109CORE::do +{};
94bb57f9
FC
1110>>>>
1111do({});
1112do({});
8b46c09b
FC
1113package foo;
1114CORE::do({});
1115CORE::do({});
9c56d9ea
FC
1116####
1117# [perl #77096] functions that do not follow the llafr
1118() = (return 1) + time;
1119() = (return ($1 + $2) * $3) + time;
1120() = (return ($a xor $b)) + time;
1121() = (do 'file') + time;
1122() = (do ($1 + $2) * $3) + time;
1123() = (do ($1 xor $2)) + time;
41df74e3
FC
1124() = (goto 1) + 3;
1125() = (require 'foo') + 3;
1126() = (require foo) + 3;
266da325 1127() = (CORE::dump 1) + 3;
41df74e3
FC
1128() = (last 1) + 3;
1129() = (next 1) + 3;
1130() = (redo 1) + 3;
5830412d
FC
1131() = (-R $_) + 3;
1132() = (-W $_) + 3;
1133() = (-X $_) + 3;
1134() = (-r $_) + 3;
1135() = (-w $_) + 3;
1136() = (-x $_) + 3;
2462c3cc 1137####
1cabb3b3
FC
1138# [perl #97476] not() *does* follow the llafr
1139$_ = ($a xor not +($1 || 2) ** 2);
1140####
4d8ac5c7
FC
1141# Precedence conundrums with argument-less function calls
1142() = (eof) + 1;
1143() = (return) + 1;
1144() = (return, 1);
7bc8c979
FC
1145() = warn;
1146() = warn() + 1;
4d8ac5c7
FC
1147() = setpgrp() + 1;
1148####
1eb0b7be
FC
1149# loopexes have assignment prec
1150() = (CORE::dump a) | 'b';
1151() = (goto a) | 'b';
1152() = (last a) | 'b';
1153() = (next a) | 'b';
1154() = (redo a) | 'b';
1155####
2462c3cc
FC
1156# [perl #63558] open local(*FH)
1157open local *FH;
564cd6cb 1158pipe local *FH, local *FH;
843b15cc 1159####
b89b7257
FC
1160# [perl #91416] open "string"
1161open 'open';
1162open '####';
1163open '^A';
1164open "\ca";
1165>>>>
1166open *open;
1167open '####';
1168open '^A';
1169open *^A;
1170####
be6cf5cf
FC
1171# "string"->[] ->{}
1172no strict 'vars';
1173() = 'open'->[0]; #aelemfast
1174() = '####'->[0];
1175() = '^A'->[0];
1176() = "\ca"->[0];
b861b87f 1177() = 'a::]b'->[0];
10e8e32b
FC
1178() = 'open'->[$_]; #aelem
1179() = '####'->[$_];
1180() = '^A'->[$_];
1181() = "\ca"->[$_];
b861b87f 1182() = 'a::]b'->[$_];
10e8e32b
FC
1183() = 'open'->{0}; #helem
1184() = '####'->{0};
1185() = '^A'->{0};
1186() = "\ca"->{0};
b861b87f 1187() = 'a::]b'->{0};
be6cf5cf 1188>>>>
415d4c68 1189no strict 'vars';
be6cf5cf
FC
1190() = $open[0];
1191() = '####'->[0];
1192() = '^A'->[0];
1193() = $^A[0];
b861b87f 1194() = 'a::]b'->[0];
10e8e32b
FC
1195() = $open[$_];
1196() = '####'->[$_];
1197() = '^A'->[$_];
1198() = $^A[$_];
b861b87f 1199() = 'a::]b'->[$_];
10e8e32b
FC
1200() = $open{'0'};
1201() = '####'->{'0'};
1202() = '^A'->{'0'};
1203() = $^A{'0'};
b861b87f 1204() = 'a::]b'->{'0'};
be6cf5cf 1205####
843b15cc
FC
1206# [perl #74740] -(f()) vs -f()
1207$_ = -(f());
c75b4828
FC
1208####
1209# require <binop>
1210require 'a' . $1;
afb60448
HY
1211####
1212#[perl #30504] foreach-my postfix/prefix difference
1213$_ = 'foo' foreach my ($foo1, $bar1, $baz1);
1214foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' }
1215foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' }
1216>>>>
1217$_ = 'foo' foreach (my($foo1, $bar1, $baz1));
1218foreach $_ (my($foo2, $bar2, $baz2)) {
1219 $_ = 'foo';
1220}
1221foreach my $i (my($foo3, $bar3, $baz3)) {
1222 $i = 'foo';
1223}
1224####
1225#[perl #108224] foreach with continue block
1226foreach (1 .. 3) { print } continue { print "\n" }
1227foreach (1 .. 3) { } continue { }
1228foreach my $i (1 .. 3) { print $i } continue { print "\n" }
1229foreach my $i (1 .. 3) { } continue { }
1230>>>>
1231foreach $_ (1 .. 3) {
1232 print $_;
1233}
1234continue {
1235 print "\n";
1236}
1237foreach $_ (1 .. 3) {
1238 ();
1239}
1240continue {
1241 ();
1242}
1243foreach my $i (1 .. 3) {
1244 print $i;
1245}
1246continue {
1247 print "\n";
1248}
1249foreach my $i (1 .. 3) {
1250 ();
1251}
1252continue {
1253 ();
1254}