This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
overload.t: add more concat tests
[perl5.git] / lib / B / Deparse.t
CommitLineData
87a42246
MS
1#!./perl
2
3BEGIN {
738f9dbf 4 splice @INC, 0, 0, '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 }
738f9dbf 10 require 'test.pl';
87a42246
MS
11}
12
87a42246
MS
13use warnings;
14use strict;
87a42246 15
a9cafc78 16my $tests = 49; # 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');
4da9a2ca 21my %deparse;
87a42246 22
ad46c0be
RH
23$/ = "\n####\n";
24while (<DATA>) {
25 chomp;
d8cf01c3 26 $tests ++;
e9c69003
NC
27 # This code is pinched from the t/lib/common.pl for TODO.
28 # It's not clear how to avoid duplication
a6087f24 29 my %meta = (context => '');
4da9a2ca 30 foreach my $what (qw(skip todo context options)) {
c4a350e6 31 s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $1;
b871937f
NC
32 # If the SKIP reason starts ? then it's taken as a code snippet to
33 # evaluate. This provides the flexibility to have conditional SKIPs
c4a350e6
NC
34 if ($meta{$what} && $meta{$what} =~ s/^\?//) {
35 my $temp = eval $meta{$what};
b871937f 36 if ($@) {
c4a350e6 37 die "# In \U$what\E code reason:\n# $meta{$what}\n$@";
b871937f 38 }
c4a350e6 39 $meta{$what} = $temp;
e9c69003 40 }
e9c69003
NC
41 }
42
4a4b8592 43 s/^\s*#\s*(.*)$//mg;
507a68aa
NC
44 my $desc = $1;
45 die "Missing name in test $_" unless defined $desc;
e9c69003 46
c4a350e6 47 if ($meta{skip}) {
f9d3bdea 48 SKIP: { 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
4da9a2ca
FC
60 # parse options if necessary
61 my $deparse = $meta{options}
62 ? $deparse{$meta{options}} ||=
63 new B::Deparse split /,/, $meta{options}
64 : $deparse;
65
27cbbc57 66 my $code = "$meta{context};\n" . <<'EOC' . "sub {$input\n}";
a6087f24
NC
67# Tell B::Deparse about our ambient pragmas
68my ($hint_bits, $warning_bits, $hinthash);
69BEGIN {
70 ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H);
71}
72$deparse->ambient_pragmas (
73 hint_bits => $hint_bits,
74 warning_bits => $warning_bits,
75 '%^H' => $hinthash,
76);
77EOC
27cbbc57 78 my $coderef = eval $code;
87a42246 79
c9fa6ae9 80 local $::TODO = $meta{todo};
ad46c0be 81 if ($@) {
27cbbc57
DM
82 is($@, "", "compilation of $desc")
83 or diag "=============================================\n"
84 . "CODE:\n--------\n$code\n--------\n"
85 . "=============================================\n";
ad46c0be
RH
86 }
87 else {
88 my $deparsed = $deparse->coderef2text( $coderef );
31c6271a
RD
89 my $regex = $expected;
90 $regex =~ s/(\S+)/\Q$1/g;
91 $regex =~ s/\s+/\\s+/g;
92 $regex = '^\{\s*' . $regex . '\s*\}$';
b871937f 93
bc304ab2
DM
94 like($deparsed, qr/$regex/, $desc)
95 or diag "=============================================\n"
96 . "CODE:\n--------\n$input\n--------\n"
97 . "EXPECTED:\n--------\n{\n$expected\n}\n--------\n"
98 . "GOT:\n--------\n$deparsed\n--------\n"
99 . "=============================================\n";
87a42246 100 }
87a42246
MS
101}
102
9187b6e4
FC
103# Reset the ambient pragmas
104{
105 my ($b, $w, $h);
106 BEGIN {
107 ($b, $w, $h) = ($^H, ${^WARNING_BITS}, \%^H);
108 }
109 $deparse->ambient_pragmas (
110 hint_bits => $b,
111 warning_bits => $w,
112 '%^H' => $h,
113 );
114}
115
87a42246 116use constant 'c', 'stuff';
507a68aa
NC
117is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
118 'the subroutine generated by use constant deparses');
87a42246 119
09d856fb 120my $a = 0;
507a68aa
NC
121is($deparse->coderef2text(sub{(-1) ** $a }), "{\n (-1) ** \$a;\n}",
122 'anon sub capturing an external lexical');
87a42246 123
d989cdac
SM
124use constant cr => ['hello'];
125my $string = "sub " . $deparse->coderef2text(\&cr);
0707d6cc 126my $val = (eval $string)->() or diag $string;
507a68aa
NC
127is(ref($val), 'ARRAY', 'constant array references deparse');
128is($val->[0], 'hello', 'and return the correct value');
87a42246 129
87a42246 130my $path = join " ", map { qq["-I$_"] } @INC;
87a42246 131
7cde0a5f 132$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
e69a2255 133$a =~ s/-e syntax OK\n//g;
d2bc402e 134$a =~ s/.*possible typo.*\n//; # Remove warning line
82f96200 135$a =~ s/.*-i used with no filenames.*\n//; # Remove warning line
c96cf1c0 136$b = quotemeta <<'EOF';
d2bc402e
RGS
137BEGIN { $^I = ".bak"; }
138BEGIN { $^W = 1; }
139BEGIN { $/ = "\n"; $\ = "\n"; }
18371617 140LINE: while (defined($_ = readline ARGV)) {
87a42246 141 chomp $_;
f86ea535 142 our(@F) = split(' ', $_, 0);
87a42246
MS
143 '???';
144}
87a42246 145EOF
c96cf1c0
FC
146$b =~ s/our\\\(\\\@F\\\)/our[( ]\@F\\)?/; # accept both our @F and our(@F)
147like($a, qr/$b/,
507a68aa 148 'command line flags deparse as BEGIN blocks setting control variables');
87a42246 149
5b4ee549
NC
150$a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
151$a =~ s/-e syntax OK\n//g;
6436970c 152is($a, "use constant ('PI', 4);\n",
5b4ee549
NC
153 "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
154
a9cafc78
FC
155$a = `$^X $path "-MO=Deparse" -e "sub foo(){1}" 2>&1`;
156$a =~ s/-e syntax OK\n//g;
157is($a, "sub foo () {\n 1;\n}\n",
158 "Main prog consisting of just a constant (via empty proto)");
159
160$a = readpipe qq|$^X $path "-MO=Deparse"|
161 .qq| -e "package F; sub f(){0} sub s{}"|
162 .qq| -e "#line 123 four-five-six"|
163 .qq| -e "package G; sub g(){0} sub s{}" 2>&1|;
164$a =~ s/-e syntax OK\n//g;
6fbf0c31 165like($a, qr/sub F::f \(\) \{\s*0;?\s*}/,
a9cafc78
FC
166 "Constant is dumped in package in which other subs are dumped");
167unlike($a, qr/sub g/,
168 "Constant is not dumped in package in which other subs are not dumped");
169
579a54dc 170#Re: perlbug #35857, patch #24505
b3980c39
YO
171#handle warnings::register-ed packages properly.
172package B::Deparse::Wrapper;
173use strict;
174use warnings;
175use warnings::register;
176sub getcode {
579a54dc 177 my $deparser = B::Deparse->new();
b3980c39
YO
178 return $deparser->coderef2text(shift);
179}
180
2990415a
FR
181package Moo;
182use overload '0+' => sub { 42 };
183
b3980c39
YO
184package main;
185use strict;
186use warnings;
71c4dbc3 187use constant GLIPP => 'glipp';
2990415a
FR
188use constant PI => 4;
189use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
3779476a 190use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
aaf9c2b2 191BEGIN { delete $::Fcntl::{O_APPEND}; }
2990415a 192use POSIX qw/O_CREAT/;
b3980c39 193sub test {
579a54dc
RGS
194 my $val = shift;
195 my $res = B::Deparse::Wrapper::getcode($val);
507a68aa
NC
196 like($res, qr/use warnings/,
197 '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
b3980c39
YO
198}
199my ($q,$p);
200my $x=sub { ++$q,++$p };
201test($x);
202eval <<EOFCODE and test($x);
203 package bar;
204 use strict;
205 use warnings;
206 use warnings::register;
207 package main;
208 1
209EOFCODE
210
d1dc589d
FC
211# Exotic sub declarations
212$a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
213$a =~ s/-e syntax OK\n//g;
214is($a, <<'EOCODG', "sub :::: and sub ::::::");
215sub :::: {
216
217}
218sub :::::: {
219
220}
221EOCODG
222
f2734596 223# [perl #117311]
224$a = `$^X $path "-MO=Deparse,-l" -e "map{ eval(0) }()" 2>&1`;
225$a =~ s/-e syntax OK\n//g;
226is($a, <<'EOCODH', "[perl #117311] [PATCH] -l option ('#line ...') does not emit ^Ls in the output");
227#line 1 "-e"
228map {
229#line 1 "-e"
230eval 0;} ();
231EOCODH
232
640d5d41
FC
233# [perl #33752]
234{
235 my $code = <<"EOCODE";
236{
237 our \$\x{1e1f}\x{14d}\x{14d};
238}
239EOCODE
240 my $deparsed
241 = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
242 s/$ \n//x for $deparsed, $code;
243 is $deparsed, $code, 'our $funny_Unicode_chars';
244}
245
bdabb2d5
FC
246# [perl #62500]
247$a =
248 `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
249$a =~ s/-e syntax OK\n//g;
250is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
251sub BEGIN {
252 *CORE::GLOBAL::require = sub {
253 1;
254 }
255 ;
256}
257EOCODF
258
894e98ac
FC
259# [perl #91384]
260$a =
261 `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`;
262like($a, qr/-e syntax OK/,
263 "Deparse does not hang when traversing stash circularities");
264
bb8996b8 265# [perl #93990]
08412a26 266@] = ();
73f4c4fe 267is($deparse->coderef2text(sub{ print "foo@{]}" }),
bb8996b8 268q<{
73f4c4fe 269 print "foo@{]}";
08412a26 270}>, 'curly around to interpolate "@{]}"');
73f4c4fe 271is($deparse->coderef2text(sub{ print "foo@{-}" }),
bb8996b8 272q<{
73f4c4fe 273 print "foo@-";
bb8996b8
HY
274}>, 'no need to curly around to interpolate "@-"');
275
1c74777c
FC
276# Strict hints in %^H are mercilessly suppressed
277$a =
278 `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`;
279unlike($a, qr/BEGIN/,
280 "Deparse does not emit strict hh hints");
281
3036b99c
FC
282# ambient_pragmas should not mess with strict settings.
283SKIP: {
284 skip "requires 5.11", 1 unless $] >= 5.011;
285 eval q`
3036b99c 286 BEGIN {
d1718a7c 287 # Clear out all hints
3036b99c 288 %^H = ();
d1718a7c 289 $^H = 0;
3036b99c
FC
290 new B::Deparse -> ambient_pragmas(strict => 'all');
291 }
292 use 5.011; # should enable strict
293 ok !eval '$do_noT_create_a_variable_with_this_name = 1',
294 'ambient_pragmas do not mess with compiling scope';
295 `;
296}
297
93a8ff62
FC
298# multiple statements on format lines
299$a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`;
300$a =~ s/-e syntax OK\n//g;
93a8ff62
FC
301is($a, <<'EOCODH', 'multiple statements on format lines');
302format STDOUT =
303@
304x(); z()
305.
306EOCODH
307
ddb55548
FC
308is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-T' ],
309 prog => "format =\n\@\n\$;\n.\n"),
310 <<'EOCODM', '$; on format line';
311format STDOUT =
312@
313$;
314.
315EOCODM
316
e56a605e
FC
317is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse,-l', $path ],
318 prog => "format =\n\@\n\$foo\n.\n"),
319 <<'EOCODM', 'formats with -l';
320format STDOUT =
321@
322$foo
323.
324EOCODM
325
8b9fb2f9
FC
326is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
327 prog => "{ my \$x; format =\n\@\n\$x\n.\n}"),
328 <<'EOCODN', 'formats nested inside blocks';
329{
330 my $x;
331 format STDOUT =
332@
333$x
334.
335}
336EOCODN
337
7741ceed
FC
338# CORE::format
339$a = readpipe qq`$^X $path "-MO=Deparse" -e "use feature q|:all|;`
340 .qq` my sub format; CORE::format =" -e. 2>&1`;
341like($a, qr/CORE::format/, 'CORE::format when lex format sub is in scope');
342
fea7fb25
DM
343# literal big chars under 'use utf8'
344is($deparse->coderef2text(sub{ use utf8; /€/; }),
345'{
346 /\x{20ac}/;
347}',
348"qr/euro/");
349
e54915d6
FC
350# STDERR when deparsing sub calls
351# For a short while the output included 'While deparsing'
352$a = `$^X $path "-MO=Deparse" -e "foo()" 2>&1`;
353$a =~ s/-e syntax OK\n//g;
354is($a, <<'EOCODI', 'no extra output when deparsing foo()');
355foo();
356EOCODI
357
84ed3992
FC
358# Sub calls compiled before importation
359like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
360 prog => 'BEGIN {
361 require Test::More;
362 Test::More::->import;
363 is(*foo, *foo)
364 }'),
365 qr/&is\(/,
366 'sub calls compiled before importation of prototype subs';
367
a93cf6e2
FC
368# [perl #121050] Prototypes with whitespace
369is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
370 prog => <<'EOCODO'),
371sub _121050(\$ \$) { }
372_121050($a,$b);
373sub _121050empty( ) {}
374() = _121050empty() + 1;
375EOCODO
376 <<'EOCODP', '[perl #121050] prototypes with whitespace';
377sub _121050 (\$ \$) {
378
379}
380_121050 $a, $b;
381sub _121050empty ( ) {
382
383}
384() = _121050empty + 1;
385EOCODP
386
7741ceed
FC
387# CORE::no
388$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
389 .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`;
e276dec7 390like($a, qr/my sub no;\n.*CORE::no less;/s,
7741ceed
FC
391 'CORE::no after my sub no');
392
393# CORE::use
394$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
395 .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`;
e276dec7 396like($a, qr/my sub use;\n.*CORE::use less;/s,
7741ceed
FC
397 'CORE::use after my sub use');
398
399# CORE::__DATA__
400$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
401 .qq`"use feature q|:all|; my sub __DATA__; `
402 .qq`CORE::__DATA__" 2>&1`;
e276dec7 403like($a, qr/my sub __DATA__;\n.*CORE::__DATA__/s,
7741ceed
FC
404 'CORE::__DATA__ after my sub __DATA__');
405
fe8d6c18
FC
406# sub declarations
407$a = readpipe qq`$^X $path "-MO=Deparse" -e "sub foo{}" 2>&1`;
dd3f0a7a 408like($a, qr/sub foo\s*\{\s+\}/, 'sub declarations');
67359f08
FC
409like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
410 prog => 'sub f($); sub f($){}'),
411 qr/sub f\s*\(\$\)\s*\{\s*\}/,
412 'predeclared prototyped subs';
de001ba0
FC
413like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
414 prog => 'use Scalar::Util q-weaken-;
415 sub f($);
416 BEGIN { weaken($_=\$::{f}) }'),
417 qr/sub f\s*\(\$\)\s*;/,
418 'prototyped stub with weak reference to the stash entry';
03b8f76d
FC
419like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
420 prog => 'sub f () { 42 }'),
421 qr/sub f\s*\(\)\s*\{\s*42;\s*\}/,
422 'constant perl sub declaration';
fe8d6c18 423
8635e3c2
FC
424# BEGIN blocks
425SKIP : {
426 skip "BEGIN output is wrong on old perls", 1 if $] < 5.021006;
427 my $prog = '
428 BEGIN { pop }
429 {
430 BEGIN { pop }
431 {
432 no overloading;
433 {
434 BEGIN { pop }
435 die
436 }
437 }
438 }';
439 $prog =~ s/\n//g;
440 $a = readpipe qq`$^X $path "-MO=Deparse" -e "$prog" 2>&1`;
441 $a =~ s/-e syntax OK\n//g;
442 is($a, <<'EOCODJ', 'BEGIN blocks');
443sub BEGIN {
444 pop @ARGV;
445}
446{
447 sub BEGIN {
448 pop @ARGV;
449 }
450 {
451 no overloading;
452 {
453 sub BEGIN {
454 pop @ARGV;
455 }
456 die;
457 }
458 }
459}
460EOCODJ
461}
34b54951
FC
462is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], prog => '
463 {
464 {
465 die;
466 BEGIN { pop }
467 }
468 BEGIN { pop }
469 }
470 BEGIN { pop }
471 '), <<'EOCODL', 'BEGIN blocks at the end of their enclosing blocks';
472{
473 {
474 die;
475 sub BEGIN {
476 pop @ARGV;
477 }
34b54951
FC
478 }
479 sub BEGIN {
480 pop @ARGV;
481 }
34b54951
FC
482}
483sub BEGIN {
484 pop @ARGV;
485}
34b54951 486EOCODL
93a8ff62 487
c310a5ab
FC
488# BEGIN blocks should not be called __ANON__
489like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
490 prog => 'sub BEGIN { } CHECK { delete $::{BEGIN} }'),
491 qr/sub BEGIN/, 'anonymised BEGIN';
492
1f9498d0 493# [perl #115066]
1f9498d0
FC
494my $prog = 'use constant FOO => do { 1 }; no overloading; die';
495$a = readpipe qq`$^X $path "-MO=-qq,Deparse" -e "$prog" 2>&1`;
496is($a, <<'EOCODK', '[perl #115066] use statements accidentally nested');
497use constant ('FOO', do {
d88d1fe0 498 1
1f9498d0
FC
499});
500no overloading;
501die;
502EOCODK
503
f1013307
FC
504# BEGIN blocks inside predeclared subs
505like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
506 prog => '
507 sub run_tests;
508 run_tests();
509 sub run_tests { BEGIN { } die }'),
510 qr/sub run_tests \{\s*sub BEGIN/,
511 'BEGIN block inside predeclared sub';
512
d49c3562 513like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
d98ae4a6
FC
514 prog => 'package foo; use overload qr=>sub{}'),
515 qr/package foo;\s*use overload/,
516 'package, then use';
517
518like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
d49c3562
FC
519 prog => 'use feature lexical_subs=>; my sub f;sub main::f{}'),
520 qr/^sub main::f \{/m,
521 'sub decl when lex sub is in scope';
522
f518ad75
FC
523like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
524 prog => 'sub foo{foo()}'),
525 qr/^sub foo \{\s+foo\(\)/m,
526 'recursive sub';
527
2c5ddcd3
FC
528like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
529 prog => 'use feature lexical_subs=>state=>;
530 state sub sb5; sub { sub sb5 { } }'),
401e2e00 531 qr/sub \{\s*\(\);\s*sub sb5 \{/m,
2c5ddcd3
FC
532 'state sub in anon sub but declared outside';
533
5e965771
FC
534is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
535 prog => 'BEGIN { $::{f}=\!0 }'),
536 "sub BEGIN {\n \$main::{'f'} = \\1;\n}\n",
537 '&PL_sv_yes constant (used to croak)';
538
d02d1323
FC
539is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-T' ],
540 prog => '$x =~ (1?/$a/:0)'),
541 '$x =~ ($_ =~ /$a/);'."\n",
542 '$foo =~ <branch-folded match> under taint mode';
543
62ae7cfb
FC
544unlike runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-w' ],
545 prog => 'BEGIN { undef &foo }'),
546 qr'Use of uninitialized value',
547 'no warnings for undefined sub';
548
d8cf01c3 549done_testing($tests);
507a68aa 550
ad46c0be 551__DATA__
b8346d05
KW
552# TODO [perl #120950] This succeeds when run a 2nd time
553# y/uni/code/
554tr/\x{345}/\x{370}/;
555####
556# y/uni/code/ [perl #120950] This 2nd instance succeeds
557tr/\x{345}/\x{370}/;
558####
507a68aa 559# A constant
ad46c0be
RH
5601;
561####
507a68aa 562# Constants in a block
f5b5c2a3 563# CONTEXT no warnings;
ad46c0be 564{
ad46c0be
RH
565 '???';
566 2;
567}
568####
40ced2f4
FC
569# List of constants in void context
570# CONTEXT no warnings;
571(1,2,3);
5720;
573>>>>
574'???', '???', '???';
5750;
576####
507a68aa 577# Lexical and simple arithmetic
ad46c0be
RH
578my $test;
579++$test and $test /= 2;
580>>>>
581my $test;
582$test /= 2 if ++$test;
583####
507a68aa 584# list x
ad46c0be
RH
585-((1, 2) x 2);
586####
6a861075
FC
587# Assignment to list x
588((undef) x 3) = undef;
589####
507a68aa 590# lvalue sub
ad46c0be
RH
591{
592 my $test = sub : lvalue {
593 my $x;
594 }
595 ;
596}
597####
507a68aa 598# method
ad46c0be
RH
599{
600 my $test = sub : method {
601 my $x;
602 }
603 ;
604}
605####
6b6b21da
FC
606# anonsub attrs at statement start
607my $x = do { +sub : lvalue { my $y; } };
608my $z = do { foo: +sub : method { my $a; } };
609####
507a68aa 610# block with continue
87a42246 611{
ad46c0be 612 234;
f99a63a2 613}
ad46c0be
RH
614continue {
615 123;
87a42246 616}
ce4e655d 617####
507a68aa 618# lexical and package scalars
ce4e655d
RH
619my $x;
620print $main::x;
621####
507a68aa 622# lexical and package arrays
ce4e655d
RH
623my @x;
624print $main::x[1];
0ed5b3c8 625print \my @a;
14a55f98 626####
507a68aa 627# lexical and package hashes
14a55f98
RH
628my %x;
629$x{warn()};
ad8caead 630####
66786896
FC
631# our (LIST)
632our($foo, $bar, $baz);
633####
56cd2ef8
FC
634# CONTEXT { package Dog } use feature "state";
635# variables with declared classes
636my Dog $spot;
637our Dog $spotty;
638state Dog $spotted;
639my Dog @spot;
640our Dog @spotty;
641state Dog @spotted;
642my Dog %spot;
643our Dog %spotty;
644state Dog %spotted;
645my Dog ($foo, @bar, %baz);
646our Dog ($phoo, @barr, %bazz);
647state Dog ($fough, @barre, %bazze);
648####
f3515641
FC
649# local our
650local our $rhubarb;
5f4d8496 651local our($rhu, $barb);
f3515641 652####
507a68aa 653# <>
ad8caead 654my $foo;
18371617
LM
655$_ .= <> . <ARGV> . <$foo>;
656<$foo>;
657<${foo}>;
658<$ foo>;
659>>>>
660my $foo;
661$_ .= readline(ARGV) . readline(ARGV) . readline($foo);
662readline $foo;
663glob $foo;
664glob $foo;
cef22867 665####
9cef6114
FC
666# readline
667readline 'FH';
668readline *$_;
18371617
LM
669readline *{$_};
670readline ${"a"};
671>>>>
672readline 'FH';
673readline *$_;
9cef6114 674readline *{$_;};
18371617 675readline ${'a';};
9cef6114 676####
2fcbb74a
FC
677# <<>>
678$_ = <<>>;
679####
507a68aa 680# \x{}
11454c59 681my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
2a43599b 682my $bar = "\x{100}";
4ae52e81 683####
2d5b99ed
FC
684# Latin-1 chars
685# TODO ? ord("A") != 65 && "EBCDIC"
686my $baz = "B\366\x{100}";
687my $bba = qr/B\366\x{100}/;
688####
507a68aa 689# s///e
4ae52e81 690s/x/'y';/e;
ef90d20a
FC
691s/x/$a;/e;
692s/x/complex_expression();/e;
241416b8 693####
507a68aa 694# block
241416b8
DM
695{ my $x; }
696####
507a68aa 697# while 1
241416b8
DM
698while (1) { my $k; }
699####
507a68aa 700# trailing for
241416b8
DM
701my ($x,@a);
702$x=1 for @a;
703>>>>
704my($x, @a);
0bb5f065 705$x = 1 foreach (@a);
241416b8 706####
507a68aa 707# 2 arguments in a 3 argument for
241416b8
DM
708for (my $i = 0; $i < 2;) {
709 my $z = 1;
710}
711####
507a68aa 712# 3 argument for
241416b8
DM
713for (my $i = 0; $i < 2; ++$i) {
714 my $z = 1;
715}
716####
507a68aa 717# 3 argument for again
241416b8
DM
718for (my $i = 0; $i < 2; ++$i) {
719 my $z = 1;
720}
721####
22584011
FC
722# 3-argument for with inverted condition
723for (my $i; not $i;) {
724 die;
725}
726for (my $i; not $i; ++$i) {
727 die;
728}
88a758b5
FC
729for (my $a; not +($1 || 2) ** 2;) {
730 die;
731}
22584011
FC
732Something_to_put_the_loop_in_void_context();
733####
507a68aa 734# while/continue
241416b8
DM
735my $i;
736while ($i) { my $z = 1; } continue { $i = 99; }
737####
507a68aa 738# foreach with my
09d856fb 739foreach my $i (1, 2) {
241416b8
DM
740 my $z = 1;
741}
742####
4da9a2ca
FC
743# OPTIONS -p
744# foreach with my under -p
745foreach my $i (1) {
746 die;
747}
748####
507a68aa 749# foreach
241416b8
DM
750my $i;
751foreach $i (1, 2) {
752 my $z = 1;
753}
754####
507a68aa 755# foreach, 2 mys
241416b8
DM
756my $i;
757foreach my $i (1, 2) {
758 my $z = 1;
759}
760####
507a68aa 761# foreach with our
241416b8
DM
762foreach our $i (1, 2) {
763 my $z = 1;
764}
765####
507a68aa 766# foreach with my and our
241416b8
DM
767my $i;
768foreach our $i (1, 2) {
769 my $z = 1;
770}
3ac6e0f9 771####
bcff4148
FC
772# foreach with state
773# CONTEXT use feature "state";
774foreach state $i (1, 2) {
775 state $z = 1;
776}
777####
bba4f5ff
FC
778# foreach with sub call
779foreach $_ (hcaerof()) {
780 ();
781}
782####
507a68aa 783# reverse sort
3ac6e0f9
RGS
784my @x;
785print reverse sort(@x);
786####
507a68aa 787# sort with cmp
3ac6e0f9
RGS
788my @x;
789print((sort {$b cmp $a} @x));
790####
507a68aa 791# reverse sort with block
3ac6e0f9
RGS
792my @x;
793print((reverse sort {$b <=> $a} @x));
36d57d93 794####
507a68aa 795# foreach reverse
36d57d93
RGS
796our @a;
797print $_ foreach (reverse @a);
aae53c41 798####
507a68aa 799# foreach reverse (not inplace)
aae53c41
RGS
800our @a;
801print $_ foreach (reverse 1, 2..5);
f86ea535 802####
507a68aa 803# bug #38684
f86ea535
SM
804our @ary;
805@ary = split(' ', 'foo', 0);
31c6271a 806####
5012eebe
DM
807my @ary;
808@ary = split(' ', 'foo', 0);
809####
de183bbb
FC
810# Split to our array
811our @array = split(//, 'foo', 0);
812####
ef7999f1
FC
813# Split to my array
814my @array = split(//, 'foo', 0);
815####
5012eebe
DM
816our @array;
817my $c;
818@array = split(/x(?{ $c++; })y/, 'foo', 0);
819####
820my($x, $y, $p);
821our $c;
822($x, $y) = split(/$p(?{ $c++; })y/, 'foo', 2);
823####
824our @ary;
825my $pat;
826@ary = split(/$pat/, 'foo', 0);
827####
828my @ary;
829our $pat;
830@ary = split(/$pat/, 'foo', 0);
831####
832our @array;
833my $pat;
834local @array = split(/$pat/, 'foo', 0);
835####
836our $pat;
837my @array = split(/$pat/, 'foo', 0);
838####
507a68aa 839# bug #40055
31c6271a
RD
840do { () };
841####
507a68aa 842# bug #40055
31c6271a 843do { my $x = 1; $x };
d9002312 844####
507a68aa 845# <20061012113037.GJ25805@c4.convolution.nl>
d9002312
SM
846my $f = sub {
847 +{[]};
848} ;
8b2d6640 849####
507a68aa 850# bug #43010
8b2d6640
FC
851'!@$%'->();
852####
507a68aa 853# bug #43010
8b2d6640
FC
854::();
855####
507a68aa 856# bug #43010
8b2d6640
FC
857'::::'->();
858####
507a68aa 859# bug #43010
8b2d6640 860&::::;
09d856fb 861####
1b38d782
FC
862# [perl #77172]
863package rt77172;
864sub foo {} foo & & & foo;
865>>>>
866package rt77172;
867foo(&{&} & foo());
868####
507a68aa 869# variables as method names
09d856fb
CK
870my $bar;
871'Foo'->$bar('orz');
35a99a08 872'Foo'->$bar('orz') = 'a stranger stranger than before';
09d856fb 873####
507a68aa 874# constants as method names
09d856fb
CK
875'Foo'->bar('orz');
876####
507a68aa 877# constants as method names without ()
09d856fb 878'Foo'->bar;
0ced6c29 879####
28bfcb02 880# [perl #47359] "indirect" method call notation
1bf8bbb0
FC
881our @bar;
882foo{@bar}+1,->foo;
883(foo{@bar}+1),foo();
884foo{@bar}1 xor foo();
885>>>>
886our @bar;
887(foo { @bar } 1)->foo;
888(foo { @bar } 1), foo();
889foo { @bar } 1 xor foo();
890####
9d52f6f3
FC
891# indirops with blocks
892# CONTEXT use 5.01;
893print {*STDOUT;} 'foo';
894printf {*STDOUT;} 'foo';
895say {*STDOUT;} 'foo';
896system {'foo';} '-foo';
897exec {'foo';} '-foo';
898####
e9c69003 899# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
205fef88 900# CONTEXT use feature ':5.10';
507a68aa 901# say
7ddd1a01
NC
902say 'foo';
903####
8f57bb34 904# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
8f57bb34
NC
905# CONTEXT use 5.10.0;
906# say in the context of use 5.10.0
907say 'foo';
908####
909# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
8f57bb34
NC
910# say with use 5.10.0
911use 5.10.0;
912say 'foo';
913>>>>
127ce1cd 914no feature ':all';
8f57bb34
NC
915use feature ':5.10';
916say 'foo';
917####
918# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
919# say with use feature ':5.10';
920use feature ':5.10';
921say 'foo';
922>>>>
923use feature 'say', 'state', 'switch';
924say 'foo';
925####
926# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
8f57bb34
NC
927# CONTEXT use feature ':5.10';
928# say with use 5.10.0 in the context of use feature
929use 5.10.0;
930say 'foo';
931>>>>
127ce1cd 932no feature ':all';
8f57bb34
NC
933use feature ':5.10';
934say 'foo';
935####
936# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
937# CONTEXT use 5.10.0;
938# say with use feature ':5.10' in the context of use 5.10.0
939use feature ':5.10';
940say 'foo';
941>>>>
942say 'foo';
943####
944# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
945# CONTEXT use feature ':5.15';
946# __SUB__
947__SUB__;
948####
949# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
8f57bb34
NC
950# CONTEXT use 5.15.0;
951# __SUB__ in the context of use 5.15.0
952__SUB__;
953####
954# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
8f57bb34
NC
955# __SUB__ with use 5.15.0
956use 5.15.0;
957__SUB__;
958>>>>
127ce1cd 959no feature ':all';
8f57bb34
NC
960use feature ':5.16';
961__SUB__;
962####
963# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
964# __SUB__ with use feature ':5.15';
965use feature ':5.15';
966__SUB__;
967>>>>
968use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval';
969__SUB__;
970####
971# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
8f57bb34
NC
972# CONTEXT use feature ':5.15';
973# __SUB__ with use 5.15.0 in the context of use feature
974use 5.15.0;
975__SUB__;
976>>>>
127ce1cd 977no feature ':all';
8f57bb34
NC
978use feature ':5.16';
979__SUB__;
980####
981# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
982# CONTEXT use 5.15.0;
983# __SUB__ with use feature ':5.15' in the context of use 5.15.0
984use feature ':5.15';
985__SUB__;
986>>>>
987__SUB__;
988####
e9c69003 989# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
205fef88 990# CONTEXT use feature ':5.10';
507a68aa 991# state vars
0ced6c29
RGS
992state $x = 42;
993####
e9c69003 994# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
205fef88 995# CONTEXT use feature ':5.10';
507a68aa 996# state var assignment
7ddd1a01
NC
997{
998 my $y = (state $x = 42);
999}
1000####
e9c69003 1001# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
205fef88 1002# CONTEXT use feature ':5.10';
c4a6f826 1003# state vars in anonymous subroutines
7ddd1a01
NC
1004$a = sub {
1005 state $x;
1006 return $x++;
1007}
1008;
644741fd
NC
1009####
1010# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
507a68aa 1011# each @array;
644741fd
NC
1012each @ARGV;
1013each @$a;
1014####
1015# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
507a68aa 1016# keys @array; values @array
644741fd
NC
1017keys @$a if keys @ARGV;
1018values @ARGV if values @$a;
35925e80 1019####
507a68aa 1020# Anonymous arrays and hashes, and references to them
35925e80
RGS
1021my $a = {};
1022my $b = \{};
1023my $c = [];
1024my $d = \[];
9210de83
FR
1025####
1026# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
0f539b13 1027# CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
507a68aa 1028# implicit smartmatch in given/when
9210de83
FR
1029given ('foo') {
1030 when ('bar') { continue; }
1031 when ($_ ~~ 'quux') { continue; }
1032 default { 0; }
1033}
7ecdd211 1034####
507a68aa 1035# conditions in elsifs (regression in change #33710 which fixed bug #37302)
7ecdd211
PJ
1036if ($a) { x(); }
1037elsif ($b) { x(); }
1038elsif ($a and $b) { x(); }
1039elsif ($a or $b) { x(); }
1040else { x(); }
03b22f1b 1041####
507a68aa 1042# interpolation in regexps
03b22f1b
RGS
1043my($y, $t);
1044/x${y}z$t/;
227375e1 1045####
4a4b8592 1046# TODO new undocumented cpan-bug #33708
507a68aa 1047# cpan-bug #33708
227375e1
RU
1048%{$_ || {}}
1049####
4a4b8592 1050# TODO hash constants not yet fixed
507a68aa 1051# cpan-bug #33708
227375e1
RU
1052use constant H => { "#" => 1 }; H->{"#"}
1053####
4a4b8592 1054# TODO optimized away 0 not yet fixed
507a68aa 1055# cpan-bug #33708
227375e1 1056foreach my $i (@_) { 0 }
edbe35ea 1057####
507a68aa 1058# tests with not, not optimized
07f3cdf5 1059my $c;
edbe35ea
VP
1060x() unless $a;
1061x() if not $a and $b;
1062x() if $a and not $b;
1063x() unless not $a and $b;
1064x() unless $a and not $b;
1065x() if not $a or $b;
1066x() if $a or not $b;
1067x() unless not $a or $b;
1068x() unless $a or not $b;
07f3cdf5
VP
1069x() if $a and not $b and $c;
1070x() if not $a and $b and not $c;
1071x() unless $a and not $b and $c;
1072x() unless not $a and $b and not $c;
1073x() if $a or not $b or $c;
1074x() if not $a or $b or not $c;
1075x() unless $a or not $b or $c;
1076x() unless not $a or $b or not $c;
edbe35ea 1077####
507a68aa 1078# tests with not, optimized
07f3cdf5 1079my $c;
edbe35ea
VP
1080x() if not $a;
1081x() unless not $a;
1082x() if not $a and not $b;
1083x() unless not $a and not $b;
1084x() if not $a or not $b;
1085x() unless not $a or not $b;
07f3cdf5
VP
1086x() if not $a and not $b and $c;
1087x() unless not $a and not $b and $c;
1088x() if not $a or not $b or $c;
1089x() unless not $a or not $b or $c;
1090x() if not $a and not $b and not $c;
1091x() unless not $a and not $b and not $c;
1092x() if not $a or not $b or not $c;
1093x() unless not $a or not $b or not $c;
1094x() unless not $a or not $b or not $c;
edbe35ea 1095>>>>
07f3cdf5 1096my $c;
edbe35ea
VP
1097x() unless $a;
1098x() if $a;
1099x() unless $a or $b;
1100x() if $a or $b;
1101x() unless $a and $b;
07f3cdf5
VP
1102x() if $a and $b;
1103x() if not $a || $b and $c;
1104x() unless not $a || $b and $c;
1105x() if not $a && $b or $c;
1106x() unless not $a && $b or $c;
1107x() unless $a or $b or $c;
1108x() if $a or $b or $c;
1109x() unless $a and $b and $c;
1110x() if $a and $b and $c;
1111x() unless not $a && $b && $c;
71c4dbc3 1112####
507a68aa 1113# tests that should be constant folded
71c4dbc3
VP
1114x() if 1;
1115x() if GLIPP;
1116x() if !GLIPP;
1117x() if GLIPP && GLIPP;
1118x() if !GLIPP || GLIPP;
1119x() if do { GLIPP };
1120x() if do { no warnings 'void'; 5; GLIPP };
1121x() if do { !GLIPP };
1122if (GLIPP) { x() } else { z() }
1123if (!GLIPP) { x() } else { z() }
1124if (GLIPP) { x() } elsif (GLIPP) { z() }
1125if (!GLIPP) { x() } elsif (GLIPP) { z() }
1126if (GLIPP) { x() } elsif (!GLIPP) { z() }
1127if (!GLIPP) { x() } elsif (!GLIPP) { z() }
1128if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
1129if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
1130if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
1131>>>>
1132x();
1133x();
1134'???';
1135x();
1136x();
1137x();
1138x();
1139do {
1140 '???'
1141};
1142do {
1143 x()
1144};
1145do {
1146 z()
1147};
1148do {
1149 x()
1150};
1151do {
1152 z()
1153};
1154do {
1155 x()
1156};
1157'???';
1158do {
1159 t()
1160};
1161'???';
1162!1;
1163####
719c50dc
RGS
1164# TODO constant deparsing has been backed out for 5.12
1165# XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
507a68aa 1166# tests that shouldn't be constant folded
ac0f1413
NC
1167# It might be fundamentally impossible to make this work on ithreads, in which
1168# case the TODO should become a SKIP
71c4dbc3
VP
1169x() if $a;
1170if ($a == 1) { x() } elsif ($b == 2) { z() }
1171if (do { foo(); GLIPP }) { x() }
1172if (do { $a++; GLIPP }) { x() }
1173>>>>
1174x() if $a;
1175if ($a == 1) { x(); } elsif ($b == 2) { z(); }
2990415a
FR
1176if (do { foo(); GLIPP }) { x(); }
1177if (do { ++$a; GLIPP }) { x(); }
1178####
0fa4a265 1179# TODO constant deparsing has been backed out for 5.12
507a68aa 1180# tests for deparsing constants
2990415a
FR
1181warn PI;
1182####
0fa4a265 1183# TODO constant deparsing has been backed out for 5.12
507a68aa 1184# tests for deparsing imported constants
3779476a 1185warn O_TRUNC;
2990415a 1186####
0fa4a265 1187# TODO constant deparsing has been backed out for 5.12
507a68aa 1188# tests for deparsing re-exported constants
2990415a
FR
1189warn O_CREAT;
1190####
0fa4a265 1191# TODO constant deparsing has been backed out for 5.12
507a68aa 1192# tests for deparsing imported constants that got deleted from the original namespace
aaf9c2b2 1193warn O_APPEND;
2990415a 1194####
0fa4a265
DM
1195# TODO constant deparsing has been backed out for 5.12
1196# XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
507a68aa 1197# tests for deparsing constants which got turned into full typeglobs
ac0f1413
NC
1198# It might be fundamentally impossible to make this work on ithreads, in which
1199# case the TODO should become a SKIP
2990415a
FR
1200warn O_EXCL;
1201eval '@Fcntl::O_EXCL = qw/affe tiger/;';
1202warn O_EXCL;
1203####
0fa4a265 1204# TODO constant deparsing has been backed out for 5.12
507a68aa 1205# tests for deparsing of blessed constant with overloaded numification
2990415a 1206warn OVERLOADED_NUMIFICATION;
79289e05 1207####
507a68aa 1208# strict
79289e05 1209no strict;
415d4c68
FC
1210print $x;
1211use strict 'vars';
1212print $main::x;
1213use strict 'subs';
1214print $main::x;
1215use strict 'refs';
1216print $main::x;
1217no strict 'vars';
79289e05
NC
1218$x;
1219####
1220# TODO Subsets of warnings could be encoded textually, rather than as bitflips.
507a68aa 1221# subsets of warnings
79289e05
NC
1222no warnings 'deprecated';
1223my $x;
1224####
1225# TODO Better test for CPAN #33708 - the deparsed code has different behaviour
507a68aa 1226# CPAN #33708
79289e05
NC
1227use strict;
1228no warnings;
1229
1230foreach (0..3) {
1231 my $x = 2;
1232 {
1233 my $x if 0;
1234 print ++$x, "\n";
1235 }
1236}
d83f38d8 1237####
507a68aa 1238# no attribute list
d83f38d8
NC
1239my $pi = 4;
1240####
2dc78664
NC
1241# SKIP ?$] > 5.013006 && ":= is now a syntax error"
1242# := treated as an empty attribute list
d83f38d8
NC
1243no warnings;
1244my $pi := 4;
1245>>>>
1246no warnings;
1247my $pi = 4;
1248####
507a68aa 1249# : = empty attribute list
d83f38d8
NC
1250my $pi : = 4;
1251>>>>
1252my $pi = 4;
689e417f 1253####
507a68aa 1254# in place sort
689e417f
VP
1255our @a;
1256my @b;
1257@a = sort @a;
1258@b = sort @b;
1259();
1260####
507a68aa 1261# in place reverse
689e417f
VP
1262our @a;
1263my @b;
1264@a = reverse @a;
1265@b = reverse @b;
1266();
06fc6867 1267####
507a68aa 1268# #71870 Use of uninitialized value in bitwise and B::Deparse
06fc6867
VP
1269my($r, $s, @a);
1270@a = split(/foo/, $s, 0);
1271$r = qr/foo/;
1272@a = split(/$r/, $s, 0);
1273();
98a1a137 1274####
507a68aa 1275# package declaration before label
98a1a137
Z
1276{
1277 package Foo;
1278 label: print 123;
1279}
538f5756 1280####
507a68aa 1281# shift optimisation
538f5756
RZ
1282shift;
1283>>>>
1284shift();
1285####
507a68aa 1286# shift optimisation
538f5756
RZ
1287shift @_;
1288####
507a68aa 1289# shift optimisation
538f5756
RZ
1290pop;
1291>>>>
1292pop();
1293####
507a68aa 1294# shift optimisation
538f5756 1295pop @_;
a539498a 1296####
507a68aa 1297#[perl #20444]
a539498a
FC
1298"foo" =~ (1 ? /foo/ : /bar/);
1299"foo" =~ (1 ? y/foo// : /bar/);
5e5a1632 1300"foo" =~ (1 ? y/foo//r : /bar/);
a539498a
FC
1301"foo" =~ (1 ? s/foo// : /bar/);
1302>>>>
1303'foo' =~ ($_ =~ /foo/);
1304'foo' =~ ($_ =~ tr/fo//);
5e5a1632 1305'foo' =~ ($_ =~ tr/fo//r);
a539498a 1306'foo' =~ ($_ =~ s/foo//);
e0ab66ad 1307####
5e5a1632
FC
1308# The fix for [perl #20444] broke this.
1309'foo' =~ do { () };
1310####
4b58603b
FC
1311# [perl #81424] match against aelemfast_lex
1312my @s;
1313print /$s[1]/;
1314####
36727b53
FC
1315# /$#a/
1316print /$#main::a/;
1317####
bae5b54e
FC
1318# /@array/
1319our @a;
1320my @b;
1321print /@a/;
1322print /@b/;
1323print qr/@a/;
1324print qr/@b/;
1325####
3b91d897
FC
1326# =~ QR_CONSTANT
1327use constant QR_CONSTANT => qr/a/soupmix;
1328'' =~ QR_CONSTANT;
1329>>>>
1330'' =~ /a/impsux;
1331####
9e32885a
FC
1332# $lexical =~ //
1333my $x;
1334$x =~ //;
1335####
b9bc576f 1336# [perl #91318] /regexp/applaud
09622ee2
FC
1337print /a/a, s/b/c/a;
1338print /a/aa, s/b/c/aa;
1339print /a/p, s/b/c/p;
1340print /a/l, s/b/c/l;
1341print /a/u, s/b/c/u;
b9bc576f
FC
1342{
1343 use feature "unicode_strings";
09622ee2 1344 print /a/d, s/b/c/d;
b9bc576f
FC
1345}
1346{
1347 use re "/u";
09622ee2 1348 print /a/d, s/b/c/d;
b9bc576f 1349}
dff5ffe4
FC
1350{
1351 use 5.012;
1352 print /a/d, s/b/c/d;
1353}
b9bc576f 1354>>>>
09622ee2
FC
1355print /a/a, s/b/c/a;
1356print /a/aa, s/b/c/aa;
1357print /a/p, s/b/c/p;
1358print /a/l, s/b/c/l;
1359print /a/u, s/b/c/u;
b9bc576f 1360{
a8095af7 1361 use feature 'unicode_strings';
09622ee2 1362 print /a/d, s/b/c/d;
b9bc576f
FC
1363}
1364{
0bb01b05
FC
1365 BEGIN { $^H{'reflags'} = '0';
1366 $^H{'reflags_charset'} = '2'; }
09622ee2 1367 print /a/d, s/b/c/d;
b9bc576f 1368}
dff5ffe4 1369{
127ce1cd 1370 no feature ':all';
dff5ffe4
FC
1371 use feature ':5.12';
1372 print /a/d, s/b/c/d;
1373}
b9bc576f 1374####
dc6dfd62
LM
1375# all the flags (qr//)
1376$_ = qr/X/m;
1377$_ = qr/X/s;
1378$_ = qr/X/i;
1379$_ = qr/X/x;
1380$_ = qr/X/p;
1381$_ = qr/X/o;
1382$_ = qr/X/u;
1383$_ = qr/X/a;
1384$_ = qr/X/l;
1385$_ = qr/X/n;
1386####
1387use feature 'unicode_strings';
1388$_ = qr/X/d;
1389####
1390# all the flags (m//)
1391/X/m;
1392/X/s;
1393/X/i;
1394/X/x;
1395/X/p;
1396/X/o;
1397/X/u;
1398/X/a;
1399/X/l;
1400/X/n;
1401/X/g;
1402/X/cg;
1403####
1404use feature 'unicode_strings';
1405/X/d;
1406####
1407# all the flags (s///)
1408s/X//m;
1409s/X//s;
1410s/X//i;
1411s/X//x;
1412s/X//p;
1413s/X//o;
1414s/X//u;
1415s/X//a;
1416s/X//l;
1417s/X//n;
1418s/X//g;
1419s/X/'';/e;
1420s/X//r;
1421####
1422use feature 'unicode_strings';
1423s/X//d;
1424####
1425# all the flags (tr///)
1426tr/X/Y/c;
1427tr/X//d;
1428tr/X//s;
1429tr/X//r;
1430####
9f125c4a
FC
1431# [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
1432s/foo/\(3);/eg;
1433####
c9fa6ae9 1434# [perl #115256]
c9fa6ae9
FC
1435"" =~ /a(?{ print q|
1436|})/;
1437>>>>
f6b6ee63 1438'' =~ /a(?{ print "\n"; })/;
c9fa6ae9
FC
1439####
1440# [perl #123217]
c9fa6ae9
FC
1441$_ = qr/(??{<<END})/
1442f.o
1443b.r
1444END
1445>>>>
1446$_ = qr/(??{ "f.o\nb.r\n"; })/;
1447####
1448# More regexp code block madness
c9fa6ae9
FC
1449my($b, @a);
1450/(?{ die $b; })/;
1451/a(?{ die $b; })a/;
1452/$a(?{ die $b; })/;
1453/@a(?{ die $b; })/;
1454/(??{ die $b; })/;
1455/a(??{ die $b; })a/;
1456/$a(??{ die $b; })/;
1457/@a(??{ die $b; })/;
1458qr/(?{ die $b; })/;
1459qr/a(?{ die $b; })a/;
1460qr/$a(?{ die $b; })/;
1461qr/@a(?{ die $b; })/;
1462qr/(??{ die $b; })/;
1463qr/a(??{ die $b; })a/;
1464qr/$a(??{ die $b; })/;
1465qr/@a(??{ die $b; })/;
1466s/(?{ die $b; })//;
1467s/a(?{ die $b; })a//;
1468s/$a(?{ die $b; })//;
1469s/@a(?{ die $b; })//;
1470s/(??{ die $b; })//;
1471s/a(??{ die $b; })a//;
1472s/$a(??{ die $b; })//;
1473s/@a(??{ die $b; })//;
1474####
ba0372a0
FC
1475# /(?x)<newline><tab>/
1476/(?x)
1477 /;
1478####
e7afc405 1479# y///r
d52196e1 1480tr/a/b/r + $a =~ tr/p/q/r;
cb8157e3 1481####
12cea2fa
FC
1482# y///d in list [perl #119815]
1483() = tr/a//d;
1484####
cb8578ff 1485# [perl #90898]
f4002a4b 1486<a,>;
18371617
LM
1487glob 'a,';
1488>>>>
1489glob 'a,';
1490glob 'a,';
09dcfa7d
FC
1491####
1492# [perl #91008]
26230909 1493# SKIP ?$] >= 5.023 && "autoderef deleted in this Perl version"
d401967c 1494# CONTEXT no warnings 'experimental::autoderef';
09dcfa7d
FC
1495each $@;
1496keys $~;
1497values $!;
5d8c42c2
FC
1498####
1499# readpipe with complex expression
1500readpipe $a + $b;
93bad3fd
NC
1501####
1502# aelemfast
1503$b::a[0] = 1;
1504####
1505# aelemfast for a lexical
1506my @a;
1507$a[0] = 1;
80e3f4ad
FC
1508####
1509# feature features without feature
0f539b13 1510# CONTEXT no warnings 'experimental::smartmatch';
80e3f4ad 1511CORE::state $x;
223b1722
FC
1512CORE::say $x;
1513CORE::given ($x) {
1514 CORE::when (3) {
1515 continue;
1516 }
1517 CORE::default {
1518 CORE::break;
1519 }
1520}
1521CORE::evalbytes '';
1522() = CORE::__SUB__;
838f2281 1523() = CORE::fc $x;
223b1722
FC
1524####
1525# feature features when feature has been disabled by use VERSION
0f539b13 1526# CONTEXT no warnings 'experimental::smartmatch';
223b1722
FC
1527use feature (sprintf(":%vd", $^V));
1528use 1;
412989c2 1529CORE::say $_;
223b1722 1530CORE::state $x;
223b1722
FC
1531CORE::given ($x) {
1532 CORE::when (3) {
1533 continue;
1534 }
1535 CORE::default {
1536 CORE::break;
1537 }
1538}
1539CORE::evalbytes '';
1540() = CORE::__SUB__;
1541>>>>
412989c2 1542CORE::say $_;
205fef88 1543CORE::state $x;
205fef88
NC
1544CORE::given ($x) {
1545 CORE::when (3) {
1546 continue;
1547 }
1548 CORE::default {
1549 CORE::break;
1550 }
1551}
1552CORE::evalbytes '';
1553() = CORE::__SUB__;
1554####
1555# (the above test with CONTEXT, and the output is equivalent but different)
0f539b13 1556# CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
205fef88
NC
1557# feature features when feature has been disabled by use VERSION
1558use feature (sprintf(":%vd", $^V));
1559use 1;
412989c2 1560CORE::say $_;
205fef88 1561CORE::state $x;
205fef88
NC
1562CORE::given ($x) {
1563 CORE::when (3) {
1564 continue;
1565 }
1566 CORE::default {
1567 CORE::break;
1568 }
1569}
1570CORE::evalbytes '';
1571() = CORE::__SUB__;
1572>>>>
127ce1cd 1573no feature ':all';
0bb01b05 1574use feature ':default';
412989c2 1575CORE::say $_;
223b1722 1576CORE::state $x;
80e3f4ad
FC
1577CORE::given ($x) {
1578 CORE::when (3) {
1579 continue;
1580 }
1581 CORE::default {
e36901c8 1582 CORE::break;
80e3f4ad
FC
1583 }
1584}
7d789282 1585CORE::evalbytes '';
84ed0108 1586() = CORE::__SUB__;
6ec73527 1587####
7741ceed
FC
1588# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1589# lexical subroutines and keywords of the same name
1590# CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental';
1591my sub default;
1592my sub else;
1593my sub elsif;
1594my sub for;
1595my sub foreach;
1596my sub given;
1597my sub if;
1598my sub m;
1599my sub no;
1600my sub package;
1601my sub q;
1602my sub qq;
1603my sub qr;
1604my sub qx;
1605my sub require;
1606my sub s;
1607my sub sub;
1608my sub tr;
1609my sub unless;
1610my sub until;
1611my sub use;
1612my sub when;
1613my sub while;
1614CORE::default { die; }
1615CORE::if ($1) { die; }
1616CORE::if ($1) { die; }
1617CORE::elsif ($1) { die; }
1618CORE::else { die; }
1619CORE::for (die; $1; die) { die; }
1620CORE::foreach $_ (1 .. 10) { die; }
1621die CORE::foreach (1);
1622CORE::given ($1) { die; }
1623CORE::m[/];
1624CORE::m?/?;
1625CORE::package foo;
1626CORE::no strict;
1627() = (CORE::q['], CORE::qq["$_], CORE::qr//, CORE::qx[`]);
1628CORE::require 1;
1629CORE::s///;
1630() = CORE::sub { die; } ;
1631CORE::tr///;
1632CORE::unless ($1) { die; }
1633CORE::until ($1) { die; }
1634die CORE::until $1;
1635CORE::use strict;
1636CORE::when ($1 ~~ $2) { die; }
1637CORE::while ($1) { die; }
1638die CORE::while $1;
1639####
0bb01b05
FC
1640# Feature hints
1641use feature 'current_sub', 'evalbytes';
1642print;
1643use 1;
1644print;
1645use 5.014;
1646print;
1647no feature 'unicode_strings';
1648print;
1649>>>>
a8095af7 1650use feature 'current_sub', 'evalbytes';
0bb01b05 1651print $_;
127ce1cd 1652no feature ':all';
0bb01b05
FC
1653use feature ':default';
1654print $_;
127ce1cd 1655no feature ':all';
0bb01b05
FC
1656use feature ':5.12';
1657print $_;
a8095af7 1658no feature 'unicode_strings';
0bb01b05
FC
1659print $_;
1660####
6ec73527
FC
1661# $#- $#+ $#{%} etc.
1662my @x;
5b6da579 1663@x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
6ec73527
FC
1664@x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
1665@x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
b6bba886 1666@x = ($#{;}, $#{:}, $#{1}), $#_;
61154ac0 1667####
ff683671
NC
1668# ${#} interpolated
1669# It's a known TODO that warnings are deparsed as bits, not textually.
1670no warnings;
61154ac0 1671() = "${#}a";
958ed56b 1672####
337d7381
FC
1673# [perl #86060] $( $| $) in regexps need braces
1674/${(}/;
1675/${|}/;
1676/${)}/;
1677/${(}${|}${)}/;
3f193e55 1678/@{+}@{-}/;
337d7381 1679####
958ed56b
FC
1680# ()[...]
1681my(@a) = ()[()];
521795fe
FC
1682####
1683# sort(foo(bar))
1684# sort(foo(bar)) is interpreted as sort &foo(bar)
1685# sort foo(bar) is interpreted as sort foo bar
1686# parentheses are not optional in this case
1687print sort(foo('bar'));
1688>>>>
1689print sort(foo('bar'));
24fcb59f
FC
1690####
1691# substr assignment
1692substr(my $a, 0, 0) = (foo(), bar());
1693$a++;
04be0204 1694####
d1718a7c
FC
1695# This following line works around an unfixed bug that we are not trying to
1696# test for here:
1697# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
04be0204
FC
1698# hint hash
1699BEGIN { $^H{'foo'} = undef; }
1700{
1701 BEGIN { $^H{'bar'} = undef; }
1702 {
1703 BEGIN { $^H{'baz'} = undef; }
1704 {
1705 print $_;
1706 }
1707 print $_;
1708 }
1709 print $_;
1710}
035146a3
FC
1711BEGIN { $^H{q[']} = '('; }
1712print $_;
c306e834 1713####
d1718a7c
FC
1714# This following line works around an unfixed bug that we are not trying to
1715# test for here:
1716# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
c306e834
FC
1717# hint hash changes that serialise the same way with sort %hh
1718BEGIN { $^H{'a'} = 'b'; }
1719{
1720 BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
1721 print $_;
1722}
1723print $_;
94bb57f9
FC
1724####
1725# [perl #47361] do({}) and do +{} (variants of do-file)
1726do({});
1727do +{};
8b46c09b
FC
1728sub foo::do {}
1729package foo;
1730CORE::do({});
1731CORE::do +{};
94bb57f9
FC
1732>>>>
1733do({});
1734do({});
8b46c09b
FC
1735package foo;
1736CORE::do({});
1737CORE::do({});
9c56d9ea
FC
1738####
1739# [perl #77096] functions that do not follow the llafr
1740() = (return 1) + time;
1741() = (return ($1 + $2) * $3) + time;
1742() = (return ($a xor $b)) + time;
1743() = (do 'file') + time;
1744() = (do ($1 + $2) * $3) + time;
1745() = (do ($1 xor $2)) + time;
41df74e3
FC
1746() = (goto 1) + 3;
1747() = (require 'foo') + 3;
1748() = (require foo) + 3;
266da325 1749() = (CORE::dump 1) + 3;
41df74e3
FC
1750() = (last 1) + 3;
1751() = (next 1) + 3;
1752() = (redo 1) + 3;
5830412d
FC
1753() = (-R $_) + 3;
1754() = (-W $_) + 3;
1755() = (-X $_) + 3;
1756() = (-r $_) + 3;
1757() = (-w $_) + 3;
1758() = (-x $_) + 3;
2462c3cc 1759####
917a8f4f
FC
1760# require(foo()) and do(foo())
1761require (foo());
1762do (foo());
df465735
FC
1763goto (foo());
1764CORE::dump (foo());
1765last (foo());
1766next (foo());
1767redo (foo());
917a8f4f 1768####
5e7acd25
FC
1769# require vstring
1770require v5.16;
1771####
1cabb3b3
FC
1772# [perl #97476] not() *does* follow the llafr
1773$_ = ($a xor not +($1 || 2) ** 2);
1774####
4d8ac5c7
FC
1775# Precedence conundrums with argument-less function calls
1776() = (eof) + 1;
1777() = (return) + 1;
1778() = (return, 1);
7bc8c979
FC
1779() = warn;
1780() = warn() + 1;
4d8ac5c7
FC
1781() = setpgrp() + 1;
1782####
1eb0b7be
FC
1783# loopexes have assignment prec
1784() = (CORE::dump a) | 'b';
1785() = (goto a) | 'b';
1786() = (last a) | 'b';
1787() = (next a) | 'b';
1788() = (redo a) | 'b';
1789####
2462c3cc
FC
1790# [perl #63558] open local(*FH)
1791open local *FH;
564cd6cb 1792pipe local *FH, local *FH;
843b15cc 1793####
b89b7257
FC
1794# [perl #91416] open "string"
1795open 'open';
1796open '####';
1797open '^A';
1798open "\ca";
1799>>>>
1800open *open;
1801open '####';
1802open '^A';
1803open *^A;
1804####
be6cf5cf
FC
1805# "string"->[] ->{}
1806no strict 'vars';
1807() = 'open'->[0]; #aelemfast
1808() = '####'->[0];
1809() = '^A'->[0];
1810() = "\ca"->[0];
b861b87f 1811() = 'a::]b'->[0];
10e8e32b
FC
1812() = 'open'->[$_]; #aelem
1813() = '####'->[$_];
1814() = '^A'->[$_];
1815() = "\ca"->[$_];
b861b87f 1816() = 'a::]b'->[$_];
10e8e32b
FC
1817() = 'open'->{0}; #helem
1818() = '####'->{0};
1819() = '^A'->{0};
1820() = "\ca"->{0};
b861b87f 1821() = 'a::]b'->{0};
be6cf5cf 1822>>>>
415d4c68 1823no strict 'vars';
be6cf5cf
FC
1824() = $open[0];
1825() = '####'->[0];
1826() = '^A'->[0];
1827() = $^A[0];
b861b87f 1828() = 'a::]b'->[0];
10e8e32b
FC
1829() = $open[$_];
1830() = '####'->[$_];
1831() = '^A'->[$_];
1832() = $^A[$_];
b861b87f 1833() = 'a::]b'->[$_];
10e8e32b
FC
1834() = $open{'0'};
1835() = '####'->{'0'};
1836() = '^A'->{'0'};
1837() = $^A{'0'};
b861b87f 1838() = 'a::]b'->{'0'};
be6cf5cf 1839####
843b15cc
FC
1840# [perl #74740] -(f()) vs -f()
1841$_ = -(f());
c75b4828
FC
1842####
1843# require <binop>
1844require 'a' . $1;
afb60448
HY
1845####
1846#[perl #30504] foreach-my postfix/prefix difference
1847$_ = 'foo' foreach my ($foo1, $bar1, $baz1);
1848foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' }
1849foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' }
1850>>>>
1851$_ = 'foo' foreach (my($foo1, $bar1, $baz1));
1852foreach $_ (my($foo2, $bar2, $baz2)) {
1853 $_ = 'foo';
1854}
1855foreach my $i (my($foo3, $bar3, $baz3)) {
1856 $i = 'foo';
1857}
1858####
1859#[perl #108224] foreach with continue block
1860foreach (1 .. 3) { print } continue { print "\n" }
1861foreach (1 .. 3) { } continue { }
1862foreach my $i (1 .. 3) { print $i } continue { print "\n" }
1863foreach my $i (1 .. 3) { } continue { }
1864>>>>
1865foreach $_ (1 .. 3) {
1866 print $_;
1867}
1868continue {
1869 print "\n";
1870}
1871foreach $_ (1 .. 3) {
1872 ();
1873}
1874continue {
1875 ();
1876}
1877foreach my $i (1 .. 3) {
1878 print $i;
1879}
1880continue {
1881 print "\n";
1882}
1883foreach my $i (1 .. 3) {
1884 ();
1885}
1886continue {
1887 ();
1888}
bc1cc2c3
DM
1889####
1890# file handles
1891no strict;
1892my $mfh;
1893open F;
1894open *F;
1895open $fh;
1896open $mfh;
1897open 'a+b';
1898select *F;
1899select F;
1900select $f;
1901select $mfh;
1902select 'a+b';
a7fd8ef6
DM
1903####
1904# 'my' works with padrange op
1905my($z, @z);
1906my $m1;
1907$m1 = 1;
1908$z = $m1;
1909my $m2 = 2;
1910my($m3, $m4);
1911($m3, $m4) = (1, 2);
1912@z = ($m3, $m4);
1913my($m5, $m6) = (1, 2);
1914my($m7, undef, $m8) = (1, 2, 3);
1915@z = ($m7, undef, $m8);
1916($m7, undef, $m8) = (1, 2, 3);
1917####
1918# 'our/local' works with padrange op
a7fd8ef6
DM
1919our($z, @z);
1920our $o1;
0298c760 1921no strict;
a7fd8ef6
DM
1922local $o11;
1923$o1 = 1;
1924local $o1 = 1;
1925$z = $o1;
1926$z = local $o1;
1927our $o2 = 2;
1928our($o3, $o4);
1929($o3, $o4) = (1, 2);
1930local($o3, $o4) = (1, 2);
1931@z = ($o3, $o4);
1932@z = local($o3, $o4);
1933our($o5, $o6) = (1, 2);
1934our($o7, undef, $o8) = (1, 2, 3);
1935@z = ($o7, undef, $o8);
1936@z = local($o7, undef, $o8);
1937($o7, undef, $o8) = (1, 2, 3);
1938local($o7, undef, $o8) = (1, 2, 3);
1939####
1940# 'state' works with padrange op
412989c2 1941# CONTEXT no strict; use feature 'state';
a7fd8ef6
DM
1942state($z, @z);
1943state $s1;
1944$s1 = 1;
1945$z = $s1;
1946state $s2 = 2;
1947state($s3, $s4);
1948($s3, $s4) = (1, 2);
1949@z = ($s3, $s4);
1950# assignment of state lists isn't implemented yet
1951#state($s5, $s6) = (1, 2);
1952#state($s7, undef, $s8) = (1, 2, 3);
1953#@z = ($s7, undef, $s8);
1954($s7, undef, $s8) = (1, 2, 3);
1955####
df2b00e8 1956# anon arrays with padrange
a7fd8ef6
DM
1957my($a, $b);
1958my $c = [$a, $b];
1959my $d = {$a, $b};
1960####
1961# slices with padrange
1962my($a, $b);
1963my(@x, %y);
1964@x = @x[$a, $b];
1965@x = @y{$a, $b};
1966####
1967# binops with padrange
1968my($a, $b, $c);
1969$c = $a cmp $b;
1970$c = $a + $b;
1971$a += $b;
1972$c = $a - $b;
1973$a -= $b;
1974$c = my $a1 cmp $b;
1975$c = my $a2 + $b;
1976$a += my $b1;
1977$c = my $a3 - $b;
1978$a -= my $b2;
1979####
1980# 'x' with padrange
1981my($a, $b, $c, $d, @e);
1982$c = $a x $b;
1983$a x= $b;
1984@e = ($a) x $d;
1985@e = ($a, $b) x $d;
1986@e = ($a, $b, $c) x $d;
1987@e = ($a, 1) x $d;
d5524600
DM
1988####
1989# @_ with padrange
1990my($a, $b, $c) = @_;
ce4062e7
AC
1991####
1992# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
ce4062e7 1993# lexical subroutine
db629560 1994# CONTEXT use feature 'lexical_subs';
601448c3 1995no warnings "experimental::lexical_subs";
ce4062e7
AC
1996my sub f {}
1997print f();
d4f1bfe7 1998>>>>
bc304ab2 1999BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
d4f1bfe7 2000my sub f {
d4f1bfe7
FC
2001
2002}
d4f1bfe7 2003print f();
f0cf3754
AC
2004####
2005# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
f0cf3754 2006# lexical "state" subroutine
db629560 2007# CONTEXT use feature 'state', 'lexical_subs';
f0cf3754
AC
2008no warnings 'experimental::lexical_subs';
2009state sub f {}
2010print f();
d4f1bfe7 2011>>>>
bc304ab2 2012BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
db629560 2013state sub f {
d4f1bfe7
FC
2014
2015}
d4f1bfe7 2016print f();
bcbe2b27 2017####
8443930e 2018# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
8443930e
FC
2019# lexical subroutine scoping
2020# CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
2021{
2022 {
2023 my sub a { die; }
2024 {
2025 foo();
2026 my sub b;
bb9bfaa4 2027 b ;
8443930e 2028 main::b();
d49c3562
FC
2029 &main::b;
2030 &main::b();
2031 my $b = \&main::b;
2032 sub b { $b; }
8443930e
FC
2033 }
2034 }
2035 b();
2036}
2037####
bb9bfaa4
FC
2038# self-referential lexical subroutine
2039# CONTEXT use feature 'lexical_subs', 'state'; no warnings 'experimental::lexical_subs';
2040();
2041state sub sb2;
2042sub sb2 {
2043 sb2 ;
2044}
2045####
494a4b9c
FC
2046# lexical subroutine with outer declaration and inner definition
2047# CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
2048();
2049my sub f;
2050my sub g {
2051 ();
2052 sub f { }
2053}
2054####
2c5ddcd3
FC
2055# TODO only partially fixed
2056# lexical state subroutine with outer declaration and inner definition
2057# CONTEXT use feature 'lexical_subs', 'state'; no warnings 'experimental::lexical_subs';
2058();
2059state sub sb4;
2060state sub a {
2061 ();
2062 sub sb4 { }
2063}
2064state sub sb5;
2065sub {
2066 ();
2067 sub sb5 { }
2068} ;
2069####
bcbe2b27
FC
2070# Elements of %# should not be confused with $#{ array }
2071() = ${#}{'foo'};
c4cf781e 2072####
cfd916dd 2073# $; [perl #123357]
ddb55548
FC
2074$_ = $;;
2075do {
2076 $;
2077};
2078####
c65b7c4d
FC
2079# Ampersand calls and scalar context
2080# OPTIONS -P
2081package prototest;
2082sub foo($$);
2083foo(bar(),baz());
2084>>>>
2085package prototest;
2086&foo(scalar bar(), scalar baz());
2087####
de4fa237
FC
2088# coderef2text and prototyped sub calls [perl #123435]
2089is 'foo', 'oo';
2090####
fd8be4a1
FC
2091# prototypes with unary precedence
2092package prototest;
2093sub dollar($) {}
2094sub optdollar(;$) {}
2095sub optoptdollar(;;$) {}
2096sub splat(*) {}
2097sub optsplat(;*) {}
2098sub optoptsplat(;;*) {}
2099sub bar(_) {}
2100sub optbar(;_) {}
2101sub optoptbar(;;_) {}
2102sub plus(+) {}
2103sub optplus(;+) {}
2104sub optoptplus(;;+) {}
2105sub wack(\$) {}
2106sub optwack(;\$) {}
2107sub optoptwack(;;\$) {}
2108sub wackbrack(\[$]) {}
2109sub optwackbrack(;\[$]) {}
2110sub optoptwackbrack(;;\[$]) {}
2111dollar($a < $b);
2112optdollar($a < $b);
2113optoptdollar($a < $b);
2114splat($a < $b); # Some of these deparse with ‘&’; if that changes, just
2115optsplat($a < $b); # change the tests.
2116optoptsplat($a < $b);
2117bar($a < $b);
2118optbar($a < $b);
2119optoptbar($a < $b);
2120plus($a < $b);
2121optplus($a < $b);
2122optoptplus($a < $b);
2123wack($a = $b);
2124optwack($a = $b);
2125optoptwack($a = $b);
2126wackbrack($a = $b);
2127optwackbrack($a = $b);
2128optoptwackbrack($a = $b);
2129>>>>
2130package prototest;
2131dollar($a < $b);
2132optdollar($a < $b);
2133optoptdollar($a < $b);
2134&splat($a < $b);
2135&optsplat($a < $b);
2136&optoptsplat($a < $b);
2137bar($a < $b);
2138optbar($a < $b);
2139optoptbar($a < $b);
2140&plus($a < $b);
2141&optplus($a < $b);
2142&optoptplus($a < $b);
2143&wack(\($a = $b));
2144&optwack(\($a = $b));
2145&optoptwack(\($a = $b));
2146&wackbrack(\($a = $b));
2147&optwackbrack(\($a = $b));
2148&optoptwackbrack(\($a = $b));
2149####
b024352e
DM
2150# ensure aelemfast works in the range -128..127 and that there's no
2151# funky edge cases
2152my $x;
2153no strict 'vars';
2154$x = $a[-256] + $a[-255] + $a[-129] + $a[-128] + $a[-127] + $a[-1] + $a[0];
2155$x = $a[1] + $a[126] + $a[127] + $a[128] + $a[255] + $a[256];
2156my @b;
2157$x = $b[-256] + $b[-255] + $b[-129] + $b[-128] + $b[-127] + $b[-1] + $b[0];
2158$x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256];
e09d73a6
DIM
2159####
2160# 'm' must be preserved in m??
2161m??;
c8ec376c
FC
2162####
2163# \(@array) and \(..., (@array), ...)
2164my(@array, %hash, @a, @b, %c, %d);
2165() = \(@array);
2166() = \(%hash);
2167() = \(@a, (@b), (%c), %d);
2168() = \(@Foo::array);
2169() = \(%Foo::hash);
2170() = \(@Foo::a, (@Foo::b), (%Foo::c), %Foo::d);
a958cfbb
FC
2171####
2172# subs synonymous with keywords
2173main::our();
2174main::pop();
2175state();
2176use feature 'state';
2177main::state();
9187b6e4
FC
2178####
2179# lvalue references
baabe3fb 2180# CONTEXT use feature "state", 'refaliasing', 'lexical_subs'; no warnings 'experimental';
9187b6e4
FC
2181our $x;
2182\$x = \$x;
2183my $m;
2184\$m = \$x;
2185\my $n = \$x;
2186(\$x) = @_;
2187\($x) = @_;
2188\($m) = @_;
2189(\$m) = @_;
2190\my($p) = @_;
2191(\my $r) = @_;
2192\($x, my $a) = @{[\$x, \$x]};
2193(\$x, \my $b) = @{[\$x, \$x]};
2194\local $x = \3;
2195\local($x) = \3;
2196\state $c = \3;
2197\state($d) = \3;
2198\our $e = \3;
2199\our($f) = \3;
2200\$_[0] = foo();
2201\($_[1]) = foo();
2202my @a;
2203\$a[0] = foo();
2204\($a[1]) = foo();
2205\local($a[1]) = foo();
2206\@a[0,1] = foo();
2207\(@a[2,3]) = foo();
2208\local @a[0,1] = (\$a)x2;
2209\$_{a} = foo();
2210\($_{b}) = foo();
2211my %h;
2212\$h{a} = foo();
2213\($h{b}) = foo();
2214\local $h{a} = \$x;
2215\local($h{b}) = \$x;
2216\@h{'a','b'} = foo();
2217\(@h{2,3}) = foo();
2218\local @h{'a','b'} = (\$x)x2;
2219\@_ = foo();
2220\@a = foo();
2221(\@_) = foo();
2222(\@a) = foo();
2223\my @c = foo();
2224(\my @d) = foo();
2225\(@_) = foo();
2226\(@a) = foo();
2227\my(@g) = foo();
2228\local @_ = \@_;
2229(\local @_) = \@_;
2230\state @e = [1..3];
2231\state(@f) = \3;
2232\our @i = [1..3];
2233\our(@h) = \3;
2234\%_ = foo();
2235\%h = foo();
2236(\%_) = foo();
2237(\%h) = foo();
2238\my %c = foo();
2239(\my %d) = foo();
2240\local %_ = \%h;
2241(\local %_) = \%h;
2242\state %y = {1,2};
2243\our %z = {1,2};
2244(\our %zz) = {1,2};
2245\&a = foo();
2246(\&a) = foo();
2247\(&a) = foo();
2248{
2249 my sub a;
2250 \&a = foo();
2251 (\&a) = foo();
2252 \(&a) = foo();
2253}
2254(\$_, $_) = \(1, 2);
2255$_ == 3 ? \$_ : $_ = \3;
2256$_ == 3 ? \$_ : \$x = \3;
2257\($_ == 3 ? $_ : $x) = \3;
2258for \my $topic (\$1, \$2) {
2259 die;
2260}
2261for \state $topic (\$1, \$2) {
2262 die;
2263}
2264for \our $topic (\$1, \$2) {
2265 die;
2266}
2267for \$_ (\$1, \$2) {
2268 die;
2269}
2270for \my @a ([1,2], [3,4]) {
2271 die;
2272}
2273for \state @a ([1,2], [3,4]) {
2274 die;
2275}
2276for \our @a ([1,2], [3,4]) {
2277 die;
2278}
2279for \@_ ([1,2], [3,4]) {
2280 die;
2281}
2282for \my %a ({5,6}, {7,8}) {
2283 die;
2284}
2285for \our %a ({5,6}, {7,8}) {
2286 die;
2287}
2288for \state %a ({5,6}, {7,8}) {
2289 die;
2290}
2291for \%_ ({5,6}, {7,8}) {
2292 die;
2293}
2294{
2295 my sub a;
2296 for \&a (sub { 9; }, sub { 10; }) {
2297 die;
2298 }
2299}
2300for \&a (sub { 9; }, sub { 10; }) {
2301 die;
2302}
2303>>>>
2304our $x;
2305\$x = \$x;
2306my $m;
2307\$m = \$x;
2308\my $n = \$x;
2309(\$x) = @_;
2310(\$x) = @_;
2311(\$m) = @_;
2312(\$m) = @_;
2313(\my $p) = @_;
2314(\my $r) = @_;
2315(\$x, \my $a) = @{[\$x, \$x];};
2316(\$x, \my $b) = @{[\$x, \$x];};
2317\local $x = \3;
2318(\local $x) = \3;
2319\state $c = \3;
2320(\state $d) = \3;
2321\our $e = \3;
2322(\our $f) = \3;
2323\$_[0] = foo();
2324(\$_[1]) = foo();
2325my @a;
2326\$a[0] = foo();
2327(\$a[1]) = foo();
2328(\local $a[1]) = foo();
2329(\@a[0, 1]) = foo();
2330(\@a[2, 3]) = foo();
2331(\local @a[0, 1]) = (\$a) x 2;
2332\$_{'a'} = foo();
2333(\$_{'b'}) = foo();
2334my %h;
2335\$h{'a'} = foo();
2336(\$h{'b'}) = foo();
2337\local $h{'a'} = \$x;
2338(\local $h{'b'}) = \$x;
2339(\@h{'a', 'b'}) = foo();
2340(\@h{2, 3}) = foo();
2341(\local @h{'a', 'b'}) = (\$x) x 2;
2342\@_ = foo();
2343\@a = foo();
2344(\@_) = foo();
2345(\@a) = foo();
2346\my @c = foo();
2347(\my @d) = foo();
2348(\(@_)) = foo();
2349(\(@a)) = foo();
2350(\(my @g)) = foo();
2351\local @_ = \@_;
2352(\local @_) = \@_;
2353\state @e = [1..3];
2354(\(state @f)) = \3;
2355\our @i = [1..3];
2356(\(our @h)) = \3;
2357\%_ = foo();
2358\%h = foo();
2359(\%_) = foo();
2360(\%h) = foo();
2361\my %c = foo();
2362(\my %d) = foo();
2363\local %_ = \%h;
2364(\local %_) = \%h;
2365\state %y = {1, 2};
2366\our %z = {1, 2};
2367(\our %zz) = {1, 2};
2368\&a = foo();
2369(\&a) = foo();
2370(\&a) = foo();
2371{
2372 my sub a;
2373 \&a = foo();
2374 (\&a) = foo();
2375 (\&a) = foo();
2376}
2377(\$_, $_) = \(1, 2);
2378$_ == 3 ? \$_ : $_ = \3;
2379$_ == 3 ? \$_ : \$x = \3;
2380($_ == 3 ? \$_ : \$x) = \3;
2381foreach \my $topic (\$1, \$2) {
2382 die;
2383}
2384foreach \state $topic (\$1, \$2) {
2385 die;
2386}
2387foreach \our $topic (\$1, \$2) {
2388 die;
2389}
2390foreach \$_ (\$1, \$2) {
2391 die;
2392}
2393foreach \my @a ([1, 2], [3, 4]) {
2394 die;
2395}
2396foreach \state @a ([1, 2], [3, 4]) {
2397 die;
2398}
2399foreach \our @a ([1, 2], [3, 4]) {
2400 die;
2401}
2402foreach \@_ ([1, 2], [3, 4]) {
2403 die;
2404}
2405foreach \my %a ({5, 6}, {7, 8}) {
2406 die;
2407}
2408foreach \our %a ({5, 6}, {7, 8}) {
2409 die;
2410}
2411foreach \state %a ({5, 6}, {7, 8}) {
2412 die;
2413}
2414foreach \%_ ({5, 6}, {7, 8}) {
2415 die;
2416}
2417{
2418 my sub a;
2419 foreach \&a (sub { 9; } , sub { 10; } ) {
2420 die;
2421 }
2422}
2423foreach \&a (sub { 9; } , sub { 10; } ) {
2424 die;
2425}
3b4e2a4d
FC
2426####
2427# join $foo, pos
2428my $foo;
2429$_ = join $foo, pos
2430>>>>
2431my $foo;
2432$_ = join('???', pos $_);
fedf30e1
DM
2433####
2434# exists $a[0]
2435our @a;
2436exists $a[0];
2437####
2438# my @a; exists $a[0]
2439my @a;
2440exists $a[0];
2441####
2442# delete $a[0]
2443our @a;
2444delete $a[0];
2445####
2446# my @a; delete $a[0]
2447my @a;
2448delete $a[0];
2449####
2450# $_[0][$_[1]]
2451$_[0][$_[1]];
2452####
2453# f($a[0]);
2454my @a;
2455f($a[0]);
2456####
2457#qr/\Q$h{'key'}\E/;
2458my %h;
2459qr/\Q$h{'key'}\E/;
2460####
2461# my $x = "$h{foo}";
2462my %h;
2463my $x = "$h{'foo'}";
2464####
2465# weird constant hash key
2466my %h;
2467my $x = $h{"\000\t\x{100}"};
2468####
2469# multideref and packages
2470package foo;
2471my(%bar) = ('a', 'b');
2472our(@bar) = (1, 2);
2473$bar{'k'} = $bar[200];
2474$main::bar{'k'} = $main::bar[200];
2475$foo::bar{'k'} = $foo::bar[200];
2476package foo2;
2477$bar{'k'} = $bar[200];
2478$main::bar{'k'} = $main::bar[200];
2479$foo::bar{'k'} = $foo::bar[200];
2480>>>>
2481package foo;
2482my(%bar) = ('a', 'b');
2483our(@bar) = (1, 2);
2484$bar{'k'} = $bar[200];
2485$main::bar{'k'} = $main::bar[200];
2486$foo::bar{'k'} = $bar[200];
2487package foo2;
2488$bar{'k'} = $foo::bar[200];
2489$main::bar{'k'} = $main::bar[200];
2490$foo::bar{'k'} = $foo::bar[200];
2491####
2492# multideref and local
2493my %h;
2494local $h{'foo'}[0] = 1;
2495####
2496# multideref and exists
2497my(%h, $i);
2498my $e = exists $h{'foo'}[$i];
2499####
2500# multideref and delete
2501my(%h, $i);
2502my $e = delete $h{'foo'}[$i];
2503####
2504# multideref with leading expression
2505my $r;
9527dbdd 2506my $x = +($r // [])->{'foo'}[0];
fedf30e1
DM
2507####
2508# multideref with complex middle index
2509my(%h, $i, $j, $k);
2510my $x = $h{'foo'}[$i + $j]{$k};
0175f038 2511####
9527dbdd
DM
2512# multideref with trailing non-simple index that initially looks simple
2513# (i.e. the constant "3")
2514my($r, $i, $j, $k);
2515my $x = +($r || {})->{'foo'}[$i + $j]{3 + $k};
2516####
3c4a43a5
FC
2517# chdir
2518chdir 'file';
0175f038 2519chdir FH;
3c4a43a5 2520chdir;
27f31adf
FC
2521####
2522# 5.22 bitops
2523# CONTEXT use feature "bitwise"; no warnings "experimental::bitwise";
2524$_ = $_ | $_;
2525$_ = $_ & $_;
2526$_ = $_ ^ $_;
2527$_ = ~$_;
2528$_ = $_ |. $_;
2529$_ = $_ &. $_;
2530$_ = $_ ^. $_;
2531$_ = ~.$_;
2532$_ |= $_;
2533$_ &= $_;
2534$_ ^= $_;
2535$_ |.= $_;
2536$_ &.= $_;
2537$_ ^.= $_;
60f638af
DM
2538####
2539####
2540# Should really use 'no warnings "experimental::signatures"',
2541# but it doesn't yet deparse correctly.
2542# anon subs used because this test framework doesn't deparse named subs
2543# in the DATA code snippets.
2544#
2545# general signature
2546no warnings;
2547use feature 'signatures';
2548my $x;
2549sub ($a, $, $b = $glo::bal, $c = $a, $d = 'foo', $e = -37, $f = 0, $g = 1, $h = undef, $i = $a + 1, $j = /foo/, @) {
2550 $x++;
2551}
2552;
2553$x++;
2554####
2555# Signature and prototype
2556no warnings;
2557use feature 'signatures';
2558my $x;
2559sub ($a, $b) : prototype($$) {
2560 $x++;
2561}
2562;
2563$x++;
2564####
2565# Signature and prototype and attrs
2566no warnings;
2567use feature 'signatures';
2568my $x;
2569sub ($a, $b) : prototype($$) lvalue {
2570 $x++;
2571}
2572;
2573$x++;
2574####
2575# Signature and attrs
2576no warnings;
2577use feature 'signatures';
2578my $x;
2579sub ($a, $b) : lvalue method {
2580 $x++;
2581}
2582;
2583$x++;
2584####
2585# named array slurp, null body
2586no warnings;
2587use feature 'signatures';
2588sub (@a) {
2589 ;
2590}
2591;
2592####
2593# named hash slurp
2594no warnings;
2595use feature 'signatures';
2596sub ($key, %h) {
2597 $h{$key};
2598}
2599;
2600####
2601# anon hash slurp
2602no warnings;
2603use feature 'signatures';
2604sub ($a, %) {
2605 $a;
2606}
2607;
2608####
2609# parenthesised default arg
2610no warnings;
2611use feature 'signatures';
2612sub ($a, $b = (/foo/), $c = 1) {
2613 $a + $b + $c;
2614}
2615;
2616####
2617# parenthesised default arg with TARGMY
2618no warnings;
2619use feature 'signatures';
2620sub ($a, $b = ($a + 1), $c = 1) {
2621 $a + $b + $c;
2622}
2623;
2624####
2625# empty default
2626no warnings;
2627use feature 'signatures';
2628sub ($a, $=) {
2629 $a;
2630}
2631;
b814db67
DM
2632####
2633# padrange op within pattern code blocks
2634/(?{ my($x, $y) = (); })/;
2635my $a;
2636/$a(?{ my($x, $y) = (); })/;
2637my $r1 = qr/(?{ my($x, $y) = (); })/;
2638my $r2 = qr/$a(?{ my($x, $y) = (); })/;
4d7ac81a
DM
2639####
2640# don't remove pattern whitespace escapes
2641/a\ b/;
2642/a\ b/x;
2643/a\ b/;
2644/a\ b/x;
82ab48fa
DM
2645####
2646# my attributes
2647my $s1 :foo(f1, f2) bar(b1, b2);
2648my @a1 :foo(f1, f2) bar(b1, b2);
2649my %h1 :foo(f1, f2) bar(b1, b2);
2650my($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2);
2651####
2652# my class attributes
2653package Foo::Bar;
2654my Foo::Bar $s1 :foo(f1, f2) bar(b1, b2);
2655my Foo::Bar @a1 :foo(f1, f2) bar(b1, b2);
2656my Foo::Bar %h1 :foo(f1, f2) bar(b1, b2);
2657my Foo::Bar ($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2);
2658package main;
2659my Foo::Bar $s3 :foo(f1, f2) bar(b1, b2);
2660my Foo::Bar @a3 :foo(f1, f2) bar(b1, b2);
2661my Foo::Bar %h3 :foo(f1, f2) bar(b1, b2);
2662my Foo::Bar ($s4, @a4, %h4) :foo(f1, f2) bar(b1, b2);
2663####
2664# avoid false positives in my $x :attribute
2665'attributes'->import('main', \my $x1, 'foo(bar)'), my $y1;
2666'attributes'->import('Fooo', \my $x2, 'foo(bar)'), my $y2;
ac1e5644
DM
2667####
2668# hash slices and hash key/value slices
2669my(@a, %h);
2670our(@oa, %oh);
2671@a = @h{'foo', 'bar'};
2672@a = %h{'foo', 'bar'};
2673@a = delete @h{'foo', 'bar'};
2674@a = delete %h{'foo', 'bar'};
2675@oa = @oh{'foo', 'bar'};
2676@oa = %oh{'foo', 'bar'};
2677@oa = delete @oh{'foo', 'bar'};
2678@oa = delete %oh{'foo', 'bar'};
748f2c65
DM
2679####
2680# keys optimised away in void and scalar context
2681no warnings;
2682;
2683our %h1;
2684my($x, %h2);
2685%h1;
2686keys %h1;
2687$x = %h1;
2688$x = keys %h1;
2689%h2;
2690keys %h2;
2691$x = %h2;
2692$x = keys %h2;
7e8d786b
DM
2693####
2694# eq,const optimised away for (index() == -1)
2695my($a, $b);
2696our $c;
2697$c = index($a, $b) == 2;
2698$c = rindex($a, $b) == 2;
2699$c = index($a, $b) == -1;
2700$c = rindex($a, $b) == -1;
2701$c = index($a, $b) != -1;
2702$c = rindex($a, $b) != -1;
2703$c = (index($a, $b) == -1);
2704$c = (rindex($a, $b) == -1);
2705$c = (index($a, $b) != -1);
2706$c = (rindex($a, $b) != -1);
2707####
2708# eq,const,sassign,madmy optimised away for (index() == -1)
2709my($a, $b);
2710my $c;
2711$c = index($a, $b) == 2;
2712$c = rindex($a, $b) == 2;
2713$c = index($a, $b) == -1;
2714$c = rindex($a, $b) == -1;
2715$c = index($a, $b) != -1;
2716$c = rindex($a, $b) != -1;
2717$c = (index($a, $b) == -1);
2718$c = (rindex($a, $b) == -1);
2719$c = (index($a, $b) != -1);
2720$c = (rindex($a, $b) != -1);