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