Commit | Line | Data |
87a42246 |
1 | #!./perl |
2 | |
3 | BEGIN { |
5638aaac |
4 | if ($ENV{PERL_CORE}){ |
5 | chdir('t') if -d 't'; |
6 | if ($^O eq 'MacOS') { |
7 | @INC = qw(: ::lib ::macos:lib); |
8 | } else { |
9 | @INC = '.'; |
10 | push @INC, '../lib'; |
11 | } |
87a42246 |
12 | } else { |
5638aaac |
13 | unshift @INC, 't'; |
87a42246 |
14 | } |
9cd8f857 |
15 | require Config; |
16 | if (($Config::Config{'extensions'} !~ /\bB\b/) ){ |
17 | print "1..0 # Skip -- Perl configured without B module\n"; |
18 | exit 0; |
19 | } |
87a42246 |
20 | } |
21 | |
87a42246 |
22 | use warnings; |
23 | use strict; |
e9c69003 |
24 | BEGIN { |
25 | # BEGIN block is acutally a subroutine :-) |
26 | return unless $] > 5.009; |
27 | require feature; |
28 | feature->import(':5.10'); |
29 | } |
2990415a |
30 | use Test::More tests => 74; |
1bb3cfc5 |
31 | use Config (); |
87a42246 |
32 | |
33 | use B::Deparse; |
09d856fb |
34 | my $deparse = B::Deparse->new(); |
35 | ok($deparse); |
87a42246 |
36 | |
37 | # Tell B::Deparse about our ambient pragmas |
0ced6c29 |
38 | { my ($hint_bits, $warning_bits, $hinthash); |
39 | BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); } |
87a42246 |
40 | $deparse->ambient_pragmas ( |
41 | hint_bits => $hint_bits, |
42 | warning_bits => $warning_bits, |
0ced6c29 |
43 | '$[' => 0 + $[, |
44 | '%^H' => $hinthash, |
87a42246 |
45 | ); |
46 | } |
47 | |
ad46c0be |
48 | $/ = "\n####\n"; |
49 | while (<DATA>) { |
50 | chomp; |
e9c69003 |
51 | # This code is pinched from the t/lib/common.pl for TODO. |
52 | # It's not clear how to avoid duplication |
53 | my ($skip, $skip_reason); |
54 | s/^#\s*SKIP\s*(.*)\n//m and $skip_reason = $1; |
55 | # If the SKIP reason starts ? then it's taken as a code snippet to evaluate |
56 | # This provides the flexibility to have conditional SKIPs |
57 | if ($skip_reason && $skip_reason =~ s/^\?//) { |
58 | my $temp = eval $skip_reason; |
59 | if ($@) { |
60 | die "# In SKIP code reason:\n# $skip_reason\n$@"; |
61 | } |
62 | $skip_reason = $temp; |
63 | } |
64 | |
ec59cdf2 |
65 | s/#\s*(.*)$//mg; |
66 | my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/; |
e9c69003 |
67 | |
68 | if ($skip_reason) { |
69 | # Like this to avoid needing a label SKIP: |
70 | Test::More->builder->skip($skip_reason); |
71 | next; |
72 | } |
73 | |
ad46c0be |
74 | my ($input, $expected); |
75 | if (/(.*)\n>>>>\n(.*)/s) { |
76 | ($input, $expected) = ($1, $2); |
77 | } |
78 | else { |
79 | ($input, $expected) = ($_, $_); |
80 | } |
87a42246 |
81 | |
ad46c0be |
82 | my $coderef = eval "sub {$input}"; |
87a42246 |
83 | |
ad46c0be |
84 | if ($@) { |
ec59cdf2 |
85 | diag("$num deparsed: $@"); |
86 | ok(0, $testname); |
ad46c0be |
87 | } |
88 | else { |
89 | my $deparsed = $deparse->coderef2text( $coderef ); |
31c6271a |
90 | my $regex = $expected; |
91 | $regex =~ s/(\S+)/\Q$1/g; |
92 | $regex =~ s/\s+/\\s+/g; |
93 | $regex = '^\{\s*' . $regex . '\s*\}$'; |
ec59cdf2 |
94 | like($deparsed, qr/$regex/, $testname); |
87a42246 |
95 | } |
87a42246 |
96 | } |
97 | |
87a42246 |
98 | use constant 'c', 'stuff'; |
09d856fb |
99 | is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff'); |
87a42246 |
100 | |
09d856fb |
101 | my $a = 0; |
102 | is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a })); |
87a42246 |
103 | |
d989cdac |
104 | use constant cr => ['hello']; |
105 | my $string = "sub " . $deparse->coderef2text(\&cr); |
0707d6cc |
106 | my $val = (eval $string)->() or diag $string; |
107 | is(ref($val), 'ARRAY'); |
108 | is($val->[0], 'hello'); |
87a42246 |
109 | |
87a42246 |
110 | my $Is_VMS = $^O eq 'VMS'; |
111 | my $Is_MacOS = $^O eq 'MacOS'; |
112 | |
113 | my $path = join " ", map { qq["-I$_"] } @INC; |
be708cc0 |
114 | $path .= " -MMac::err=unix" if $Is_MacOS; |
87a42246 |
115 | my $redir = $Is_MacOS ? "" : "2>&1"; |
116 | |
d2bc402e |
117 | $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`; |
e69a2255 |
118 | $a =~ s/-e syntax OK\n//g; |
d2bc402e |
119 | $a =~ s/.*possible typo.*\n//; # Remove warning line |
87a42246 |
120 | $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 |
121 | $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' |
122 | $b = <<'EOF'; |
d2bc402e |
123 | BEGIN { $^I = ".bak"; } |
124 | BEGIN { $^W = 1; } |
125 | BEGIN { $/ = "\n"; $\ = "\n"; } |
87a42246 |
126 | LINE: while (defined($_ = <ARGV>)) { |
127 | chomp $_; |
f86ea535 |
128 | our(@F) = split(' ', $_, 0); |
87a42246 |
129 | '???'; |
130 | } |
87a42246 |
131 | EOF |
e69a2255 |
132 | $b =~ s/(LINE:)/sub BEGIN { |
133 | 'MacPerl'->bootstrap; |
134 | 'OSA'->bootstrap; |
135 | 'XL'->bootstrap; |
136 | } |
137 | $1/ if $Is_MacOS; |
09d856fb |
138 | is($a, $b); |
87a42246 |
139 | |
579a54dc |
140 | #Re: perlbug #35857, patch #24505 |
b3980c39 |
141 | #handle warnings::register-ed packages properly. |
142 | package B::Deparse::Wrapper; |
143 | use strict; |
144 | use warnings; |
145 | use warnings::register; |
146 | sub getcode { |
579a54dc |
147 | my $deparser = B::Deparse->new(); |
b3980c39 |
148 | return $deparser->coderef2text(shift); |
149 | } |
150 | |
2990415a |
151 | package Moo; |
152 | use overload '0+' => sub { 42 }; |
153 | |
b3980c39 |
154 | package main; |
155 | use strict; |
156 | use warnings; |
71c4dbc3 |
157 | use constant GLIPP => 'glipp'; |
2990415a |
158 | use constant PI => 4; |
159 | use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo'); |
3779476a |
160 | use Fcntl qw/O_TRUNC O_APPEND O_EXCL/; |
aaf9c2b2 |
161 | BEGIN { delete $::Fcntl::{O_APPEND}; } |
2990415a |
162 | use POSIX qw/O_CREAT/; |
b3980c39 |
163 | sub test { |
579a54dc |
164 | my $val = shift; |
165 | my $res = B::Deparse::Wrapper::getcode($val); |
09d856fb |
166 | like( $res, qr/use warnings/); |
b3980c39 |
167 | } |
168 | my ($q,$p); |
169 | my $x=sub { ++$q,++$p }; |
170 | test($x); |
171 | eval <<EOFCODE and test($x); |
172 | package bar; |
173 | use strict; |
174 | use warnings; |
175 | use warnings::register; |
176 | package main; |
177 | 1 |
178 | EOFCODE |
179 | |
ad46c0be |
180 | __DATA__ |
14a55f98 |
181 | # 2 |
ad46c0be |
182 | 1; |
183 | #### |
14a55f98 |
184 | # 3 |
ad46c0be |
185 | { |
186 | no warnings; |
187 | '???'; |
188 | 2; |
189 | } |
190 | #### |
14a55f98 |
191 | # 4 |
ad46c0be |
192 | my $test; |
193 | ++$test and $test /= 2; |
194 | >>>> |
195 | my $test; |
196 | $test /= 2 if ++$test; |
197 | #### |
14a55f98 |
198 | # 5 |
ad46c0be |
199 | -((1, 2) x 2); |
200 | #### |
14a55f98 |
201 | # 6 |
ad46c0be |
202 | { |
203 | my $test = sub : lvalue { |
204 | my $x; |
205 | } |
206 | ; |
207 | } |
208 | #### |
14a55f98 |
209 | # 7 |
ad46c0be |
210 | { |
211 | my $test = sub : method { |
212 | my $x; |
213 | } |
214 | ; |
215 | } |
216 | #### |
14a55f98 |
217 | # 8 |
ad46c0be |
218 | { |
219 | my $test = sub : locked method { |
220 | my $x; |
221 | } |
222 | ; |
223 | } |
224 | #### |
14a55f98 |
225 | # 9 |
87a42246 |
226 | { |
ad46c0be |
227 | 234; |
f99a63a2 |
228 | } |
ad46c0be |
229 | continue { |
230 | 123; |
87a42246 |
231 | } |
ce4e655d |
232 | #### |
14a55f98 |
233 | # 10 |
ce4e655d |
234 | my $x; |
235 | print $main::x; |
236 | #### |
14a55f98 |
237 | # 11 |
ce4e655d |
238 | my @x; |
239 | print $main::x[1]; |
14a55f98 |
240 | #### |
241 | # 12 |
242 | my %x; |
243 | $x{warn()}; |
ad8caead |
244 | #### |
245 | # 13 |
246 | my $foo; |
247 | $_ .= <ARGV> . <$foo>; |
cef22867 |
248 | #### |
249 | # 14 |
250 | my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ"; |
4ae52e81 |
251 | #### |
252 | # 15 |
253 | s/x/'y';/e; |
241416b8 |
254 | #### |
255 | # 16 - various lypes of loop |
256 | { my $x; } |
257 | #### |
258 | # 17 |
259 | while (1) { my $k; } |
260 | #### |
261 | # 18 |
262 | my ($x,@a); |
263 | $x=1 for @a; |
264 | >>>> |
265 | my($x, @a); |
0bb5f065 |
266 | $x = 1 foreach (@a); |
241416b8 |
267 | #### |
268 | # 19 |
269 | for (my $i = 0; $i < 2;) { |
270 | my $z = 1; |
271 | } |
272 | #### |
273 | # 20 |
274 | for (my $i = 0; $i < 2; ++$i) { |
275 | my $z = 1; |
276 | } |
277 | #### |
278 | # 21 |
279 | for (my $i = 0; $i < 2; ++$i) { |
280 | my $z = 1; |
281 | } |
282 | #### |
283 | # 22 |
284 | my $i; |
285 | while ($i) { my $z = 1; } continue { $i = 99; } |
286 | #### |
287 | # 23 |
09d856fb |
288 | foreach my $i (1, 2) { |
241416b8 |
289 | my $z = 1; |
290 | } |
291 | #### |
292 | # 24 |
293 | my $i; |
294 | foreach $i (1, 2) { |
295 | my $z = 1; |
296 | } |
297 | #### |
298 | # 25 |
299 | my $i; |
300 | foreach my $i (1, 2) { |
301 | my $z = 1; |
302 | } |
303 | #### |
304 | # 26 |
305 | foreach my $i (1, 2) { |
306 | my $z = 1; |
307 | } |
308 | #### |
309 | # 27 |
310 | foreach our $i (1, 2) { |
311 | my $z = 1; |
312 | } |
313 | #### |
314 | # 28 |
315 | my $i; |
316 | foreach our $i (1, 2) { |
317 | my $z = 1; |
318 | } |
3ac6e0f9 |
319 | #### |
320 | # 29 |
321 | my @x; |
322 | print reverse sort(@x); |
323 | #### |
324 | # 30 |
325 | my @x; |
326 | print((sort {$b cmp $a} @x)); |
327 | #### |
328 | # 31 |
329 | my @x; |
330 | print((reverse sort {$b <=> $a} @x)); |
36d57d93 |
331 | #### |
332 | # 32 |
333 | our @a; |
334 | print $_ foreach (reverse @a); |
aae53c41 |
335 | #### |
579a54dc |
336 | # 33 |
aae53c41 |
337 | our @a; |
338 | print $_ foreach (reverse 1, 2..5); |
f86ea535 |
339 | #### |
340 | # 34 (bug #38684) |
341 | our @ary; |
342 | @ary = split(' ', 'foo', 0); |
31c6271a |
343 | #### |
344 | # 35 (bug #40055) |
345 | do { () }; |
346 | #### |
347 | # 36 (ibid.) |
348 | do { my $x = 1; $x }; |
d9002312 |
349 | #### |
350 | # 37 <20061012113037.GJ25805@c4.convolution.nl> |
351 | my $f = sub { |
352 | +{[]}; |
353 | } ; |
8b2d6640 |
354 | #### |
355 | # 38 (bug #43010) |
356 | '!@$%'->(); |
357 | #### |
358 | # 39 (ibid.) |
359 | ::(); |
360 | #### |
361 | # 40 (ibid.) |
362 | '::::'->(); |
363 | #### |
364 | # 41 (ibid.) |
365 | &::::; |
09d856fb |
366 | #### |
367 | # 42 |
368 | my $bar; |
369 | 'Foo'->$bar('orz'); |
370 | #### |
371 | # 43 |
372 | 'Foo'->bar('orz'); |
373 | #### |
374 | # 44 |
375 | 'Foo'->bar; |
0ced6c29 |
376 | #### |
e9c69003 |
377 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" |
7ddd1a01 |
378 | # 45 say |
379 | say 'foo'; |
380 | #### |
e9c69003 |
381 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
7ddd1a01 |
382 | # 46 state vars |
0ced6c29 |
383 | state $x = 42; |
384 | #### |
e9c69003 |
385 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
7ddd1a01 |
386 | # 47 state var assignment |
387 | { |
388 | my $y = (state $x = 42); |
389 | } |
390 | #### |
e9c69003 |
391 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
7ddd1a01 |
392 | # 48 state vars in anoymous subroutines |
393 | $a = sub { |
394 | state $x; |
395 | return $x++; |
396 | } |
397 | ; |
644741fd |
398 | #### |
399 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' |
400 | # 49 each @array; |
401 | each @ARGV; |
402 | each @$a; |
403 | #### |
404 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' |
405 | # 50 keys @array; values @array |
406 | keys @$a if keys @ARGV; |
407 | values @ARGV if values @$a; |
35925e80 |
408 | #### |
43b09ad7 |
409 | # 51 Anonymous arrays and hashes, and references to them |
35925e80 |
410 | my $a = {}; |
411 | my $b = \{}; |
412 | my $c = []; |
413 | my $d = \[]; |
9210de83 |
414 | #### |
415 | # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version" |
43b09ad7 |
416 | # 52 implicit smartmatch in given/when |
9210de83 |
417 | given ('foo') { |
418 | when ('bar') { continue; } |
419 | when ($_ ~~ 'quux') { continue; } |
420 | default { 0; } |
421 | } |
7ecdd211 |
422 | #### |
423 | # 53 conditions in elsifs (regression in change #33710 which fixed bug #37302) |
424 | if ($a) { x(); } |
425 | elsif ($b) { x(); } |
426 | elsif ($a and $b) { x(); } |
427 | elsif ($a or $b) { x(); } |
428 | else { x(); } |
03b22f1b |
429 | #### |
430 | # 54 interpolation in regexps |
431 | my($y, $t); |
432 | /x${y}z$t/; |
227375e1 |
433 | #### |
2990415a |
434 | # SKIP ?$B::Deparse::VERSION <= 0.88 && "TODO new undocumented cpan-bug #33708" |
227375e1 |
435 | # 55 (cpan-bug #33708) |
436 | %{$_ || {}} |
437 | #### |
2990415a |
438 | # SKIP ?$B::Deparse::VERSION <= 0.88 && "TODO hash constants not yet fixed" |
227375e1 |
439 | # 56 (cpan-bug #33708) |
440 | use constant H => { "#" => 1 }; H->{"#"} |
441 | #### |
2990415a |
442 | # SKIP ?$B::Deparse::VERSION <= 0.88 && "TODO optimized away 0 not yet fixed" |
227375e1 |
443 | # 57 (cpan-bug #33708) |
444 | foreach my $i (@_) { 0 } |
edbe35ea |
445 | #### |
446 | # 58 tests with not, not optimized |
07f3cdf5 |
447 | my $c; |
edbe35ea |
448 | x() unless $a; |
449 | x() if not $a and $b; |
450 | x() if $a and not $b; |
451 | x() unless not $a and $b; |
452 | x() unless $a and not $b; |
453 | x() if not $a or $b; |
454 | x() if $a or not $b; |
455 | x() unless not $a or $b; |
456 | x() unless $a or not $b; |
07f3cdf5 |
457 | x() if $a and not $b and $c; |
458 | x() if not $a and $b and not $c; |
459 | x() unless $a and not $b and $c; |
460 | x() unless not $a and $b and not $c; |
461 | x() if $a or not $b or $c; |
462 | x() if not $a or $b or not $c; |
463 | x() unless $a or not $b or $c; |
464 | x() unless not $a or $b or not $c; |
edbe35ea |
465 | #### |
466 | # 59 tests with not, optimized |
07f3cdf5 |
467 | my $c; |
edbe35ea |
468 | x() if not $a; |
469 | x() unless not $a; |
470 | x() if not $a and not $b; |
471 | x() unless not $a and not $b; |
472 | x() if not $a or not $b; |
473 | x() unless not $a or not $b; |
07f3cdf5 |
474 | x() if not $a and not $b and $c; |
475 | x() unless not $a and not $b and $c; |
476 | x() if not $a or not $b or $c; |
477 | x() unless not $a or not $b or $c; |
478 | x() if not $a and not $b and not $c; |
479 | x() unless not $a and not $b and not $c; |
480 | x() if not $a or not $b or not $c; |
481 | x() unless not $a or not $b or not $c; |
482 | x() unless not $a or not $b or not $c; |
edbe35ea |
483 | >>>> |
07f3cdf5 |
484 | my $c; |
edbe35ea |
485 | x() unless $a; |
486 | x() if $a; |
487 | x() unless $a or $b; |
488 | x() if $a or $b; |
489 | x() unless $a and $b; |
07f3cdf5 |
490 | x() if $a and $b; |
491 | x() if not $a || $b and $c; |
492 | x() unless not $a || $b and $c; |
493 | x() if not $a && $b or $c; |
494 | x() unless not $a && $b or $c; |
495 | x() unless $a or $b or $c; |
496 | x() if $a or $b or $c; |
497 | x() unless $a and $b and $c; |
498 | x() if $a and $b and $c; |
499 | x() unless not $a && $b && $c; |
71c4dbc3 |
500 | #### |
501 | # 60 tests that should be constant folded |
502 | x() if 1; |
503 | x() if GLIPP; |
504 | x() if !GLIPP; |
505 | x() if GLIPP && GLIPP; |
506 | x() if !GLIPP || GLIPP; |
507 | x() if do { GLIPP }; |
508 | x() if do { no warnings 'void'; 5; GLIPP }; |
509 | x() if do { !GLIPP }; |
510 | if (GLIPP) { x() } else { z() } |
511 | if (!GLIPP) { x() } else { z() } |
512 | if (GLIPP) { x() } elsif (GLIPP) { z() } |
513 | if (!GLIPP) { x() } elsif (GLIPP) { z() } |
514 | if (GLIPP) { x() } elsif (!GLIPP) { z() } |
515 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } |
516 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() } |
517 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() } |
518 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() } |
519 | >>>> |
520 | x(); |
521 | x(); |
522 | '???'; |
523 | x(); |
524 | x(); |
525 | x(); |
526 | x(); |
527 | do { |
528 | '???' |
529 | }; |
530 | do { |
531 | x() |
532 | }; |
533 | do { |
534 | z() |
535 | }; |
536 | do { |
537 | x() |
538 | }; |
539 | do { |
540 | z() |
541 | }; |
542 | do { |
543 | x() |
544 | }; |
545 | '???'; |
546 | do { |
547 | t() |
548 | }; |
549 | '???'; |
550 | !1; |
551 | #### |
1bb3cfc5 |
552 | # SKIP ? $Config::Config{useithreads} && "TODO doesn't work with threads" |
71c4dbc3 |
553 | # 61 tests that shouldn't be constant folded |
554 | x() if $a; |
555 | if ($a == 1) { x() } elsif ($b == 2) { z() } |
556 | if (do { foo(); GLIPP }) { x() } |
557 | if (do { $a++; GLIPP }) { x() } |
558 | >>>> |
559 | x() if $a; |
560 | if ($a == 1) { x(); } elsif ($b == 2) { z(); } |
2990415a |
561 | if (do { foo(); GLIPP }) { x(); } |
562 | if (do { ++$a; GLIPP }) { x(); } |
563 | #### |
564 | # 62 tests for deparsing constants |
565 | warn PI; |
566 | #### |
567 | # 63 tests for deparsing imported constants |
3779476a |
568 | warn O_TRUNC; |
2990415a |
569 | #### |
570 | # 64 tests for deparsing re-exported constants |
571 | warn O_CREAT; |
572 | #### |
573 | # 65 tests for deparsing imported constants that got deleted from the original namespace |
aaf9c2b2 |
574 | warn O_APPEND; |
2990415a |
575 | #### |
1bb3cfc5 |
576 | # SKIP ? $Config::Config{useithreads} && "TODO doesn't work with threads" |
2990415a |
577 | # 66 tests for deparsing constants which got turned into full typeglobs |
578 | warn O_EXCL; |
579 | eval '@Fcntl::O_EXCL = qw/affe tiger/;'; |
580 | warn O_EXCL; |
581 | #### |
582 | # 67 tests for deparsing of blessed constant with overloaded numification |
583 | warn OVERLOADED_NUMIFICATION; |