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